---------------------------------------------------------------
-- This file contains the definitions of several versions of --
-- subcategories.                                            --
---------------------------------------------------------------
module Category.Subcategory where

open import Level
open import Data.Product

open import Setoid.Total
open import Relation.Relation
open import Category.Category

open Setoid
open SetoidFun
open Pred
open Subcarrier
open EqRel
open Cat

-- Categorical Predicate: A predicate on objects, and morphisms such
-- that the latter is closed under identities and composition.
record CatPred {l : Level} (ℂ : Cat {l}) : Set (lsuc l) where
  field
      oinc : Obj ℂ → Set l
      minc : ∀{A B} → oinc A → oinc B → Pred {l} (Hom ℂ A B)
      cp-idPf : ∀{A} → {p : oinc A} → pf (minc p p) (id ℂ {A})
      cp-compPf : ∀{A B C} → (op₁ : (oinc A))
                        → (op₂ : (oinc B))
                        → (op₃ : (oinc C))
                        → {f : el (Hom ℂ A B)}
                        → {g : el (Hom ℂ B C)}
                        → (pf (minc op₁ op₂) f)
                        → (pf (minc op₂ op₃) g)
                        → (pf (minc op₁ op₃) (f ○[ comp ℂ ] g))
open CatPred

-- Subcategories:

-- The restriction of a category ℂ to the category determined by the
-- categorical predicate P.  Note that the objects of this category
-- are pairs of an object and a proof that the object belongs in the
-- category, and morphisms are similarly defined but using setoid
-- predicates.
subcatPred : {l : Level}{ℂ : Cat {l}}
  → (P : CatPred ℂ)
  → Cat {l}
subcatPred {_}{ℂ} P =
  record
    { Obj = Σ[ x ∈ Obj ℂ ]( oinc P x)
    ; Hom = λ AP BP → let A = proj₁ AP
                          B = proj₁ BP
                          op₁ = proj₂ AP
                          op₂ = proj₂ BP
                      in Subsetoid (Hom ℂ A B) (minc P op₁ op₂)
    ; comp = λ {AP}{BP}{CP} →
             let A = proj₁ AP
                 B = proj₁ BP
                 C = proj₁ CP
                 op₁ = proj₂ AP
                 op₂ = proj₂ BP
                 op₃ = proj₂ CP
             in record {
                  appT = λ x →
                           record {
                             appT = λ x₁ →
                                      record { subel = (subel x) ○[ comp ℂ ] (subel x₁) ;
                                               insub = cp-compPf P op₁ op₂ op₃ (insub x) (insub x₁) } ;
                             extT = λ {y} {z} x₂ → eq-comp-right {_}{ℂ}{A}{B}{C}{subel x}{subel y}{subel z} x₂ } ;
                  extT = λ {f₁}{f₂} pf g₂ → extT (comp ℂ) pf (subel g₂) }
    ; id = λ {AP} → let A = proj₁ AP
                        A-op = proj₂ AP
                    in record { subel = id ℂ ; insub = cp-idPf P {_}{A-op} }
    ; assocPf = assocPf ℂ
    ; idPfCom = idPfCom ℂ
    ; idPf = idPf ℂ
    }

-- Subcategories using subsetoids.
subcat : {l : Level}
  → (ℂ : Cat {l})(O : Set l)
  → (oinc : O → Obj ℂ)
  → (minc : ∀{A B} → Pred {l} (Hom ℂ (oinc A) (oinc B)))
  → (∀{A} → pf (minc {A}{A}) (id ℂ {oinc A}))
  → (∀{A B C}
         → {f : el (Hom ℂ (oinc A) (oinc B))}
         → {g : el (Hom ℂ (oinc B) (oinc C))}
         → (pf minc f)
         → (pf minc g)
         → (pf minc (f ○[ comp ℂ ] g)))
  → Cat {l}
subcat ℂ O oinc minc idPF compPF =
  record {
    Obj = O;
    Hom = λ A B → Subsetoid (Hom ℂ (oinc A) (oinc B)) (minc {A}{B});
    comp = λ {A} {B} {C} →
      record { appT = λ x →
                record { appT = λ x₁ →
                              record { subel = (subel x) ○[ comp ℂ ] (subel x₁);
                                       insub = compPF {f = subel x}{subel x₁} (insub x) (insub x₁) };
                         extT =  λ {y}{z} p → extT (appT (comp ℂ {oinc A}{oinc B}{oinc C}) (subel x)) {subel y}{subel z} p };
               extT = λ {y}{z} x₁ x₂ → extT (comp ℂ {oinc A} {oinc B} {oinc C}) x₁ (subel x₂) };
    id = λ {A} → record { subel = id ℂ {oinc A}; insub = idPF {A} };
    assocPf = assocPf ℂ;
    idPf = idPf ℂ;
    idPfCom = idPfCom ℂ
  }

-- An alternate definition of a subcategory where the predicate is not
-- a setoid predicate.
subcat-pred : {l : Level}
  → (ℂ : Cat {l})(O : Set l)
  → (oinc : O → Obj ℂ)
  → (minc : ∀{A B} → el (Hom ℂ (oinc A) (oinc B)) → Set l)
  → (∀{A} → minc (id ℂ {oinc A}))
  → (∀{A B C}
         → {f : el (Hom ℂ (oinc A) (oinc B))}
         → {g : el (Hom ℂ (oinc B) (oinc C))}
         → (minc f)
         → (minc g)
         → (minc (f ○[ comp ℂ ] g)))
  → Cat {l}
subcat-pred ℂ O oinc minc idPF compPF =
    record {
      Obj = O;
      Hom = λ A B → ↓Setoid (Hom ℂ (oinc A) (oinc B)) (minc {A}{B});
     comp = λ {A} {B} {C} → ↓BinSetoidFun (comp ℂ) compPF;
       id = (id ℂ , idPF);
  assocPf = assocPf ℂ;
     idPf = idPf ℂ;
     idPfCom = idPfCom ℂ}


{-# OPTIONS --without-K #-}

open import HoTT

module homotopy.JoinComm where

module _ {i j} {A : Type i} {B : Type j} where

  swap : A * B → B * A
  swap = Swap.f  module _ where

    swap-glue : (a : A) (b : B) → right a == left b
    swap-glue a b = ! (glue (b , a))

    module Swap = PushoutRec right left (uncurry swap-glue)

{- ∞TT:

  swap : A * B → B * A
  swap (left a) = right a
  swap (right b) = left b
  ap swap (glue (a , b)) = ! (glue (b , a))
-}

module _ {i j} {A : Type i} {B : Type j} where

  swap-swap : (x : A * B) → swap (swap x) == x
  swap-swap = Pushout-elim (λ a → idp) (λ b → idp) (λ c → ↓-∘=idf-in swap swap
    (swap-swap-glue c)) where

    swap-swap-glue : (c : A × B) → ap swap (ap swap (glue c)) == glue c
    swap-swap-glue (a , b) =
      ap swap (ap swap (glue (a , b)))   =⟨ Swap.glue-β (a , b) |in-ctx ap swap ⟩
      ap swap (! (glue (b , a)))         =⟨ ap-! swap (glue (b , a)) ⟩
      ! (ap swap (glue (b , a)))         =⟨ Swap.glue-β (b , a) |in-ctx ! ⟩
      ! (! (glue (a , b)))               =⟨ !-! (glue (a , b)) ⟩
      glue (a , b) ∎

{- ∞TT:

  swap-swap : (x : A * B) → swap (swap x) == x
  swap-swap (left a) = idp
  swap-swap (right b) = idp
  apd swap-swap (glue (a , b)) = !-! (glue (a , b))
-}

module _ {i j} {A : Type i} {B : Type j} where

  swap-equiv : (A * B) ≃ (B * A)
  swap-equiv = equiv swap swap swap-swap swap-swap

  swap-path : (A * B) == (B * A)
  swap-path = ua swap-equiv


module Data.Num.Maximum where

open import Data.Num.Core

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties.Extra

open import Data.Fin as Fin
    using (Fin; fromℕ≤; inject≤)
    renaming (zero to z; suc to s)

open import Data.Fin.Properties using (toℕ-fromℕ≤; bounded)
open import Data.Product

open import Function
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open ≡-Reasoning
open ≤-Reasoning renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≈⟨_⟩_)
open DecTotalOrder decTotalOrder using (reflexive) renaming (refl to ≤-refl)

------------------------------------------------------------------------

Maximum : ∀ {b d o} → (xs : Numeral b d o) → Set
Maximum {b} {d} {o} xs = (ys : Numeral b d o) → ⟦ xs ⟧ ≥ ⟦ ys ⟧

-- Maximum-unique : ∀ {b d o}
--     → (max xs : Numeral b d o)
--     → Maximum max
--     → Maximum xs
--     → ⟦ max ⟧ ≡ ⟦ xs ⟧
-- Maximum-unique max xs max-max xs-max = IsPartialOrder.antisym isPartialOrder
--     (xs-max max)
--     (max-max xs)

Maximum-NullBase-Greatest : ∀ {d} {o}
    → (xs : Numeral 0 (suc d) o)
    → Greatest (lsd xs)
    → Maximum xs
Maximum-NullBase-Greatest {_} {o} (x ∙) greatest (y ∙) =
    greatest-of-all o x y greatest
Maximum-NullBase-Greatest {_} {o} (x ∙) greatest (y ∷ ys) =
    start
        Fin.toℕ y + o + ⟦ ys ⟧ * 0
    ≈⟨ toℕ-NullBase y ys ⟩
        Fin.toℕ y + o
    ≤⟨ greatest-of-all o x y greatest ⟩
        Fin.toℕ x + o
    □
Maximum-NullBase-Greatest {_} {o} (x ∷ xs) greatest (y ∙) =
    start
        Fin.toℕ y + o
    ≤⟨ greatest-of-all o x y greatest ⟩
        Fin.toℕ x + o
    ≈⟨ sym (toℕ-NullBase x xs) ⟩
        Fin.toℕ x + o + ⟦ xs ⟧ * 0
    □
Maximum-NullBase-Greatest {_} {o} (x ∷ xs) greatest (y ∷ ys) =
    start
        ⟦ y ∷ ys ⟧
    ≈⟨ toℕ-NullBase y ys ⟩
        Fin.toℕ y + o
    ≤⟨ greatest-of-all o x y greatest ⟩
        Fin.toℕ x + o
    ≈⟨ sym (toℕ-NullBase x xs) ⟩
        ⟦ x ∷ xs ⟧
    □

Maximum⇒Greatest-LSD : ∀ {b} {d} {o}
    → (xs : Numeral b d o)
    → Maximum xs
    → Greatest (lsd xs)
Maximum⇒Greatest-LSD xs max with Greatest? (lsd xs)
Maximum⇒Greatest-LSD xs max | yes greatest = greatest
Maximum⇒Greatest-LSD {b} {zero}      xs       max | no ¬greatest = NoDigits-explode xs
Maximum⇒Greatest-LSD {b} {suc d} {o} (x ∙)    max | no ¬greatest
    = contradiction p ¬p
    where
        ys : Numeral b (suc d) o
        ys = greatest-digit d ∙

        p : Digit-toℕ x o ≥ ⟦ ys ⟧
        p = max ys

        ¬p : Digit-toℕ x o ≱ ⟦ ys ⟧
        ¬p = <⇒≱ $
            start
                suc (Digit-toℕ x o)
            ≤⟨ +n-mono o (≤-pred (≤∧≢⇒< (bounded x) ¬greatest)) ⟩
                d + o
            ≈⟨ sym (greatest-digit-toℕ (Fin.fromℕ d) (greatest-digit-is-the-Greatest d)) ⟩
                Digit-toℕ (greatest-digit d) o
            ≈⟨ refl ⟩
                ⟦ ys ⟧
            □
Maximum⇒Greatest-LSD {b} {suc d} {o} (x ∷ xs) max | no ¬greatest
    = contradiction p ¬p
    where
        ys : Numeral b (suc d) o
        ys = greatest-digit d ∷ xs

        p : ⟦ x ∷ xs ⟧ ≥ ⟦ ys ⟧
        p = max ys

        ¬p : ⟦ x ∷ xs ⟧ ≱ ⟦ ys ⟧
        ¬p = <⇒≱ $ +n-mono (⟦ xs ⟧ * b) $
            start
                suc (Digit-toℕ x o)
            ≤⟨ +n-mono o (≤-pred (≤∧≢⇒< (bounded x) ¬greatest)) ⟩
                d + o
            ≈⟨ sym (greatest-digit-toℕ (Fin.fromℕ d) (greatest-digit-is-the-Greatest d)) ⟩
                (Digit-toℕ (greatest-digit d) o)
            □

Maximum-NullBase : ∀ {d} {o}
    → (xs : Numeral 0 (suc d) o)
    → Dec (Maximum xs)
Maximum-NullBase xs with Greatest? (lsd xs)
Maximum-NullBase xs | yes greatest = yes (Maximum-NullBase-Greatest xs greatest)
Maximum-NullBase xs | no ¬greatest = no (contraposition (Maximum⇒Greatest-LSD xs) ¬greatest)

Maximum-AllZeros : ∀ {b} → (xs : Numeral b 1 0) → Maximum xs
Maximum-AllZeros xs ys = reflexive $
    begin
        ⟦ ys ⟧
    ≡⟨ toℕ-AllZeros ys ⟩
        zero
    ≡⟨ sym (toℕ-AllZeros xs) ⟩
        ⟦ xs ⟧
    ∎

Maximum-Proper : ∀ {b d o}
    → (xs : Numeral (suc b) (suc d) o)
    → (proper : 2 ≤ suc (d + o))
    → ¬ (Maximum xs)
Maximum-Proper {b} {d} {o} xs proper claim = contradiction p ¬p
    where
        p : ⟦ xs ⟧ ≥ ⟦ greatest-digit d ∷ xs ⟧
        p = claim (greatest-digit d ∷ xs)
        ¬p : ⟦ xs ⟧ ≱ ⟦ greatest-digit d ∷ xs ⟧
        ¬p = <⇒≱ $
            start
                suc ⟦ xs ⟧
            ≈⟨ cong suc (sym (*-right-identity ⟦ xs ⟧)) ⟩
                suc (⟦ xs ⟧ * 1)
            ≤⟨ s≤s (n*-mono ⟦ xs ⟧ (s≤s z≤n)) ⟩
                suc (⟦ xs ⟧ * suc b)
            ≤⟨ +n-mono (⟦ xs ⟧ * suc b) (≤-pred proper) ⟩
                d + o + ⟦ xs ⟧ * suc b
            ≈⟨ cong
                (λ w → w + ⟦ xs ⟧ * suc b)
                (sym (greatest-digit-toℕ (Fin.fromℕ d) (greatest-digit-is-the-Greatest d)))
            ⟩
                ⟦ greatest-digit d ∷ xs ⟧
            □

Maximum? : ∀ {b d o}
    → (xs : Numeral b d o)
    → Dec (Maximum xs)
Maximum? {b} {d} {o} xs with numView b d o
Maximum? xs | NullBase d o = Maximum-NullBase xs
Maximum? xs | NoDigits b o = no (NoDigits-explode xs)
Maximum? xs | AllZeros b   = yes (Maximum-AllZeros xs)
Maximum? xs | Proper b d o proper = no (Maximum-Proper xs proper)


module InstanceArgumentsHidden where

record ⊤ : Set where

-- check that the instance argument resolution takes into account
-- instances which take hidden arguments to be of the correct type.
postulate A1 A2 B : Set
          f1 : {{a : A1}} → B
          f2 : {{a : A2}} → B
          inst1 : {_ : ⊤} → A1

checkProperty : ⊤ → Set
checkProperty _ = ⊤

postulate inst2 : {a : ⊤} → {_ : checkProperty a} → A2

test1 = f1
test2 = f2


module Numeral.Natural.Relation.ModuloCongruence where

open import Data.Boolean.Stmt
open import Functional
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.Modulo
open import Relator.Equals
open import Type

private variable m n x y : ℕ

_≡_[mod_] : ℕ → ℕ → (m : ℕ) → .⦃ pos : IsTrue(positive? m) ⦄ → Type
a ≡ b [mod m ] = ((_≡_) on₂ (_mod m)) a b

open import Relator.Equals.Proofs.Equiv
open import Structure.Relator.Equivalence
open import Structure.Relator.Equivalence.Proofs
open import Structure.Setoid using (Equiv ; intro)

instance
  mod-congruence-equivalence : ⦃ pos : IsTrue(positive? m) ⦄ → Equivalence(_≡_[mod m ])
  mod-congruence-equivalence {m} = on₂-equivalence {f = _mod m} ⦃ [≡]-equivalence ⦄

mod-congruence-equiv : (m : ℕ) → ⦃ pos : IsTrue(positive? m) ⦄ → Equiv(ℕ)
mod-congruence-equiv m = intro(_≡_[mod m ]) ⦃ mod-congruence-equivalence {m} ⦄

open import Lang.Instance
open import Logic.Propositional
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Modulo.Proofs
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Relation.Divisibility
open import Numeral.Natural.Relation.Order
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Proofs
open import Structure.Operator
open import Structure.Operator.Proofs.Util
open import Structure.Operator.Properties
open import Structure.Relator.Properties
open import Syntax.Implication
open import Syntax.Transitivity

mod-congruence-loose-linear-map : ∀{f g₁ g₂ h : ℕ → ℕ} (add : ∀{a b} → (f(a + b) ≡ g₁(a) + g₂(b))) → (mul : ∀{a b} → (g₂(a ⋅ b) ≡ a ⋅ h(b))) → ∀{m} ⦃ pos : IsTrue(positive? m) ⦄ → Function ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ f
Function.congruence (mod-congruence-loose-linear-map {f}{g₁}{g₂}{h} add mul {𝐒 m}) {a}{b} = mod-intro₂(\{a}{b} am bm → (am ≡ bm) → (f(a) mod 𝐒(m) ≡ f(b) mod 𝐒(m))) {𝐒 m} (\{a}{b}{n₁}{n₂} → p{a}{b}{n₁}{n₂}) {a}{b} where
  p : ∀{a b n₁ n₂} → (a < 𝐒(m)) → (b < 𝐒(m)) → (a ≡ b) → (f(a + (n₁ ⋅ 𝐒(m))) mod 𝐒(m)) ≡ (f(b + (n₂ ⋅ 𝐒(m))) mod 𝐒(m))
  p {a}{b}{n₁}{n₂} am bm ab =
    f(a + (n₁ ⋅ 𝐒(m))) mod 𝐒(m)       🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (add{a}{n₁ ⋅ 𝐒(m)}) ]
    (g₁(a) + g₂(n₁ ⋅ 𝐒(m))) mod 𝐒(m)  🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₂ᵣ(_+_)(g₁(a)) (congruence₁(g₂) (commutativity(_⋅_) {n₁}{𝐒 m}))) ]
    (g₁(a) + g₂(𝐒(m) ⋅ n₁)) mod 𝐒(m)  🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₂ᵣ(_+_)(g₁(a)) (mul{𝐒(m)}{n₁})) ]
    (g₁(a) + (𝐒(m) ⋅ h(n₁))) mod 𝐒(m) 🝖[ _≡_ ]-[ mod-of-modulus-sum-multiple{g₁(a)}{𝐒 m}{h(n₁)} ]
    g₁(a) mod 𝐒(m)                    🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₁(g₁) ab) ]
    g₁(b) mod 𝐒(m)                    🝖[ _≡_ ]-[ mod-of-modulus-sum-multiple{g₁(b)}{𝐒 m}{h(n₂)} ]-sym
    (g₁(b) + (𝐒(m) ⋅ h(n₂))) mod 𝐒(m) 🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₂ᵣ(_+_)(g₁(b)) (mul{𝐒(m)}{n₂})) ]-sym
    (g₁(b) + g₂(𝐒(m) ⋅ n₂)) mod 𝐒(m)  🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (congruence₂ᵣ(_+_)(g₁(b)) (congruence₁(g₂) (commutativity(_⋅_) {n₂}{𝐒 m}))) ]-sym
    (g₁(b) + g₂(n₂ ⋅ 𝐒(m))) mod 𝐒(m)  🝖[ _≡_ ]-[ congruence₁(_mod 𝐒(m)) (add{b}{n₂ ⋅ 𝐒(m)}) ]-sym
    f(b + (n₂ ⋅ 𝐒(m))) mod 𝐒(m)       🝖-end

module _ {m} ⦃ pos : IsTrue(positive?(m)) ⦄ where
  instance
    mod-congruence-𝐒-function : Function ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ 𝐒
    mod-congruence-𝐒-function = mod-congruence-loose-linear-map {𝐒}{𝐒}{id}{id} (reflexivity(_≡_)) (reflexivity(_≡_)) {m}

  instance
    mod-congruence-[+]-operator : BinaryOperator ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ (_+_)
    mod-congruence-[+]-operator = binaryOperator-from-function ⦃ _ ⦄ ⦃ _ ⦄ ⦃ _ ⦄ {_▫_ = _+_}
      ⦃ \{x} → functionₗ-from-commutative-functionᵣ ⦃ _ ⦄ ⦃ _ ⦄ {_+_} ⦃ r ⦄ ⦃ intro (\{x} → congruence₁(_mod m) (commutativity(_+_) {x})) ⦄ {x} ⦄
      ⦃ r ⦄
      where
        r : ∀{c} → Function ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ (_+ c)
        r{c} = mod-congruence-loose-linear-map {_+ c}{_+ c}{id}{id} (\{a}{b} → One.commuteᵣ-assocₗ{_▫_ = _+_} {a}{b}{c}) (reflexivity(_≡_)) {m}
        -- r {_}{_}{𝟎}  {_} p = p
        -- r {a}{b}{𝐒 c}{m} p = mod-congruence-with-𝐒 {a + c}{b + c}{m} (r {a}{b}{c}{m} p)

  instance
    mod-congruence-[⋅]-operator : BinaryOperator ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ (_⋅_)
    mod-congruence-[⋅]-operator = binaryOperator-from-function ⦃ _ ⦄ ⦃ _ ⦄ ⦃ _ ⦄ {_▫_ = _⋅_}
      ⦃ \{x} → functionₗ-from-commutative-functionᵣ ⦃ _ ⦄ ⦃ _ ⦄ {_⋅_} ⦃ \{c} → r{c} ⦄ ⦃ intro (\{x}{y} → congruence₁(_mod m) (commutativity(_⋅_) {x}{y})) ⦄ {x} ⦄
      ⦃ \{c} → r{c} ⦄
      where
        r : ∀{c} → Function ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ (_⋅ c)
        r{c} = mod-congruence-loose-linear-map {_⋅ c}{_⋅ c}{_⋅ c}{_⋅ c} (\{a}{b} → distributivityᵣ(_⋅_)(_+_) {a}{b}{c}) (\{a}{b} → associativity(_⋅_) {a}{b}{c}) {m}

  mod-congruence-[^]ₗ-function : ∀{n} → Function ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ (_^ n)
  Function.congruence (mod-congruence-[^]ₗ-function {𝟎})           _ = reflexivity(_≡_)
  Function.congruence (mod-congruence-[^]ₗ-function {𝐒 n}) {a} {b} p = BinaryOperator.congruence ⦃ _ ⦄ ⦃ _ ⦄ ⦃ _ ⦄ mod-congruence-[⋅]-operator {a}{b}{a ^ n}{b ^ n} p (Function.congruence ⦃ _ ⦄ ⦃ _ ⦄ (mod-congruence-[^]ₗ-function {n}) p)

instance
  mod-congruence-𝐒-injective : ⦃ pos : IsTrue(positive?(m)) ⦄ → Injective ⦃ mod-congruence-equiv m ⦄ ⦃ mod-congruence-equiv m ⦄ 𝐒
  Injective.proof (mod-congruence-𝐒-injective {𝐒 m}) {a}{b} =
    𝐒(a) mod 𝐒(m) ≡ 𝐒(b) mod 𝐒(m)             ⇒-[ swap (BinaryOperator.congruence ⦃ _ ⦄ ⦃ _ ⦄ ⦃ _ ⦄ (mod-congruence-[+]-operator {𝐒 m}) {𝐒 a}{𝐒 b}{m}{m}) (reflexivity(_≡_)) ]
    (𝐒(a) + m) mod 𝐒(m) ≡ (𝐒(b) + m) mod 𝐒(m) ⇒-[]
    (a + 𝐒(m)) mod 𝐒(m) ≡ (b + 𝐒(m)) mod 𝐒(m) ⇒-[ (p ↦ symmetry(_≡_) (mod-of-modulus-addᵣ{a}{m}) 🝖 p 🝖 mod-of-modulus-addᵣ{b}{m}) ]
    a mod 𝐒(m) ≡ b mod 𝐒(m)                   ⇒-end

mod-congruence-[𝄩] : ∀{a b m} → ⦃ pos : IsTrue(positive?(m)) ⦄ → (a ≡ b [mod m ]) ↔ (m ∣ (a 𝄩 b))
mod-congruence-[𝄩] {a} {b} {𝐒 m} = [↔]-intro (l{a}{b}) (r{a}{b}) where
  l : ∀{a b} → (a mod 𝐒(m) ≡ b mod 𝐒(m)) ← (𝐒(m) ∣ (a 𝄩 b))
  l {𝟎}   {𝟎}   div = [≡]-intro
  l {𝟎}   {𝐒 b} div = symmetry(_≡_) ([↔]-to-[←] mod-divisibility div)
  l {𝐒 a} {𝟎}   div = [↔]-to-[←] mod-divisibility div
  l {𝐒 a} {𝐒 b} div = congruence₁ ⦃ mod-congruence-equiv _ ⦄ ⦃ mod-congruence-equiv _ ⦄ (𝐒) {a}{b} (l{a}{b} div)

  r : ∀{a b} → (a mod 𝐒(m) ≡ b mod 𝐒(m)) → (𝐒(m) ∣ (a 𝄩 b))
  r {𝟎}   {𝟎}   eq = Div𝟎
  r {𝟎}   {𝐒 b} eq = [↔]-to-[→] mod-divisibility (symmetry(_≡_) eq)
  r {𝐒 a} {𝟎}   eq = [↔]-to-[→] mod-divisibility eq
  r {𝐒 a} {𝐒 b} eq = r{a}{b} (injective ⦃ mod-congruence-equiv _ ⦄ ⦃ mod-congruence-equiv _ ⦄ (𝐒) {a}{b} eq)

open import Logic.Propositional.Theorems
open import Numeral.Natural.Function.GreatestCommonDivisor
open import Numeral.Natural.Function.GreatestCommonDivisor.Proofs
open import Numeral.Natural.Oper.FlooredDivision
open import Numeral.Natural.Oper.FlooredDivision.Proofs
open import Numeral.Natural.Oper.FlooredDivision.Proofs.Inverse
open import Numeral.Natural.Coprime
open import Numeral.Natural.Coprime.Proofs
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Divisibility.Proofs
open import Numeral.Natural.Relation.Divisibility.Proofs.Product
open import Structure.Relator

-- TODO: Move the postulates below
postulate divides-[⌊/⌋] : ∀{a b c} ⦃ pos : Positive(c) ⦄ → (c ∣ a) → (a ∣ b) → ((a ⌊/⌋ c) ∣ (b ⌊/⌋ c))
postulate [⋅]-positive : ∀{a b} → ⦃ Positive(a) ⦄ → ⦃ Positive(b) ⦄ → Positive(a ⋅ b)
postulate [⌊/⌋][⋅]ₗ-compatibility : ∀{a b c} ⦃ pos : Positive(c) ⦄ → (c ∣ a) → (((a ⋅ b) ⌊/⌋ c) ≡ (a ⌊/⌋ c) ⋅ b)
postulate [⌊/⌋][⋅]ᵣ-compatibility : ∀{a b c} ⦃ pos : Positive(c) ⦄ → (c ∣ a) → (((a ⋅ b) ⌊/⌋ c) ≡ a ⋅ (b ⌊/⌋ c))

mod-congruence-scale-modulus : ∀{m} → ⦃ pos : Positive(m) ⦄ → ∀{a b c} → (c ⋅ a ≡ c ⋅ b [mod m ]) ↔ (a ≡ b [mod((m ⌊/⌋ gcd c m) ⦃ _ ⦄)]) ⦃ _ ⦄
mod-congruence-scale-modulus {m} ⦃ pos ⦄ {a}{b}{c} = [↔]-transitivity  ([↔]-transitivity mod-congruence-[𝄩] ([↔]-intro l r)) ([↔]-symmetry (mod-congruence-[𝄩] ⦃ [⌊/⌋]-positive ⦃ pos ⦄ ⦃ pgcd ⦄ ⦄)) where
  instance
    pgcd : Positive(gcd c m)
    pgcd = [↔]-to-[→] gcd-positive ([∨]-introᵣ pos)

  l : (m ∣ ((c ⋅ a) 𝄩 (c ⋅ b))) ← ((m ⌊/⌋ gcd c m) ⦃ _ ⦄ ∣ (a 𝄩 b))
  l =
    (m ⌊/⌋ gcd c m) ∣ (a 𝄩 b)                         ⇒-[ divides-with-[⋅]ᵣ-both {z = gcd c m} ]
    ((m ⌊/⌋ gcd c m) ⋅ gcd c m) ∣ ((a 𝄩 b) ⋅ gcd c m) ⇒-[ substitute₂ₗ(_∣_) ([⋅][⌊/⌋]-inverseOperatorᵣ (Gcd.divisorᵣ Gcd-gcd)) ]
    m ∣ ((a 𝄩 b) ⋅ gcd c m)                           ⇒-[ divides-with-[⋅] {c = (c ⌊/⌋ gcd c m) ⦃ _ ⦄} ∘ [∨]-introₗ ]
    m ∣ ((a 𝄩 b) ⋅ gcd c m) ⋅ (c ⌊/⌋ gcd c m)         ⇒-[ substitute₂ᵣ(_∣_) (associativity(_⋅_) {a 𝄩 b}{gcd c m}{(c ⌊/⌋ gcd c m) ⦃ _ ⦄}) ]
    m ∣ (a 𝄩 b) ⋅ (gcd c m ⋅ (c ⌊/⌋ gcd c m))         ⇒-[ substitute₂ᵣ(_∣_) (congruence₂ᵣ(_⋅_)(a 𝄩 b) (symmetry(_≡_) ([⌊/⌋][⋅]ᵣ-compatibility {gcd c m}{c}{gcd c m} (reflexivity(_∣_))))) ]
    m ∣ (a 𝄩 b) ⋅ ((gcd c m ⋅ c) ⌊/⌋ gcd c m)         ⇒-[ substitute₂ᵣ(_∣_) (congruence₂ᵣ(_⋅_)(a 𝄩 b) ([⌊/⌋][swap⋅]-inverseOperatorᵣ {gcd c m}{c})) ]
    m ∣ (a 𝄩 b) ⋅ c                                   ⇒-[ substitute₂ᵣ(_∣_) (commutativity(_⋅_) {a 𝄩 b}{c}) ]
    m ∣ c ⋅ (a 𝄩 b)                                   ⇒-[ substitute₂ᵣ(_∣_) (distributivityₗ(_⋅_)(_𝄩_) {c}{a}{b}) ]
    m ∣ ((c ⋅ a) 𝄩 (c ⋅ b))                           ⇒-end

  r : (m ∣ ((c ⋅ a) 𝄩 (c ⋅ b))) → ((m ⌊/⌋ gcd c m) ⦃ _ ⦄ ∣ (a 𝄩 b))
  r =
    (m ∣ (c ⋅ a 𝄩 c ⋅ b))                                        ⇒-[ substitute₂ᵣ(_∣_) (symmetry(_≡_) (distributivityₗ(_⋅_)(_𝄩_) {c}{a}{b})) ]
    (m ∣ c ⋅ (a 𝄩 b))                                            ⇒-[ divides-[⌊/⌋] {m}{c ⋅ (a 𝄩 b)}{gcd c m} (Gcd.divisorᵣ Gcd-gcd) ]
    (m ⌊/⌋ gcd c m) ⦃ _ ⦄ ∣ ((c ⋅ (a 𝄩 b)) ⌊/⌋ gcd c m) ⦃ _ ⦄    ⇒-[ substitute₂ᵣ(_∣_) ([⌊/⌋][⋅]ₗ-compatibility {c}{a 𝄩 b}{gcd c m} ⦃ pgcd ⦄ (Gcd.divisorₗ {c}{m} Gcd-gcd)) ]
    (m ⌊/⌋ gcd c m) ⦃ _ ⦄ ∣ ((c ⌊/⌋ gcd c m) ⦃ pgcd ⦄ ⋅ (a 𝄩 b)) ⇒-[ swap(coprime-divides-of-[⋅] {(m ⌊/⌋ gcd c m) ⦃ _ ⦄}{(c ⌊/⌋ gcd c m) ⦃ _ ⦄}{a 𝄩 b}) (symmetry(Coprime) ([⌊/⌋]-gcd-coprime{c}{m} ([∨]-introᵣ pos))) ]
    ((m ⌊/⌋ gcd c m) ⦃ _ ⦄ ∣ (a 𝄩 b))                            ⇒-end

postulate mod-congruence-scale : ∀{m} ⦃ pos-m : Positive(m) ⦄ {c} ⦃ pos-c : Positive(c) ⦄ → ∀{a b} → (a ≡ b [mod m ]) → (c ⋅ a ≡ c ⋅ b [mod(c ⋅ m)]) ⦃ [⋅]-positive {c}{m} ⦄

postulate mod-congruence-divide : ∀{m} ⦃ pos-m : Positive(m) ⦄ {c} ⦃ pos-c : Positive(c) ⦄ → (c ∣ m) → ∀{a b} → (c ∣ a) → (c ∣ b) → (a ≡ b [mod m ]) → (a ⌊/⌋ c ≡ b ⌊/⌋ c [mod(m ⌊/⌋ c)]) ⦃ [⌊/⌋]-positive {m}{c} ⦄

postulate mod-congruence-smaller-modulus : ∀{m₁} ⦃ pos-m₁ : Positive(m₁) ⦄ {m₂} ⦃ pos-m₂ : Positive(m₂) ⦄ → (m₂ ∣ m₁) → ∀{a b} → (a ≡ b [mod m₁ ]) → (a ≡ b [mod m₂ ])

postulate mod-congruence-to-gcd-equality : ∀{m} ⦃ pos-m : Positive(m) ⦄ → ∀{a b} → (a ≡ b [mod m ]) → (gcd a m ≡ gcd b m)

postulate mod-congruence-[−₀]-operator : ∀{m} ⦃ pos-m : Positive(m) ⦄ → ∀{a₁ a₂ b₁ b₂} → (a₁ ≥ b₁) → (a₂ ≥ b₂) → (a₁ ≡ a₂ [mod m ]) → (b₁ ≡ b₂ [mod m ]) → (a₁ −₀ b₁ ≡ a₂ −₀ b₂ [mod m ])

postulate mod-congruence-[⌊/⌋]-operator : ∀{m} ⦃ pos-m : Positive(m) ⦄ → ∀{a₁ a₂ b₁ b₂} ⦃ pos-b₁ : Positive(b₁) ⦄ ⦃ pos-b₂ : Positive(b₂) ⦄ → (a₁ ∣ b₁) → (a₂ ∣ b₂) → (a₁ ≡ a₂ [mod m ]) → (b₁ ≡ b₂ [mod m ]) → (a₁ ⌊/⌋ b₁ ≡ a₂ ⌊/⌋ b₂ [mod m ])


-- Andreas, 2020-09-26, issue #4944.
-- Size solver got stuck on projected variables which are left over
-- in some size constraints by the generalization feature.

-- {-# OPTIONS --sized-types #-}
-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.conv.size:60 -v tc.size:30 -v tc.meta.assign:10 #-}

open import Agda.Builtin.Size

variable
  i : Size

postulate
  A : Set

data ListA (i : Size) : Set where
  nil   : ListA i
  cons  : (j : Size< i) (t : A) (as : ListA j) → ListA i

postulate
  node : A → ListA ∞ → A
  R    : (i : Size) (as as′ : ListA i) → Set

  test : -- {i : Size} -- made error vanish
         (t u : A) (as : ListA i) →
         R (↑ (↑ i)) (cons (↑ i) t (cons i u as)) (cons _ (node t (cons _ u nil)) as)

variable
  t u : A
  as : ListA i

postulate
  tst2 : R _ (cons _ t (cons _ u as)) (cons _ (node t (cons _ u nil)) as)

-- Should pass.


-- Jesper, 2017-08-13: This test case now fails since instantiation
-- of metavariables during case splitting was disabled (see #2621).

{-# OPTIONS --allow-unsolved-metas #-}

record ⊤ : Set where
  constructor tt

data I : Set where
  i : ⊤ → I

data D : I → Set where
  d : D (i tt)

postulate
  P : (x : I) → D x → Set

foo : (y : _) → P _ y
foo d = {!!}


{-# OPTIONS --without-K --rewriting #-}

open import HoTT

module homotopy.WedgeExtension
  {i j} {A : Type i} {a₀ : A} {B : Type j} {b₀ : B} where

  -- easier to keep track of than a long list of arguments
  record args : Type (lmax (lsucc i) (lsucc j)) where
    field
      n m : ℕ₋₂
      {{cA}} : is-connected (S n) A
      {{cB}} : is-connected (S m) B
      P : A → B → (n +2+ m) -Type (lmax i j)
      f : (a : A) → fst (P a b₀)
      g : (b : B) → fst (P a₀ b)
      p : f a₀ == g b₀

  private
    module _ (r : args) where
      open args r

      Q : A → n -Type (lmax i j)
      Q a = ((Σ (∀ b → fst (P a b)) (λ k → (k ∘ cst b₀) == cst (f a)) ,
                conn-extend-general (pointed-conn-out B b₀)
                                    (P a) (cst (f a))))

      l : Π A (fst ∘ Q)
      l = conn-extend (pointed-conn-out A a₀)
                      Q (λ (_ : Unit) → (g , ap cst (! p)))

  module _ (r : args) where
    open args r

    ext : ∀ a → ∀ b → fst (P a b)
    ext a = fst (l r a)

  module _ {r : args} where
    open args r

    abstract
      β-l : ∀ a → ext r a b₀ == f a
      β-l a = ap (λ t → t unit) (snd (l r a))

    private
      abstract
        β-r-aux : fst (l r a₀) == g
        β-r-aux = fst= (conn-extend-β
          (pointed-conn-out A a₀)
          (Q r) (λ (_ : Unit) → (g , ap cst (! p))) unit)

    abstract
      β-r : ∀ b → ext r a₀ b == g b
      β-r = app= β-r-aux

    abstract
      coh : ! (β-l a₀) ∙ β-r b₀ == p
      coh =
        ! (β-l a₀) ∙ β-r b₀
          =⟨ ! lemma₂ |in-ctx (λ w → ! w ∙ β-r b₀) ⟩
        ! (β-r b₀ ∙ ! p) ∙ β-r b₀
          =⟨ !-∙ (β-r b₀) (! p) |in-ctx (λ w → w ∙ β-r b₀) ⟩
        (! (! p) ∙ ! (β-r b₀)) ∙ β-r b₀
          =⟨ ∙-assoc (! (! p)) (! (β-r b₀)) (β-r b₀) ⟩
        ! (! p) ∙ (! (β-r b₀) ∙ β-r b₀)
          =⟨ ap2 _∙_ (!-! p) (!-inv-l (β-r b₀)) ⟩
        p ∙ idp
          =⟨ ∙-unit-r p ⟩
        p =∎
        where
        lemma₁ : β-l a₀ == ap (λ s → s unit) (ap cst (! p))
                 [ (λ k → k b₀ == f a₀) ↓ β-r-aux ]
        lemma₁ = ap↓ (ap (λ s → s unit)) $
                      snd= (conn-extend-β (pointed-conn-out A a₀)
                           (Q r) (λ (_ : Unit) → (g , ap cst (! p))) unit)

        lemma₂ : β-r b₀ ∙ ! p == β-l a₀
        lemma₂ = ap (λ w → β-r b₀ ∙ w)
                    (! (ap-idf (! p)) ∙ ap-∘ (λ s → s unit) cst (! p))
                 ∙ (! (↓-app=cst-out lemma₁))


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.EquivCarac.AB-An[X]Bn[X] where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels

open import Cubical.Data.Nat using (ℕ ; zero ; suc)
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat
open import Cubical.Data.Sigma

open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly

private variable
  ℓ : Level

-----------------------------------------------------------------------------
-- Lift

open IsRingHom
open CommRingStr

module _
  (A'@(A , Astr) : CommRing ℓ)
  (B'@(B , Bstr) : CommRing ℓ)
  (n : ℕ)
  where

  private
    PA = PolyCommRing A' n
    PB = PolyCommRing B' n

  makeCommRingHomPoly : (f : CommRingHom A' B') → CommRingHom (PolyCommRing A' n) (PolyCommRing B' n)
  fst (makeCommRingHomPoly (f , fstr)) = DS-Rec-Set.f _ _ _ _ trunc
                                         (0r (snd PB))
                                         (λ v a → base v (f a))
                                         (_+_ (snd PB))
                                         (+Assoc (snd PB))
                                         (+IdR (snd PB))
                                         (+Comm (snd PB))
                                         (λ v → (cong (base v) (pres0 fstr)) ∙ (base-neutral v))
                                         (λ v a b → (base-add v (f a) (f b)) ∙ (cong (base v) (sym (pres+ fstr a b))))
  snd (makeCommRingHomPoly (f , fstr)) = makeIsRingHom
                                         (cong (base (replicate zero)) (pres1 fstr))
                                         (λ _ _ → refl)
                                         (DS-Ind-Prop.f _ _ _ _ (λ _ → isPropΠ λ _ → trunc _ _)
                                             (λ _ → refl)
                                             (λ v a → DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
                                                                    refl
                                                                    (λ v' b → cong (base (v +n-vec v')) (pres· fstr a b))
                                                                    (λ {U V} ind-U ind-V → cong₂ (_+_ (snd PB)) ind-U  ind-V))
                                             λ {U V} ind-U ind-V Q → cong₂ (_+_ (snd PB)) (ind-U Q) (ind-V Q))

-----------------------------------------------------------------------------
-- Lift preserve equivalence

module _
  (A'@(A , Astr) : CommRing ℓ)
  (B'@(B , Bstr) : CommRing ℓ)
  (n : ℕ)
  where

  private
    PA = PolyCommRing A' n
    PB = PolyCommRing B' n

  open Iso
  open RingEquivs

  lift-equiv-poly : (e : CommRingEquiv A' B') → CommRingEquiv (PolyCommRing A' n) (PolyCommRing B' n)
  fst (lift-equiv-poly (e , fstr)) = isoToEquiv is
    where
    f = fst e
    g = invEq e
    gstr : IsRingHom (snd (CommRing→Ring B')) g (snd (CommRing→Ring A'))
    gstr = isRingHomInv (e , fstr)

    is : Iso (fst PA) (fst PB)
    fun is = fst (makeCommRingHomPoly A' B' n (f , fstr))
    inv is = fst (makeCommRingHomPoly B' A' n (g , gstr))
    rightInv is = DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
                  refl
                  (λ v a → cong (base v) (secEq e a))
                  λ {U V} ind-U ind-V → cong₂ (_+_ (snd PB)) ind-U ind-V
    leftInv is = DS-Ind-Prop.f _ _ _ _ (λ _ → trunc _ _)
                 refl
                 (λ v a → cong (base v) (retEq e a))
                 λ {U V} ind-U ind-V → cong₂ (_+_ (snd PA)) ind-U ind-V
  snd (lift-equiv-poly (e , fstr)) = snd (makeCommRingHomPoly A' B' n ((fst e) , fstr))


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Integers.Definition
open import Semirings.Definition
open import Groups.Abelian.Definition
open import Groups.Definition
open import Setoids.Setoids

module Numbers.Integers.Addition where

infix 15 _+Z_
_+Z_ : ℤ → ℤ → ℤ
nonneg zero +Z b = b
nonneg (succ x) +Z nonneg y = nonneg (succ x +N y)
nonneg (succ x) +Z negSucc zero = nonneg x
nonneg (succ x) +Z negSucc (succ y) = nonneg x +Z negSucc y
negSucc x +Z nonneg zero = negSucc x
negSucc zero +Z nonneg (succ y) = nonneg y
negSucc (succ x) +Z nonneg (succ y) = negSucc x +Z nonneg y
negSucc x +Z negSucc y = negSucc (succ x +N y)

+Zinherits : (a b : ℕ) → nonneg (a +N b) ≡ (nonneg a) +Z (nonneg b)
+Zinherits zero b = refl
+Zinherits (succ a) b = refl

+ZCommutative : (a b : ℤ) → a +Z b ≡ b +Z a
+ZCommutative (nonneg zero) (nonneg zero) = refl
+ZCommutative (nonneg zero) (nonneg (succ y)) = applyEquality (λ i → nonneg (succ i)) (Semiring.commutative ℕSemiring 0 y)
+ZCommutative (nonneg (succ x)) (nonneg zero) = applyEquality (λ i → nonneg (succ i)) (Semiring.commutative ℕSemiring x 0)
+ZCommutative (nonneg (succ x)) (nonneg (succ y)) = applyEquality (λ i → nonneg (succ i)) (transitivity (Semiring.commutative ℕSemiring x (succ y)) (transitivity (applyEquality succ (Semiring.commutative ℕSemiring y x)) (Semiring.commutative ℕSemiring (succ x) y)))
+ZCommutative (nonneg zero) (negSucc y) = refl
+ZCommutative (nonneg (succ x)) (negSucc zero) = refl
+ZCommutative (nonneg (succ x)) (negSucc (succ y)) = +ZCommutative (nonneg x) (negSucc y)
+ZCommutative (negSucc x) (nonneg zero) = refl
+ZCommutative (negSucc zero) (nonneg (succ y)) = refl
+ZCommutative (negSucc (succ x)) (nonneg (succ y)) = +ZCommutative (negSucc x) (nonneg y)
+ZCommutative (negSucc x) (negSucc y) = applyEquality (λ i → negSucc (succ i)) (Semiring.commutative ℕSemiring x y)

+ZAssociative : (a b c : ℤ) → a +Z (b +Z c) ≡ (a +Z b) +Z c
+ZAssociative (nonneg zero) (nonneg b) (nonneg c) = refl
+ZAssociative (nonneg (succ a)) (nonneg zero) (nonneg c) rewrite Semiring.commutative ℕSemiring a 0 = refl
+ZAssociative (nonneg (succ a)) (nonneg (succ b)) (nonneg c) = applyEquality (λ i → nonneg (succ i)) (Semiring.+Associative ℕSemiring a (succ b) c)
+ZAssociative (nonneg zero) (nonneg b) (negSucc c) = refl
+ZAssociative (nonneg (succ a)) (nonneg zero) (negSucc c) rewrite Semiring.sumZeroRight ℕSemiring a = refl
+ZAssociative (nonneg (succ a)) (nonneg (succ b)) (negSucc zero) = applyEquality nonneg (transitivity (applyEquality succ (Semiring.commutative ℕSemiring a b)) (Semiring.commutative ℕSemiring (succ b) a))
+ZAssociative (nonneg (succ a)) (nonneg (succ b)) (negSucc (succ c)) = transitivity (+ZAssociative (nonneg (succ a)) (nonneg b) (negSucc c)) (applyEquality (λ i → nonneg i +Z negSucc c) (transitivity (applyEquality succ (Semiring.commutative ℕSemiring a b)) (Semiring.commutative ℕSemiring (succ b) a)))
+ZAssociative (nonneg zero) (negSucc b) c = refl
+ZAssociative (nonneg (succ a)) (negSucc zero) (nonneg zero) = +ZCommutative (nonneg 0) (nonneg a)
+ZAssociative (nonneg (succ a)) (negSucc zero) (nonneg (succ c)) = transitivity (applyEquality nonneg (transitivity (applyEquality succ (Semiring.commutative ℕSemiring a c)) (Semiring.commutative ℕSemiring (succ c) a))) (+Zinherits a (succ c))
+ZAssociative (nonneg (succ a)) (negSucc zero) (negSucc c) = refl
+ZAssociative (nonneg (succ a)) (negSucc (succ b)) (nonneg zero) = +ZCommutative (nonneg 0) _
+ZAssociative (nonneg (succ a)) (negSucc (succ b)) (nonneg (succ c)) = transitivity (applyEquality (nonneg (succ a) +Z_) (+ZCommutative (negSucc b) (nonneg c))) (transitivity (+ZAssociative (nonneg (succ a)) (nonneg c) (negSucc b)) (transitivity (transitivity (transitivity (transitivity (applyEquality (λ i → nonneg (succ i) +Z negSucc b) (Semiring.commutative ℕSemiring a c)) (+ZCommutative (nonneg (succ (c +N a))) (negSucc b))) (applyEquality (negSucc b +Z_) (+ZCommutative (nonneg (succ c)) (nonneg a)))) (+ZAssociative (negSucc b) (nonneg a) (nonneg (succ c)))) (applyEquality (_+Z nonneg (succ c)) (+ZCommutative (negSucc b) (nonneg a)))))
+ZAssociative (nonneg (succ a)) (negSucc (succ b)) (negSucc c) = +ZAssociative (nonneg a) (negSucc b) (negSucc c)
+ZAssociative (negSucc a) (nonneg zero) c = refl
+ZAssociative (negSucc zero) (nonneg (succ b)) (nonneg c) = +Zinherits b c
+ZAssociative (negSucc zero) (nonneg (succ b)) (negSucc zero) = +ZCommutative (negSucc 0) (nonneg b)
+ZAssociative (negSucc zero) (nonneg (succ b)) (negSucc (succ c)) = transitivity (+ZCommutative (negSucc 0) (nonneg b +Z negSucc c)) (transitivity (equalityCommutative (+ZAssociative (nonneg b) (negSucc c) (negSucc 0))) (applyEquality (λ i → nonneg b +Z negSucc (succ i)) (Semiring.sumZeroRight ℕSemiring c)))
+ZAssociative (negSucc (succ a)) (nonneg (succ b)) (nonneg zero) = transitivity (applyEquality (λ i → negSucc a +Z (nonneg i)) (Semiring.sumZeroRight ℕSemiring b)) (+ZCommutative (nonneg 0) (negSucc a +Z nonneg b))
+ZAssociative (negSucc (succ a)) (nonneg (succ b)) (nonneg (succ c)) = transitivity (applyEquality (negSucc a +Z_) (+Zinherits b (succ c))) (+ZAssociative (negSucc a) (nonneg b) (nonneg (succ c)))
+ZAssociative (negSucc (succ a)) (nonneg (succ b)) (negSucc zero) = transitivity (+ZCommutative (negSucc (succ a)) (nonneg b)) (transitivity (transitivity (applyEquality (λ i → nonneg b +Z negSucc (succ i)) (equalityCommutative (Semiring.sumZeroRight ℕSemiring a))) (+ZAssociative (nonneg b) (negSucc a) (negSucc 0))) (applyEquality (_+Z negSucc 0) (+ZCommutative (nonneg b) (negSucc a))))
+ZAssociative (negSucc (succ a)) (nonneg (succ b)) (negSucc (succ c)) = transitivity (+ZCommutative (negSucc (succ a)) (nonneg b +Z negSucc c)) (transitivity (transitivity (equalityCommutative (+ZAssociative (nonneg b) (negSucc c) (negSucc (succ a)))) (transitivity (applyEquality (λ i → nonneg b +Z negSucc i) (Semiring.commutative ℕSemiring (succ c) (succ a))) (+ZAssociative (nonneg b) (negSucc a) (negSucc (succ c))))) (applyEquality (_+Z negSucc (succ c)) (+ZCommutative (nonneg b) (negSucc a))))
+ZAssociative (negSucc a) (negSucc b) (nonneg zero) = refl
+ZAssociative (negSucc a) (negSucc zero) (nonneg (succ c)) = applyEquality (λ i → negSucc i +Z nonneg c) (Semiring.commutative ℕSemiring 0 a)
+ZAssociative (negSucc a) (negSucc (succ b)) (nonneg (succ c)) = transitivity (+ZAssociative (negSucc a) (negSucc b) (nonneg c)) (applyEquality (λ i → negSucc i +Z nonneg c) (transitivity (applyEquality succ (Semiring.commutative ℕSemiring a b)) (Semiring.commutative ℕSemiring (succ b) a)))
+ZAssociative (negSucc a) (negSucc b) (negSucc c) = applyEquality (λ i → negSucc (succ i)) (transitivity (Semiring.+Associative ℕSemiring a (succ b) c) (applyEquality (_+N c) (transitivity (Semiring.commutative ℕSemiring a (succ b)) (applyEquality succ (Semiring.commutative ℕSemiring b a)))))

additiveInverseExists : (a : ℕ) → (negSucc a +Z nonneg (succ a)) ≡ nonneg 0
additiveInverseExists zero = refl
additiveInverseExists (succ a) = additiveInverseExists a

additiveInverse : (a : ℤ) → ℤ
additiveInverse (nonneg zero) = nonneg 0
additiveInverse (nonneg (succ x)) = negSucc x
additiveInverse (negSucc x) = nonneg (succ x)

ℤGroup : Group (reflSetoid ℤ) (_+Z_)
Group.+WellDefined ℤGroup refl refl = refl
Group.0G ℤGroup = nonneg 0
Group.inverse ℤGroup = additiveInverse
Group.+Associative ℤGroup {a} {b} {c} = +ZAssociative a b c
Group.identRight ℤGroup {nonneg zero} = refl
Group.identRight ℤGroup {nonneg (succ x)} = applyEquality (λ i → nonneg (succ i)) (Semiring.commutative ℕSemiring x 0)
Group.identRight ℤGroup {negSucc x} = refl
Group.identLeft ℤGroup = refl
Group.invLeft ℤGroup {nonneg zero} = refl
Group.invLeft ℤGroup {nonneg (succ x)} = additiveInverseExists x
Group.invLeft ℤGroup {negSucc x} = transitivity (+ZCommutative (nonneg (succ x)) (negSucc x)) (additiveInverseExists x)
Group.invRight ℤGroup {nonneg zero} = refl
Group.invRight ℤGroup {nonneg (succ x)} = transitivity (+ZCommutative (nonneg (succ x)) (negSucc x)) (additiveInverseExists x)
Group.invRight ℤGroup {negSucc x} = additiveInverseExists x

ℤAbGrp : AbelianGroup ℤGroup
ℤAbGrp = record { commutative = λ {a} {b} → +ZCommutative a b }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bundles for types of functions
------------------------------------------------------------------------

-- The contents of this file should usually be accessed from `Function`.

-- Note that these bundles differ from those found elsewhere in other
-- library hierarchies as they take Setoids as parameters. This is
-- because a function is of no use without knowing what its domain and
-- codomain is, as well which equalities are being considered over them.
-- One consequence of this is that they are not built from the
-- definitions found in `Function.Structures` as is usually the case in
-- other library hierarchies, as this would duplicate the equality
-- axioms.

{-# OPTIONS --without-K --safe #-}

module Function.Bundles where

import Function.Definitions as FunctionDefinitions
import Function.Structures as FunctionStructures
open import Level using (Level; _⊔_; suc)
open import Data.Product using (proj₁; proj₂)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as ≡
  using (_≡_)
open Setoid using (isEquivalence)

private
  variable
    a b ℓ₁ ℓ₂ : Level

------------------------------------------------------------------------
-- Setoid bundles

module _ (From : Setoid a ℓ₁) (To : Setoid b ℓ₂) where

  open Setoid From using () renaming (Carrier to A; _≈_ to _≈₁_)
  open Setoid To   using () renaming (Carrier to B; _≈_ to _≈₂_)
  open FunctionDefinitions _≈₁_ _≈₂_
  open FunctionStructures  _≈₁_ _≈₂_

  record Injection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f           : A → B
      cong        : f Preserves _≈₁_ ⟶ _≈₂_
      injective   : Injective f

    isCongruent : IsCongruent f
    isCongruent = record
      { cong           = cong
      ; isEquivalence₁ = isEquivalence From
      ; isEquivalence₂ = isEquivalence To
      }

    open IsCongruent isCongruent public using (module Eq₁; module Eq₂)

    isInjection : IsInjection f
    isInjection = record
      { isCongruent = isCongruent
      ; injective   = injective
      }

  record Surjection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f          : A → B
      cong       : f Preserves _≈₁_ ⟶ _≈₂_
      surjective : Surjective f

    isCongruent : IsCongruent f
    isCongruent = record
      { cong           = cong
      ; isEquivalence₁ = isEquivalence From
      ; isEquivalence₂ = isEquivalence To
      }

    open IsCongruent isCongruent public using (module Eq₁; module Eq₂)

    isSurjection : IsSurjection f
    isSurjection = record
      { isCongruent = isCongruent
      ; surjective  = surjective
      }

  record Bijection : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f         : A → B
      cong      : f Preserves _≈₁_ ⟶ _≈₂_
      bijective : Bijective f

    injective : Injective f
    injective = proj₁ bijective

    surjective : Surjective f
    surjective = proj₂ bijective

    injection : Injection
    injection = record
      { cong      = cong
      ; injective = injective
      }

    surjection : Surjection
    surjection = record
      { cong       = cong
      ; surjective = surjective
      }

    open Injection  injection  public using (isInjection)
    open Surjection surjection public using (isSurjection)

    isBijection : IsBijection f
    isBijection = record
      { isInjection = isInjection
      ; surjective  = surjective
      }

    open IsBijection isBijection public using (module Eq₁; module Eq₂)

  record Equivalence : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f     : A → B
      g     : B → A
      cong₁ : f Preserves _≈₁_ ⟶ _≈₂_
      cong₂ : g Preserves _≈₂_ ⟶ _≈₁_

  record LeftInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f         : A → B
      g         : B → A
      cong₁     : f Preserves _≈₁_ ⟶ _≈₂_
      cong₂     : g Preserves _≈₂_ ⟶ _≈₁_
      inverseˡ  : Inverseˡ f g

    isCongruent : IsCongruent f
    isCongruent = record
      { cong           = cong₁
      ; isEquivalence₁ = isEquivalence From
      ; isEquivalence₂ = isEquivalence To
      }

    open IsCongruent isCongruent public using (module Eq₁; module Eq₂)

    isLeftInverse : IsLeftInverse f g
    isLeftInverse = record
      { isCongruent = isCongruent
      ; cong₂       = cong₂
      ; inverseˡ    = inverseˡ
      }

    equivalence : Equivalence
    equivalence = record
      { cong₁ = cong₁
      ; cong₂ = cong₂
      }

  record RightInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f         : A → B
      g         : B → A
      cong₁     : f Preserves _≈₁_ ⟶ _≈₂_
      cong₂     : g Preserves _≈₂_ ⟶ _≈₁_
      inverseʳ  : Inverseʳ f g

    isCongruent : IsCongruent f
    isCongruent = record
      { cong           = cong₁
      ; isEquivalence₁ = isEquivalence From
      ; isEquivalence₂ = isEquivalence To
      }

    isRightInverse : IsRightInverse f g
    isRightInverse = record
      { isCongruent = isCongruent
      ; cong₂       = cong₂
      ; inverseʳ    = inverseʳ
      }

    equivalence : Equivalence
    equivalence = record
      { cong₁ = cong₁
      ; cong₂ = cong₂
      }

  record BiEquivalence : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f     : A → B
      g₁    : B → A
      g₂    : B → A
      cong₁ : f Preserves _≈₁_ ⟶ _≈₂_
      cong₂ : g₁ Preserves _≈₂_ ⟶ _≈₁_
      cong₃ : g₂ Preserves _≈₂_ ⟶ _≈₁_

  record BiInverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f         : A → B
      g₁        : B → A
      g₂        : B → A
      cong₁     : f Preserves _≈₁_ ⟶ _≈₂_
      cong₂     : g₁ Preserves _≈₂_ ⟶ _≈₁_
      cong₃     : g₂ Preserves _≈₂_ ⟶ _≈₁_
      inverseˡ  : Inverseˡ f g₁
      inverseʳ  : Inverseʳ f g₂

    f-isCongruent : IsCongruent f
    f-isCongruent = record
      { cong           = cong₁
      ; isEquivalence₁ = isEquivalence From
      ; isEquivalence₂ = isEquivalence To
      }

    isBiInverse : IsBiInverse f g₁ g₂
    isBiInverse = record
      { f-isCongruent = f-isCongruent
      ; cong₂         = cong₂
      ; inverseˡ      = inverseˡ
      ; cong₃         = cong₃
      ; inverseʳ      = inverseʳ
      }

    biEquivalence : BiEquivalence
    biEquivalence = record
      { cong₁ = cong₁
      ; cong₂ = cong₂
      ; cong₃ = cong₃
      }

  record Inverse : Set (a ⊔ b ⊔ ℓ₁ ⊔ ℓ₂) where
    field
      f         : A → B
      f⁻¹       : B → A
      cong₁     : f Preserves _≈₁_ ⟶ _≈₂_
      cong₂     : f⁻¹ Preserves _≈₂_ ⟶ _≈₁_
      inverse   : Inverseᵇ f f⁻¹

    inverseˡ : Inverseˡ f f⁻¹
    inverseˡ = proj₁ inverse

    inverseʳ : Inverseʳ f f⁻¹
    inverseʳ = proj₂ inverse

    leftInverse : LeftInverse
    leftInverse = record
      { cong₁    = cong₁
      ; cong₂    = cong₂
      ; inverseˡ = inverseˡ
      }

    rightInverse : RightInverse
    rightInverse = record
      { cong₁    = cong₁
      ; cong₂    = cong₂
      ; inverseʳ = inverseʳ
      }

    open LeftInverse leftInverse   public using (isLeftInverse)
    open RightInverse rightInverse public using (isRightInverse)

    isInverse : IsInverse f f⁻¹
    isInverse = record
      { isLeftInverse = isLeftInverse
      ; inverseʳ      = inverseʳ
      }

    open IsInverse isInverse public using (module Eq₁; module Eq₂)

------------------------------------------------------------------------
-- Bundles specialised for propositional equality

infix 3 _↣_ _↠_ _⤖_ _⇔_ _↩_ _↪_ _↩↪_ _↔_

_↣_ : Set a → Set b → Set _
A ↣ B = Injection (≡.setoid A) (≡.setoid B)

_↠_ : Set a → Set b → Set _
A ↠ B = Surjection (≡.setoid A) (≡.setoid B)

_⤖_ : Set a → Set b → Set _
A ⤖ B = Bijection (≡.setoid A) (≡.setoid B)

_⇔_ : Set a → Set b → Set _
A ⇔ B = Equivalence (≡.setoid A) (≡.setoid B)

_↩_ : Set a → Set b → Set _
A ↩ B = LeftInverse (≡.setoid A) (≡.setoid B)

_↪_ : Set a → Set b → Set _
A ↪ B = RightInverse (≡.setoid A) (≡.setoid B)

_↩↪_ : Set a → Set b → Set _
A ↩↪ B = BiInverse (≡.setoid A) (≡.setoid B)

_↔_ : Set a → Set b → Set _
A ↔ B = Inverse (≡.setoid A) (≡.setoid B)

-- We now define some constructors for the above that
-- automatically provide the required congruency proofs.

module _ {A : Set a} {B : Set b} where

  open FunctionDefinitions {A = A} {B} _≡_ _≡_

  mk↣ : ∀ {f : A → B} → Injective f → A ↣ B
  mk↣ {f} inj = record
    { f         = f
    ; cong      = ≡.cong f
    ; injective = inj
    }

  mk↠ : ∀ {f : A → B} → Surjective f → A ↠ B
  mk↠ {f} surj = record
    { f          = f
    ; cong       = ≡.cong f
    ; surjective = surj
    }

  mk⤖ : ∀ {f : A → B} → Bijective f → A ⤖ B
  mk⤖ {f} bij = record
    { f         = f
    ; cong      = ≡.cong f
    ; bijective = bij
    }

  mk⇔ : ∀ (f : A → B) (g : B → A) → A ⇔ B
  mk⇔ f g = record
    { f     = f
    ; g     = g
    ; cong₁ = ≡.cong f
    ; cong₂ = ≡.cong g
    }

  mk↩ : ∀ {f : A → B} {g : B → A} → Inverseˡ f g → A ↩ B
  mk↩ {f} {g} invˡ = record
    { f        = f
    ; g        = g
    ; cong₁    = ≡.cong f
    ; cong₂    = ≡.cong g
    ; inverseˡ = invˡ
    }

  mk↪ : ∀ {f : A → B} {g : B → A} → Inverseʳ f g → A ↪ B
  mk↪ {f} {g} invʳ = record
    { f        = f
    ; g        = g
    ; cong₁    = ≡.cong f
    ; cong₂    = ≡.cong g
    ; inverseʳ = invʳ
    }

  mk↩↪ : ∀ {f : A → B} {g₁ : B → A} {g₂ : B → A}
    → Inverseˡ f g₁ → Inverseʳ f g₂ → A ↩↪ B
  mk↩↪ {f} {g₁} {g₂} invˡ invʳ = record
    { f        = f
    ; g₁       = g₁
    ; g₂       = g₂
    ; cong₁    = ≡.cong f
    ; cong₂    = ≡.cong g₁
    ; cong₃    = ≡.cong g₂
    ; inverseˡ = invˡ
    ; inverseʳ = invʳ
    }

  mk↔ : ∀ {f : A → B} {f⁻¹ : B → A} → Inverseᵇ f f⁻¹ → A ↔ B
  mk↔ {f} {f⁻¹} inv = record
    { f       = f
    ; f⁻¹     = f⁻¹
    ; cong₁   = ≡.cong f
    ; cong₂   = ≡.cong f⁻¹
    ; inverse = inv
    }


module Data.Num.Bijective where

open import Data.Nat
open import Data.Fin as Fin using (Fin; #_; fromℕ≤)
open import Data.Fin.Extra
open import Data.Fin.Properties using (bounded)
open ≤-Reasoning renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≈⟨_⟩_)
open import Level using () renaming (suc to lsuc)
open import Function
open import Relation.Nullary.Negation
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as PropEq

infixr 5 _∷_

-- For a system to be bijective wrt ℕ:
--  * base ≥ 1
--  * digits = {1 .. base}
data Bij : ℕ → Set where
    -- from the terminal object, which represents 0
    ∙ : ∀ {b}           -- base
        → Bij (suc b)   -- base ≥ 1

    -- successors
    _∷_ : ∀ {b}
        → Fin b         -- digit = {1 .. b}
        → Bij b → Bij b

infixr 9 _/_
-- syntax sugar for chaining digits with ℕ
_/_ : ∀ {b} → (n : ℕ)
    → {lower-bound : True (suc zero ≤? n)}      -- digit ≥ 1
    → {upper-bound : True (n        ≤? b)}      -- digit ≤ base
    → Bij b → Bij b
_/_ {b} zero    {()} {ub} ns
_/_ {b} (suc n) {lb} {ub} ns = (# n) {b} {ub} ∷ ns

module _/_-Examples where

    零 : Bij 2
    零 = ∙

    一 : Bij 2
    一 = 1 / ∙

    八 : Bij 3
    八 = 2 / 2 / ∙

八 : Bij 3
八 = 2 / 2 / ∙

open import Data.Nat.DM
open import Data.Nat.Properties using (≰⇒>)
open import Relation.Binary

-- a digit at its largest
full : ∀ {b} (x : Fin (suc b)) → Dec (Fin.toℕ {suc b} x ≡ b)
full {b} x = Fin.toℕ x ≟ b

-- a digit at its largest (for ℕ)
full-ℕ : ∀ b n → Dec (n ≡ b)
full-ℕ b n = n ≟ b

------------------------------------------------------------------------
-- Digit
------------------------------------------------------------------------

digit-toℕ : ∀ {b} → Fin b → ℕ
digit-toℕ x = suc (Fin.toℕ x)

digit+1-lemma : ∀ a b → a < suc b → a ≢ b → a < b
digit+1-lemma zero    zero    a<1+b a≢b = contradiction refl a≢b
digit+1-lemma zero    (suc b) a<1+b a≢b = s≤s z≤n
digit+1-lemma (suc a) zero    (s≤s ()) a≢b
digit+1-lemma (suc a) (suc b) (s≤s a<1+b) a≢b = s≤s (digit+1-lemma a b a<1+b (λ z → a≢b (cong suc z)))

digit+1 : ∀ {b} → (x : Fin (suc b)) → Fin.toℕ x ≢ b → Fin (suc b)
digit+1 {b} x ¬p = fromℕ≤ {digit-toℕ x} (s≤s (digit+1-lemma (Fin.toℕ x) b (bounded x) ¬p))

------------------------------------------------------------------------
-- Bij
------------------------------------------------------------------------

1+ : ∀ {b} → Bij (suc b) → Bij (suc b)
1+     ∙        = Fin.zero ∷ ∙
1+ {b} (x ∷ xs) with full x
1+ {b} (x ∷ xs) | yes p = Fin.zero ∷ 1+ xs
1+ {b} (x ∷ xs) | no ¬p = digit+1 x ¬p ∷ xs

n+ : ∀ {b} → ℕ → Bij (suc b) → Bij (suc b)
n+ zero    xs = xs
n+ (suc n) xs = 1+ (n+ n xs)

------------------------------------------------------------------------
-- From and to ℕ
------------------------------------------------------------------------

toℕ : ∀ {b} → Bij b → ℕ
toℕ ∙              = zero
toℕ {b} (x ∷ xs) = digit-toℕ x + (toℕ xs * b)

fromℕ : ∀ {b} → ℕ → Bij (suc b)
fromℕ zero    = ∙
fromℕ (suc n) = 1+ (fromℕ n)

------------------------------------------------------------------------
-- Functions on Bij
------------------------------------------------------------------------

-- infixl 6 _⊹_
--
-- _⊹_ : ∀ {b} → Bij b → Bij b → Bij b
-- _⊹_         ∙       ys        = ys
-- _⊹_         xs       ∙        = xs
-- _⊹_ {zero} (() ∷ xs) (y ∷ ys)
-- _⊹_ {suc b} (x ∷ xs) (y ∷ ys) with (suc (Fin.toℕ x + Fin.toℕ y)) divMod (suc b)
-- _⊹_ {suc b} (x ∷ xs) (y ∷ ys) | result quotient remainder property div-eq mod-eq =
--     remainder ∷ n+ quotient (xs ⊹ ys)

-- old base = suc b
-- new base = suc (suc b)
increase-base : ∀ {b} → Bij (suc b) → Bij (suc (suc b))
increase-base {b} ∙        = ∙
increase-base {b} (x ∷ xs) with fromℕ {suc b} (toℕ (increase-base xs) * suc b)
    | inspect (λ ws → fromℕ {suc b} (toℕ ws * suc b)) (increase-base xs)
increase-base {b} (x ∷ xs) | ∙      | [ eq ] = Fin.inject₁ x ∷ ∙
increase-base {b} (x ∷ xs) | y ∷ ys | [ eq ]
    with suc (Fin.toℕ x + Fin.toℕ y) divMod (suc (suc b))
increase-base {b} (x ∷ xs) | y ∷ ys | [ eq ]
    | result quotient remainder property div-eq mod-eq =
    remainder ∷ n+ quotient ys

-- old base = suc (suc b)
-- new base = suc b
decrease-base : ∀ {b} → Bij (suc (suc b)) → Bij (suc b)
decrease-base {b} ∙ = ∙
decrease-base {b} (x ∷ xs) with fromℕ {b} (toℕ (decrease-base xs) * suc (suc b))
              | inspect (λ ws → fromℕ {b} (toℕ ws * suc (suc b))) (decrease-base xs)
decrease-base {b} (x ∷ xs) | ∙      | [ eq ] with full x
decrease-base {b} (x ∷ xs) | ∙      | [ eq ] | yes p = Fin.zero ∷ Fin.zero ∷ ∙
decrease-base {b} (x ∷ xs) | ∙      | [ eq ] | no ¬p = inject-1 x ¬p ∷ ∙
decrease-base {b} (x ∷ xs) | y ∷ ys | [ eq ] with (suc (Fin.toℕ x + Fin.toℕ y)) divMod (suc b)
decrease-base (x ∷ xs) | y ∷ ys | [ eq ] | result quotient remainder property div-eq mod-eq
    = remainder ∷ n+ quotient ys


{-

Constant structure: _ ↦ A

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Relational.Constant where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.RelationalStructure

open import Cubical.Structures.Constant

private
  variable
    ℓ ℓ' : Level

-- Structured relations

module _ (A : hSet ℓ') where

  preservesSetsConstant : preservesSets {ℓ = ℓ} (ConstantStructure (A .fst))
  preservesSetsConstant _ = A .snd

  ConstantRelStr : StrRel {ℓ = ℓ} (ConstantStructure (A .fst)) ℓ'
  ConstantRelStr _ a₀ a₁ = a₀ ≡ a₁

  open SuitableStrRel

  constantSuitableRel : SuitableStrRel {ℓ = ℓ} (ConstantStructure (A .fst)) ConstantRelStr
  constantSuitableRel .quo _ _ _ = isContrSingl _
  constantSuitableRel .symmetric _ = sym
  constantSuitableRel .transitive _ _ = _∙_
  constantSuitableRel .prop _ = A .snd

  constantRelMatchesEquiv : StrRelMatchesEquiv {ℓ = ℓ} ConstantRelStr (ConstantEquivStr (A .fst))
  constantRelMatchesEquiv _ _ _ = idEquiv _


{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.WellFounded
open import Numbers.Naturals.Order.Lemmas
open import Numbers.Integers.Definition
open import Numbers.Integers.Integers
open import Numbers.Integers.Order
open import Groups.Groups
open import Groups.Definition
open import Rings.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Fields.Fields
open import Numbers.Primes.PrimeNumbers
open import Setoids.Setoids
open import Functions.Definition
open import Sets.EquivalenceRelations
open import Numbers.Rationals.Definition
open import Semirings.Definition
open import Orders.Total.Definition
open import Orders.WellFounded.Induction
open import Setoids.Orders.Total.Definition

module Numbers.Rationals.Lemmas where

open import Semirings.Lemmas ℕSemiring

open PartiallyOrderedRing ℤPOrderedRing
open import Rings.Orders.Total.Lemmas ℤOrderedRing
open import Rings.Orders.Total.AbsoluteValue ℤOrderedRing
open SetoidTotalOrder (totalOrderToSetoidTotalOrder ℤOrder)

evenOrOdd : (a : ℕ) → (Sg ℕ (λ i → i *N 2 ≡ a)) || (Sg ℕ (λ i → succ (i *N 2) ≡ a))
evenOrOdd zero = inl (zero , refl)
evenOrOdd (succ zero) = inr (zero , refl)
evenOrOdd (succ (succ a)) with evenOrOdd a
evenOrOdd (succ (succ a)) | inl (a/2 , even) = inl (succ a/2 , applyEquality (λ i → succ (succ i)) even)
evenOrOdd (succ (succ a)) | inr (a/2-1 , odd) = inr (succ a/2-1 , applyEquality (λ i → succ (succ i)) odd)

parity : (a b : ℕ) → succ (2 *N a) ≡ 2 *N b → False
parity zero (succ b) pr rewrite Semiring.commutative ℕSemiring b (succ (b +N 0)) = bad pr
  where
    bad : (1 ≡ succ (succ ((b +N 0) +N b))) → False
    bad ()
parity (succ a) (succ b) pr rewrite Semiring.commutative ℕSemiring b (succ (b +N 0)) | Semiring.commutative ℕSemiring a (succ (a +N 0)) | Semiring.commutative ℕSemiring (a +N 0) a | Semiring.commutative ℕSemiring (b +N 0) b = parity a b (succInjective (succInjective pr))

sqrt0 : (p : ℕ) → p *N p ≡ 0 → p ≡ 0
sqrt0 zero pr = refl
sqrt0 (succ p) ()

-- So as to give us something easy to induct down, introduce a silly extra variable
evil' : (k : ℕ) → ((a b : ℕ) → (0 <N a) → (pr : k ≡ a +N b) → a *N a ≡ (b *N b) *N 2 → False)
evil' = rec <NWellfounded (λ z → (x x₁ : ℕ) (pr' : 0 <N x) (x₂ : z ≡ x +N x₁) (x₃ : x *N x ≡ (x₁ *N x₁) *N 2) → False) go
  where
    go : (k : ℕ) (indHyp : (k' : ℕ) (k'<k : k' <N k) (r s : ℕ) (0<r : 0 <N r) (r+s : k' ≡ r +N s) (x₇ : r *N r ≡ (s *N s) *N 2) → False) (a b : ℕ) (0<a : 0 <N a) (a+b : k ≡ a +N b) (pr : a *N a ≡ (b *N b) *N 2) → False
    go k indHyp a b 0<a a+b pr = contr
      where
        open import Semirings.Solver ℕSemiring multiplicationNIsCommutative
        aEven : Sg ℕ (λ i → i *N 2 ≡ a)
        aEven with evenOrOdd a
        aEven | inl x = x
        aEven | inr (a/2-1 , odd) rewrite equalityCommutative odd =
          -- Derive a pretty mechanical contradiction using the automatic solver.
          -- This line looks hellish, but it was almost completely mechanical.
          exFalso (parity (a/2-1 +N (a/2-1 *N succ (a/2-1 *N 2))) (b *N b) (transitivity (
            -- truly mechanical bit starts here
            from (succ (plus (plus (const a/2-1) (times (const a/2-1) (succ (times (const a/2-1) (succ (succ zero)))))) (plus (plus (const a/2-1) (times (const a/2-1) (succ (times (const a/2-1) (succ (succ zero)))))) (times zero (plus (const a/2-1) (times (const a/2-1) (succ (times (const a/2-1) (succ (succ zero))))))))))
            to succ (plus (times (const a/2-1) (succ (succ zero))) (times (times (const a/2-1) (succ (succ zero))) (succ (times (const a/2-1) (succ (succ zero))))))
            -- truly mechanical bit ends here
            by applyEquality (λ i → succ (a/2-1 +N i)) (
              -- Grinding out some manipulations
              transitivity (equalityCommutative (Semiring.+Associative ℕSemiring a/2-1 _ _)) (applyEquality (a/2-1 +N_) (transitivity (Semiring.commutative ℕSemiring (a/2-1 *N (a/2-1 +N a/2-1)) _) (transitivity (equalityCommutative (Semiring.+Associative ℕSemiring a/2-1 _ _)) (applyEquality (a/2-1 +N_) (transitivity (equalityCommutative (Semiring.+Associative ℕSemiring a/2-1 _ _)) (applyEquality (a/2-1 +N_) (transitivity (equalityCommutative (Semiring.+DistributesOver* ℕSemiring a/2-1 _ _)) (applyEquality (a/2-1 *N_) (equalityCommutative (Semiring.+Associative ℕSemiring a/2-1 _ _))))))))))
            )) (transitivity pr (multiplicationNIsCommutative (b *N b) 2))))

        next : (underlying aEven *N 2) *N (underlying aEven *N 2) ≡ (b *N b) *N 2
        next with aEven
        ... | a/2 , even rewrite even = pr

        next2 : (underlying aEven *N 2) *N underlying aEven ≡ b *N b
        next2 = productCancelsRight 2 _ _ (le 1 refl) (transitivity (equalityCommutative (Semiring.*Associative ℕSemiring (underlying aEven *N 2) _ _)) next)

        next3 : b *N b ≡ (underlying aEven *N underlying aEven) *N 2
        next3 = equalityCommutative (transitivity (transitivity (equalityCommutative (Semiring.*Associative ℕSemiring (underlying aEven) _ _)) (multiplicationNIsCommutative (underlying aEven) _)) next2)

        halveDecreased : underlying aEven <N a
        halveDecreased with aEven
        halveDecreased | zero , even rewrite equalityCommutative even = exFalso (TotalOrder.irreflexive ℕTotalOrder 0<a)
        halveDecreased | succ a/2 , even = le a/2 (transitivity (applyEquality succ (transitivity (Semiring.commutative ℕSemiring a/2 _) (applyEquality succ (transitivity (doubleIsAddTwo a/2) (multiplicationNIsCommutative 2 a/2))))) even)

        reduced : b +N underlying aEven <N k
        reduced with lessRespectsAddition b halveDecreased
        ... | bl rewrite a+b = identityOfIndiscernablesLeft _<N_ bl (Semiring.commutative ℕSemiring _ b)

        0<b : 0 <N b
        0<b with TotalOrder.totality ℕTotalOrder 0 b
        0<b | inl (inl 0<b) = 0<b
        0<b | inl (inr ())
        0<b | inr 0=b rewrite equalityCommutative 0=b = exFalso (TotalOrder.irreflexive ℕTotalOrder {0} (identityOfIndiscernablesRight _<N_ 0<a (sqrt0 a pr)))

        contr : False
        contr = indHyp (b +N underlying aEven) reduced b (underlying aEven) 0<b refl next3

evil : (a b : ℕ) → (0 <N a) → a *N a ≡ (b *N b) *N 2 → False
evil a b 0<a = evil' (a +N b) a b 0<a refl

absNonneg : (x : ℕ) → abs (nonneg x) ≡ nonneg x
absNonneg x with totality (nonneg 0) (nonneg x)
absNonneg x | inl (inl 0<x) = refl
absNonneg x | inr 0=x = refl

absNegsucc : (x : ℕ) → abs (negSucc x) ≡ nonneg (succ x)
absNegsucc x with totality (nonneg 0) (negSucc x)
absNegsucc x | inl (inr _) = refl

toNats : (numerator denominator : ℤ) → .(denominator ≡ nonneg 0 → False) → (abs numerator) *Z (abs numerator) ≡ ((abs denominator) *Z (abs denominator)) *Z nonneg 2 → Sg (ℕ && ℕ) (λ nats → ((_&&_.fst nats *N _&&_.fst nats) ≡ (_&&_.snd nats *N _&&_.snd nats) *N 2) && (_&&_.snd nats ≡ 0 → False))
toNats (nonneg num) (nonneg 0) pr _ = exFalso (pr refl)
toNats (nonneg num) (nonneg (succ denom)) _ pr = (num ,, (succ denom)) , (nonnegInjective (transitivity (transitivity (equalityCommutative (absNonneg (num *N num))) (absRespectsTimes (nonneg num) (nonneg num))) pr) ,, λ ())
toNats (nonneg num) (negSucc denom) _ pr = (num ,, succ denom) , (nonnegInjective (transitivity (transitivity (equalityCommutative (absNonneg (num *N num))) (absRespectsTimes (nonneg num) (nonneg num))) pr) ,, λ ())
toNats (negSucc num) (nonneg (succ denom)) _ pr = (succ num ,, succ denom) , (nonnegInjective pr ,, λ ())
toNats (negSucc num) (negSucc denom) _ pr = (succ num ,, succ denom) , (nonnegInjective pr ,, λ ())

sqrt2Irrational : (a : ℚ) → (a *Q a) =Q (injectionQ (nonneg 2)) → False
sqrt2Irrational (record { num = numerator ; denom = denominator ; denomNonzero = denom!=0 }) pr = bad
  where
    -- We have in hand `pr`, which is the following (almost by definition):
    pr' : (numerator *Z numerator) ≡ (denominator *Z denominator) *Z nonneg 2
    pr' = transitivity (equalityCommutative (transitivity (Ring.*Commutative ℤRing) (Ring.identIsIdent ℤRing))) pr

    -- Move into the naturals so that we can do nice divisibility things.
    lemma1 : abs ((denominator *Z denominator) *Z nonneg 2) ≡ (abs denominator *Z abs denominator) *Z nonneg 2
    lemma1 = transitivity (absRespectsTimes (denominator *Z denominator) (nonneg 2)) (applyEquality (_*Z nonneg 2) (absRespectsTimes denominator denominator))
    amenableToNaturals : (abs numerator) *Z (abs numerator) ≡ ((abs denominator) *Z (abs denominator)) *Z nonneg 2
    amenableToNaturals = transitivity (equalityCommutative (absRespectsTimes numerator numerator)) (transitivity (applyEquality abs pr') lemma1)

    naturalsStatement : Sg (ℕ && ℕ) (λ nats → ((_&&_.fst nats *N _&&_.fst nats) ≡ (_&&_.snd nats *N _&&_.snd nats) *N 2) && (_&&_.snd nats ≡ 0 → False))
    naturalsStatement = toNats numerator denominator denom!=0 amenableToNaturals

    bad : False
    bad with naturalsStatement
    bad | (num ,, 0) , (pr1 ,, pr2) = exFalso (pr2 refl)
    bad | (num ,, succ denom) , (pr1 ,, pr2) = evil num (succ denom) 0<num pr1
      where
        0<num : 0 <N num
        0<num with TotalOrder.totality ℕTotalOrder 0 num
        0<num | inl (inl 0<num) = 0<num
        0<num | inr 0=num rewrite equalityCommutative 0=num = exFalso (naughtE pr1)


{-

    Interactive Programming with Dependent Types

                      Ulf Norell

                  ICFP 2013, Boston

 -}

module ICFP where

open import ICFPPrelude

data Type : Set where
  nat : Type
  _⇒_ : (a b : Type) → Type

infixr 7 _⇒_

data Raw : Set where
  var : (n : Nat) → Raw
  app : (e₁ e₂ : Raw) → Raw
  lam : (a : Type) (e : Raw) → Raw

data Cxt : Set where
  [] : Cxt
  _,_ : (Γ : Cxt) (a : Type) → Cxt

data Var : Cxt → Type → Set where
  zero : ∀ {Γ a} → Var (Γ , a) a
  suc  : ∀ {Γ a b} → Var Γ a → Var (Γ , b) a

data Term : Cxt → Type → Set where
  var : ∀ {Γ a} → Var Γ a → Term Γ a
  app : ∀ {Γ a b} (u : Term Γ (a ⇒ b)) (v : Term Γ a) →
        Term Γ b
  lam : ∀ {Γ} a {b} (u : Term (Γ , a) b) → Term Γ (a ⇒ b)

eraseVar : ∀ {Γ a} → Var Γ a → Nat
eraseVar zero = zero
eraseVar (suc x) = suc (eraseVar x)

erase : ∀ {Γ a} → Term Γ a → Raw
erase (var x) = var (eraseVar x)
erase (app v v₁) = app (erase v) (erase v₁)
erase (lam a v) = lam a (erase v)

data _≠_ : Type → Type → Set where
  nat≠fun : ∀ {a b} → nat ≠ a ⇒ b
  fun≠nat : ∀ {a b} → a ⇒ b ≠ nat
  src≠    : ∀ {a a′ b c} → a ≠ a′ → a ⇒ b ≠ a′ ⇒ c
  tgt≠    : ∀ {a b c c′} → c ≠ c′ → a ⇒ c ≠ b ⇒ c′

sound : ∀ a → a ≠ a → ⊥
sound nat ()
sound (a ⇒ b) (src≠ x) = sound a x
sound (a ⇒ b) (tgt≠ x) = sound b x

infix 4 _≠_ _≟_

data _≟_ : Type → Type → Set where
  equal : ∀ {a} → a ≟ a
  not-equal : ∀ {a b} → a ≠ b → a ≟ b

compareFun : ∀ {a b c d} → a ≟ b → c ≟ d → a ⇒ c ≟ b ⇒ d
compareFun equal equal = equal
compareFun equal (not-equal x) = not-equal (tgt≠ x)
compareFun (not-equal x) q = not-equal (src≠ x)

compare : ∀ a b → a ≟ b
compare nat nat = equal
compare nat (a ⇒ b) = not-equal nat≠fun
compare (a ⇒ b) nat = not-equal fun≠nat
compare (a ⇒ b) (a₁ ⇒ b₁) = compareFun (compare a a₁) (compare b b₁)

data OutOfScope : Cxt → Nat → Set where
  oops : ∀ {n} → OutOfScope [] n
  suc  : ∀ {Γ a n} → OutOfScope Γ n → OutOfScope (Γ , a) (suc n)

data WellScoped? : Cxt → Nat → Set where
  yes : ∀ {Γ} a (x : Var Γ a) → WellScoped? Γ (eraseVar x)
  no  : ∀ {Γ n} → OutOfScope Γ n → WellScoped? Γ n

data TypeError : Cxt → Raw → Set where
  arg-mismatch : ∀ {a a′ Γ b} {u : Term Γ (a ⇒ b)} {u₁ : Term Γ a′} →
                 a ≠ a′ → TypeError Γ (app (erase u) (erase u₁))
  not-fun : ∀ {Γ} {u : Term Γ nat} {a₁} {u₁ : Term Γ a₁} →
            TypeError Γ (app (erase u) (erase u₁))
  bad-arg : ∀ {Γ e₂ e₁} → TypeError Γ e₂ → TypeError Γ (app e₁ e₂)
  bad-fun : ∀ {Γ e₁ e₂} → TypeError Γ e₁ → TypeError Γ (app e₁ e₂)
  out-of-scope : ∀ {Γ n} → OutOfScope Γ n → TypeError Γ (var n)
  lam : ∀ {Γ e} a → TypeError (Γ , a) e → TypeError Γ (lam a e)

data WellTyped? : Cxt → Raw → Set where
  yes : ∀ {Γ} a (u : Term Γ a) → WellTyped? Γ (erase u)
  no  : ∀ {Γ e} (err : TypeError Γ e) → WellTyped? Γ e

checkApp : ∀ {Γ e₁ e₂} → WellTyped? Γ e₁ → WellTyped? Γ e₂ →
             WellTyped? Γ (app e₁ e₂)
checkApp (yes nat u) (yes a₁ u₁) = no not-fun
checkApp (yes (a ⇒ b) u) (yes a′ u₁) with compare a a′
checkApp (yes (a ⇒ b) u) (yes .a u₁) | equal         = yes b (app u u₁)
checkApp (yes (a ⇒ b) u) (yes a′ u₁) | not-equal err = no (arg-mismatch err)
checkApp (yes a u) (no err) = no (bad-arg err)
checkApp (no err) (yes a u) = no (bad-fun err)
checkApp (no err) (no err₁) = no (bad-arg err₁)

lookupSuc : ∀ {Γ a n} →
            WellScoped? Γ n → WellScoped? (Γ , a) (suc n)
lookupSuc (yes a₁ x) = yes a₁ (suc x)
lookupSuc (no x) = no (suc x)

lookupVar : ∀ Γ n → WellScoped? Γ n
lookupVar [] n = no oops
lookupVar (Γ , a) zero = yes a zero
lookupVar (Γ , a) (suc n) = lookupSuc (lookupVar Γ n)

checkVar : ∀ {Γ n} → WellScoped? Γ n → WellTyped? Γ (var n)
checkVar (yes a x) = yes a (var x)
checkVar (no x) = no (out-of-scope x)

checkLam : ∀ {Γ e} a → WellTyped? (Γ , a) e → WellTyped? Γ (lam a e)
checkLam a (yes a₁ u) = yes (a ⇒ a₁) (lam a u)
checkLam a (no err) = no (lam a err)

check : ∀ Γ e → WellTyped? Γ e
check Γ (var n) = checkVar (lookupVar Γ n)
check Γ (app e₁ e₂) = checkApp (check Γ e₁) (check Γ e₂)
check Γ (lam a e) = checkLam a (check (Γ , a) e)


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.NatMinusOne where

open import Cubical.Data.NatMinusOne.Base public


module Cats.Category.Product.Binary.Facts where

open import Cats.Category
open import Cats.Category.Product.Binary using (_×_)
open import Cats.Functor
open import Cats.Util.Logic.Constructive using (_∧_ ; _,_ ; ∧-eliml ; ∧-elimr)

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈}
  {D : Category lo′ la′ l≈′}
  where

  private
    module C = Category C
    module D = Category D
    module × = Category (C × D)

  open Category._≅_

  iso-intro : ∀ {A A′ B B′} → A C.≅ A′ → B D.≅ B′ → (A , B) ×.≅ (A′ , B′)
  iso-intro f g = record
      { forth = forth f , forth g
      ; back = back f , back g
      ; back-forth = back-forth f , back-forth g
      ; forth-back = forth-back f , forth-back g
      }

  iso-elim : ∀ {A A′ B B′} → (A , B) ×.≅ (A′ , B′) → A C.≅ A′ ∧ B D.≅ B′
  iso-elim f
      = record
      { forth = ∧-eliml (forth f)
      ; back = ∧-eliml (back f)
      ; back-forth = ∧-eliml (back-forth f)
      ; forth-back = ∧-eliml (forth-back f)
      }
      , record
      { forth = ∧-elimr (forth f)
      ; back = ∧-elimr (back f)
      ; back-forth = ∧-elimr (back-forth f)
      ; forth-back = ∧-elimr (forth-back f)
      }


{-# OPTIONS --without-K --safe #-}

open import Level

-- This is really a degenerate version of Categories.Category.Instance.Zero
-- Here EmptySet is not given an explicit name, it is an alias for Lift o ⊥
module Categories.Category.Instance.EmptySet where

open import Data.Empty using (⊥; ⊥-elim)
open import Relation.Binary.PropositionalEquality using (refl)

open import Categories.Category.Instance.Sets
import Categories.Object.Initial as Init

module _ {o : Level} where
  open Init (Sets o)

  EmptySet-⊥ : Initial
  EmptySet-⊥ = record { ⊥ = Lift o ⊥ ; ! = λ { {A} (lift x) → ⊥-elim x } ; !-unique = λ { f {()} } }


{-# OPTIONS --without-K --rewriting #-}

open import lib.Basics

module lib.types.TwoSemiCategory where

module _ {i j} {El : Type i} (Arr : El → El → Type j)
  (_ : ∀ x y → has-level 1 (Arr x y)) where

  record TwoSemiCategoryStructure : Type (lmax i j) where
    field
      comp : ∀ {x y z} → Arr x y → Arr y z → Arr x z
      assoc : ∀ {x y z w} (a : Arr x y) (b : Arr y z) (c : Arr z w)
        → comp (comp a b) c == comp a (comp b c)
      {- coherence -}
      pentagon-identity : ∀ {v w x y z} (a : Arr v w) (b : Arr w x) (c : Arr x y) (d : Arr y z)
        → assoc (comp a b) c d ◃∙
          assoc a b (comp c d) ◃∎
          =ₛ
          ap (λ s → comp s d) (assoc a b c) ◃∙
          assoc a (comp b c) d ◃∙
          ap (comp a) (assoc b c d) ◃∎

record TwoSemiCategory i j : Type (lsucc (lmax i j)) where
  constructor two-semi-category
  field
    El : Type i
    Arr : El → El → Type j
    Arr-level : ∀ x y → has-level 1 (Arr x y)
    two-semi-cat-struct : TwoSemiCategoryStructure Arr Arr-level

  open TwoSemiCategoryStructure two-semi-cat-struct public


{-# OPTIONS --without-K --safe #-}

module Experiment.FingerTree where
open import Level renaming (zero to lzero ; suc to lsuc)
open import Algebra

open import Experiment.FingerTree.Common

data Digit {a} (A : Set a) : Set a where
  one   : (a       : A) → Digit A
  two   : (a b     : A) → Digit A
  three : (a b c   : A) → Digit A
  four  : (a b c d : A) → Digit A

data Node {v a} (V : Set v) (A : Set a) : Set (a ⊔ v) where
  :node2 : (v : V) → (a b   : A) → Node V A
  :node3 : (v : V) → (a b c : A) → Node V A

nodeToDigit : ∀ {v a} {V : Set v} {A : Set a} → Node V A → Digit A
nodeToDigit (:node2 v a b  ) = two a b
nodeToDigit (:node3 v a b c) = three a b c

data FingerTree {v a} (V : Set v) (A : Set a) : Set (a ⊔ v) where
  :empty  : FingerTree V A
  :single : A → FingerTree V A
  :deep   : V → Digit A → FingerTree V (Node V A) → Digit A → FingerTree V A

Digit-foldr : ∀ {a b} {A : Set a} {B : Set b} → (A → B → B) → B → Digit A → B
Digit-foldr _<>_ e (one   a)       = a <> e
Digit-foldr _<>_ e (two   a b)     = a <> (b <> e)
Digit-foldr _<>_ e (three a b c)   = a <> (b <> (c <> e))
Digit-foldr _<>_ e (four  a b c d) = a <> (b <> (c <> (d <> e)))

Node-foldr : ∀ {v a b} {V : Set v} {A : Set a} {B : Set b} →
  (A → B → B) → B → Node V A → B
Node-foldr _<>_ e (:node2 v a b  ) = a <> (b <> e)
Node-foldr _<>_ e (:node3 v a b c) = a <> (b <> (c <> e))

Node-measure : ∀ {v a} {V : Set v} {A : Set a} → Node V A → V
Node-measure (:node2 v a b  ) = v
Node-measure (:node3 v a b c) = v

record IsMeasured {c e a} (M : Monoid c e) (A : Set a) : Set (a ⊔ c ⊔ e) where
  open Monoid M
  field
    measure : A → Carrier

module Constructor {c e a} {A : Set a} {M : Monoid c e} (MS : IsMeasured M A) where
  open Monoid M renaming (Carrier to V)
  open IsMeasured MS

  empty : FingerTree V A
  empty = :empty

  single : A → FingerTree V A
  single = :single

  deep : Digit A → FingerTree V (Node V A) → Digit A → FingerTree V A
  deep pr m sf = :deep {! (Node-measure pr ∙ measure m) ∙ Node-measure sf  !} pr m sf


module TypeConstructorsWhichPreserveGuardedness3 where

record ⊤ : Set where

data _⊎_ (A B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

-- This should not be allowed.

ℕ : Set
ℕ = ⊤ ⊎ ℕ


module _ where

open import Agda.Builtin.Equality

module _ (Ty : Set) where

  data Cxt : Set where
    sg : (A : Ty) → Cxt
    _∙_ : (Γ₁ Γ₂ : Cxt) → Cxt

  postulate Sub : Cxt → Cxt → Set

  variable Γ Δ : Cxt

  data Var (A : Ty) : Cxt → Set where
    •   : Var A (sg A)
    inl : (x : Var A Γ) → Var A (Γ ∙ Δ)

postulate
  T : ∀ {a} {A : Set a} → A → Set

  bla : T Γ

check-bla : {Ty : Set} {Γ : Cxt Ty} → T Γ
check-bla = bla


module Cats.Trans.Iso where

open import Level using (_⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)

open import Cats.Category.Base
open import Cats.Functor using (Functor)
open import Cats.Util.Simp using (simp!)
open import Cats.Trans using (Trans ; component ; natural)

import Cats.Category.Constructions.Iso as Iso

open Functor
open Iso.Build._≅_

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  where

  private
    module C = Category C
    module D = Category D
    open module D≅ = Iso.Build D using (_≅_)
    module ≅ = D≅.≅
    open D.≈-Reasoning

  record NatIso (F G : Functor C D) : Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′)
    where
    field
      iso : ∀ {c} → fobj F c ≅ fobj G c

      forth-natural : ∀ {c d} {f : c C.⇒ d}
        → forth iso D.∘ fmap F f D.≈ fmap G f D.∘ forth iso

    back-natural : ∀ {c d} {f : c C.⇒ d}
      → back iso D.∘ fmap G f D.≈ fmap F f D.∘ back iso
    back-natural {f = f} =
        begin
          back iso D.∘ fmap G f
        ≈⟨ D.∘-resp-r (D.≈.sym D.id-r) ⟩
          back iso D.∘ fmap G f D.∘ D.id
        ≈⟨ D.∘-resp-r (D.∘-resp-r (D.≈.sym (forth-back iso))) ⟩
          back iso D.∘ fmap G f D.∘ forth iso D.∘ back iso
        ≈⟨ simp! D ⟩
          back iso D.∘ (fmap G f D.∘ forth iso) D.∘ back iso
        ≈⟨ D.∘-resp-r (D.∘-resp-l (D.≈.sym forth-natural)) ⟩
          back iso D.∘ (forth iso D.∘ fmap F f) D.∘ back iso
        ≈⟨ simp! D ⟩
          (back iso D.∘ (forth iso)) D.∘ fmap F f D.∘ back iso
        ≈⟨ D.∘-resp-l (back-forth iso) ⟩
          D.id D.∘ fmap F f D.∘ back iso
        ≈⟨ D.id-l ⟩
          fmap F f D.∘ back iso
        ∎

    Forth : Trans F G
    Forth = record
        { component = λ _ → forth iso
        ; natural = forth-natural
        }

    Back : Trans G F
    Back = record
        { component = λ _ → back iso
        ; natural = back-natural
        }

  open NatIso public

  id : ∀ {F} → NatIso F F
  id = record
      { iso = ≅.refl
      ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }

  sym : ∀ {F G} → NatIso F G → NatIso G F
  sym θ = record
      { iso = ≅.sym (iso θ)
      ; forth-natural = back-natural θ
      }

  _∘_ : ∀ {F G H} → NatIso G H → NatIso F G → NatIso F H
  _∘_ {F} {G} {H} θ ι = record
      { iso = ≅.trans (iso ι) (iso θ)
      ; forth-natural = λ {_} {_} {f} →
          begin
            (forth (iso θ) D.∘ forth (iso ι)) D.∘ fmap F f
          ≈⟨ D.assoc ⟩
            forth (iso θ) D.∘ forth (iso ι) D.∘ fmap F f
          ≈⟨ D.∘-resp-r (forth-natural ι) ⟩
            forth (iso θ) D.∘ fmap G f D.∘ forth (iso ι)
          ≈⟨ D.unassoc ⟩
            (forth (iso θ) D.∘ fmap G f) D.∘ forth (iso ι)
          ≈⟨ D.∘-resp-l (forth-natural θ) ⟩
            (fmap H f D.∘ forth (iso θ)) D.∘ forth (iso ι)
          ≈⟨ D.assoc ⟩
            fmap H f D.∘ forth (iso θ) D.∘ forth (iso ι)
          ∎
      }


------------------------------------------------------------------------
-- The Agda standard library
--
-- A categorical view of List⁺
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

module Data.List.NonEmpty.Categorical where

open import Agda.Builtin.List
import Data.List.Categorical as List
open import Data.List.NonEmpty
open import Data.Product using (uncurry)
open import Category.Functor
open import Category.Applicative
open import Category.Monad
open import Category.Comonad
open import Function

------------------------------------------------------------------------
-- List⁺ applicative functor

functor : ∀ {f} → RawFunctor {f} List⁺
functor = record
  { _<$>_ = map
  }

applicative : ∀ {f} → RawApplicative {f} List⁺
applicative = record
  { pure = [_]
  ; _⊛_  = λ fs as → concatMap (λ f → map f as) fs
  }

------------------------------------------------------------------------
-- List⁺ monad

monad : ∀ {f} → RawMonad {f} List⁺
monad = record
  { return = [_]
  ; _>>=_  = flip concatMap
  }

------------------------------------------------------------------------
-- List⁺ comonad

comonad : ∀ {f} → RawComonad {f} List⁺
comonad = record
  { extract = head
  ; extend  = λ f → uncurry (extend f) ∘′ uncons
  } where

  extend : ∀ {A B} → (List⁺ A → B) → A → List A → List⁺ B
  extend f x xs@[]       = f (x ∷ xs) ∷ []
  extend f x xs@(y ∷ ys) = f (x ∷ xs) ∷⁺ extend f y ys

------------------------------------------------------------------------
-- Get access to other monadic functions

module _ {f F} (App : RawApplicative {f} F) where

  open RawApplicative App

  sequenceA : ∀ {A} → List⁺ (F A) → F (List⁺ A)
  sequenceA (x ∷ xs) = _∷_ <$> x ⊛ List.sequenceA App xs

  mapA : ∀ {a} {A : Set a} {B} → (A → F B) → List⁺ A → F (List⁺ B)
  mapA f = sequenceA ∘ map f

  forA : ∀ {a} {A : Set a} {B} → List⁺ A → (A → F B) → F (List⁺ B)
  forA = flip mapA

module _ {m M} (Mon : RawMonad {m} M) where

  private App = RawMonad.rawIApplicative Mon

  sequenceM = sequenceA App
  mapM = mapA App
  forM = forA App

------------------------------------------------------------------------
-- List⁺ monad transformer

monadT : ∀ {f} → RawMonadT {f} (_∘′ List⁺)
monadT M = record
  { return = pure ∘′ [_]
  ; _>>=_  = λ mas f → mas >>= λ as → concat <$> mapM M f as
  } where open RawMonad M


open import Prelude
open import core
open import contexts
open import lemmas-matching

module synth-unicity where
  -- synthesis only produces equal types. note that there is no need for an
  -- analagous theorem for analytic positions because we think of
  -- the type as an input
  synthunicity : {Γ : tctx} {e : hexp} {t t' : htyp} →
                 Γ ⊢ e => t →
                 Γ ⊢ e => t' →
                 t == t'
  synthunicity (SAsc _) (SAsc _) = refl
  synthunicity {Γ = G} (SVar in1) (SVar in2) = ctxunicity {Γ = G} in1 in2
  synthunicity (SAp  D1 MAHole _) (SAp D2 MAHole y) = refl
  synthunicity (SAp D1 MAHole _) (SAp D2 MAArr y) with synthunicity D1 D2
  ... | ()
  synthunicity (SAp D1 MAArr _) (SAp D2 MAHole y) with synthunicity D1 D2
  ... | ()
  synthunicity (SAp D1 MAArr _) (SAp D2 MAArr y) with synthunicity D1 D2
  ... | refl = refl
  synthunicity SEHole SEHole = refl
  synthunicity (SNEHole _) (SNEHole _) = refl
  synthunicity SNum SNum = refl
  synthunicity (SPlus _ _) (SPlus _ _) = refl
  synthunicity (SLam _ D1) (SLam _ D2) with synthunicity D1 D2
  synthunicity (SLam x₁ D1) (SLam x₂ D2) | refl = refl
  synthunicity (SPair D1 D2) (SPair D3 D4)
    with synthunicity D1 D3 | synthunicity D2 D4
  ... | refl | refl = refl
  synthunicity (SFst D1 x) (SFst D2 x₁) with synthunicity D1 D2
  ... | refl with ▸prod-unicity x x₁
  ... | refl = refl
  synthunicity (SSnd D1 x) (SSnd D2 x₁) with synthunicity D1 D2
  ... | refl with ▸prod-unicity x x₁
  ... | refl = refl


module SizedPolyIO.Object where

open import Data.Product

open import Level using (_⊔_) renaming (suc to lsuc)

record Interface μ ρ : Set (lsuc (μ ⊔ ρ)) where
  field
    Method  : Set μ
    Result  : (m : Method) → Set ρ
open Interface public

-- A simple object just returns for a method the response
-- and the object itself
record Object {μ ρ} (i : Interface μ ρ) : Set (μ ⊔ ρ) where
  coinductive
  field
    objectMethod : (m : Method i) → Result i m × Object i

open Object public


module Issue1441 where

open import Common.Nat
open import Common.Unit
open import Common.IO

data Sing : (n : Nat) → Set where
  sing : ∀ n → Sing n

data D : Set → Set where
  c : ∀ n → D (Sing n)

test : (A : Set) → D A → Nat
test .(Sing n) (c n) = n

main : IO Unit
main = printNat (test (Sing 1) (c 1))

-- should succeed and print 1


-- Andreas, 2017-07-11, issue #2637, reported by nad.
--
-- This error was triggered by a meta m in a constraint UnBlock m
-- which is solved to infinity by the size solver.

-- The constraint printer did not expect such a situation
-- and crashed when printing the UnBlock constraint.

{-# OPTIONS --allow-unsolved-metas #-}

module _ (Z : Set) where

open import Common.Size
open import Common.Product

postulate
  map    : (A B C : Set) → (A → C) → A × B → C × B
  I      : Set
  P      : I → Set
  Q      : Size → I → Set
  f      : I → I
  lemma₁ : (R : I → Set) → (∀ x → R (f x) → R x) → ∀ x → R x → R (f x)
  lemma₂ : ∀ i x → Q i (f x) → Q i x

works : ∀ i x → Q i (f x) × P x → Q i (f (f x)) × P x
works i x = map
  (Q i (f x))
  (P x)
  (Q i (f (f x)))
  (lemma₁ (Q i) (λ y → lemma₂ i y) (f x))

-- Replacing any underscore by its solution or parts of its solution
-- makes the internal error disappear.

lemma₃ : ∀ i x → Q i (f x) × P x → Q i (f (f x)) × P x
lemma₃ i x = map
  (Q _ _)
  (P x)
  (Q _ (f (f x)))
  (lemma₁ _ (λ y → lemma₂ _ _) _)


open import SOAS.Common
open import SOAS.Families.Core
open import Categories.Object.Initial
open import SOAS.Coalgebraic.Strength
import SOAS.Metatheory.MetaAlgebra

-- Initial-algebra semantics
module SOAS.Metatheory.Semantics {T : Set}
  (⅀F : Functor 𝔽amiliesₛ 𝔽amiliesₛ) (⅀:Str : Strength ⅀F)
  (𝔛 : Familyₛ) (open SOAS.Metatheory.MetaAlgebra ⅀F 𝔛)
  (𝕋:Init : Initial 𝕄etaAlgebras)
  where

open import SOAS.Context
open import SOAS.Variable
open import SOAS.Construction.Structure as Structure
open import SOAS.Abstract.Hom
import SOAS.Abstract.Coalgebra as →□ ; open →□.Sorted
import SOAS.Abstract.Box as □ ; open □.Sorted

open import SOAS.Metatheory.Algebra ⅀F

open Strength ⅀:Str

private
  variable
    Γ Δ Θ Π : Ctx
    α β : T
    𝒫 𝒬 𝒜 : Familyₛ

open Initial 𝕋:Init

open Object ⊥ public renaming (𝐶 to 𝕋 ; ˢ to 𝕋ᵃ)
open MetaAlg 𝕋ᵃ public renaming (𝑎𝑙𝑔 to 𝕒𝕝𝕘 ; 𝑣𝑎𝑟 to 𝕧𝕒𝕣 ; 𝑚𝑣𝑎𝑟 to 𝕞𝕧𝕒𝕣 ;
                                  𝑚≈₁ to 𝕞≈₁ ; 𝑚≈₂ to 𝕞≈₂)

module Semantics (𝒜ᵃ : MetaAlg 𝒜) where

  open Morphism (! {𝒜 ⋉ 𝒜ᵃ}) public renaming (𝑓 to 𝕤𝕖𝕞 ; ˢ⇒ to 𝕤𝕖𝕞ᵃ⇒)
  open MetaAlg⇒ 𝕤𝕖𝕞ᵃ⇒ public renaming (⟨𝑎𝑙𝑔⟩ to ⟨𝕒⟩ ; ⟨𝑣𝑎𝑟⟩ to ⟨𝕧⟩ ; ⟨𝑚𝑣𝑎𝑟⟩ to ⟨𝕞⟩)
  open MetaAlg 𝒜ᵃ
  module 𝒜 = MetaAlg 𝒜ᵃ

  eq : {g h : 𝕋 ⇾̣ 𝒜} (gᵃ : MetaAlg⇒ 𝕋ᵃ 𝒜ᵃ g) (hᵃ : MetaAlg⇒ 𝕋ᵃ 𝒜ᵃ h) (t : 𝕋 α Γ)
     → g t ≡ h t
  eq {g = g}{h} gᵃ hᵃ t  = !-unique₂ (g ⋉ gᵃ) (h ⋉ hᵃ) {x = t}

  -- The interpretation is equal to any other pointed meta-Λ-algebra
  𝕤𝕖𝕞! : {g : 𝕋 ⇾̣ 𝒜}(gᵃ : MetaAlg⇒ 𝕋ᵃ 𝒜ᵃ g)(t : 𝕋 α Γ) → 𝕤𝕖𝕞 t ≡ g t
  𝕤𝕖𝕞! {g = g} gᵃ t = !-unique (g ⋉ gᵃ) {x = t}

-- Corollaries: every meta-algebra endo-homomorphism is the identity, including 𝕤𝕖𝕞
eq-id : {g : 𝕋 ⇾̣ 𝕋} (gᵃ : MetaAlg⇒ 𝕋ᵃ 𝕋ᵃ g) (t : 𝕋 α Γ) →
        g t ≡ t
eq-id gᵃ t = Semantics.eq 𝕋ᵃ gᵃ (idᵃ 𝕋ᵃ) t

𝕤𝕖𝕞-id : {t : 𝕋 α Γ} → Semantics.𝕤𝕖𝕞 𝕋ᵃ t ≡ t
𝕤𝕖𝕞-id {t = t} = eq-id (Semantics.𝕤𝕖𝕞ᵃ⇒ 𝕋ᵃ) t


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties for distributive lattice
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Relation.Binary.Lattice

module Relation.Binary.Properties.DistributiveLattice
  {c ℓ₁ ℓ₂} (L : DistributiveLattice c ℓ₁ ℓ₂) where

open DistributiveLattice L hiding (refl)

open import Algebra.FunctionProperties _≈_
open import Data.Product using (_,_)
open import Relation.Binary
open import Relation.Binary.Reasoning.Setoid setoid
open import Relation.Binary.Properties.Lattice lattice
open import Relation.Binary.Properties.MeetSemilattice meetSemilattice
open import Relation.Binary.Properties.JoinSemilattice joinSemilattice

open Setoid setoid

∧-distribʳ-∨ : _∧_ DistributesOverʳ _∨_
∧-distribʳ-∨ x y z = begin
  (y ∨ z) ∧ x    ≈⟨ ∧-comm _ _ ⟩
  x ∧ (y ∨ z)    ≈⟨ ∧-distribˡ-∨ x y z ⟩
  x ∧ y ∨ x ∧ z  ≈⟨ ∨-cong (∧-comm _ _) (∧-comm _ _) ⟩
  y ∧ x ∨ z ∧ x  ∎

∧-distrib-∨ : _∧_ DistributesOver _∨_
∧-distrib-∨ = ∧-distribˡ-∨ , ∧-distribʳ-∨

∨-distribˡ-∧ : _∨_ DistributesOverˡ _∧_
∨-distribˡ-∧ x y z = begin
  x ∨ y ∧ z                  ≈⟨ ∨-cong (sym (∨-absorbs-∧ x y)) refl ⟩
  (x ∨ x ∧ y) ∨ y ∧ z        ≈⟨ ∨-cong (∨-cong refl (∧-comm _ _)) refl ⟩
  (x ∨ y ∧ x) ∨ y ∧ z        ≈⟨ ∨-assoc x (y ∧ x) (y ∧ z) ⟩
  x ∨ y ∧ x ∨ y ∧ z          ≈⟨ ∨-cong refl (sym (∧-distribˡ-∨ y x z)) ⟩
  x ∨ y ∧ (x ∨ z)            ≈⟨ ∨-cong (sym (∧-absorbs-∨ _ _)) refl ⟩
  x ∧ (x ∨ z) ∨ y ∧ (x ∨ z)  ≈⟨ sym (∧-distribʳ-∨ (x ∨ z) x y) ⟩
  (x ∨ y) ∧ (x ∨ z)          ∎

∨-distribʳ-∧ : _∨_ DistributesOverʳ _∧_
∨-distribʳ-∧ x y z = begin
  y ∧ z ∨ x          ≈⟨ ∨-comm _ _ ⟩
  x ∨ y ∧ z          ≈⟨ ∨-distribˡ-∧ _ _ _ ⟩
  (x ∨ y) ∧ (x ∨ z)  ≈⟨ ∧-cong (∨-comm _ _) (∨-comm _ _) ⟩
  (y ∨ x) ∧ (z ∨ x)  ∎

∨-distrib-∧ : _∨_ DistributesOver _∧_
∨-distrib-∧ = ∨-distribˡ-∧ , ∨-distribʳ-∧


{-# OPTIONS --without-K --safe #-}

open import Categories.Category

module Categories.Category.Construction.Properties.Presheaves.Complete {o ℓ e} (C : Category o ℓ e) where

open import Data.Product
open import Function.Equality using (Π) renaming (_∘_ to _∙_)
open import Relation.Binary
open import Relation.Binary.Construct.Closure.SymmetricTransitive as ST using (Plus⇔)
open Plus⇔

open import Categories.Category.Complete
open import Categories.Category.Cocomplete
open import Categories.Category.Construction.Presheaves
open import Categories.Category.Instance.Setoids
open import Categories.Category.Instance.Properties.Setoids
open import Categories.Diagram.Limit as Lim
open import Categories.Diagram.Colimit
open import Categories.Functor
open import Categories.NaturalTransformation

import Categories.Category.Construction.Cones as Co
import Categories.Category.Construction.Cocones as Coc
import Relation.Binary.Reasoning.Setoid as SetoidR

private
  module C = Category C
  open C
  open Π using (_⟨$⟩_)

module _ o′ where
  private
    P = Presheaves′ o′ o′ C
    module P = Category P

    module _ {J : Category o′ o′ o′} (F : Functor J P) where
      module J = Category J
      module F = Functor F
      open F
      module F₀ j = Functor (F₀ j)
      module F₁ {a b} (f : a J.⇒ b) = NaturalTransformation (F₁ f)
      open Setoid using () renaming (_≈_ to [_]_≈_)

      F[-,_] : Obj → Functor J (Setoids o′ o′)
      F[-, X ] = record
        { F₀           = λ j → F₀.₀ j X
        ; F₁           = λ f → F₁.η f X
        ; identity     = identity
        ; homomorphism = homomorphism
        ; F-resp-≈     = λ eq → F-resp-≈ eq -- this application cannot be eta reduced
        }

      -- limit related definitions

      module LimFX X = Limit (Setoids-Complete _ _ _ o′ o′ F[-, X ])

      module FCone (K : Co.Cone F) where
        open Co.Cone F K public
        module N = Functor N
        module ψ j = NaturalTransformation (ψ j)

      module FCone⇒ {K K′ : Co.Cone F} (K⇒K′ : Co.Cone⇒ F K K′) where
        open Co.Cone⇒ F K⇒K′ public
        module arr = NaturalTransformation arr

      FXcone : ∀ X → (K : Co.Cone F) → Co.Cone F[-, X ]
      FXcone X K = record
        { N    = N.₀ X
        ; apex = record
          { ψ       = λ j → ψ.η j X
          ; commute = λ f → commute f -- this application cannot be eta reduced
          }
        }
        where open FCone K

      ⊤ : Co.Cone F
      ⊤ = record
        { N    = record
          { F₀           = λ X → LimFX.apex X
          ; F₁           = λ {A B} f → record
            { _⟨$⟩_ = λ { (S , eq) → (λ j → F₀.₁ j f ⟨$⟩ S j) , λ {X Y} g →
              let open SetoidR (F₀.₀ Y B)
              in begin
                F₁.η g B ⟨$⟩ (F₀.₁ X f ⟨$⟩ S X) ≈⟨ F₁.commute g f (Setoid.refl (F₀.₀ X A)) ⟩
                F₀.₁ Y f ⟨$⟩ (F₁.η g A ⟨$⟩ S X) ≈⟨ Π.cong (F₀.₁ Y f) (eq g) ⟩
                F₀.₁ Y f ⟨$⟩ S Y ∎ }
            ; cong  = λ eq j → Π.cong (F₀.₁ j f) (eq j)
            }
          ; identity     = λ eq j → F₀.identity j (eq j)
          ; homomorphism = λ eq j → F₀.homomorphism j (eq j)
          ; F-resp-≈     = λ eq eq′ j → F₀.F-resp-≈ j eq (eq′ j)
          }
        ; apex = record
          { ψ       = λ j → ntHelper record
            { η       = λ X → record
              { _⟨$⟩_ = λ { (S , eq) → S j }
              ; cong  = λ eq → eq j
              }
            ; commute = λ f eq → Π.cong (F₀.₁ j f) (eq j)
            }
          ; commute = λ { {Y} {Z} f {W} {S₁ , eq₁} {S₂ , eq₂} eq →
            let open SetoidR (F₀.₀ Z W)
            in begin
              F₁.η f W ⟨$⟩ S₁ Y ≈⟨ eq₁ f ⟩
              S₁ Z              ≈⟨ eq Z ⟩
              S₂ Z              ∎ }
          }
        }

      K⇒⊤′ : ∀ X {K} → Co.Cones F [ K , ⊤ ] → Co.Cones F[-, X ] [ FXcone X K , LimFX.limit X ]
      K⇒⊤′ X {K} K⇒⊤ = record
        { arr     = arr.η X
        ; commute = comm
        }
        where open FCone⇒ K⇒⊤ renaming (commute to comm)

      complete : Limit F
      complete = record
        { terminal = record
          { ⊤        = ⊤
          ; !        = λ {K} →
            let module K = FCone K
            in record
            { arr     = ntHelper record
              { η       = λ X → LimFX.rep X (FXcone X K)
              ; commute = λ {X Y} f eq j → K.ψ.commute j f eq
              }
            ; commute = λ eq → Π.cong (K.ψ.η _ _) eq
            }
          ; !-unique = λ K⇒⊤ {X} → LimFX.terminal.!-unique X (K⇒⊤′ X K⇒⊤)
          }
        }

      -- colimit related definitions

      module ColimFX X = Colimit (Setoids-Cocomplete _ _ _ o′ o′ F[-, X ])

      module FCocone (K : Coc.Cocone F) where
        open Coc.Cocone F K public
        module N = Functor N
        module ψ j = NaturalTransformation (ψ j)

      module FCocone⇒ {K K′ : Coc.Cocone F} (K⇒K′ : Coc.Cocone⇒ F K K′) where
        open Coc.Cocone⇒ F K⇒K′ public
        module arr = NaturalTransformation arr

      FXcocone : ∀ X → (K : Coc.Cocone F) → Coc.Cocone F[-, X ]
      FXcocone X K = record
        { N      = N.₀ X
        ; coapex = record
          { ψ       = λ j → ψ.η j X
          ; commute = λ f → commute f -- this application cannot be eta reduced
          }
        }
        where open FCocone K

      ⊥ : Coc.Cocone F
      ⊥ = record
        { N      = record
          { F₀           = λ X → ColimFX.coapex X
          ; F₁           = λ {A B} f → record
            { _⟨$⟩_ = λ { (j , Sj) → j , F₀.₁ j f ⟨$⟩ Sj  }
            ; cong  = λ { {a , Sa} {b , Sb} →
              ST.map (λ { (j , Sj) → j , F₀.₁ j f ⟨$⟩ Sj }) (helper f) }
            }
          ; identity     = λ { {A} {j , _} eq → forth⁺ (J.id , identity (F₀.identity j (Setoid.refl (F₀.₀ j A)))) eq }
          ; homomorphism = λ {X Y Z} {f g} → λ { {_} {j , Sj} eq →
            let open Setoid (F₀.₀ j Z)
            in ST.trans (coc o′ o′ F[-, Z ])
                        (ST.map (hom-map f g) (helper (f ∘ g)) eq)
                        (forth (J.id , trans (identity refl) (F₀.homomorphism j (Setoid.refl (F₀.₀ j X))))) }
          ; F-resp-≈     = λ {A B} {f g} eq → λ { {j , Sj} eq′ →
            let open Setoid (F₀.₀ j B)
            in ST.trans (coc o′ o′ F[-, B ])
                        (forth (J.id , trans (identity refl) (F₀.F-resp-≈ j eq (Setoid.refl (F₀.₀ j A)))))
                        (ST.map (λ { (j , Sj) → (j , F₀.₁ j g ⟨$⟩ Sj) }) (helper g) eq′) }
          }
        ; coapex = record
          { ψ       = λ j → ntHelper record
            { η       = λ X → record
              { _⟨$⟩_ = j ,_
              ; cong  = λ eq → forth (-, identity eq)
              }
            ; commute = λ {X Y} f eq → back (-, identity (Π.cong (F₀.₁ j f) (Setoid.sym (F₀.₀ j X) eq)))
            }
          ; commute = λ {a b} f {X} {x y} eq →
            let open ST.Plus⇔Reasoning (coc o′ o′ F[-, X ])
            in back (f , Π.cong (F₁.η f X) (Setoid.sym (F₀.₀ a X) eq))
          }
        }
        where helper : ∀ {A B} (f : B C.⇒ A) {a Sa b Sb} →
                         Σ (a J.⇒ b) (λ g → [ F₀.₀ b A ] F₁.η g A ⟨$⟩ Sa ≈ Sb) →
                         Σ (a J.⇒ b) λ h → [ F₀.₀ b B ] F₁.η h B ⟨$⟩ (F₀.₁ a f ⟨$⟩ Sa) ≈ F₀.₁ b f ⟨$⟩ Sb
              helper {A} {B} f {a} {Sa} {b} {Sb} (g , eq′) =
                let open SetoidR (F₀.₀ b B)
                in g , (begin
                  F₁.η g B ⟨$⟩ (F₀.₁ a f ⟨$⟩ Sa) ≈⟨ F₁.commute g f (Setoid.refl (F₀.₀ a A)) ⟩
                  F₀.₁ b f ⟨$⟩ (F₁.η g A ⟨$⟩ Sa) ≈⟨ Π.cong (F₀.₁ b f) eq′ ⟩
                  F₀.₁ b f ⟨$⟩ Sb ∎)

              hom-map : ∀ {X Y Z} → Y C.⇒ X → Z C.⇒ Y → Σ J.Obj (λ j → Setoid.Carrier (F₀.₀ j X)) → Σ J.Obj (λ j → Setoid.Carrier (F₀.₀ j Z))
              hom-map f g (j , Sj) = j , F₀.₁ j (f ∘ g) ⟨$⟩ Sj

      ⊥⇒K′ : ∀ X {K} → Coc.Cocones F [ ⊥ , K ] → Coc.Cocones F[-, X ] [ ColimFX.colimit X , FXcocone X K ]
      ⊥⇒K′ X {K} ⊥⇒K = record
        { arr     = arr.η X
        ; commute = comm
        }
        where open FCocone⇒ ⊥⇒K renaming (commute to comm)

      ! : {K : Coc.Cocone F} → Coc.Cocone⇒ F ⊥ K
      ! {K} = record
        { arr     = ntHelper record
          { η       = λ X → ColimFX.rep X (FXcocone X K)
          ; commute = λ {X Y} f → λ { {a , Sa} {b , Sb} eq →
            let open SetoidR (K.N.F₀ Y)
            in begin
              K.ψ.η a Y ⟨$⟩ (F₀.₁ a f ⟨$⟩ Sa) ≈⟨ K.ψ.commute a f (Setoid.refl (F₀.₀ a X)) ⟩
              K.N.F₁ f ⟨$⟩ (K.ψ.η a X ⟨$⟩ Sa) ≈⟨ Π.cong (K.N.F₁ f) (ST.minimal (coc o′ o′ F[-, X ]) (K.N.₀ X) (Kψ X) (helper X) eq) ⟩
              K.N.F₁ f ⟨$⟩ (K.ψ.η b X ⟨$⟩ Sb) ∎ }
          }
        ; commute = λ eq → Π.cong (K.ψ.η _ _) eq
        }
        where module K = FCocone K
              Kψ : ∀ X → Σ J.Obj (λ j → Setoid.Carrier (F₀.₀ j X)) → Setoid.Carrier (K.N.F₀ X)
              Kψ X (j , S) = K.ψ.η j X ⟨$⟩ S
              helper : ∀ X → coc o′ o′ F[-, X ] =[ Kψ X ]⇒ [ K.N.₀ X ]_≈_
              helper X {a , Sa} {b , Sb} (f , eq) = begin
                K.ψ.η a X ⟨$⟩ Sa                ≈˘⟨ K.commute f (Setoid.refl (F₀.₀ a X)) ⟩
                K.ψ.η b X ⟨$⟩ (F₁.η f X ⟨$⟩ Sa) ≈⟨ Π.cong (K.ψ.η b X) eq ⟩
                K.ψ.η b X ⟨$⟩ Sb                ∎
                where open SetoidR (K.N.₀ X)

      cocomplete : Colimit F
      cocomplete = record
        { initial = record
          { ⊥        = ⊥
          ; !        = !
          ; !-unique = λ ⊥⇒K {X} → ColimFX.initial.!-unique X (⊥⇒K′ X ⊥⇒K)
          }
        }

  Presheaves-Complete : Complete o′ o′ o′ P
  Presheaves-Complete F = complete F

  Presheaves-Cocomplete : Cocomplete o′ o′ o′ P
  Presheaves-Cocomplete F = cocomplete F


-- This file tests that record constructors are used in error
-- messages, if possible.

module RecordConstructorsInErrorMessages where

record R : Set₁ where
  constructor con
  field
    {A}         : Set
    f           : A → A
    {B C} D {E} : Set
    g           : B → C → E

postulate
  A  : Set
  r₁ : R

r₂ : R
r₂ = record
  { A = A
  ; f = λ x → x
  ; B = A
  ; C = A
  ; D = A
  ; g = λ x _ → x
  }

data _≡_ {A : Set₁} (x : A) : A → Set where
  refl : x ≡ x

foo : r₁ ≡ r₂
foo = refl


------------------------------------------------------------------------
-- Excluded middle
------------------------------------------------------------------------

{-# OPTIONS --without-K --safe #-}

open import Equality

module Excluded-middle
  {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Prelude

open import H-level.Closure eq

-- Excluded middle (roughly as stated in the HoTT book).

Excluded-middle : (ℓ : Level) → Type (lsuc ℓ)
Excluded-middle p = {P : Type p} → Is-proposition P → Dec P

-- Excluded middle is pointwise propositional (assuming
-- extensionality).

Excluded-middle-propositional :
  ∀ {ℓ} →
  Extensionality (lsuc ℓ) ℓ →
  Is-proposition (Excluded-middle ℓ)
Excluded-middle-propositional ext =
  implicit-Π-closure ext 1 λ _ →
  Π-closure (lower-extensionality _ lzero ext) 1 λ P-prop →
  Dec-closure-propositional (lower-extensionality _ _ ext) P-prop


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Sn.Base where

open import Cubical.HITs.Susp
open import Cubical.Foundations.Pointed
open import Cubical.Data.Nat
open import Cubical.Data.NatMinusOne
open import Cubical.Data.Empty
open import Cubical.Foundations.Prelude

S : ℕ₋₁ → Type₀
S neg1 = ⊥
S (ℕ→ℕ₋₁ n) = Susp (S (-1+ n))

S₊ : ℕ → Type₀
S₊ n = S (ℕ→ℕ₋₁ n)

-- Pointed version
S₊∙ : (n : ℕ) → Pointed₀
S₊∙ n = (S₊ n) , north