open import Prelude
open import Nat
open import List

module contexts where
  -- helper function
  diff-1 : ∀{n m} → n < m → Nat
  diff-1 n<m = difference (n<m→1+n≤m n<m)

  ---- the core declarations ----
  -- TODO move definitions

  _ctx : Set → Set
  A ctx = List (Nat ∧ A)

  -- nil context
  ∅ : {A : Set} → A ctx
  ∅ = []

  -- singleton context
  ■_ : {A : Set} → (Nat ∧ A) → A ctx
  ■_ (x , a) = (x , a) :: []

  infixr 100 ■_

  -- context extension/insertion - never use _::_
  _,,_ : ∀{A} → A ctx → (Nat ∧ A) → A ctx
  [] ,, (x , a) = ■ (x , a)
  ((hx , ha) :: t) ,, (x , a) with <dec x hx
  ... | Inl x<hx       = (x , a) :: ((diff-1 x<hx , ha) :: t)
  ... | Inr (Inl refl) = (x , a) :: t
  ... | Inr (Inr hx<x) = (hx , ha) :: (t ,, (diff-1 hx<x , a))

  infixl 10 _,,_

  -- membership, or presence, in a context
  data _∈_ : {A : Set} (p : Nat ∧ A) → (Γ : A ctx) → Set where
    InH : {A : Set} {Γ : A ctx} {x : Nat} {a : A} →
           (x , a) ∈ ((x , a) :: Γ)
    InT : {A : Set} {Γ : A ctx} {x s : Nat} {a a' : A} →
           (x , a) ∈ Γ →
           ((x + 1+ s , a)) ∈ ((s , a') :: Γ)

  -- the domain of a context
  dom : {A : Set} → A ctx → Nat → Set
  dom {A} Γ x = Σ[ a ∈ A ] ((x , a) ∈ Γ)

  -- apartness for contexts
  _#_ : {A : Set} (n : Nat) → (Γ : A ctx) → Set
  x # Γ = dom Γ x → ⊥

  _##_ : {A : Set} → A ctx → A ctx → Set
  Γ1 ## Γ2 = (x : Nat) → dom Γ1 x → x # Γ2

  _≈_ : {A : Set} → A ctx → A ctx → Set
  _≈_ {A} Γ1 Γ2 = (x : Nat) (a1 a2 : A) →
                   (x , a1) ∈ Γ1 ∧ (x , a2) ∈ Γ2 →
                   a1 == a2

  -- TODO theorems and explanation
  ctxmap : {A B : Set} → (A → B) → A ctx → B ctx
  ctxmap f Γ = map (λ {(hx , ha) → (hx , f ha)}) Γ

  -- TODO theorems
  -- returns a list of the values stored in the context
  ctx⇒values : {A : Set} → A ctx → List A

  -- TODO theorems
  -- converts a list of key-value pairs into a context, with later pairs in the list
  -- overriding bindings definend by previous pairs
  list⇒ctx : {A : Set} → List (Nat ∧ A) → A ctx

  -- TODO theorems
  -- converts a list of key-value pairs into a multi-context, where each value of
  -- the result is the sublist of values from the former that were mapped to by the
  -- corresponding key
  list⇒list-ctx : {A : Set} → List (Nat ∧ A) → (List A) ctx

  -- union merge A B is the union of A and B,
  -- with (merge a b) being invoked to handle the mappings they have in common
  union : {A : Set} → (A → A → A) → A ctx → A ctx → A ctx

  -- The primary way to test membership is to use _∈_,
  -- but this can be used in cases where using _∈_
  -- would be too verbose or awkward.
  -- The lookup theorems prove that they are compatible
  _⦃⦃_⦄⦄ : {A : Set} → A ctx → Nat → Maybe A
  [] ⦃⦃ x ⦄⦄ = None
  ((hx , ha) :: t) ⦃⦃ x ⦄⦄ with <dec x hx
  ... | Inl x<hx       = None
  ... | Inr (Inl refl) = Some ha
  ... | Inr (Inr hx<x) = t ⦃⦃ diff-1 hx<x ⦄⦄

  ---- lemmas ----

  undiff-1 : (x s : Nat) → (x<s+1+x : x < s + 1+ x) → s == diff-1 x<s+1+x
  undiff-1 x s x<s+1+x
    rewrite n+1+m==1+n+m {s} {x} | ! (m-n==1+m-1+n n≤m+n (n<m→1+n≤m x<s+1+x)) | +comm {s} {x}
      = ! (n+m-n==m n≤n+m)

  too-small : {A : Set} {Γ : A ctx} {xl xb : Nat} {a : A} →
               xl < xb →
               dom ((xb , a) :: Γ) xl →
               ⊥
  too-small (_ , ne) (_ , InH) = ne refl
  too-small (x+1+xb≤xb , x+1+xb==xb) (_ , InT _) =
    x+1+xb==xb (≤antisym x+1+xb≤xb (≤trans (≤1+ ≤refl) n≤m+n))

  all-not-none : {A : Set} {Γ : A ctx} {x : Nat} {a : A} →
                  None ≠ (((x , a) :: Γ) ⦃⦃ x ⦄⦄)
  all-not-none {x = x} rewrite <dec-refl x = λ ()

  all-bindings-==-rec-eq : {A : Set} {Γ1 Γ2 : A ctx} {x : Nat} {a : A} →
                            ((x' : Nat) → ((x , a) :: Γ1) ⦃⦃ x' ⦄⦄ == ((x , a) :: Γ2) ⦃⦃ x' ⦄⦄) →
                            ((x' : Nat) → Γ1 ⦃⦃ x' ⦄⦄ == Γ2 ⦃⦃ x' ⦄⦄)
  all-bindings-==-rec-eq {x = x} h x'
    with h (x' + 1+ x)
  ... | eq
    with <dec (x' + 1+ x) x
  ... | Inl x'+1+x<x
          = abort (<antisym x'+1+x<x (n<m→n<s+m n<1+n))
  ... | Inr (Inl x'+1+x==x)
          = abort ((flip n≠n+1+m) (n+1+m==1+n+m · (+comm {1+ x} · x'+1+x==x)))
  ... | Inr (Inr x<x'+1+x)
          rewrite ! (undiff-1 x x' x<x'+1+x) = eq

  all-bindings-==-rec : {A : Set} {Γ1 Γ2 : A ctx} {x1 x2 : Nat} {a1 a2 : A} →
                         ((x : Nat) → ((x1 , a1) :: Γ1) ⦃⦃ x ⦄⦄ == ((x2 , a2) :: Γ2) ⦃⦃ x ⦄⦄) →
                         ((x : Nat) → Γ1 ⦃⦃ x ⦄⦄ == Γ2 ⦃⦃ x ⦄⦄)
  all-bindings-==-rec {x1 = x1} {x2} h x
    with h x1 | h x2
  ... | eq1 | eq2
    rewrite <dec-refl x1 | <dec-refl x2
    with <dec x1 x2 | <dec x2 x1
  ... | Inl _ | _
          = abort (somenotnone eq1)
  ... | Inr _ | Inl _
          = abort (somenotnone (! eq2))
  ... | Inr (Inl refl) | Inr (Inl refl)
          rewrite someinj eq1 | someinj eq2
            = all-bindings-==-rec-eq h x
  ... | Inr (Inl refl) | Inr (Inr x2<x2)
          = abort (<antirefl x2<x2)
  ... | Inr (Inr x2<x2) | Inr (Inl refl)
          = abort (<antirefl x2<x2)
  ... | Inr (Inr x2<x1) | Inr (Inr x1<x2)
          = abort (<antisym x1<x2 x2<x1)

  ---- core theorems ----

  -- lookup is decidable
  lookup-dec : {A : Set} (Γ : A ctx) (x : Nat) →
                Σ[ a ∈ A ] (Γ ⦃⦃ x ⦄⦄ == Some a) ∨ Γ ⦃⦃ x ⦄⦄ == None
  lookup-dec Γ x
    with Γ ⦃⦃ x ⦄⦄
  ... | Some a = Inl (a , refl)
  ... | None   = Inr refl

  -- The next two theorems show that lookup (_⦃⦃_⦄⦄) is consistent with membership (_∈_)
  lookup-cons-1 : {A : Set} {Γ : A ctx} {x : Nat} {a : A} →
                   Γ ⦃⦃ x ⦄⦄ == Some a →
                   (x , a) ∈ Γ
  lookup-cons-1 {Γ = []} ()
  lookup-cons-1 {Γ = (hx , ha) :: t} {x} h
    with <dec x hx
  lookup-cons-1 {_} {(hx , ha) :: t} {x} ()        | Inl _
  lookup-cons-1 {_} {(hx , ha) :: t} {.hx} refl    | Inr (Inl refl) = InH
  lookup-cons-1 {_} {(hx , ha) :: t} {x} {a = a} h | Inr (Inr hx<x)
    = tr
        (λ y → (y , a) ∈ ((hx , ha) :: t))
        (m-n+n==m (n<m→1+n≤m hx<x))
        (InT (lookup-cons-1 {Γ = t} h))

  lookup-cons-2 : {A : Set} {Γ : A ctx} {x : Nat} {a : A} →
                   (x , a) ∈ Γ →
                   Γ ⦃⦃ x ⦄⦄ == Some a
  lookup-cons-2 {x = x} InH rewrite <dec-refl x = refl
  lookup-cons-2 (InT {Γ = Γ} {x = x} {s} {a} x∈Γ)
    with <dec (x + 1+ s) s
  ... | Inl x+1+s<s        = abort (<antisym x+1+s<s (n<m→n<s+m n<1+n))
  ... | Inr (Inl x+1+s==s) = abort ((flip n≠n+1+m) (n+1+m==1+n+m · (+comm {1+ s} · x+1+s==s)))
  ... | Inr (Inr s<x+1+s)
    with lookup-cons-2 x∈Γ
  ... | h rewrite ! (undiff-1 s x s<x+1+s) = h

  -- membership (_∈_) respects insertion (_,,_)
  x,a∈Γ,,x,a : {A : Set} {Γ : A ctx} {x : Nat} {a : A} →
                (x , a) ∈ (Γ ,, (x , a))
  x,a∈Γ,,x,a {Γ = []} {x} {a} = InH
  x,a∈Γ,,x,a {_} {(hx , ha) :: t} {x} {a}
    with <dec x hx
  ... | Inl _          = InH
  ... | Inr (Inl refl) = InH
  ... | Inr (Inr hx<x) =
          tr
            (λ y → (y , a) ∈ ((hx , ha) :: (t ,, (diff-1 hx<x , a))))
            (m-n+n==m (n<m→1+n≤m hx<x))
            (InT (x,a∈Γ,,x,a {Γ = t} {diff-1 hx<x} {a}))

  -- insertion can't generate spurious membership
  x∈Γ+→x∈Γ : {A : Set} {Γ : A ctx} {x x' : Nat} {a a' : A} →
                x ≠ x' →
                (x , a) ∈ (Γ ,, (x' , a')) →
                (x , a) ∈ Γ
  x∈Γ+→x∈Γ {Γ = []} x≠x' InH = abort (x≠x' refl)
  x∈Γ+→x∈Γ {Γ = []} x≠x' (InT ())
  x∈Γ+→x∈Γ {Γ = (hx , ha) :: t} {x' = x'} x≠x' x∈Γ+
    with <dec x' hx
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = x'} x≠x' InH | Inl x'<hx = abort (x≠x' refl)
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = x'} x≠x' (InT InH) | Inl x'<hx
    rewrite m-n+n==m (n<m→1+n≤m x'<hx) = InH
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = x'} x≠x' (InT (InT {x = x} x∈Γ+)) | Inl x'<hx
    rewrite +assc {x} {1+ (diff-1 x'<hx)} {1+ x'} | m-n+n==m (n<m→1+n≤m x'<hx)
      = InT x∈Γ+
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = .hx} x≠x' InH | Inr (Inl refl) = abort (x≠x' refl)
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = .hx} x≠x' (InT x∈Γ+) | Inr (Inl refl) = InT x∈Γ+
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = x'} x≠x' InH | Inr (Inr hx<x') = InH
  x∈Γ+→x∈Γ {_} {(hx , ha) :: t} {x' = x'} x≠x' (InT x∈Γ+) | Inr (Inr hx<x')
    = InT (x∈Γ+→x∈Γ (λ where refl → x≠x' (m-n+n==m (n<m→1+n≤m hx<x'))) x∈Γ+)

  -- insertion respects membership
  x∈Γ→x∈Γ+ : {A : Set} {Γ : A ctx} {x x' : Nat} {a a' : A} →
                x ≠ x' →
                (x , a) ∈ Γ →
                (x , a) ∈ (Γ ,, (x' , a'))
  x∈Γ→x∈Γ+ {x = x} {x'} {a} {a'} x≠x' (InH {Γ = Γ'})
    with <dec x' x
  ... | Inl x'<x
          = tr
              (λ y → (y , a) ∈ ((x' , a') :: ((diff-1 x'<x , a) :: Γ')))
              (m-n+n==m (n<m→1+n≤m x'<x))
              (InT InH)
  ... | Inr (Inl refl) = abort (x≠x' refl)
  ... | Inr (Inr x<x') = InH
  x∈Γ→x∈Γ+ {x = .(_ + 1+ _)} {x'} {a} {a'} x≠x' (InT {Γ = Γ} {x} {s} {a' = a''} x∈Γ)
    with <dec x' s
  ... | Inl x'<s
          = tr
              (λ y → (y , a) ∈ ((x' , a') :: ((diff-1 x'<s , a'') :: Γ)))
              ((+assc {b = 1+ (diff-1 x'<s)}) · (ap1 (_+_ x) (1+ap (m-n+n==m (n<m→1+n≤m x'<s)))))
              (InT (InT x∈Γ))
  ... | Inr (Inl refl) = InT x∈Γ
  ... | Inr (Inr s<x') =
          InT (x∈Γ→x∈Γ+ (λ where refl → x≠x' (m-n+n==m (n<m→1+n≤m s<x'))) x∈Γ)

  -- Decidability of membership
  -- This also packages up an appeal to context membership into a form that
  -- lets us retain more information
  ctxindirect : {A : Set} (Γ : A ctx) (x : Nat) → dom Γ x ∨ x # Γ
  ctxindirect [] x = Inr (λ ())
  ctxindirect ((hx , ha) :: t) x
    with <dec x hx
  ... | Inl x<hx       = Inr (too-small x<hx)
  ... | Inr (Inl refl) = Inl (ha , InH)
  ... | Inr (Inr hx<x)
    with ctxindirect t (diff-1 hx<x)
  ctxindirect ((hx , ha) :: t) x | Inr (Inr hx<x) | Inl (a , rec) =
    Inl (a , tr
               (λ y → (y , a) ∈ ((hx , ha) :: t))
               (m-n+n==m (n<m→1+n≤m hx<x))
               (InT rec))
  ctxindirect {A} ((hx , ha) :: t) x | Inr (Inr hx<x) | Inr dne =
    Inr x∉Γ
    where
      x∉Γ : Σ[ a ∈ A ] ((x , a) ∈ ((hx , ha) :: t)) → ⊥
      x∉Γ (_ , x∈Γ) with x∈Γ
      ... | InH = (π2 hx<x) refl
      ... | InT {x = s} x-hx-1∈t
        rewrite ! (undiff-1 hx s hx<x) = dne (_ , x-hx-1∈t)

  -- contexts give at most one binding for each variable
  ctxunicity : {A : Set} {Γ : A ctx} {x : Nat} {a a' : A} →
                 (x , a) ∈ Γ →
                 (x , a') ∈ Γ →
                 a == a'
  ctxunicity ah a'h
    with lookup-cons-2 ah | lookup-cons-2 a'h
  ... | ah' | a'h' = someinj (! ah' · a'h')

  -- everything is apart from the nil context
  x#∅ : {A : Set} {x : Nat} → _#_ {A} x ∅
  x#∅ (_ , ())

  -- if an index is in the domain of a singleton context, it's the only
  -- index in the context
  lem-dom-eq : {A : Set} {a : A} {n m : Nat} →
                 dom (■ (m , a)) n →
                 n == m
  lem-dom-eq (_ , InH) = refl
  lem-dom-eq (_ , InT ())

  -- If two contexts are semantically equivalent
  -- (i.e. they represent the same mapping from ids to values),
  -- then they are physically equal as judged by _==_
  ctx-==-eqv : {A : Set} {Γ1 Γ2 : A ctx} →
                ((x : Nat) → Γ1 ⦃⦃ x ⦄⦄ == Γ2 ⦃⦃ x ⦄⦄) →
                Γ1 == Γ2
  ctx-==-eqv {Γ1 = []} {[]} all-bindings-== = refl
  ctx-==-eqv {Γ1 = []} {(hx2 , ha2) :: t2} all-bindings-==
    = abort (all-not-none {Γ = t2} {x = hx2} (all-bindings-== hx2))
  ctx-==-eqv {Γ1 = (hx1 , ha1) :: t1} {[]} all-bindings-==
    = abort (all-not-none {Γ = t1} {x = hx1} (! (all-bindings-== hx1)))
  ctx-==-eqv {Γ1 = (hx1 , ha1) :: t1} {(hx2 , ha2) :: t2} all-bindings-==
    rewrite ctx-==-eqv {Γ1 = t1} {t2} (all-bindings-==-rec all-bindings-==)
    with all-bindings-== hx1 | all-bindings-== hx2
  ... | ha1== | ha2== rewrite <dec-refl hx1 | <dec-refl hx2
    with <dec hx1 hx2 | <dec hx2 hx1
  ... | Inl hx1<hx2 | _
          = abort (somenotnone ha1==)
  ... | Inr (Inl refl) | Inl hx2<hx1
          = abort (somenotnone (! ha2==))
  ... | Inr (Inr hx2<hx1) | Inl hx2<'hx1
          = abort (somenotnone (! ha2==))
  ... | Inr (Inl refl) | Inr _
          rewrite someinj ha1== = refl
  ... | Inr (Inr hx2<hx1) | Inr (Inl refl)
          rewrite someinj ha2== = refl
  ... | Inr (Inr hx2<hx1) | Inr (Inr hx1<hx2)
          = abort (<antisym hx1<hx2 hx2<hx1)

  -- equality of contexts is decidable
  ctx-==-dec : {A : Set}
                (Γ1 Γ2 : A ctx) →
                ((a1 a2 : A) → a1 == a2 ∨ a1 ≠ a2) →
                Γ1 == Γ2 ∨ Γ1 ≠ Γ2
  ctx-==-dec [] [] _ = Inl refl
  ctx-==-dec [] (_ :: _) _ = Inr (λ ())
  ctx-==-dec (_ :: _) [] _ = Inr (λ ())
  ctx-==-dec ((hx1 , ha1) :: t1) ((hx2 , ha2) :: t2) A==dec
    with natEQ hx1 hx2 | A==dec ha1 ha2 | ctx-==-dec t1 t2 A==dec
  ... | Inl refl | Inl refl | Inl refl = Inl refl
  ... | Inl refl | Inl refl | Inr ne   = Inr λ where refl → ne refl
  ... | Inl refl | Inr ne   | _        = Inr λ where refl → ne refl
  ... | Inr ne   | _        | _        = Inr λ where refl → ne refl

  -- A useful way to destruct context membership. Never destruct a context via _::_
  ctx-split : {A : Set} {Γ : A ctx} {n m : Nat} {an am : A} →
                (n , an) ∈ (Γ ,, (m , am)) →
                (n ≠ m ∧ (n , an) ∈ Γ) ∨ (n == m ∧ an == am)
  ctx-split {Γ = Γ} {n} {m} {an} {am} n∈Γ+
    with natEQ n m
  ... | Inl refl = Inr (refl , ctxunicity n∈Γ+ (x,a∈Γ,,x,a {Γ = Γ}))
  ... | Inr n≠m  = Inl (n≠m , x∈Γ+→x∈Γ n≠m n∈Γ+)

  -- I'd say "God dammit agda" but AFAICT Coq is terrible about this as well
  lemma-bullshit : {A : Set} (Γ' : A ctx) (a : A) (n m : Nat) →
                    Σ[ Γ ∈ A ctx ] (Γ == (n + 1+ m , a) :: Γ')
  lemma-bullshit Γ' a n m = ((n + 1+ m , a) :: Γ') , refl

  -- Allows the elimination of contexts. Never destruct a context via _::_
  ctx-elim : {A : Set} {Γ : A ctx} →
              Γ == ∅
                ∨
              Σ[ n ∈ Nat ] Σ[ a ∈ A ] Σ[ Γ' ∈ A ctx ]
                 (Γ == Γ' ,, (n , a) ∧ n # Γ')
  ctx-elim {Γ = []}            = Inl refl
  ctx-elim {Γ = (n , a) :: []} = Inr (_ , _ , _ , refl , x#∅)
  ctx-elim {Γ = (n , a) :: ((m , a2) :: Γ'')}
    with lemma-bullshit Γ'' a2 m n
  ... | Γ' , eq
    = Inr (n , a , Γ' , eqP , not-dom)
      where
        eqP : (n , a) :: ((m , a2) :: Γ'') == Γ' ,, (n , a)
        eqP rewrite eq with <dec n (m + 1+ n)
        ... | Inl n<m+1+n
          rewrite ! (undiff-1 n m n<m+1+n) = refl
        ... | Inr (Inl n==m+1+n)
          = abort (n≠n+1+m (n==m+1+n · (n+1+m==1+n+m · +comm {1+ m})))
        ... | Inr (Inr m+1+n<n)
          = abort (<antisym m+1+n<n (n<m→n<s+m n<1+n))
        not-dom : dom Γ' n → ⊥
        not-dom rewrite eq = λ n∈Γ' →
          too-small (n<m→n<s+m n<1+n) n∈Γ'

  -- When using ctx-elim, this theorem is useful for establishing termination
  ctx-decreasing : {A : Set} {Γ : A ctx} {n : Nat} {a : A} →
                    n # Γ →
                    ∥ Γ ,, (n , a) ∥ == 1+ ∥ Γ ∥
  ctx-decreasing {Γ = []} n#Γ = refl
  ctx-decreasing {Γ = (n' , a') :: Γ} {n} n#Γ
    with <dec n n'
  ... | Inl n<n'       = refl
  ... | Inr (Inl refl) = abort (n#Γ (_ , InH))
  ... | Inr (Inr n'<n)
    = 1+ap (ctx-decreasing λ {(a , diff∈Γ) →
        n#Γ (a , tr
                   (λ y → (y , a) ∈ ((n' , a') :: Γ))
                   (m-n+n==m (n<m→1+n≤m n'<n))
                   (InT diff∈Γ))})

  ---- contrapositives of some previous theorems ----

  lem-neq-apart : {A : Set} {a : A} {n m : Nat} →
                    n ≠ m →
                    n # (■ (m , a))
  lem-neq-apart n≠m h = n≠m (lem-dom-eq h)

  x#Γ→x#Γ+ : {A : Set} {Γ : A ctx} {x x' : Nat} {a' : A} →
               x ≠ x' →
               x # Γ →
               x # (Γ ,, (x' , a'))
  x#Γ→x#Γ+ {Γ = Γ} {x} {x'} {a'} x≠x' x#Γ
    with ctxindirect (Γ ,, (x' , a')) x
  ... | Inl (_ , x∈Γ+) = abort (x#Γ (_ , x∈Γ+→x∈Γ x≠x' x∈Γ+))
  ... | Inr x#Γ+       = x#Γ+

  x#Γ+→x#Γ : {A : Set} {Γ : A ctx} {x x' : Nat} {a' : A} →
               x # (Γ ,, (x' , a')) →
               x # Γ
  x#Γ+→x#Γ {Γ = Γ} {x} {x'} {a'} x#Γ+
    with ctxindirect Γ x
  ... | Inr x#Γ       = x#Γ
  ... | Inl (_ , x∈Γ)
    with natEQ x x'
  ... | Inl refl = abort (x#Γ+ (_ , x,a∈Γ,,x,a {Γ = Γ}))
  ... | Inr x≠x' = abort (x#Γ+ (_ , x∈Γ→x∈Γ+ x≠x' x∈Γ))

  lookup-cp-1 : {A : Set} {Γ : A ctx} {x : Nat} →
                 x # Γ →
                 Γ ⦃⦃ x ⦄⦄ == None
  lookup-cp-1 {Γ = Γ} {x} x#Γ
    with lookup-dec Γ x
  ... | Inl (_ , x∈Γ) = abort (x#Γ (_ , (lookup-cons-1 x∈Γ)))
  ... | Inr x#'Γ      = x#'Γ

  lookup-cp-2 : {A : Set} {Γ : A ctx} {x : Nat} →
                 Γ ⦃⦃ x ⦄⦄ == None →
                 x # Γ
  lookup-cp-2 {Γ = Γ} {x} x#Γ
    with ctxindirect Γ x
  ... | Inl (_ , x∈Γ) = abort (somenotnone ((! (lookup-cons-2 x∈Γ)) · x#Γ))
  ... | Inr x#'Γ      = x#'Γ

  ---- some definitions ----

  merge' : {A : Set} → (A → A → A) → Maybe A → A → A
  merge' merge ma1 a2
    with ma1
  ... | None    = a2
  ... | Some a1 = merge a1 a2

  union' : {A : Set} → (A → A → A) → A ctx → A ctx → Nat → A ctx
  union' merge Γ1 [] _ = Γ1
  union' merge Γ1 ((hx , ha) :: Γ2) offset
    = union' merge (Γ1 ,, (hx + offset , merge' merge (Γ1 ⦃⦃ hx + offset ⦄⦄) ha)) Γ2 (1+ hx + offset)

  union merge Γ1 Γ2 = union' merge Γ1 Γ2 0

  ---- union theorems ----

  lemma-math' : ∀{x x1 n} → x ≠ x1 + (n + 1+ x)
  lemma-math' {x} {x1} {n}
    rewrite ! (+assc {x1} {n} {1+ x})
          | n+1+m==1+n+m {x1 + n} {x}
          | +comm {1+ x1 + n} {x}
      = n≠n+1+m

  lemma-union'-0 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x n : Nat} {a : A} →
                    (x , a) ∈ Γ1 →
                    (x , a) ∈ union' m Γ1 Γ2 (n + 1+ x)
  lemma-union'-0 {Γ2 = []} x∈Γ1 = x∈Γ1
  lemma-union'-0 {Γ2 = (x1 , a1) :: Γ2} {x} {n} x∈Γ1
    rewrite ! (+assc {1+ x1} {n} {1+ x})
      = lemma-union'-0 {Γ2 = Γ2} {n = 1+ x1 + n} (x∈Γ→x∈Γ+ (lemma-math' {x1 = x1} {n}) x∈Γ1)

  lemma-union'-1 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x n : Nat} {a : A} →
                    (x , a) ∈ Γ1 →
                    (n≤x : n ≤ x) →
                    (difference n≤x) # Γ2 →
                    (x , a) ∈ union' m Γ1 Γ2 n
  lemma-union'-1 {Γ2 = []} {x} x∈Γ1 n≤x x-n#Γ2 = x∈Γ1
  lemma-union'-1 {m = m} {Γ1} {(x1 , a1) :: Γ2} {x} {n} {a} x∈Γ1 n≤x x-n#Γ2
    with <dec x (x1 + n)
  lemma-union'-1 {m = m} {Γ1} {(x1 , a1) :: Γ2} {x} {n} {a} x∈Γ1 n≤x x-n#Γ2 | Inl x<x1+n
    with Γ1 ⦃⦃ x1 + n ⦄⦄
  lemma-union'-1 {m = m} {Γ1} {(x1 , a1) :: Γ2} {x} {n} {a} x∈Γ1 n≤x x-n#Γ2 | Inl x<x1+n | Some a'
    = tr
         (λ y → (x , a) ∈ union' m (Γ1 ,, (x1 + n , m a' a1)) Γ2 y)
         (n+1+m==1+n+m {difference (π1 x<x1+n)} · 1+ap (m-n+n==m (π1 x<x1+n)))
         (lemma-union'-0 {Γ2 = Γ2} (x∈Γ→x∈Γ+ (π2 x<x1+n) x∈Γ1))
  lemma-union'-1 {m = m} {Γ1} {(x1 , a1) :: Γ2} {x} {n} {a} x∈Γ1 n≤x x-n#Γ2 | Inl x<x1+n | None
    = tr
         (λ y → (x , a) ∈ union' m (Γ1 ,, (x1 + n , a1)) Γ2 y)
         (n+1+m==1+n+m {difference (π1 x<x1+n)} · 1+ap (m-n+n==m (π1 x<x1+n)))
         (lemma-union'-0 {Γ2 = Γ2} (x∈Γ→x∈Γ+ (π2 x<x1+n) x∈Γ1))
  lemma-union'-1 {m = m} {Γ1} {(x1 , a1) :: Γ2} {x} {n} {a} x∈Γ1 n≤x x-n#Γ2 | Inr (Inl refl)
    rewrite +comm {x1} {n} | n+m-n==m n≤x
      = abort (x-n#Γ2 (_ , InH))
  lemma-union'-1 {m = m} {Γ1} {(x1 , a1) :: Γ2} {x} {n} {a} x∈Γ1 n≤x x-n#Γ2 | Inr (Inr x1+n<x)
    rewrite (! (a+b==c→a==c-b (+assc {diff-1 x1+n<x} · m-n+n==m (n<m→1+n≤m x1+n<x)) n≤x))
      = lemma-union'-1
          (x∈Γ→x∈Γ+ (flip (π2 x1+n<x)) x∈Γ1)
          (n<m→1+n≤m x1+n<x)
          λ {(_ , x-x1-n∈Γ2) → x-n#Γ2 (_ , InT x-x1-n∈Γ2)}

  lemma-union'-2 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x n : Nat} {a : A} →
                    (x + n) # Γ1 →
                    (x , a) ∈ Γ2 →
                    (x + n , a) ∈ union' m Γ1 Γ2 n
  lemma-union'-2 {Γ1 = Γ1} x+n#Γ1 (InH {Γ = Γ2})
    rewrite lookup-cp-1 x+n#Γ1
      = lemma-union'-0 {Γ2 = Γ2} {n = Z} (x,a∈Γ,,x,a {Γ = Γ1})
  lemma-union'-2 {Γ1 = Γ1} {n = n} x+n#Γ1 (InT {Γ = Γ2} {x = x} {s} x∈Γ2)
    rewrite +assc {x} {1+ s} {n}
    with Γ1 ⦃⦃ s + n ⦄⦄
  ... | Some a'
    = lemma-union'-2
        (λ {(_ , x∈Γ1+) →
             x+n#Γ1 (_ , x∈Γ+→x∈Γ (flip (lemma-math' {x1 = Z})) x∈Γ1+)})
        x∈Γ2
  ... | None
    = lemma-union'-2
        (λ {(_ , x∈Γ1+) →
             x+n#Γ1 (_ , x∈Γ+→x∈Γ (flip (lemma-math' {x1 = Z})) x∈Γ1+)})
        x∈Γ2

  lemma-union'-3 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x n : Nat} {a1 a2 : A} →
                    (x + n , a1) ∈ Γ1 →
                    (x , a2) ∈ Γ2 →
                    (x + n , m a1 a2) ∈ union' m Γ1 Γ2 n
  lemma-union'-3 {Γ1 = Γ1} x+n∈Γ1 (InH {Γ = Γ2})
    rewrite lookup-cons-2 x+n∈Γ1
      = lemma-union'-0 {Γ2 = Γ2} {n = Z} (x,a∈Γ,,x,a {Γ = Γ1})
  lemma-union'-3 {Γ1 = Γ1} {n = n} x+n∈Γ1 (InT {Γ = Γ2} {x = x} {s} x∈Γ2)
    rewrite +assc {x} {1+ s} {n}
    with Γ1 ⦃⦃ s + n ⦄⦄
  ... | Some a'
    = lemma-union'-3 (x∈Γ→x∈Γ+ (flip (lemma-math' {x1 = Z})) x+n∈Γ1) x∈Γ2
  ... | None
    = lemma-union'-3 (x∈Γ→x∈Γ+ (flip (lemma-math' {x1 = Z})) x+n∈Γ1) x∈Γ2

  lemma-union'-4 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x n : Nat} →
                    dom (union' m Γ1 Γ2 n) x →
                    dom Γ1 x ∨ (Σ[ s ∈ Nat ] (x == n + s ∧ dom Γ2 s))
  lemma-union'-4 {Γ2 = []} x∈un = Inl x∈un
  lemma-union'-4 {Γ1 = Γ1} {(x1 , a1) :: Γ2} {x} {n} x∈un
    with lemma-union'-4 {Γ2 = Γ2} x∈un
  ... | Inr (s , refl , _ , s∈Γ2)
    rewrite +comm {x1} {n}
          | ! (n+1+m==1+n+m {n + x1} {s})
          | +assc {n} {x1} {1+ s}
          | +comm {x1} {1+ s}
          | ! (n+1+m==1+n+m {s} {x1})
      = Inr (_ , refl , _ , InT s∈Γ2)
  ... | Inl (_ , x∈Γ1+)
    with natEQ x (n + x1)
  ... | Inl refl   = Inr (_ , refl , _ , InH)
  ... | Inr x≠n+x1
    rewrite +comm {x1} {n}
      = Inl (_ , x∈Γ+→x∈Γ x≠n+x1 x∈Γ1+)

  x,a∈Γ1→x∉Γ2→x,a∈Γ1∪Γ2 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x : Nat} {a : A} →
                              (x , a) ∈ Γ1 →
                              x # Γ2 →
                              (x , a) ∈ union m Γ1 Γ2
  x,a∈Γ1→x∉Γ2→x,a∈Γ1∪Γ2 {Γ2 = Γ2} x∈Γ1 x#Γ2
    = lemma-union'-1 x∈Γ1 0≤n (tr (λ y → y # Γ2) (! (n+m-n==m 0≤n)) x#Γ2)

  x∉Γ1→x,a∈Γ2→x,a∈Γ1∪Γ2 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x : Nat} {a : A} →
                              x # Γ1 →
                              (x , a) ∈ Γ2 →
                              (x , a) ∈ union m Γ1 Γ2
  x∉Γ1→x,a∈Γ2→x,a∈Γ1∪Γ2 {Γ1 = Γ1} {x = x} x#Γ1 x∈Γ2
    with lemma-union'-2 {n = Z} (tr (λ y → y # Γ1) (! n+Z==n) x#Γ1) x∈Γ2
  ... | rslt
    rewrite n+Z==n {x}
      = rslt

  x∈Γ1→x∈Γ2→x∈Γ1∪Γ2 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x : Nat} {a1 a2 : A} →
                              (x , a1) ∈ Γ1 →
                              (x , a2) ∈ Γ2 →
                              (x , m a1 a2) ∈ union m Γ1 Γ2
  x∈Γ1→x∈Γ2→x∈Γ1∪Γ2 {Γ1 = Γ1} {Γ2} {x} {a1} x∈Γ1 x∈Γ2
    with lemma-union'-3 (tr (λ y → (y , a1) ∈ Γ1) (! n+Z==n) x∈Γ1) x∈Γ2
  ... | rslt
    rewrite n+Z==n {x}
      = rslt

  x∈Γ1∪Γ2→x∈Γ1∨x∈Γ2 : {A : Set} {m : A → A → A} {Γ1 Γ2 : A ctx} {x : Nat} →
                          dom (union m Γ1 Γ2) x →
                          dom Γ1 x ∨ dom Γ2 x
  x∈Γ1∪Γ2→x∈Γ1∨x∈Γ2 x∈Γ1∪Γ2
    with lemma-union'-4 {n = Z} x∈Γ1∪Γ2
  x∈Γ1∪Γ2→x∈Γ1∨x∈Γ2 x∈Γ1∪Γ2 | Inl x'∈Γ1 = Inl x'∈Γ1
  x∈Γ1∪Γ2→x∈Γ1∨x∈Γ2 x∈Γ1∪Γ2 | Inr (_ , refl , x'∈Γ2) = Inr x'∈Γ2

  ---- contraction and exchange ----

  -- TODO these proofs could use refactoring -
  -- contraction should probably make use of ctx-==-dec and
  -- exchange is way too long and repetitive

  contraction : {A : Set} {Γ : A ctx} {x : Nat} {a a' : A} →
                 Γ ,, (x , a') ,, (x , a) == Γ ,, (x , a)
  contraction {Γ = []} {x} rewrite <dec-refl x = refl
  contraction {Γ = (hx , ha) :: t} {x} {a} {a'}
    with <dec x hx
  ... | Inl _          rewrite <dec-refl x  = refl
  ... | Inr (Inl refl) rewrite <dec-refl hx = refl
  ... | Inr (Inr hx<x)
    with <dec x hx
  ... | Inl x<hx        = abort (<antisym x<hx hx<x)
  ... | Inr (Inl refl)  = abort (<antirefl hx<x)
  ... | Inr (Inr hx<'x)
    rewrite diff-proof-irrelevance (n<m→1+n≤m hx<x) (n<m→1+n≤m hx<'x)
          | contraction {Γ = t} {diff-1 hx<'x} {a} {a'}
    = refl

  exchange : {A : Set} {Γ : A ctx} {x1 x2 : Nat} {a1 a2 : A} →
              x1 ≠ x2 →
              Γ ,, (x1 , a1) ,, (x2 , a2) == Γ ,, (x2 , a2) ,, (x1 , a1)
  exchange {A} {Γ} {x1} {x2} {a1} {a2} x1≠x2
    = ctx-==-eqv fun
      where
        fun : (x : Nat) →
               (Γ ,, (x1 , a1) ,, (x2 , a2)) ⦃⦃ x ⦄⦄ ==
               (Γ ,, (x2 , a2) ,, (x1 , a1)) ⦃⦃ x ⦄⦄
        fun x
          with natEQ x x1 | natEQ x x2 | ctxindirect Γ x
        fun x  | Inl refl | Inl refl | _
          = abort (x1≠x2 refl)
        fun x1 | Inl refl | Inr x≠x2 | Inl (_ , x1∈Γ)
          with x,a∈Γ,,x,a {Γ = Γ} {x1} {a1}
        ... | x∈Γ+1
          with x∈Γ→x∈Γ+ {a' = a2} x≠x2 x∈Γ+1 | x,a∈Γ,,x,a {Γ = Γ ,, (x2 , a2)} {x1} {a1}
        ... | x∈Γ++1 | x∈Γ++2
          rewrite lookup-cons-2 x∈Γ++1 | lookup-cons-2 x∈Γ++2 = refl
        fun x1 | Inl refl | Inr x≠x2 | Inr x1#Γ
          with x,a∈Γ,,x,a {Γ = Γ} {x1} {a1}
        ... | x∈Γ+1
          with x∈Γ→x∈Γ+ {a' = a2} x≠x2 x∈Γ+1 | x,a∈Γ,,x,a {Γ = Γ ,, (x2 , a2)} {x1} {a1}
        ... | x∈Γ++1 | x∈Γ++2
          rewrite lookup-cons-2 x∈Γ++1 | lookup-cons-2 x∈Γ++2 = refl
        fun x2 | Inr x≠x1 | Inl refl | Inl (_ , x2∈Γ)
          with x,a∈Γ,,x,a {Γ = Γ} {x2} {a2}
        ... | x∈Γ+2
          with x∈Γ→x∈Γ+ {a' = a1} x≠x1 x∈Γ+2 | x,a∈Γ,,x,a {Γ = Γ ,, (x1 , a1)} {x2} {a2}
        ... | x∈Γ++1 | x∈Γ++2
          rewrite lookup-cons-2 x∈Γ++1 | lookup-cons-2 x∈Γ++2 = refl
        fun x2 | Inr x≠x1 | Inl refl | Inr x2#Γ
          with x,a∈Γ,,x,a {Γ = Γ} {x2} {a2}
        ... | x∈Γ+2
          with x∈Γ→x∈Γ+ {a' = a1} x≠x1 x∈Γ+2 | x,a∈Γ,,x,a {Γ = Γ ,, (x1 , a1)} {x2} {a2}
        ... | x∈Γ++1 | x∈Γ++2
          rewrite lookup-cons-2 x∈Γ++1 | lookup-cons-2 x∈Γ++2 = refl
        fun x  | Inr x≠x1 | Inr x≠x2 | Inl (_ , x∈Γ)
          with x∈Γ→x∈Γ+ {a' = a1} x≠x1 x∈Γ   | x∈Γ→x∈Γ+ {a' = a2} x≠x2 x∈Γ
        ... | x∈Γ+1  | x∈Γ+2
          with x∈Γ→x∈Γ+ {a' = a2} x≠x2 x∈Γ+1 | x∈Γ→x∈Γ+ {a' = a1} x≠x1 x∈Γ+2
        ... | x∈Γ++1 | x∈Γ++2
          rewrite lookup-cons-2 x∈Γ++1 | lookup-cons-2 x∈Γ++2 = refl
        fun x  | Inr x≠x1 | Inr x≠x2 | Inr x#Γ
          with x#Γ→x#Γ+ {a' = a1} x≠x1 x#Γ   | x#Γ→x#Γ+ {a' = a2} x≠x2 x#Γ
        ... | x#Γ+1  | x#Γ+2
          with x#Γ→x#Γ+ {a' = a2} x≠x2 x#Γ+1 | x#Γ→x#Γ+ {a' = a1} x≠x1 x#Γ+2
        ... | x#Γ++1 | x#Γ++2
          rewrite lookup-cp-1 x#Γ++1 | lookup-cp-1 x#Γ++2 = refl

  ---- remaining function definitions ----

  list⇒ctx = foldl _,,_ ∅

  list⇒list-ctx {A} l
    = foldl f ∅ (reverse l)
      where
        f : (List A) ctx → Nat ∧ A → (List A) ctx
        f Γ (n , a)
          with ctxindirect Γ n
        ... | Inl (as , n∈Γ)
          = Γ ,, (n , a :: as)
        ... | Inr n#Γ
          = Γ ,, (n , a :: [])

  ctx⇒values = map π2


{-# OPTIONS -v treeless.opt:20 #-}
module _ where

open import Agda.Builtin.Nat using (_<_)
open import Common.Prelude
open import Common.Integer

-- Should compile to
--   λ a b → case a of
--              "neg" → 0 - b
--              _     → b
match-on-lit : String → Integer → Integer
match-on-lit "neg" x with x
...                     | pos (suc n) = negsuc n
...                     | pos 0       = pos 0
...                     | negsuc n    = pos (suc n)
match-on-lit _     x = x

-- This doesn't compile as nicely, since the match on "neg"
-- ends up between the match on the int and the nat (not sure why).
match-on-lit₂ : String → Integer → Integer
match-on-lit₂ "neg" (pos (suc n)) = negsuc n
match-on-lit₂ "neg" (negsuc n)    = pos (suc n)
match-on-lit₂ _     x             = x

-- Should compile to a flat case
nested-match : Integer → String
nested-match (pos 0) = "zero"
nested-match (pos 1) = "one"
nested-match (pos (suc (suc n))) = "lots"
nested-match (negsuc 0) = "minus one"
nested-match (negsuc 1) = "minus two"
nested-match (negsuc (suc (suc n))) = "minus lots"

data Diff : Set where
  less : Nat → Diff
  equal : Diff
  greater : Nat → Diff

compareNat : Nat → Nat → Diff
compareNat a b with a < b
... | true = less (b ∸ suc a)
... | false with b < a
...   | true  = greater (a ∸ suc b)
...   | false = equal
{-# INLINE compareNat #-}

-- Should compile to 0 - a
neg : Nat → Integer
neg zero    = pos zero
neg (suc a) = negsuc a
{-# INLINE neg #-}

-- Should compile to a - b
_-N_ : Nat → Nat → Integer
a -N b with compareNat a b
... | less k    = negsuc k
... | equal     = pos (a ∸ b)
... | greater k = pos (suc k)
{-# INLINE _-N_ #-}

-- Should compile to a + b
_+Z_ : Integer → Integer → Integer
pos    a +Z pos    b = pos (a + b)
pos    a +Z negsuc b = a -N suc b
negsuc a +Z pos    b = b -N suc a
negsuc a +Z negsuc b = negsuc (suc a + b)
{-# INLINE _+Z_ #-}

-- Should compile to a * b
_*Z_ : Integer → Integer → Integer
pos    a *Z pos    b = pos (a * b)
pos    a *Z negsuc b = neg (a * suc b)
negsuc a *Z pos    b = neg (suc a * b)
negsuc a *Z negsuc b = pos (suc a * suc b)
{-# INLINE _*Z_ #-}

printInt : Integer → IO Unit
printInt x = putStrLn (intToString x)

main : IO Unit
main = printInt (match-on-lit "neg" (pos 42))
    ,, printInt (match-on-lit₂ "neg" (pos 42))
    ,, putStrLn (nested-match (negsuc 5))


module Issue1039 where
open import Common.Level

Test : ∀ {a b} → Set a → Set (a ⊔ b) → Set a
Test X Y = X

test : Set (lsuc lzero)
test = Test Set (Set (lsuc lzero))

test₂ : ∀ {l} → Set (lsuc l)
test₂ {l} = Test (Set l) (Set (lsuc l))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.DiffInt.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Univalence
open import Cubical.Data.DiffInt.Base
open import Cubical.Data.Nat as ℕ using (suc; zero; isSetℕ; discreteℕ; ℕ) renaming (_+_ to _+ⁿ_; _·_ to _·ⁿ_)
open import Cubical.Data.Sigma
open import Cubical.Data.Bool

open import Cubical.Data.Int as Int using (Int; sucInt)
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism

open import Cubical.Relation.Binary.Base
open import Cubical.Relation.Nullary

open import Cubical.HITs.SetQuotients

open BinaryRelation

relIsEquiv : isEquivRel rel
relIsEquiv = equivRel {A = ℕ × ℕ} relIsRefl relIsSym relIsTrans
  where
    open import Cubical.Data.Nat
    relIsRefl : isRefl rel
    relIsRefl (a0 , a1) = refl

    relIsSym : isSym rel
    relIsSym (a0 , a1) (b0 , b1) p = sym p

    relIsTrans : isTrans rel
    relIsTrans (a0 , a1) (b0 , b1) (c0 , c1) p0 p1 =
      inj-m+ {m = (b0 + b1)} ((b0 + b1) + (a0 + c1) ≡⟨ +-assoc (b0 + b1) a0 c1  ⟩
            ((b0 + b1) + a0) + c1 ≡[ i ]⟨ +-comm b0 b1 i + a0   + c1 ⟩
            ((b1 + b0) + a0) + c1 ≡[ i ]⟨ +-comm (b1 + b0) a0 i + c1 ⟩
            (a0 + (b1 + b0)) + c1 ≡[ i ]⟨ +-assoc a0 b1 b0 i    + c1 ⟩
            (a0 + b1) + b0 + c1 ≡⟨ sym (+-assoc (a0 + b1) b0 c1) ⟩
            (a0 + b1) + (b0 + c1) ≡⟨ cong (λ p → p . fst + p .snd) (transport ΣPath≡PathΣ (p0 , p1))⟩
            (b0 + a1) + (c0 + b1) ≡⟨ sym (+-assoc b0 a1 (c0 + b1))⟩
            b0 + (a1 + (c0 + b1)) ≡[ i ]⟨ b0 + (a1 + +-comm c0 b1 i) ⟩
            b0 + (a1 + (b1 + c0)) ≡[ i ]⟨ b0 + +-comm a1 (b1 + c0) i ⟩
            b0 + ((b1 + c0) + a1) ≡[ i ]⟨ b0 + +-assoc b1 c0 a1 (~ i) ⟩
            b0 + (b1 + (c0 + a1)) ≡⟨ +-assoc b0 b1 (c0 + a1)⟩
            (b0 + b1) + (c0 + a1) ∎ )

relIsProp : BinaryRelation.isPropValued rel
relIsProp a b x y = isSetℕ _ _ _ _

discreteℤ : Discrete ℤ
discreteℤ = discreteSetQuotients (discreteΣ discreteℕ λ _ → discreteℕ) relIsProp relIsEquiv (λ _ _ → discreteℕ _ _)

isSetℤ : isSet ℤ
isSetℤ = Discrete→isSet discreteℤ

sucℤ' : ℕ × ℕ -> ℤ
sucℤ' (a⁺ , a⁻) = [ suc a⁺ , a⁻ ]

sucℤ'-respects-rel : (a b : ℕ × ℕ) → rel a b → sucℤ' a ≡ sucℤ' b
sucℤ'-respects-rel a@(a⁺ , a⁻) b@(b⁺ , b⁻) a~b = eq/ (suc a⁺ , a⁻) (suc b⁺ , b⁻) λ i → suc (a~b i)

sucℤ : ℤ -> ℤ
sucℤ = elim {R = rel} {B = λ _ → ℤ} (λ _ → isSetℤ) sucℤ' sucℤ'-respects-rel

predℤ' : ℕ × ℕ -> ℤ
predℤ' (a⁺ , a⁻) = [ a⁺ , suc a⁻ ]

⟦_⟧ : Int -> ℤ
⟦_⟧ (Int.pos n) = [ n , 0 ]
⟦_⟧ (Int.negsuc n) = [ 0 , suc n ]

fwd = ⟦_⟧

bwd' : ℕ × ℕ -> Int
bwd' (zero   , a⁻) = Int.neg a⁻
bwd' (suc a⁺ , a⁻) = sucInt (bwd' (a⁺ , a⁻))

rel-suc : ∀ a⁺ a⁻ → rel (a⁺ , a⁻) (suc a⁺ , suc a⁻)
rel-suc a⁺ a⁻ = ℕ.+-suc a⁺ a⁻

bwd'-suc : ∀ a⁺ a⁻ → bwd' (a⁺ , a⁻) ≡ bwd' (suc a⁺ , suc a⁻)
bwd'-suc zero zero = refl
bwd'-suc zero (suc a⁻) = refl
bwd'-suc (suc a⁺) a⁻ i = sucInt (bwd'-suc a⁺ a⁻ i)

bwd'+ : ∀ m n → bwd' (m , m +ⁿ n) ≡ bwd' (0 , n)
bwd'+ zero n = refl
bwd'+ (suc m) n = sym (bwd'-suc m (m +ⁿ n)) ∙ bwd'+ m n

bwd'-respects-rel : (a b : ℕ × ℕ) → rel a b → bwd' a ≡ bwd' b
bwd'-respects-rel (zero   , a⁻) (    b⁺ , b⁻) a~b = sym (bwd'+ b⁺ a⁻) ∙ (λ i → bwd' (b⁺ , a~b (~ i)))
bwd'-respects-rel (suc a⁺ , a⁻) (zero   , b⁻) a~b = (λ i → bwd' (suc a⁺ , a~b (~ i))) ∙ sym (bwd'-suc a⁺ (a⁺ +ⁿ b⁻)) ∙ bwd'+ a⁺ b⁻
bwd'-respects-rel (suc a⁺ , a⁻) (suc b⁺ , b⁻) a~b i = sucInt (bwd'-respects-rel (a⁺ , a⁻) (b⁺ , b⁻) (ℕ.inj-m+ {1} {a⁺ +ⁿ b⁻} {b⁺ +ⁿ a⁻} a~b) i)

bwd : ℤ -> Int
bwd = elim {R = rel} {B = λ _ → Int} (λ _ → Int.isSetInt) bwd' bwd'-respects-rel

bwd-fwd : ∀ (x : Int) -> bwd (fwd x) ≡ x
bwd-fwd (Int.pos zero) = refl
bwd-fwd (Int.pos (suc n)) i = sucInt (bwd-fwd (Int.pos n) i)
bwd-fwd (Int.negsuc n) = refl

suc-⟦⟧ : ∀ x → sucℤ ⟦ x ⟧ ≡ ⟦ sucInt x ⟧
suc-⟦⟧ (Int.pos n) = refl
suc-⟦⟧ (Int.negsuc zero) = eq/ {R = rel} (1 , 1) (0 , 0) refl
suc-⟦⟧ (Int.negsuc (suc n)) = eq/ {R = rel} (1 , 2 +ⁿ n) (0 , 1 +ⁿ n) refl

fwd-bwd' : (a : ℕ × ℕ) → fwd (bwd [ a ]) ≡ [ a ]
fwd-bwd' a@(zero , zero) = refl
fwd-bwd' a@(zero , suc a⁻) = refl
fwd-bwd' a@(suc a⁺ , a⁻) = sym (suc-⟦⟧ (bwd [ a⁺ , a⁻ ])) ∙ (λ i → sucℤ (fwd-bwd' (a⁺ , a⁻) i))

fwd-bwd : ∀ (z : ℤ) -> fwd (bwd z) ≡ z
fwd-bwd = elimProp {R = rel} (λ _  → isSetℤ _ _) fwd-bwd'

Int≡ℤ : Int ≡ ℤ
Int≡ℤ = isoToPath (iso fwd bwd fwd-bwd bwd-fwd)

infix  8 -_
infixl 7 _·_
infixl 6 _+_

_+'_ : (a b : ℕ × ℕ) → ℤ
(a⁺ , a⁻) +' (b⁺ , b⁻) = [ a⁺ +ⁿ b⁺ , a⁻ +ⁿ b⁻ ]

private
  commˡⁿ : ∀ a b c → a +ⁿ b +ⁿ c ≡ a +ⁿ c +ⁿ b
  commˡⁿ a b c = sym (ℕ.+-assoc a b c) ∙ (λ i → a +ⁿ ℕ.+-comm b c i) ∙ ℕ.+-assoc a c b

  lem0 : ∀ a b c d → (a +ⁿ b) +ⁿ (c +ⁿ d) ≡ (a +ⁿ c) +ⁿ (b +ⁿ d)
  lem0 a b c d = ℕ.+-assoc (a +ⁿ b) c d ∙ (λ i → commˡⁿ a b c i +ⁿ d) ∙ sym (ℕ.+-assoc (a +ⁿ c) b d)

+ⁿ-creates-rel-≡ : ∀ a⁺ a⁻ x → _≡_ {A = ℤ} [ a⁺ , a⁻ ] [ a⁺ +ⁿ x , a⁻ +ⁿ x ]
+ⁿ-creates-rel-≡ a⁺ a⁻ x = eq/ (a⁺ , a⁻) (a⁺ +ⁿ x , a⁻ +ⁿ x) ((λ i → a⁺ +ⁿ ℕ.+-comm a⁻ x i) ∙ ℕ.+-assoc a⁺ x a⁻)

+-respects-relʳ : (a b c : ℕ × ℕ) → rel a b → (a +' c) ≡ (b +' c)
+-respects-relʳ a@(a⁺ , a⁻) b@(b⁺ , b⁻) c@(c⁺ , c⁻) p = eq/ {R = rel} (a⁺ +ⁿ c⁺ , a⁻ +ⁿ c⁻) (b⁺ +ⁿ c⁺ , b⁻ +ⁿ c⁻) (
  (a⁺ +ⁿ c⁺) +ⁿ (b⁻ +ⁿ c⁻) ≡⟨ lem0 a⁺ c⁺ b⁻ c⁻ ⟩
  (a⁺ +ⁿ b⁻) +ⁿ (c⁺ +ⁿ c⁻) ≡[ i ]⟨ p i +ⁿ (c⁺ +ⁿ c⁻) ⟩
  (b⁺ +ⁿ a⁻) +ⁿ (c⁺ +ⁿ c⁻) ≡⟨ sym (lem0 b⁺ c⁺ a⁻ c⁻) ⟩
  (b⁺ +ⁿ c⁺) +ⁿ (a⁻ +ⁿ c⁻) ∎)

+-respects-relˡ : (a b c : ℕ × ℕ) → rel b c → (a +' b) ≡ (a +' c)
+-respects-relˡ a@(a⁺ , a⁻) b@(b⁺ , b⁻) c@(c⁺ , c⁻) p = eq/ {R = rel} (a⁺ +ⁿ b⁺ , a⁻ +ⁿ b⁻) (a⁺ +ⁿ c⁺ , a⁻ +ⁿ c⁻) (
  (a⁺ +ⁿ b⁺) +ⁿ (a⁻ +ⁿ c⁻) ≡⟨ lem0 a⁺ b⁺ a⁻ c⁻ ⟩
  (a⁺ +ⁿ a⁻) +ⁿ (b⁺ +ⁿ c⁻) ≡[ i ]⟨ (a⁺ +ⁿ a⁻) +ⁿ p i ⟩
  (a⁺ +ⁿ a⁻) +ⁿ (c⁺ +ⁿ b⁻) ≡⟨ sym (lem0 a⁺ c⁺ a⁻ b⁻) ⟩
  (a⁺ +ⁿ c⁺) +ⁿ (a⁻ +ⁿ b⁻) ∎)

_+''_ : ℤ → ℤ → ℤ
_+''_ = rec2 {R = rel} {B = ℤ} φ _+'_ +-respects-relʳ +-respects-relˡ
  where abstract φ = isSetℤ

-- normalization of isSetℤ explodes. Therefore we wrap this with expanded cases
_+_ : ℤ → ℤ → ℤ
x@([ _ ])               + y@([ _ ])               = x +'' y
x@([ _ ])               + y@(eq/ _ _ _ _)         = x +'' y
x@(eq/ _ _ _ _)         + y@([ _ ])               = x +'' y
x@(eq/ _ _ _ _)         + y@(eq/ _ _ _ _)         = x +'' y
x@(eq/ _ _ _ _)         + y@(squash/ a b p q i j) = isSetℤ _ _ (cong (x +_) p) (cong (x +_) q) i j
x@([ _ ])               + y@(squash/ a b p q i j) = isSetℤ _ _ (cong (x +_) p) (cong (x +_) q) i j
x@(squash/ a b p q i j) + y                       = isSetℤ _ _ (cong (_+ y) p) (cong (_+ y) q) i j

-'_ : ℕ × ℕ → ℤ
-' (a⁺ , a⁻) = [ a⁻ , a⁺ ]

neg-respects-rel'-≡ : (a b : ℕ × ℕ) → rel a b → (-' a) ≡ (-' b)
neg-respects-rel'-≡ a@(a⁺ , a⁻) b@(b⁺ , b⁻) p = eq/ {R = rel} (a⁻ , a⁺) (b⁻ , b⁺) (ℕ.+-comm a⁻ b⁺ ∙ sym p ∙ ℕ.+-comm a⁺ b⁻)

-_ : ℤ → ℤ
-_ = rec {R = rel} {B = ℤ} isSetℤ -'_ neg-respects-rel'-≡

_·'_ : (a b : ℕ × ℕ) → ℤ
(a⁺ , a⁻) ·' (b⁺ , b⁻) = [ a⁺ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ b⁻ , a⁺ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ b⁺ ]

private
  lem1 : ∀ a b c d → (a +ⁿ b) +ⁿ (c +ⁿ d) ≡ (a +ⁿ d) +ⁿ (b +ⁿ c)
  lem1 a b c d = (λ i → (a +ⁿ b) +ⁿ ℕ.+-comm c d i) ∙ ℕ.+-assoc (a +ⁿ b) d c ∙ (λ i → commˡⁿ a b d i +ⁿ c) ∙ sym (ℕ.+-assoc (a +ⁿ d) b c)

·-respects-relʳ : (a b c : ℕ × ℕ) → rel a b → (a ·' c) ≡ (b ·' c)
·-respects-relʳ a@(a⁺ , a⁻) b@(b⁺ , b⁻) c@(c⁺ , c⁻) p = eq/ {R = rel} (a⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ c⁻ , a⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ c⁺) (b⁺ ·ⁿ c⁺ +ⁿ b⁻ ·ⁿ c⁻ , b⁺ ·ⁿ c⁻ +ⁿ b⁻ ·ⁿ c⁺) (
  (a⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ c⁻) +ⁿ (b⁺ ·ⁿ c⁻ +ⁿ b⁻ ·ⁿ c⁺) ≡⟨ lem1 (a⁺ ·ⁿ c⁺) (a⁻ ·ⁿ c⁻) (b⁺ ·ⁿ c⁻) (b⁻ ·ⁿ c⁺) ⟩
  (a⁺ ·ⁿ c⁺ +ⁿ b⁻ ·ⁿ c⁺) +ⁿ (a⁻ ·ⁿ c⁻ +ⁿ b⁺ ·ⁿ c⁻) ≡[ i ]⟨ ℕ.·-distribʳ a⁺ b⁻ c⁺ i +ⁿ ℕ.·-distribʳ a⁻ b⁺ c⁻ i ⟩
  ((a⁺ +ⁿ b⁻) ·ⁿ c⁺) +ⁿ ((a⁻ +ⁿ b⁺) ·ⁿ c⁻)         ≡[ i ]⟨ p i ·ⁿ c⁺ +ⁿ (ℕ.+-comm a⁻ b⁺ ∙ sym p ∙ ℕ.+-comm a⁺ b⁻) i ·ⁿ c⁻ ⟩
  ((b⁺ +ⁿ a⁻) ·ⁿ c⁺) +ⁿ ((b⁻ +ⁿ a⁺) ·ⁿ c⁻)         ≡[ i ]⟨ ℕ.·-distribʳ b⁺ a⁻ c⁺ (~ i) +ⁿ ℕ.·-distribʳ b⁻ a⁺ c⁻ (~ i) ⟩
  (b⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ c⁺) +ⁿ (b⁻ ·ⁿ c⁻ +ⁿ a⁺ ·ⁿ c⁻) ≡⟨ sym (lem1 (b⁺ ·ⁿ c⁺) (b⁻ ·ⁿ c⁻) (a⁺ ·ⁿ c⁻) (a⁻ ·ⁿ c⁺)) ⟩
  (b⁺ ·ⁿ c⁺ +ⁿ b⁻ ·ⁿ c⁻) +ⁿ (a⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ c⁺) ∎)

·-respects-relˡ : (a b c : ℕ × ℕ) → rel b c → (a ·' b) ≡ (a ·' c)
·-respects-relˡ a@(a⁺ , a⁻) b@(b⁺ , b⁻) c@(c⁺ , c⁻) p = eq/ {R = rel} (a⁺ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ b⁻ , a⁺ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ b⁺) (a⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ c⁻ , a⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ c⁺) (
  (a⁺ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ b⁻) +ⁿ (a⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ c⁺) ≡⟨ lem0 (a⁺ ·ⁿ b⁺) (a⁻ ·ⁿ b⁻) (a⁺ ·ⁿ c⁻) (a⁻ ·ⁿ c⁺) ⟩
  (a⁺ ·ⁿ b⁺ +ⁿ a⁺ ·ⁿ c⁻) +ⁿ (a⁻ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ c⁺) ≡[ i ]⟨ ℕ.·-distribˡ a⁺ b⁺ c⁻ i +ⁿ ℕ.·-distribˡ a⁻ b⁻ c⁺ i ⟩
  (a⁺ ·ⁿ (b⁺ +ⁿ c⁻)) +ⁿ (a⁻ ·ⁿ (b⁻ +ⁿ c⁺))         ≡[ i ]⟨ a⁺ ·ⁿ p i +ⁿ a⁻ ·ⁿ (ℕ.+-comm b⁻ c⁺ ∙ sym p ∙ ℕ.+-comm b⁺ c⁻) i ⟩
  (a⁺ ·ⁿ (c⁺ +ⁿ b⁻)) +ⁿ (a⁻ ·ⁿ (c⁻ +ⁿ b⁺))         ≡[ i ]⟨ ℕ.·-distribˡ a⁺ c⁺ b⁻ (~ i) +ⁿ ℕ.·-distribˡ a⁻ c⁻ b⁺ (~ i) ⟩
  (a⁺ ·ⁿ c⁺ +ⁿ a⁺ ·ⁿ b⁻) +ⁿ (a⁻ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ b⁺) ≡⟨ sym (lem0 (a⁺ ·ⁿ c⁺) (a⁻ ·ⁿ c⁻) (a⁺ ·ⁿ b⁻) (a⁻ ·ⁿ b⁺)) ⟩
  (a⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ c⁻) +ⁿ (a⁺ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ b⁺) ∎)

_·''_ : ℤ → ℤ → ℤ
_·''_ = rec2 {R = rel} {B = ℤ} isSetℤ _·'_ ·-respects-relʳ ·-respects-relˡ

-- normalization of isSetℤ explodes. Therefore we wrap this with expanded cases
_·_ : ℤ → ℤ → ℤ
x@([ _ ])               · y@([ _ ])               = x ·'' y
x@([ _ ])               · y@(eq/ _ _ _ _)         = x ·'' y
x@(eq/ _ _ _ _)         · y@([ _ ])               = x ·'' y
x@(eq/ _ _ _ _)         · y@(eq/ _ _ _ _)         = x ·'' y
x@(eq/ _ _ _ _)         · y@(squash/ a b p q i j) = isSetℤ _ _ (cong (x ·_) p) (cong (x ·_) q) i j
x@([ _ ])               · y@(squash/ a b p q i j) = isSetℤ _ _ (cong (x ·_) p) (cong (x ·_) q) i j
x@(squash/ a b p q i j) · y                       = isSetℤ _ _ (cong (_· y) p) (cong (_· y) q) i j

+-identityʳ : (x : ℤ) → x + 0 ≡ x
+-identityʳ = elimProp {R = rel} (λ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) i → [ ℕ.+-comm a⁺ 0 i , ℕ.+-comm a⁻ 0 i ] }

+-comm : (x y : ℤ) → x + y ≡ y + x
+-comm = elimProp2 {R = rel} (λ _ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) (b⁺ , b⁻) i → [ ℕ.+-comm a⁺ b⁺ i , ℕ.+-comm a⁻ b⁻ i ] }

+-inverseʳ : (x : ℤ) → x + (- x) ≡ 0
+-inverseʳ = elimProp {R = rel} (λ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) → eq/ {R = rel} (a⁺ +ⁿ a⁻ , a⁻ +ⁿ a⁺) (0 , 0) (ℕ.+-zero (a⁺ +ⁿ a⁻) ∙ ℕ.+-comm a⁺ a⁻) }

+-assoc : (x y z : ℤ) → x + (y + z) ≡ x + y + z
+-assoc = elimProp3 {R = rel} (λ _ _ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) (b⁺ , b⁻) (c⁺ , c⁻) i → [ ℕ.+-assoc a⁺ b⁺ c⁺ i , ℕ.+-assoc a⁻ b⁻ c⁻ i ] }

·-identityʳ : (x : ℤ) → x · 1 ≡ x
·-identityʳ = elimProp {R = rel} (λ _ → isSetℤ _ _) γ
  where
  γ : (a : ℕ × ℕ) → _
  γ (a⁺ , a⁻) i = [ p i , q i ]
    where
    p : a⁺ ·ⁿ 1 +ⁿ a⁻ ·ⁿ 0 ≡ a⁺
    p i = ℕ.+-comm (ℕ.·-identityʳ a⁺ i) (ℕ.0≡m·0 a⁻ (~ i)) i
    q : a⁺ ·ⁿ 0 +ⁿ a⁻ ·ⁿ 1 ≡ a⁻
    q i = ℕ.0≡m·0 a⁺ (~ i) +ⁿ ℕ.·-identityʳ a⁻ i

·-comm : (x y : ℤ) → x · y ≡ y · x
·-comm = elimProp2 {R = rel} (λ _ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) (b⁺ , b⁻) i → [ ℕ.·-comm a⁺ b⁺ i +ⁿ ℕ.·-comm a⁻ b⁻ i , ℕ.+-comm (ℕ.·-comm a⁺ b⁻ i) (ℕ.·-comm a⁻ b⁺ i) i ] }

·-distribˡ : (x y z : ℤ) → x · (y + z) ≡ x · y + x · z
·-distribˡ = elimProp3 {R = rel} (λ _ _ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) (b⁺ , b⁻) (c⁺ , c⁻) →
    [ a⁺ ·ⁿ (b⁺ +ⁿ c⁺) +ⁿ a⁻ ·ⁿ (b⁻ +ⁿ c⁻)
    , a⁺ ·ⁿ (b⁻ +ⁿ c⁻) +ⁿ a⁻ ·ⁿ (b⁺ +ⁿ c⁺)
    ] ≡[ i ]⟨ [ ℕ.·-distribˡ a⁺ b⁺ c⁺ (~ i) +ⁿ ℕ.·-distribˡ a⁻ b⁻ c⁻ (~ i) , ℕ.·-distribˡ a⁺ b⁻ c⁻ (~ i) +ⁿ ℕ.·-distribˡ a⁻ b⁺ c⁺ (~ i) ] ⟩
    [ (a⁺ ·ⁿ b⁺ +ⁿ a⁺ ·ⁿ c⁺) +ⁿ (a⁻ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ c⁻)
    , (a⁺ ·ⁿ b⁻ +ⁿ a⁺ ·ⁿ c⁻) +ⁿ (a⁻ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ c⁺)
    ] ≡[ i ]⟨ [ lem0 (a⁺ ·ⁿ b⁺) (a⁻ ·ⁿ b⁻) (a⁺ ·ⁿ c⁺) (a⁻ ·ⁿ c⁻) (~ i), lem0 (a⁺ ·ⁿ b⁻) (a⁺ ·ⁿ c⁻) (a⁻ ·ⁿ b⁺) (a⁻ ·ⁿ c⁺) i ] ⟩
    [ a⁺ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ b⁻ +ⁿ (a⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ c⁻)
    , a⁺ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ b⁺ +ⁿ (a⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ c⁺)
    ] ∎
   }

·-assoc : (x y z : ℤ) → x · (y · z) ≡ x · y · z
·-assoc = elimProp3 {R = rel} (λ _ _ _ → isSetℤ _ _)
  λ{ (a⁺ , a⁻) (b⁺ , b⁻) (c⁺ , c⁻) →
    [ a⁺ ·ⁿ (b⁺ ·ⁿ c⁺ +ⁿ b⁻ ·ⁿ c⁻) +ⁿ a⁻ ·ⁿ (b⁺ ·ⁿ c⁻ +ⁿ b⁻ ·ⁿ c⁺)
    , a⁺ ·ⁿ (b⁺ ·ⁿ c⁻ +ⁿ b⁻ ·ⁿ c⁺) +ⁿ a⁻ ·ⁿ (b⁺ ·ⁿ c⁺ +ⁿ b⁻ ·ⁿ c⁻)
    ] ≡[ i ]⟨ [ ℕ.·-distribˡ a⁺ (b⁺ ·ⁿ c⁺) (b⁻ ·ⁿ c⁻) (~ i) +ⁿ ℕ.·-distribˡ a⁻ (b⁺ ·ⁿ c⁻) (b⁻ ·ⁿ c⁺) (~ i)
              , ℕ.·-distribˡ a⁺ (b⁺ ·ⁿ c⁻) (b⁻ ·ⁿ c⁺) (~ i) +ⁿ ℕ.·-distribˡ a⁻ (b⁺ ·ⁿ c⁺) (b⁻ ·ⁿ c⁻) (~ i) ] ⟩
    [ (a⁺ ·ⁿ (b⁺ ·ⁿ c⁺) +ⁿ a⁺ ·ⁿ (b⁻ ·ⁿ c⁻)) +ⁿ (a⁻ ·ⁿ (b⁺ ·ⁿ c⁻) +ⁿ a⁻ ·ⁿ (b⁻ ·ⁿ c⁺))
    , (a⁺ ·ⁿ (b⁺ ·ⁿ c⁻) +ⁿ a⁺ ·ⁿ (b⁻ ·ⁿ c⁺)) +ⁿ (a⁻ ·ⁿ (b⁺ ·ⁿ c⁺) +ⁿ a⁻ ·ⁿ (b⁻ ·ⁿ c⁻))
    ] ≡[ i ]⟨ [ (ℕ.·-assoc a⁺ b⁺ c⁺ i +ⁿ ℕ.·-assoc a⁺ b⁻ c⁻ i) +ⁿ (ℕ.·-assoc a⁻ b⁺ c⁻ i +ⁿ ℕ.·-assoc a⁻ b⁻ c⁺ i)
              , (ℕ.·-assoc a⁺ b⁺ c⁻ i +ⁿ ℕ.·-assoc a⁺ b⁻ c⁺ i) +ⁿ (ℕ.·-assoc a⁻ b⁺ c⁺ i +ⁿ ℕ.·-assoc a⁻ b⁻ c⁻ i) ] ⟩
    [ (a⁺ ·ⁿ b⁺ ·ⁿ c⁺ +ⁿ a⁺ ·ⁿ b⁻ ·ⁿ c⁻) +ⁿ (a⁻ ·ⁿ b⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ b⁻ ·ⁿ c⁺)
    , (a⁺ ·ⁿ b⁺ ·ⁿ c⁻ +ⁿ a⁺ ·ⁿ b⁻ ·ⁿ c⁺) +ⁿ (a⁻ ·ⁿ b⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ b⁻ ·ⁿ c⁻)
    ] ≡[ i ]⟨ [ lem1 (a⁺ ·ⁿ b⁺ ·ⁿ c⁺) (a⁺ ·ⁿ b⁻ ·ⁿ c⁻) (a⁻ ·ⁿ b⁺ ·ⁿ c⁻) (a⁻ ·ⁿ b⁻ ·ⁿ c⁺) i
              , lem1 (a⁺ ·ⁿ b⁺ ·ⁿ c⁻) (a⁺ ·ⁿ b⁻ ·ⁿ c⁺) (a⁻ ·ⁿ b⁺ ·ⁿ c⁺) (a⁻ ·ⁿ b⁻ ·ⁿ c⁻) i ] ⟩
    [ (a⁺ ·ⁿ b⁺ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ b⁻ ·ⁿ c⁺) +ⁿ (a⁺ ·ⁿ b⁻ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ b⁺ ·ⁿ c⁻)
    , (a⁺ ·ⁿ b⁺ ·ⁿ c⁻ +ⁿ a⁻ ·ⁿ b⁻ ·ⁿ c⁻) +ⁿ (a⁺ ·ⁿ b⁻ ·ⁿ c⁺ +ⁿ a⁻ ·ⁿ b⁺ ·ⁿ c⁺)
    ] ≡[ i ]⟨ [ ℕ.·-distribʳ (a⁺ ·ⁿ b⁺) (a⁻ ·ⁿ b⁻) c⁺ i +ⁿ ℕ.·-distribʳ (a⁺ ·ⁿ b⁻) (a⁻ ·ⁿ b⁺) c⁻ i
              , ℕ.·-distribʳ (a⁺ ·ⁿ b⁺) (a⁻ ·ⁿ b⁻) c⁻ i +ⁿ ℕ.·-distribʳ (a⁺ ·ⁿ b⁻) (a⁻ ·ⁿ b⁺) c⁺ i ] ⟩
    [ (a⁺ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ b⁻) ·ⁿ c⁺ +ⁿ (a⁺ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ b⁺) ·ⁿ c⁻
    , (a⁺ ·ⁿ b⁺ +ⁿ a⁻ ·ⁿ b⁻) ·ⁿ c⁻ +ⁿ (a⁺ ·ⁿ b⁻ +ⁿ a⁻ ·ⁿ b⁺) ·ⁿ c⁺
    ] ∎
   }

private
  _ : Dec→Bool (discreteℤ [ (3 , 5) ] [ (4 , 6) ]) ≡ true
  _ = refl

  _ : Dec→Bool (discreteℤ [ (3 , 5) ] [ (4 , 7) ]) ≡ false
  _ = refl


module x08-747Quantifiers-hc where

-- Library

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; sym)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _≤_; z≤n; s≤s) -- added ≤
-- open import Data.Nat.Properties using (≤-refl)
open import Relation.Nullary using (¬_)
open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩) -- added proj₂
open import Data.Sum using (_⊎_; inj₁; inj₂ ) -- added inj₁, inj₂
open import Function using (_∘_) -- added

-- BEGIN: Copied from 747Isomorphism.
postulate
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

infix 0 _≃_
record _≃_ (A B : Set) : Set where
  constructor mk-≃
  field
    to   : A → B
    from : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y
open _≃_

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
open _⇔_
-- END: Copied from 747Isomorphism.

-- Logical forall is ∀.
-- Forall elimination is function application.
∀-elim : ∀ {A : Set} {B : A → Set}
  → (L : ∀ (x : A) → B x)
  → (M : A)
    -----------------
  → B M
∀-elim L M = L M

-- A → B is nicer syntax for ∀ (_ : A) → B.

-- 747/PLFA exercise: ForAllDistProd (1 point)
-- ∀ distributes over ×
-- (note: → distributes over × was shown in Connectives)

∀-distrib-× : ∀ {A : Set} {B C : A → Set} →
  (∀ (a : A) → B a × C a) ≃ (∀ (a : A) → B a) × (∀ (a : A) → C a)
to      ∀-distrib-× a→Ba×Ca         = ⟨ proj₁ ∘ a→Ba×Ca , proj₂ ∘ a→Ba×Ca ⟩
from    ∀-distrib-× ⟨ a→ba , a→ca ⟩ = λ a → ⟨ a→ba a , a→ca a ⟩
from∘to ∀-distrib-× a→Ba×Ca         = refl
to∘from ∀-distrib-× ⟨ a→ba , a→ca ⟩ = refl

-- 747/PLFA exercise: SumForAllImpForAllSum (1 point)
-- disjunction of foralls implies a forall of disjunctions
⊎∀-implies-∀⊎ : ∀ {A : Set} {B C : A → Set} →
  (∀ (a : A) → B a) ⊎ (∀ (a : A) → C a)  →  ∀ (a : A) → B a ⊎ C a
⊎∀-implies-∀⊎ (inj₁ a→ba) = inj₁ ∘ a→ba
⊎∀-implies-∀⊎ (inj₂ a→ca) = inj₂ ∘ a→ca

-- Existential quantification
-- a pair:
-- - a witness and
-- - a proof that the witness satisfies the property
data Σ (A : Set) (B : A → Set) : Set where
  ⟨_,_⟩ : (a : A) → B a → Σ A B

-- convenient syntax

Σ-syntax = Σ
infix 2 Σ-syntax
syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

-- can use the RHS syntax in code,
-- but LHS will show up in displays of goal and context.
-- This syntax is equivalent to defining a dependent record type.

record Σ′ (A : Set) (B : A → Set) : Set where
  field
    proj₁′ : A
    proj₂′ : B proj₁′

-- convention : library uses ∃ when domain of bound variable is implicit

∃ : ∀ {A : Set} (B : A → Set) → Set
∃ {A} B = Σ A B

-- syntax

∃-syntax = ∃
syntax ∃-syntax (λ x → B) = ∃[ x ] B

-- eliminate existential with a function
-- that consumes the witness and proof
-- and reaches a conclusion C
∃-elim : ∀ {A : Set} {B : A → Set} {C : Set}
  → (∀ a → B a → C)
  → ∃[ a ] B a
    ---------------
  → C
∃-elim a→Ba→C ⟨ a , Ba ⟩ = a→Ba→C a Ba

-- generalization of currying (from Connectives)
-- currying : ∀ {A B C : Set} → (A → B → C) ≃ (A × B → C)
∀∃-currying : ∀ {A : Set} {B : A → Set} {C : Set}
  → (∀ a → B a → C) ≃ (∃[ a ] B a → C)
_≃_.to      ∀∃-currying a→Ba→C ⟨ a , Ba ⟩ = a→Ba→C a Ba
_≃_.from    ∀∃-currying ∃xB a Ba          = ∃xB ⟨ a , Ba ⟩
_≃_.from∘to ∀∃-currying a→Ba→C            = refl
_≃_.to∘from ∀∃-currying ∃xB               = extensionality λ { ⟨ a , Ba ⟩ → refl}

-- 747/PLFA exercise: ExistsDistSum (2 points)
-- existentials distribute over disjunction
∃-distrib-⊎ : ∀ {A : Set} {B C : A → Set} →
  ∃[ a ] (B a ⊎ C a) ≃ (∃[ a ] B a) ⊎ (∃[ a ] C a)
to      ∃-distrib-⊎       ⟨ a , inj₁ Ba ⟩  = inj₁ ⟨ a ,      Ba ⟩
to      ∃-distrib-⊎       ⟨ a , inj₂ Ca ⟩  = inj₂ ⟨ a ,      Ca ⟩
from    ∃-distrib-⊎ (inj₁ ⟨ a ,      Ba ⟩) =      ⟨ a , inj₁ Ba ⟩
from    ∃-distrib-⊎ (inj₂ ⟨ a ,      Ca ⟩) =      ⟨ a , inj₂ Ca ⟩
from∘to ∃-distrib-⊎       ⟨ a , inj₁ Ba ⟩  = refl
from∘to ∃-distrib-⊎       ⟨ a , inj₂ Ca ⟩  = refl
to∘from ∃-distrib-⊎ (inj₁ ⟨ a ,      Ba ⟩) = refl
to∘from ∃-distrib-⊎ (inj₂ ⟨ a ,      Ca ⟩) = refl

-- 747/PLFA exercise: ExistsProdImpProdExists (1 point)
-- existentials distribute over ×
∃×-implies-×∃ : ∀ {A : Set} {B C : A → Set} →
  ∃[ a ] (B a × C a) → (∃[ a ] B a) × (∃[ a ] C a)
∃×-implies-×∃ ⟨ a , ⟨ Ba , Ca ⟩ ⟩ = ⟨ ⟨ a , Ba ⟩ , ⟨ a , Ca ⟩ ⟩

-- existential example: revisiting even/odd.
-- mutually-recursive definitions of even and odd.
data even : ℕ → Set
data odd  : ℕ → Set

data even where

  even-zero : even zero

  even-suc : ∀ {n : ℕ}
    → odd n
      ------------
    → even (suc n)

data odd where
  odd-suc : ∀ {n : ℕ}
    → even n
      -----------
    → odd (suc n)

-- number is even iff it is          double some other number
even-∃ : ∀ {n : ℕ} → even n → ∃[ m ] (    m * 2 ≡ n)
-- number is odd  iff it is one plus double some other number
odd-∃  : ∀ {n : ℕ} →  odd n → ∃[ m ] (1 + m * 2 ≡ n)

even-∃  even-zero = ⟨ zero , refl ⟩
even-∃ (even-suc odd-suc-x*2)
    with odd-∃ odd-suc-x*2
... | ⟨ x , refl ⟩ = ⟨ suc x , refl ⟩
odd-∃  (odd-suc  even-x*2)
    with even-∃ even-x*2
... | ⟨ x , refl ⟩ = ⟨     x , refl ⟩

∃-even : ∀ {n : ℕ} → ∃[ m ] (    m * 2 ≡ n) → even n
∃-odd  : ∀ {n : ℕ} → ∃[ m ] (1 + m * 2 ≡ n) →  odd n

∃-even ⟨ zero  , refl ⟩ = even-zero
∃-even ⟨ suc x , refl ⟩ = even-suc (∃-odd  ⟨ x , refl ⟩)
∃-odd  ⟨     x , refl ⟩ = odd-suc  (∃-even ⟨ x , refl ⟩)

-- PLFA exercise: what if we write the arithmetic more "naturally"?
-- (Proof gets harder but is still doable).

-- 747/PLFA exercise: AltLE (3 points)
-- alternate definition of y ≤ z
-- (Optional exercise: Is this an isomorphism?)
+0 : ∀ (m : ℕ) → m + zero ≡ m
+0  zero   = refl
+0 (suc m) = cong suc (+0 m)

open import x03-842Relations-hc-2 using (s≤s)

xxx : ∀ {m n : ℕ} → m ≤ n → suc (m + zero) ≤ suc n
xxx {m} {n} p rewrite +0 m = s≤s p

≤-refl : ∀ {n : ℕ}
    -----
  → n ≤ n
≤-refl {zero}  = z≤n
≤-refl {suc n} = s≤s (≤-refl {n})

+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc  zero   n = refl
+-suc (suc m) n = cong suc (+-suc m n)

aaa : ∀ {x y z : ℕ} → y + suc x ≡ z → y ≤ y + suc x
--aaa {x} {y} y+sucx≡z rewrite sym y+sucx≡z {- | +-suc y x -} = {!!}
aaa {zero}  {zero}  refl = z≤n
aaa {suc x} {zero}  refl = z≤n
aaa {zero}  {suc y} refl = s≤s {!!}
aaa {suc x} {suc y} refl = s≤s {!!}

zzz : ∀ {y z : ℕ} → y + zero ≡ z → y ≤ z
zzz {y} y+x≡z rewrite +0 y | y+x≡z | sym y+x≡z = ≤-refl {y}

∃-≤ : ∀ {y z : ℕ} → ( (y ≤ z) ⇔ ( ∃[ x ] (y + x ≡ z) ) )
{-
∃-≤ {y} {z} = record { to = λ { z≤n → ⟨ zero , {!!} ⟩ ; (s≤s y≤z) → {!!} }; from = {!!} }
-}
to   ∃-≤           z≤n        = ⟨          zero  , {!!} ⟩
to   ∃-≤      (s≤s z≤n)       = ⟨      suc zero  , {!!} ⟩
to   ∃-≤ (s≤s (s≤s m≤n))      = ⟨ suc (suc zero) , {!!} ⟩
from ∃-≤ ⟨ zero  , y+zero≡z ⟩ = zzz y+zero≡z
from ∃-≤ ⟨ suc x , y+sucx≡z ⟩ rewrite sym y+sucx≡z = {!!}

-- The negation of an existential is isomorphic to a universal of a negation.
¬∃≃∀¬ : ∀ {A : Set} {B : A → Set}
  → (¬ ∃[ a ] B a) ≃ ∀ a → ¬ B a
to      ¬∃≃∀¬ = λ { ¬∃B     a → λ Ba   → ¬∃B ⟨ a , Ba ⟩ }
from    ¬∃≃∀¬ = λ { a→¬Ba ⟨ a ,   Ba ⟩ → a→¬Ba a   Ba }
from∘to ¬∃≃∀¬ = λ   ¬∃B                → {!!} -- TODO
to∘from ¬∃≃∀¬ = λ   a→¬Ba              → refl

-- 747/PLFA exercise: ExistsNegImpNegForAll (1 point)
-- Existence of negation implies negation of universal.

∃¬-implies-¬∀ : ∀ {A : Set} {B : A → Set}
  → ∃[ a ] (¬ B a)
    --------------
  → ¬ (∀ a → B a)
∃¬-implies-¬∀ ⟨ a , ¬Ba ⟩ = λ a→Ba → ¬Ba (a→Ba a)

-- The converse cannot be proved in intuitionistic logic.

-- PLFA exercise: isomorphism between naturals and existence of canonical binary.
-- This is essentially what we did at the end of 747Isomorphism.


-- Issue498: Underapplied projection-like functions did not evaluate correctly.
module Issue498 where

data ⊤ : Set where
  tt : ⊤

data C : ⊤ → Set where
  c : C tt

data C₂ : ⊤ → ⊤ → Set where
  c : C₂ tt tt

module NoParams where

  f₁ : ∀ a → C a → ⊤
  f₁ a x = tt

  f₁′ : ∀ a → C a → ⊤
  f₁′ = f₁

  check₁ : ∀ a x → C (f₁′ a x)
  check₁ s x = c

  f₂ : ∀ a b → C₂ a b → ⊤
  f₂ a b x = tt

  f₂′ : ∀ a b → C₂ a b → ⊤
  f₂′ a = f₂ a

  check₂ : ∀ a b x → C (f₂′ a b x)
  check₂ a b x = c

  f₃ : ∀ a {b} → C₂ a b → ⊤
  f₃ a x = tt

  f₃′ : ∀ a {b} → C₂ a b → ⊤
  f₃′ = f₃

  data Is-f₃ : (∀ a {b} → C₂ a b → ⊤) → Set where
    is-f₃ : Is-f₃ (λ a {b} x → tt)

  check₃ : Is-f₃ f₃′
  check₃ = is-f₃

module SomeParams (X Y : Set) where

  f₁ : ∀ a → C a → ⊤
  f₁ a x = tt

  f₁′ : ∀ a → C a → ⊤
  f₁′ = f₁

  check₁ : ∀ a x → C (f₁′ a x)
  check₁ s x = c

  f₂ : ∀ a b → C₂ a b → ⊤
  f₂ a b x = tt

  f₂′ : ∀ a b → C₂ a b → ⊤
  f₂′ a = f₂ a

  check₂ : ∀ a b x → C (f₂′ a b x)
  check₂ a b x = c

check₃ : ∀ {X Y} a x → C (SomeParams.f₁′ X Y a x)
check₃ a x = c

check₄ : ∀ {X Y} a b x → C (SomeParams.f₂′ X Y a b x)
check₄ a b x = c


-- Verify that issue 3415 has been fixed by checking that the
-- computation rule for univalence holds up to a trivial transport (it
-- used to only hold up to a more complicated argument).
{-# OPTIONS --cubical #-}
module Issue3415 where

open import Agda.Primitive.Cubical public
open import Agda.Builtin.Cubical.Path public
open import Agda.Builtin.Cubical.Glue public
open import Agda.Builtin.Sigma public

idIsEquiv : ∀ {ℓ} (A : Set ℓ) → isEquiv (λ (x : A) → x)
equiv-proof (idIsEquiv A) y =
  ((y , λ _ → y) , λ z i → z .snd (primINeg i)
  , λ j → z .snd (primIMax (primINeg i) j))

idEquiv : ∀ {ℓ} (A : Set ℓ) → A ≃ A
idEquiv A = ((λ x → x) , idIsEquiv A)

ua : ∀ {ℓ} {A B : Set ℓ} → A ≃ B → A ≡ B
ua {A = A} {B = B} e i =
  primGlue B (λ { (i = i0) → A ; (i = i1) → B })
             (λ { (i = i0) → e ; (i = i1) → (idEquiv B) })

transport : ∀ {ℓ} {A B : Set ℓ} → A ≡ B → A → B
transport p a = primTransp (λ i → p i) i0 a

transportRefl : ∀ {ℓ}  {A : Set ℓ} → (x : A) → transport (λ _ → A) x ≡ x
transportRefl {A = A} x i = primTransp (λ _ → A) i x

uaβ : ∀ {ℓ} {A B : Set ℓ} (e : A ≃ B) (x : A) → transport (ua e) x ≡ e .fst x
uaβ e x = transportRefl (e .fst x)


{-# OPTIONS --type-in-type #-}

-- Yeah, that's type-in-type. I'm a sissy, I want to use the stdlib, I
-- don't want to reimplement ℕ, ⊤, etc. in Set1.

module ILabel where

open import Data.String

open import Data.Empty
open import Data.Unit

open import Data.Product

open import Data.Maybe
open import Data.Nat

open import Relation.Binary.PropositionalEquality

--****************************************************************
-- A universe of labels
--****************************************************************

infixr 5 _∷_

data AllowedBy : Set -> Set where
  ε    : forall {T} ->
         AllowedBy T
  _∷_  : {S : Set}{T : S -> Set} ->
         (s : S)(ts : AllowedBy (T s)) -> AllowedBy ((x : S) -> T x)

UId = String

-- The universe (that's a tiny one):

data Label : Set where
  label : (u : UId)(T : Set)(ts : AllowedBy T) -> Label

--****************************************************************
-- IDesc & co.
--****************************************************************

data IDesc (I : Set1) : Set1 where
  var    : I -> IDesc I
  const  : Set -> IDesc I
  prod   : IDesc I -> IDesc I -> IDesc I
  sigma  : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi     : (S : Set) -> (S -> IDesc I) -> IDesc I

desc : {I : Set1} -> IDesc I -> (I -> Set) -> Set
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P × desc D' P
desc (sigma S T) P = Σ S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

-- We (may) stuck a label on the fix-point:

data IMu {I : Set1}(L : Maybe (I -> Label))(R : I -> IDesc I)(i : I) : Set where
  con : desc (R i) (\j -> IMu L R j) -> IMu L R i

--****************************************************************
-- Example: Nat
--****************************************************************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc ⊤
natCases Ze = const ⊤
natCases Suc = var _

NatD : ⊤ → IDesc ⊤
NatD _ = sigma NatConst natCases

Nat : Set
Nat = IMu (just (\ _ -> label "Nat" Set ε)) NatD _

--****************************************************************
-- Example: Vector
--****************************************************************

data VecConst : ℕ -> Set where
  Vnil : VecConst 0
  Vcons : {n : ℕ} -> VecConst (1 + n)

vecDChoice : Set -> (n : ℕ) -> VecConst n -> IDesc ℕ
vecDChoice X 0 Vnil = const ⊤
vecDChoice X (suc n) Vcons = prod (const X) (var n)

vecD : Set -> ℕ -> IDesc ℕ
vecD X n = sigma (VecConst n) (vecDChoice X n)

vec : Set -> ℕ -> Set
vec X n = IMu (just (\n -> label "Vec" (ℕ -> Set) (n ∷ ε))) (vecD X) n

--****************
-- Example: Fin
--****************

data FinConst : ℕ -> Set where
  Fz : {n : ℕ} -> FinConst (1 + n)
  Fs : {n : ℕ} -> FinConst (1 + n)

finDChoice : (n : ℕ) -> FinConst n -> IDesc ℕ
finDChoice 0 ()
finDChoice (suc n) Fz = const ⊤
finDChoice (suc n) Fs = var n

finD : ℕ -> IDesc ℕ
finD n = sigma (FinConst n) (finDChoice n)

fin : ℕ -> Set
fin n = IMu (just (\ n -> label "Fin" (ℕ -> Set) (n ∷ ε))) finD n

--****************
-- Example: Identity type
--****************

-- data Id (A : Set) (a : A) : A -> Set := (refl : Id A a a)

data IdConst : Set where
  Refl : IdConst

idD : (A : Set)(a : A)(b : A) -> IDesc A
idD A a b = sigma IdConst (\ _ -> const (a ≡ b))

id : (A : Set)(a : A)(b : A) -> Set
id A a b = IMu (just (\ b -> label "Id" ((A : Set)(a : A)(b : A) -> Set) (A ∷ a ∷ b ∷ ε))) (idD A a) b


{-# OPTIONS --cubical --safe #-}

module Data.Nat.Base where

open import Agda.Builtin.Nat public
  using (_+_; _*_; zero; suc)
  renaming (Nat to ℕ; _-_ to _∸_)
import Agda.Builtin.Nat as Nat

open import Level
open import Data.Bool

data Ordering : ℕ → ℕ → Type₀ where
  less    : ∀ m k → Ordering m (suc (m + k))
  equal   : ∀ m   → Ordering m m
  greater : ∀ m k → Ordering (suc (m + k)) m

compare : ∀ m n → Ordering m n
compare zero    zero    = equal   zero
compare (suc m) zero    = greater zero m
compare zero    (suc n) = less    zero n
compare (suc m) (suc n) with compare m n
... | less    m k = less (suc m) k
... | equal   m   = equal (suc m)
... | greater n k = greater (suc n) k

nonZero : ℕ → Bool
nonZero (suc _) = true
nonZero zero    = false

_÷_ : (n m : ℕ) → { m≢0 : T (nonZero m) } → ℕ
_÷_ n (suc m) = Nat.div-helper 0 m n m

rem : (n m : ℕ) → { m≢0 : T (nonZero m) } → ℕ
rem n (suc m) = Nat.mod-helper 0 m n m


{-# OPTIONS --cubical --safe #-}

module Container.List.Syntax where

open import Prelude
open import Container
open import Container.List
open import Data.Fin

record ListSyntax {a b} (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  field [_] : B → List A

open ListSyntax ⦃ ... ⦄ public

instance
  cons : ⦃ _ : ListSyntax A B ⦄ →  ListSyntax A (A × B)
  [_] ⦃ cons ⦄ (x , xs) .fst = suc ([ xs ] .fst)
  [_] ⦃ cons ⦄ (x , xs) .snd f0 = x
  [_] ⦃ cons ⦄ (x , xs) .snd (fs n) = [ xs ] .snd n

instance
  sing : ListSyntax A A
  [_] ⦃ sing ⦄ x = 1 , const x


open import Oscar.Prelude
open import Oscar.Class.IsPrecategory
open import Oscar.Class.Surjection
open import Oscar.Class.Smap
open import Oscar.Class.Surjtranscommutativity
open import Oscar.Class.Surjextensionality
open import Oscar.Class.Transitivity

module Oscar.Class.IsPrefunctor where

module _
  {𝔬₁} {𝔒₁ : Ø 𝔬₁}
  {𝔯₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
  {ℓ₁} (_∼̇₁_ : ∀ {x y} → x ∼₁ y → x ∼₁ y → Ø ℓ₁)
  (_↦₁_ : Transitivity.type _∼₁_)
  {𝔬₂} {𝔒₂ : Ø 𝔬₂}
  {𝔯₂} (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
  {ℓ₂} (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
  (_↦₂_ : Transitivity.type _∼₂_)
  {surjection : Surjection.type 𝔒₁ 𝔒₂}
  (smap : Smap.type _∼₁_ _∼₂_ surjection surjection)
  where
  record IsPrefunctor : Ø 𝔬₁ ∙̂ 𝔯₁ ∙̂ ℓ₁ ∙̂ 𝔬₂ ∙̂ 𝔯₂ ∙̂ ℓ₂ where
    constructor ∁
    field
      overlap ⦃ `IsPrecategory₁ ⦄ : IsPrecategory _∼₁_ _∼̇₁_ _↦₁_
      overlap ⦃ `IsPrecategory₂ ⦄ : IsPrecategory _∼₂_ _∼̇₂_ _↦₂_
      overlap ⦃ `𝓢urjtranscommutativity ⦄ : Surjtranscommutativity.class _∼₁_ _∼₂_ _∼̇₂_ smap _↦₁_ _↦₂_
      ⦃ `𝓢urjextensionality ⦄ : Surjextensionality.class _∼₁_ _∼̇₁_ _∼₂_ _∼̇₂_ surjection smap


open import Relation.Nullary.Decidable using (False; map)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; cong; module ≡-Reasoning)
open ≡-Reasoning
open import Function.Equivalence as FE using ()

open import Data.Unit using (⊤; tt)
open import Agda.Builtin.FromNat using (Number)

module AKS.Modular.Quotient.Base where

open import AKS.Nat using (ℕ; zero; suc; _<_; _∸_) renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; _≟_ to _≟ℕ_)
open import AKS.Nat using (≢⇒¬≟; ∸-mono-<ʳ; 0<1+n; <⇒≤; <-irrelevant; 0≢⇒0<)
open import AKS.Nat.Divisibility using (_%_; n%m<m; 0%m≡0; 1%m≡1; [m+kn]%n≡m%n; m%n%n≡m%n; %-distribˡ-+; %-distribˡ-*)
open import AKS.Nat.GCD using (+ʳ; +ˡ)
open import AKS.Primality using (IsPrime; Prime; prime≢0; bézout-prime)
open Prime

record ℤ/[_] (P : Prime) : Set where
  constructor ℤ✓
  field
    mod : ℕ
    mod<p : mod < prime P
open ℤ/[_] public

module Operations {P : Prime} where
  open Prime P using () renaming (prime to p; isPrime to p-isPrime)
  open IsPrime p-isPrime using (1<p)

  p≢0 : False (p ≟ℕ 0)
  p≢0 = ≢⇒¬≟ (prime≢0 p-isPrime)

  [_] : ℕ → ℤ/[ P ]
  [ n ] = ℤ✓ ((n % p) {p≢0}) (n%m<m n p)

  instance
    ℤ/[]-number : Number (ℤ/[ P ])
    ℤ/[]-number = record
      { Constraint = λ _ → ⊤
      ; fromNat = λ n → [ n ]
      }

  infixl 6 _+_
  _+_ : ℤ/[ P ] → ℤ/[ P ] → ℤ/[ P ]
  n + m = [ mod n +ℕ mod m ]

  infix 8 -_
  -_ : ℤ/[ P ] → ℤ/[ P ]
  - (ℤ✓ zero    0<p) = ℤ✓ zero  0<p
  - (ℤ✓ (suc n) 1+n<p) = ℤ✓ (p ∸ suc n) (∸-mono-<ʳ (<⇒≤ 1+n<p) 0<1+n)

  infixl 7 _*_
  _*_ : ℤ/[ P ] → ℤ/[ P ] → ℤ/[ P ]
  n * m = [ mod n *ℕ mod m ]

  ℤ/[]-irrelevance : ∀ {x y : ℤ/[ P ]} → mod x ≡ mod y → x ≡ y
  ℤ/[]-irrelevance {ℤ✓ mod[x] mod[x]<p} {ℤ✓ .mod[x] mod[y]<p} refl = cong (λ z<p → ℤ✓ mod[x] z<p) (<-irrelevant mod[x]<p mod[y]<p)

  n≢0⇒mod[n]≢0 : ∀ {n} → n ≢ 0 → mod n ≢ 0
  n≢0⇒mod[n]≢0 {ℤ✓ zero _} n≢0 = contradiction (ℤ/[]-irrelevance (sym (0%m≡0 p))) n≢0
  n≢0⇒mod[n]≢0 {ℤ✓ (suc n) _} n≢0 = λ ()

  bézout-x∤p : ∀ n x y → 1 +ℕ x *ℕ n ≡ y *ℕ p → 0 ≢ (x % p) {p≢0}
  bézout-x∤p n x y 1+x*n≡y*p 0≡x%p = contradiction 1≡0 (λ ())
    where
    1≡0 : 1 ≡ zero
    1≡0 = begin
      1 ≡⟨ sym (1%m≡1 1<p) ⟩
      (1 +ℕ 0 *ℕ n) % p ≡⟨ cong (λ t → ((1 +ℕ t *ℕ n) % p) {p≢0}) 0≡x%p ⟩
      (1 +ℕ (x % p) *ℕ n) % p ≡⟨ %-distribˡ-+ 1 ((x % p) *ℕ n) p ⟩
      (1 % p +ℕ ((x % p) *ℕ n) % p) % p ≡⟨ cong (λ t → ((1 % p +ℕ t) % p) {p≢0}) (%-distribˡ-* (x % p) n p) ⟩
      (1 % p +ℕ ((x % p % p) *ℕ (n % p)) % p) % p ≡⟨ cong (λ t → (1 % p +ℕ (t *ℕ (n % p)) % p) % p) (m%n%n≡m%n x p) ⟩
      (1 % p +ℕ ((x % p) *ℕ (n % p)) % p) % p ≡⟨ cong (λ t → (1 % p +ℕ t) % p) (sym (%-distribˡ-* x n p)) ⟩
      (1 % p +ℕ (x *ℕ n) % p) % p ≡⟨ sym (%-distribˡ-+ 1 (x *ℕ n) p) ⟩
      (1 +ℕ x *ℕ n) % p ≡⟨ cong (λ t → (t % p) {p≢0}) 1+x*n≡y*p ⟩
      (y *ℕ p) % p ≡⟨ [m+kn]%n≡m%n 0 y p {p≢0} ⟩
      0 % p ≡⟨ 0%m≡0 p ⟩
      0 ∎

  -- x⁻¹ * x - 1 ≡ z * p
  infix 8 _⁻¹
  _⁻¹ : ∀ (n : ℤ/[ P ]) {n≢0 : n ≢ 0} → ℤ/[ P ]
  (n ⁻¹) {n≢0} with bézout-prime (mod n) p (n≢0⇒mod[n]≢0 n≢0) (mod<p n) p-isPrime
  ... | +ʳ x y 1+x*n≡y*p = ℤ✓ (p ∸ (x % p) {p≢0}) (∸-mono-<ʳ (<⇒≤ (n%m<m x p)) (0≢⇒0< (bézout-x∤p (mod n) x y 1+x*n≡y*p)))
  ... | +ˡ x y 1+y*p≡x*n = [ x ]

  infixl 7 _/_
  _/_ : ∀ (n m : ℤ/[ P ]) {m≢0 : m ≢ 0} → ℤ/[ P ]
  (n / m) {m≢0} = n * (m ⁻¹) {m≢0}

  _≟_ : Decidable {A = ℤ/[ P ]} _≡_
  ℤ✓ x x<p ≟ ℤ✓ y y<p = map (FE.equivalence ℤ/[]-irrelevance (λ { refl → refl })) (x ≟ℕ y)

open Operations public


module vector-test where

open import bool
open import nat
open import list
open import vector

test-vector : 𝕍 𝔹 4
test-vector = ff :: tt :: ff :: ff :: []

test-vector2 : 𝕃 (𝕍 𝔹 2)
test-vector2 = (ff :: tt :: []) ::
               (tt :: ff :: []) ::
               (tt :: ff :: []) :: []

test-vector3 : 𝕍 (𝕍 𝔹 3) 2
test-vector3 = (tt :: tt :: tt :: []) ::
               (ff :: ff :: ff :: []) :: []

test-vector-append : 𝕍 𝔹 8
test-vector-append = test-vector ++𝕍 test-vector

test-set-vector : 𝕍 Set 3
test-set-vector = ℕ :: 𝔹 :: (𝔹 → 𝔹) :: []


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.ZCohomology.RingStructure.CohomologyRingFun where

{-
   There is two definitionof the Cohomology Ring.
   We recommend to use the HIT definition (the other one)
   as the ring product is eaiser to handle.
   Nevertheless the equality is harder to handle so
   this definition can interessting too.
-}

open import Cubical.Foundations.Prelude

open import Cubical.Relation.Nullary

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Nat renaming (_+_ to _+ℕ_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Sigma

open import Cubical.Algebra.Monoid
open import Cubical.Algebra.Ring
open import Cubical.Algebra.GradedRing.DirectSumFun

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.GroupStructure
open import Cubical.ZCohomology.RingStructure.CupProduct
open import Cubical.ZCohomology.RingStructure.RingLaws
open import Cubical.ZCohomology.RingStructure.GradedCommutativity

private variable
  ℓ ℓ' : Level

open PlusBis

module _ (A : Type ℓ) where

  H*FunR : Ring ℓ
  H*FunR = ⊕FunGradedRing-Ring
           _+'_ (makeIsMonoid isSetℕ +'-assoc +'-rid +'-lid)
           +'≡+
           (λ k → coHom k A)
           (λ k → snd (coHomGroup k A))
           1⌣
           _⌣_
           (λ {k} {l} → 0ₕ-⌣ k l)
           (λ {k} {l} → ⌣-0ₕ k l)
           (λ _ _ _ → sym (ΣPathTransport→PathΣ _ _ ((sym (+'-assoc _ _ _)) , (sym (assoc-⌣ _ _ _ _ _ _)))))
           (λ _ → sym (ΣPathTransport→PathΣ _ _ (sym (+'-rid _) , sym (lUnit⌣ _ _))))
           (λ _ → ΣPathTransport→PathΣ _ _ (refl , transportRefl _ ∙ rUnit⌣ _ _))
           (λ _ _ _ → leftDistr-⌣ _ _ _ _ _)
           λ _ _ _ → rightDistr-⌣ _ _ _ _ _

  H*Fun : Type ℓ
  H*Fun = fst H*FunR


open import Prelude
open import Nat
open import core
open import contexts

module lemmas-env where
  env-ctx-same-1 : ∀{Δ Σ' Γ E x} →
                     Δ , Σ' , Γ ⊢ E →
                     x # E →
                     x # Γ
  env-ctx-same-1 EnvId h = x#∅
  env-ctx-same-1 {x = x} (EnvInd {E = E} {x = x'} ctxcons _) x#E+
    with natEQ x x'
  ... | Inl refl = abort (x#E+ (_ , x,a∈Γ,,x,a {Γ = E}))
  ... | Inr x≠x'
    with env-ctx-same-1 ctxcons (x#Γ+→x#Γ {Γ = E} x#E+)
  ... | x#Γ = x#Γ→x#Γ+ x≠x' x#Γ

  env-ctx-same-2 : ∀{Δ Σ' Γ E x} →
                     Δ , Σ' , Γ ⊢ E →
                     x # Γ →
                     x # E
  env-ctx-same-2 EnvId h = x#∅
  env-ctx-same-2 {x = x} (EnvInd {Γ = Γ} {x = x'} ctxcons _) x#Γ+
    with natEQ x x'
  ... | Inl refl = abort (x#Γ+ (_ , x,a∈Γ,,x,a {Γ = Γ}))
  ... | Inr x≠x'
    with env-ctx-same-2 ctxcons (x#Γ+→x#Γ {Γ = Γ} x#Γ+)
  ... | x#E = x#Γ→x#Γ+ x≠x' x#E

  env-all-Γ : ∀{Δ Σ' Γ E x τ} →
                Δ , Σ' , Γ ⊢ E →
                (x , τ) ∈ Γ →
                Σ[ r ∈ result ] ((x , r) ∈ E ∧ Δ , Σ' ⊢ r ·: τ)
  env-all-Γ EnvId x∈Γ = abort (x#∅ (_ , x∈Γ))
  env-all-Γ {x = x} (EnvInd {Γ = Γ} {E} {x'} ctxcons ta) x∈Γ
    with natEQ x x'
  ... | Inl refl
          rewrite ctxunicity x∈Γ (x,a∈Γ,,x,a {Γ = Γ})
            = _ , x,a∈Γ,,x,a {Γ = E} , ta
  ... | Inr x≠x'
    with env-all-Γ ctxcons (x∈Γ+→x∈Γ {Γ = Γ} x≠x' x∈Γ)
  ... | _ , x∈E , ta-rec = _ , x∈Γ→x∈Γ+ x≠x' x∈E , ta-rec

  env-all-E : ∀{Δ Σ' Γ E x r} →
                Δ , Σ' , Γ ⊢ E →
                (x , r) ∈ E →
                Σ[ τ ∈ typ ] ((x , τ) ∈ Γ ∧ Δ , Σ' ⊢ r ·: τ)
  env-all-E EnvId x∈E = abort (x#∅ (_ , x∈E))
  env-all-E {x = x} (EnvInd {Γ = Γ} {E} {x'} ctxcons ta) x∈E
    with natEQ x x'
  ... | Inl refl
          rewrite ctxunicity x∈E (x,a∈Γ,,x,a {Γ = E})
            = _ , x,a∈Γ,,x,a {Γ = Γ} , ta
  ... | Inr x≠x'
    with env-all-E ctxcons (x∈Γ+→x∈Γ {Γ = E} x≠x' x∈E)
  ... | _ , x∈Γ , ta-rec = _ , x∈Γ→x∈Γ+ x≠x' x∈Γ , ta-rec


{-# OPTIONS --copatterns --sized-types #-}

open import Function
open import Data.Unit as Unit renaming (tt to ∗)
open import Data.List as List

TyCtx = List ⊤

data TyVar : (Γ : TyCtx) → Set where
  zero : ∀{Γ}                          → TyVar (∗ ∷ Γ)
  succ : ∀{Γ} → (x : TyVar Γ) → TyVar (∗ ∷ Γ)

data Type (Γ : TyCtx) : Set where
  unit :                                     Type Γ
  var  : (x : TyVar Γ)                     → Type Γ
  _⊕_  : (t₁ : Type Γ)       (t₂ : Type Γ) → Type Γ
  μ    : (t : Type (_ ∷ Γ))                → Type Γ
  _⊗_  : (t₁ : Type Γ)       (t₂ : Type Γ) → Type Γ
  _⇒_  : (t₁ : Type [])      (t₂ : Type Γ) → Type Γ
  ν    : (t : Type (_ ∷ Γ))                → Type Γ

-- | Variable renaming in types
_▹_ : (Γ Δ : TyCtx) → Set
Γ ▹ Δ = TyVar Γ → TyVar Δ

{-
rename : {Γ Δ : TyCtx} → (ρ : Γ ▹ Δ) → Type Γ → Type Δ
rename         ρ unit      = unit
rename         ρ (var x)   = var (ρ ∗ x)
rename         ρ (t₁ ⊕ t₂) = rename ρ t₁ ⊕ rename ρ t₂
rename {Γ} {Δ} ρ (μ t)     = μ (rename ρ' t)
  where
    ρ' : (∗ ∷ Γ) ▹ (∗ ∷ Δ)
    ρ' = ?
    -- ρ' = id {[ ∗ ]} ⧻ ρ
rename         ρ (t₁ ⊗ t₂) = rename ρ t₁ ⊗ rename ρ t₂
rename         ρ (t₁ ⇒ t₂) = t₁ ⇒ rename ρ t₂
rename {Γ} {Δ} ρ (ν t)     = ν (rename ρ' t)
  where
    ρ' : (∗ ∷ Γ) ▹ (∗ ∷ Δ)
    ρ' = ?
--    ρ' = ctx-id {[ ∗ ]} ⧻ ρ

-------------------------
---- Generating structure on contexts (derived from renaming)

weaken : {Γ : TyCtx} (Δ : TyCtx) → Type Γ -> Type (Δ ++ Γ)
weaken {Γ} Δ = rename {Γ} {Δ ++ Γ} ?

exchange : (Γ Δ : TyCtx) → Type (Γ ++ Δ) -> Type (Δ ++ Γ)
exchange Γ Δ = rename [ i₂ {Δ} {Γ} , i₁ {Δ} {Γ} ]

contract : {Γ : TyCtx} → Type (Γ ∐ Γ) -> Type Γ
contract = rename [ ctx-id , ctx-id ]

-}

Subst : TyCtx → TyCtx → Set
Subst Γ Δ = TyVar Γ → Type Δ

update : ∀{Γ Δ : TyCtx} → Subst Γ Δ → Type Δ → (Subst (∗ ∷ Γ) Δ)
update σ a zero        = a
update σ _ (succ x) = σ x

lift : ∀{Γ Δ} → Subst Γ Δ → Subst (∗ ∷ Γ) (∗ ∷ Δ)
lift σ zero = {!!}
lift σ (succ x) = {!!}

-- | Simultaneous substitution
subst : {Γ Δ : TyCtx} → (σ : Subst Γ Δ) → Type Γ → Type Δ
subst         σ unit      = unit
subst         σ (var x)   = σ x
subst         σ (t₁ ⊕ t₂) = subst σ t₁ ⊕ subst σ t₂
subst {Γ} {Δ} σ (μ t)     = μ (subst (lift σ) t)
subst         σ (t₁ ⊗ t₂) = subst σ t₁ ⊗ subst σ t₂
subst         σ (t₁ ⇒ t₂) = t₁ ⇒ subst σ t₂
subst {Γ} {Δ} σ (ν t)     = ν (subst (lift σ) t)

data Term : Set where


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

open import LogicalFormulae
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Functions.Definition
open import Setoids.Setoids
open import Setoids.DirectSum
open import Setoids.Subset
open import Graphs.Definition
open import Sets.FinSet.Definition
open import Sets.FinSet.Lemmas
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Sets.EquivalenceRelations
open import Graphs.PathGraph

module Graphs.UnionGraph where

unionGraph : {a b c d e f : _} {V' : Set a} {V : Setoid {a} {b} V'} (G : Graph c V) {W' : Set d} {W : Setoid {d} {e} W'} (H : Graph f W) → Graph (c ⊔ f) (directSumSetoid V W)
Graph._<->_ (unionGraph {c = c} {f = f} G H) (inl v) (inl v2) = embedLevel {c} {f} (Graph._<->_ G v v2)
Graph._<->_ (unionGraph G H) (inl v) (inr w) = False'
Graph._<->_ (unionGraph G H) (inr w) (inl v) = False'
Graph._<->_ (unionGraph {c = c} {f = f} G H) (inr w) (inr w2) = embedLevel {f} {c} (Graph._<->_ H w w2)
Graph.noSelfRelation (unionGraph G H) (inl v) (v=v ,, _) = Graph.noSelfRelation G v v=v
Graph.noSelfRelation (unionGraph G H) (inr w) (w=w ,, _) = Graph.noSelfRelation H w w=w
Graph.symmetric (unionGraph G H) {inl x} {inl y} (x=y ,, _) = Graph.symmetric G x=y ,, record {}
Graph.symmetric (unionGraph G H) {inr x} {inr y} (x=y ,, _) = Graph.symmetric H x=y ,, record {}
Graph.wellDefined (unionGraph G H) {inl x} {inl y} {inl z} {inl w} (x=y ,, _) (y=z ,, _) (z=w ,, _) = Graph.wellDefined G x=y y=z z=w ,, record {}
Graph.wellDefined (unionGraph G H) {inr x} {inr y} {inr z} {inr w} (x=y ,, _) (y=z ,, _) (z=w ,, _) = Graph.wellDefined H x=y y=z z=w ,, record {}


{-# OPTIONS --prop #-}

data _≡_ {X : Set} (a : X) : X → Prop where
  refl : a ≡ a

postulate
  A : Set
  P : Prop
  p : P
  u : P → A

f : {x : A} (q : u p ≡ x) → P
f refl = p   -- works in 2.6.0.1


{-# OPTIONS --safe --without-K #-}
module Categories.Examples.Monad.Duration where

-- Monad induced by pairing a Monoid and a Setoid
open import Level

open import Function.Base using (_-⟪_⟫-_; _on_; _∘_) renaming (id to id→)
open import Function.Equality using (Π; _⟨$⟩_; cong)

open import Relation.Binary
open import Relation.Binary.Indexed.Heterogeneous.Construct.Trivial

open import Data.Product using (Σ; _,_; _×_; proj₁; proj₂; dmap′; zip; map₁; map₂)
open import Algebra using (Monoid)

open import Categories.Category
open import Categories.Category.Instance.Setoids
open import Categories.Functor renaming (id to idF)
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)
open import Categories.Monad using (Monad)

open import Data.Nat.Properties renaming (+-0-monoid to +-0-nat-monoid)
open import Data.Integer.Properties renaming (+-0-monoid to +-0-integer-monoid)
open import Data.Rational.Properties renaming (+-0-monoid to +-0-rational-monoid)

open Monoid public

monoid×-₀ : ∀ {l₁ l₂ e₁ e₂} → Monoid l₁ e₁ → Setoid l₂ e₂ → Setoid _ _
monoid×-₀ m s = record
  { Carrier = m.Carrier × s.Carrier
  ; _≈_ = m._≈_ on proj₁ -⟪ _×_ ⟫- s._≈_ on proj₂
  ; isEquivalence = record
      { refl = m.refl , s.refl
      ; sym = dmap′ m.sym s.sym
      ; trans = zip m.trans s.trans
      }
  }
  where
    module m = Monoid m
    module s = Setoid s

monoid×-₁ : ∀ {l₁ l₂ e₁ e₂} {A B : Setoid l₂ e₂} → (m : Monoid l₁ e₁) → (f : Setoids l₂ e₂ [ A , B ]) → Setoids _ _ [ monoid×-₀ m A , monoid×-₀ m B ]
monoid×-₁ _ f = record
  { _⟨$⟩_ = map₂ (_⟨$⟩_ f)
  ; cong = map₂ (cong f)
  }

-- levels have to be the same because everything gets put into the same stop
monoid×-endo : ∀ {l₁ e₁} → Monoid l₁ e₁ → Endofunctor (Setoids l₁ e₁)
monoid×-endo m =  record
  { F₀ = monoid×-₀ m
  ; F₁ = monoid×-₁ m
  ; identity = id→
  ; homomorphism = λ {_} {_} {_} {f} {g} p → map₂ (cong g ∘ cong f) p
  ; F-resp-≈ = λ f → map₂ f
  }

monoid×-η : ∀ {l e} → (m : Monoid l e) → NaturalTransformation idF (monoid×-endo m)
monoid×-η m = ntHelper record
  { η = λ _ → record { _⟨$⟩_ = m.ε ,_ ; cong = m.refl ,_ }
  ; commute = λ f x → m.refl , cong f x
  }
  where module m = Monoid m

monoid×-μ : ∀ {l} → (m : Monoid l l) → NaturalTransformation (monoid×-endo m ∘F monoid×-endo m) (monoid×-endo m)
monoid×-μ m = ntHelper record
  { η = λ X → record
    { _⟨$⟩_ =  λ { (d , d₁ , value) → ( d m.∙ d₁) , value }
    ; cong = λ { (d , d₁ , v) → m.∙-cong d d₁ , v }
    }
  ; commute = λ { f (d , d₁ , v) → m.∙-cong d d₁ , cong f v }
  }
  where
    module m = Monoid m

monoid×-monad : ∀ {l} → Monoid l l → Monad (Setoids l l)
monoid×-monad m = record
  { F = monoid×-endo m
  ; η = monoid×-η m
  ; μ = monoid×-μ m
  ; assoc     = λ (p₀ , p₁ , p₂ , p₃) → m.trans (m.∙-cong p₀ (m.∙-cong p₁ p₂)) (m.sym (m.assoc _ _ _)) , p₃
  ; sym-assoc = λ (p₀ , p₁ , p₂ , p₃) → m.trans (m.∙-cong (m.∙-cong p₀ p₁) p₂) (      (m.assoc _ _ _)) , p₃
  ; identityˡ  = λ p → map₁ (m.trans (m.identityʳ _)) p
  ; identityʳ  = λ p → map₁ (m.trans (m.identityˡ _)) p
  }
  where module m = Monoid m

natDuration : Monad (Setoids 0ℓ 0ℓ)
natDuration = monoid×-monad +-0-nat-monoid

integerDuration : Monad (Setoids 0ℓ 0ℓ)
integerDuration = monoid×-monad +-0-integer-monoid

rationalDuration : Monad (Setoids 0ℓ 0ℓ)
rationalDuration = monoid×-monad +-0-rational-monoid


module Categories.Products where

open import Library renaming (_×_ to Pair) hiding ([_])
open import Categories

_×_ : ∀{l l' m m'}(C : Cat {l}{m})(D : Cat {l'}{m'}) -> Cat
C × D = record
          { Obj  = Pair (Obj C) (Obj D)
          ; Hom  = λ {(X , X') (Y , Y') -> Pair (Hom C X Y) (Hom D X' Y')}
          ; iden = iden C , iden D
          ; comp = λ {(f , f') (g , g') -> comp C f g , comp D f' g'}
          ; idl  = cong₂ _,_ (idl C) (idl D)
          ; idr  = cong₂ _,_ (idr C) (idr D)
          ; ass  = cong₂ _,_ (ass C) (ass D)
          } where open Cat

infixr 50 _×_

record Prod {l}{m}(C : Cat {l}{m})(A : Cat.Obj C)(B : Cat.Obj C) : Set (l ⊔ m)
  where
  constructor prod
  open Cat C
  field Pr : Obj
        π₁ : Hom Pr A
        π₂ : Hom Pr B
        [_,_] : ∀{C} → Hom C A → Hom C B → Hom C Pr
        law1 : ∀{C}{f : Hom C A}{g} → comp π₁ [ f , g ] ≅ f
        law2 : ∀{C}{f : Hom C A}{g} → comp π₂ [ f , g ] ≅ g
        law3 : ∀{C}{f : Hom C A}{g : Hom C B}{h : Hom C Pr} →
               comp π₁ h ≅ f → comp π₂ h ≅ g → h ≅ [ f , g ]


------------------------------------------------------------------------
-- The Agda standard library
--
-- Convenient syntax for reasoning with a partial setoid
------------------------------------------------------------------------

{-# OPTIONS --cubical --no-import-sorts --safe #-}

open import Cubical.Core.Everything
open import Cubical.Relation.Binary.Raw

module Cubical.Relation.Binary.Reasoning.PartialEquivalence
  {c ℓ} {A : Type c} (E : PartialEquivalence A ℓ) where

open PartialEquivalence E
import Cubical.Relation.Binary.Reasoning.Base.Partial _≈_ transitive as Base

------------------------------------------------------------------------
-- Re-export the contents of the base module

open Base public
  renaming (_∼⟨_⟩_ to _≈⟨_⟩_)

------------------------------------------------------------------------
-- Additional reasoning combinators

infixr 1 _≈˘⟨_⟩_

_≈˘⟨_⟩_ : ∀ x {y z} → y ≈ x → y IsRelatedTo z → x IsRelatedTo z
x ≈˘⟨ y≈x ⟩ y∼z = x ≈⟨ symmetric y≈x ⟩ y∼z


module Dipsy.Example.CLL where

open import Data.Nat using (ℕ)
open import Data.Vec using (Vec; _∷_; [])
open import Dipsy.Polarity using (Polarity; flip) renaming (pos to +; neg to -)

mutual
  Op₀ : (r : Polarity) → Set
  Op₀ r = Op [] r
  Op₁ : (a r : Polarity) → Set
  Op₁ a r = Op (a ∷ []) r
  Op₂ : (a₁ a₂ r : Polarity) → Set
  Op₂ a₁ a₂ r = Op (a₁ ∷ a₂ ∷ []) r

  data Op : {n : ℕ} → Vec Polarity n → Polarity → Set where
    ″⊥″ : Op₀ -
    ″𝟏″ : Op₀ +
    ″⊤″ : Op₀ -
    ″𝟎″ : Op₀ +
    ″¬″ : {p : Polarity} → Op₁ (flip p) p
    ″⅋″ : Op₂ - - -
    ″⊗″ : Op₂ + + +
    ″&″ : Op₂ - - -
    ″⊕″ : Op₂ + + +

open import Dipsy.Base Op Op

pattern ⊥ = op ″⊥″ []
pattern 𝟏 = op ″𝟏″ []
pattern ⊤ = op ″⊤″ []
pattern 𝟎 = op ″𝟎″ []
pattern ¬_ A = op ″¬″ (A ∷ [])
pattern _⅋_ A B = op ″⅋″ (A ∷ B ∷ [])
pattern _⊗_ A B = op ″⊗″ (A ∷ B ∷ [])
pattern _&_ A B = op ″&″ (A ∷ B ∷ [])
pattern _⊕_ A B = op ″⊕″ (A ∷ B ∷ [])


module Syntax.Implication.Dependent where

open import Functional using (id)
open import Functional.Dependent
import      Lvl
open import Type

private variable ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Lvl.Level

_⇒-[_]_ : ∀(X : Type{ℓ₁}){Y : ∀{_ : X} → Type{ℓ₂}}{Z : ∀{x : X}{_ : Y{x}} → Type{ℓ₃}} → (P : (x : X) → Y{x}) → (∀{x : X} → (y : Y{x}) → Z{x}{y}) → ((x : X) → Z{x}{P(x)})
_⇒-[_]_ = const(swap(_∘_))
infixr 0.98 _⇒-[_]_
{-# INLINE _⇒-[_]_ #-}

_⇒-[]_ : ∀(X : Type{ℓ₁}){Y : ∀{_ : X} → Type{ℓ₂}} → ((x : X) → Y{x}) → ((x : X) → Y{x})
_⇒-[]_ = const id
infixr 0.98 _⇒-[]_
{-# INLINE _⇒-[]_ #-}

_⇒-end : ∀(X : Type{ℓ₁}) → (X → X)
_⇒-end = const id
infixr 0.99 _⇒-end
{-# INLINE _⇒-end #-}

_⇒_ = apply
infixl 0.97 _⇒_
{-# INLINE _⇒_ #-}

-- TODO: Change these to be similar to the ones in Syntax.Implication
•_⇒₁_ = apply
infixl 0.97 •_⇒₁_
{-# INLINE •_⇒₁_ #-}

•_•_⇒₂_ : ∀{X : Type{ℓ₁}}{Y : ∀{_ : X} → Type{ℓ₂}}{Z : ∀{x : X}{_ : Y{x}} → Type{ℓ₃}} → (x : X) → (y : Y{x}) → ((x : X) → (y : Y{x}) → Z{x}{y}) → Z{x}{y}
• a • b ⇒₂ P = P ⇒ apply a ⇒ apply b
infixl 0.97 •_•_⇒₂_
{-# INLINE •_•_⇒₂_ #-}

•_•_•_⇒₃_ : ∀{X : Type{ℓ₁}}{Y : ∀{_ : X} → Type{ℓ₂}}{Z : ∀{x : X}{_ : Y{x}} → Type{ℓ₃}}{W : ∀{x : X}{y : Y{x}}{_ : Z{x}{y}} → Type{ℓ₄}} → (x : X) → (y : Y{x}) → (z : Z{x}{y}) → ((x : X) → (y : Y{x}) → (z : Z{x}{y}) → W{x}{y}{z}) → W{x}{y}{z}
• a • b • c ⇒₃ P = P ⇒ apply a ⇒ apply b ⇒ apply c
infixl 0.97 •_•_•_⇒₃_
{-# INLINE •_•_•_⇒₃_ #-}


module Cats.Category.Setoids.Facts where

open import Cats.Category
open import Cats.Category.Setoids using (Setoids)
open import Cats.Category.Setoids.Facts.Exponentials using (hasExponentials)
open import Cats.Category.Setoids.Facts.Initial using (hasInitial)
open import Cats.Category.Setoids.Facts.Products
  using (hasProducts ; hasBinaryProducts)
open import Cats.Category.Setoids.Facts.Terminal using (hasTerminal)

instance
  isCCC : ∀ l → IsCCC (Setoids l l)
  isCCC l = record { hasFiniteProducts = record {} } -- [1]

-- [1] For no discernible reason, `record {}` doesn't work.


{-# OPTIONS --universe-polymorphism #-}
module Categories.Adjunction where

open import Level

open import Relation.Binary using (Rel; IsEquivalence)
open import Data.Sum
open import Data.Product
open import Function using (flip)

open import Categories.Category
open import Categories.Functor hiding (equiv; assoc; identityˡ; identityʳ; ∘-resp-≡) renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_)
open import Categories.NaturalTransformation hiding (equiv; setoid) renaming (id to idT; _≡_ to _≡T_)
open import Categories.Monad
open import Categories.Support.Equivalence

record Adjunction {o ℓ e} {o₁ ℓ₁ e₁} {C : Category o ℓ e} {D : Category o₁ ℓ₁ e₁} (F : Functor D C) (G : Functor C D) : Set (o ⊔ ℓ ⊔ e ⊔ o₁ ⊔ ℓ₁ ⊔ e₁) where
  field
    unit   : NaturalTransformation idF (G ∘F F)
    counit : NaturalTransformation (F ∘F G) idF

    .zig : idT ≡T (counit ∘ʳ F) ∘₁ (F ∘ˡ unit)
    .zag : idT ≡T (G ∘ˡ counit) ∘₁ (unit ∘ʳ G)

  private module C = Category C
  private module D = Category D

  private module F = Functor F
  private module G = Functor G renaming (F₀ to G₀; F₁ to G₁; F-resp-≡ to G-resp-≡)
  open F hiding (op)
  open G hiding (op)

  private module unit   = NaturalTransformation unit
  private module counit = NaturalTransformation counit

  monad : Monad D
  monad = record
    { F = G ∘F F
    ; η = unit
    ; μ = G ∘ˡ (counit ∘ʳ F)
    ; assoc = assoc′
    ; identityˡ = identityˡ′
    ; identityʳ = identityʳ′
    }
    where

    .assoc′ : ∀ {x}
           → G₁ (counit.η (F₀ x)) D.∘ G₁ (F₁ (G₁ (counit.η (F₀ x)))) D.≡ G₁ (counit.η (F₀ x)) D.∘ G₁ (counit.η (F₀ (G₀ (F₀ x))))
    assoc′ {x} =
        begin
          G₁ (counit.η (F₀ x)) D.∘ G₁ (F₁ (G₁ (counit.η (F₀ x))))
        ↑⟨ G.homomorphism ⟩
          G₁ ((counit.η (F₀ x)) C.∘ (F₁ (G₁ (counit.η (F₀ x)))))
        ↓⟨ G-resp-≡ (NaturalTransformation.commute counit (counit.η (F₀ x))) ⟩
          G₁ (counit.η (F₀ x) C.∘ counit.η (F₀ (G₀ (F₀ x))))
        ↓⟨ G.homomorphism ⟩
          G₁ (counit.η (F₀ x)) D.∘ G₁ (counit.η (F₀ (G₀ (F₀ x))))
        ∎
      where
      open D.HomReasoning

    .identityˡ′ : ∀ {x} → G₁ (counit.η (F₀ x)) D.∘ G₁ (F₁ (unit.η x)) D.≡ D.id
    identityˡ′ {x} =
        begin
          G₁ (counit.η (F₀ x)) D.∘ G₁ (F₁ (unit.η x))
        ↑⟨ G.homomorphism ⟩
          G₁ ((counit.η (F₀ x)) C.∘ (F₁ (unit.η x)))
        ↑⟨ G-resp-≡ zig ⟩
          G₁ C.id
        ↓⟨ G.identity ⟩
          D.id
        ∎
      where
      open D.HomReasoning

    .identityʳ′ : ∀ {x} → G₁ (counit.η (F₀ x)) D.∘ unit.η (G₀ (F₀ x)) D.≡ D.id
    identityʳ′ = D.Equiv.sym zag

  op : Adjunction {C = D.op} {D = C.op} G.op F.op
  op = record { unit = counit.op; counit = unit.op; zig = zag; zag = zig }

infixr 5 _⊣_
_⊣_ = Adjunction

id : ∀ {o ℓ e} {C : Category o ℓ e} → Adjunction (idF {C = C}) (idF {C = C})
id {C = C} = record
   { unit = idT
   ; counit = idT
   ; zig = Equiv.sym C.identityˡ
   ; zag = Equiv.sym C.identityˡ
   }
  where
    module C = Category C
    open C

infix  4 _≡_

_≡_ : ∀ {o ℓ e} {o₁ ℓ₁ e₁} {C : Category o ℓ e} {D : Category o₁ ℓ₁ e₁} {F : Functor D C} {G : Functor C D} →  Rel (F ⊣ G) (o ⊔ e ⊔ o₁ ⊔ e₁)
_≡_ {C = C} {D} {F} {G} X Y = Adjunction.unit X ≡T Adjunction.unit Y ×
                                Adjunction.counit X ≡T Adjunction.counit Y

.equiv : ∀ {o ℓ e} {o₁ ℓ₁ e₁} {C : Category o ℓ e} {D : Category o₁ ℓ₁ e₁} {F : Functor D C} {G : Functor C D} → IsEquivalence (_≡_ {F = F} {G})
equiv {C = C} {D} {F} {G} = record
         { refl = (D.Equiv.refl), (C.Equiv.refl)
         ; sym = λ {T U : F ⊣ G} → sym' {T = T} {U = U}
         ; trans = λ {T U V : F ⊣ G} → trans' {T = T} {U = U} {V = V}
         }
      where
        module C = Category C
        module D = Category D

        sym' : {T U : F ⊣ G} → (H : T ≡ U) → flip _≡_ T U
        sym' {T} {U} (H₁ , H₂) = (λ {x} → D.Equiv.sym H₁) , (λ {x} → C.Equiv.sym H₂)

        trans' : {T U V : F ⊣ G} → T ≡ U → U ≡ V → T ≡ V
        trans' {T} {U} {V} (H₁ , H₂) (H₃ , H₄) = (λ {x} → D.Equiv.trans H₁ H₃) , (C.Equiv.trans H₂ H₄)

setoid : ∀ {o ℓ e} {o₁ ℓ₁ e₁} {C : Category o ℓ e} {D : Category o₁ ℓ₁ e₁} {F : Functor D C} {G : Functor C D}
         → Setoid (o ⊔ ℓ ⊔ e ⊔ o₁ ⊔ ℓ₁ ⊔ e₁) (o ⊔ e ⊔ o₁ ⊔ e₁)
setoid {C = C} {D} {F} {G} = record
       { Carrier = Adjunction F G
       ; _≈_ = _≡_
       ; isEquivalence = equiv {F = F} {G = G}
       }


{-# OPTIONS --cubical --no-import-sorts --safe #-}

module Cubical.Data.Fin where

open import Cubical.Data.Fin.Base public
open import Cubical.Data.Fin.Properties public


module Agda.Builtin.List where

infixr 5 _∷_
data List {a} (A : Set a) : Set a where
  []  : List A
  _∷_ : (x : A) (xs : List A) → List A

{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  []   #-}
{-# BUILTIN CONS _∷_  #-}

{-# HASKELL type AgdaList a b = [b] #-}

{-# COMPILED_DATA List MAlonzo.Code.Agda.Builtin.List.AgdaList [] (:) #-}
{-# COMPILED_DATA_UHC List __LIST__ __NIL__ __CONS__ #-}


module Dave.Algebra.Naturals.Ordering where
    open import Dave.Algebra.Naturals.Definition public
    open import Dave.Algebra.Naturals.Addition public
    open import Dave.Algebra.Naturals.Multiplication public

    -- TO-DO: define relation
    data _≤_ : ℕ → ℕ → Set where
        z≤n : ∀ {n : ℕ} → zero ≤ n
        s≤s : ∀ {m n : ℕ} → m ≤ n → suc m ≤ suc n

    infix 4 _≤_

    inv-s≤s : ∀ {m n : ℕ} → suc m ≤ suc n → m ≤ n
    inv-s≤s (s≤s m≤n) = m≤n

    inv-z≤n : ∀ {m : ℕ} → m ≤ zero → m ≡ zero
    inv-z≤n z≤n = refl

    -- TO-DO: define relation properties in general
    ≤-refl : ∀ {n : ℕ} → n ≤ n
    ≤-refl {zero} = z≤n
    ≤-refl {suc n} = s≤s ≤-refl

    ≤-trans : ∀ {m n p : ℕ} → m ≤ n → n ≤ p → m ≤ p
    ≤-trans z≤n n≤p = z≤n
    ≤-trans (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans m≤n n≤p)

    ≤-trans´ : ∀ (m n p : ℕ) → m ≤ n → n ≤ p → m ≤ p
    ≤-trans´ zero n p z≤n n≤p = z≤n
    ≤-trans´ (suc m) (suc n) (suc p) (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans´ m n p m≤n n≤p)

    ≤-antisym : ∀ {m n : ℕ} → m ≤ n → n ≤ m → m ≡ n
    ≤-antisym z≤n z≤n = refl
    ≤-antisym (s≤s m≤n) (s≤s n≤m) = cong suc (≤-antisym m≤n n≤m)

    data Total (m n : ℕ) : Set where
        forward : m ≤ n → Total m n
        flipped : n ≤ m → Total m n

    data Total´ : ℕ → ℕ → Set where
        forward´ : ∀ {m n : ℕ} → m ≤ n → Total´ m n
        flipped´ : ∀ {m n : ℕ} → n ≤ m → Total´ m n

    ≤-total : ∀ (m n : ℕ) → Total m n
    ≤-total zero n = forward z≤n
    ≤-total (suc m) zero = flipped z≤n
    ≤-total (suc m) (suc n) with ≤-total m n
    ...                         | forward m≤n = forward (s≤s m≤n)
    ...                         | flipped n≤m = flipped (s≤s n≤m)

    ≤-total´ : ∀ (m n : ℕ) → Total m n
    ≤-total´ zero n = forward z≤n
    ≤-total´ (suc m) zero = flipped z≤n
    ≤-total´ (suc m) (suc n) = helper (≤-total´ m n)
        where
        helper : Total m n → Total (suc m) (suc n)
        helper (forward m≤n) = forward (s≤s m≤n)
        helper (flipped n≤m) = flipped (s≤s n≤m)

    +-monoᵣ-≤ : ∀ (n p q : ℕ) → p ≤ q → n + p ≤ n + q
    +-monoᵣ-≤ zero p q p≤q = p≤q
    +-monoᵣ-≤ (suc n) p q p≤q = s≤s (+-monoᵣ-≤ n p q p≤q)

    +-monoₗ-≤ : ∀ (m n p : ℕ) → m ≤ n → m + p ≤ n + p
    +-monoₗ-≤ m n p m≤n  rewrite +-comm m p | +-comm n p = +-monoᵣ-≤ p m n m≤n

    +-mono-≤ : ∀ (m n p q : ℕ) → m ≤ n → p ≤ q → m + p ≤ n + q
    +-mono-≤ m n p q m≤n p≤q = ≤-trans (+-monoₗ-≤ m n p m≤n) (+-monoᵣ-≤ n p q p≤q)

    *-monoᵣ-≤ : ∀ (n p q : ℕ) → p ≤ q → n * p ≤ n * q
    *-monoᵣ-≤ zero p q p≤q = z≤n
    *-monoᵣ-≤ (suc n) p q p≤q = +-mono-≤ (n * p) (n * q) p q (*-monoᵣ-≤ n p q p≤q) p≤q

    *-monoₗ-≤ : ∀ (m n p : ℕ) → m ≤ n → m * p ≤ n * p
    *-monoₗ-≤ m n p m≤n  rewrite ℕ-*-comm m p | ℕ-*-comm n p = *-monoᵣ-≤ p m n m≤n

    *-mono-≤ : ∀ (m n p q : ℕ) → m ≤ n → p ≤ q → m * p ≤ n * q
    *-mono-≤ m n p q m≤n p≤q = ≤-trans (*-monoₗ-≤ m n p m≤n) (*-monoᵣ-≤ n p q p≤q)

    {- Strict inequality -}
    infix 4 _<_ _>_

    data _<_ : ℕ → ℕ → Set where
        z<s : ∀ {n : ℕ} → zero < suc n
        s<s : ∀ {m n : ℕ} → m < n → suc m < suc n

    <-trans : ∀ {m n p : ℕ} → m < n → n < p → m < p
    <-trans z<s (s<s n<p) = z<s
    <-trans (s<s m<n) (s<s n<p) = s<s (<-trans m<n n<p)

    +-monoᵣ-< : ∀ (n p q : ℕ) → p < q → n + p < n + q
    +-monoᵣ-< zero p q p<q = p<q
    +-monoᵣ-< (suc n) p q p<q = s<s (+-monoᵣ-< n p q p<q)

    +-monoₗ-< : ∀ (m n p : ℕ) → m < n → m + p < n + p
    +-monoₗ-< m n p m<n rewrite +-comm m p | +-comm n p = +-monoᵣ-< p m n m<n

    +-mono-< : ∀ (m n p q : ℕ) → m < n → p < q → m + p < n + q
    +-mono-< m n p q m<n p<q = <-trans (+-monoₗ-< m n p m<n) (+-monoᵣ-< n p q p<q)

    suc-≤→< : ∀ (m n : ℕ) → suc m ≤ n → m < n
    suc-≤→< zero (suc n) leq = z<s
    suc-≤→< (suc m) (suc n) (s≤s leq) = s<s (suc-≤→< m n leq)

    <→suc-≤ : ∀ (m n : ℕ) → m < n → suc m ≤ n
    <→suc-≤ zero (suc n) le = s≤s z≤n
    <→suc-≤ (suc m) (suc n) (s<s le) = s≤s (<→suc-≤ m n le)

    data _>_ : ℕ → ℕ → Set where
        co-m>n : ∀ {m n : ℕ} → n < m → m > n

    ℕ-suc-> : ∀ {m n : ℕ} → m > n → suc m > suc n
    ℕ-suc-> (co-m>n x) = co-m>n (s<s x)

    {- Trichotomy -}
    data Trichotomy (m n : ℕ) : Set where
        t-m>n : m > n → Trichotomy m n
        t-m≡n : m ≡ n → Trichotomy m n
        t-m<n : m < n → Trichotomy m n

    ℕ-suc-Trichotomy : ∀ {m n : ℕ} → Trichotomy m n → Trichotomy (suc m) (suc n)
    ℕ-suc-Trichotomy (t-m>n x) = t-m>n (ℕ-suc-> x)
    ℕ-suc-Trichotomy (t-m≡n refl) = t-m≡n refl
    ℕ-suc-Trichotomy (t-m<n x) = t-m<n (s<s x)

    ℕ-is-Trichotomy : ∀ (m n : ℕ) → Trichotomy m n
    ℕ-is-Trichotomy zero zero = t-m≡n refl
    ℕ-is-Trichotomy zero (suc n) = t-m<n z<s
    ℕ-is-Trichotomy (suc m) zero = t-m>n (co-m>n z<s)
    ℕ-is-Trichotomy (suc m) (suc n) = ℕ-suc-Trichotomy (ℕ-is-Trichotomy m n)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Solver for equations in commutative monoids
--
-- Adapted from Algebra.Solver.Monoid
------------------------------------------------------------------------

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

open import Algebra

module Algebra.Solver.CommutativeMonoid {m₁ m₂} (M : CommutativeMonoid m₁ m₂) where

open import Data.Fin using (Fin; zero; suc)
open import Data.Maybe as Maybe
  using (Maybe; decToMaybe; From-just; from-just)
open import Data.Nat as ℕ using (ℕ; zero; suc; _+_)
open import Data.Nat.GeneralisedArithmetic using (fold)
open import Data.Product using (_×_; uncurry)
open import Data.Vec using (Vec; []; _∷_; lookup; replicate)

open import Function using (_∘_)

import Relation.Binary.Reasoning.Setoid as EqReasoning
import Relation.Binary.Reflection as Reflection
import Relation.Nullary.Decidable as Dec
import Data.Vec.Relation.Binary.Pointwise.Inductive as Pointwise

open import Relation.Binary.PropositionalEquality as P using (_≡_; decSetoid)
open import Relation.Nullary using (Dec)

open CommutativeMonoid M
open EqReasoning setoid

------------------------------------------------------------------------
-- Monoid expressions

-- There is one constructor for every operation, plus one for
-- variables; there may be at most n variables.

infixr 5 _⊕_
infixr 10 _•_

data Expr (n : ℕ) : Set where
  var : Fin n → Expr n
  id  : Expr n
  _⊕_ : Expr n → Expr n → Expr n

-- An environment contains one value for every variable.

Env : ℕ → Set _
Env n = Vec Carrier n

-- The semantics of an expression is a function from an environment to
-- a value.

⟦_⟧ : ∀ {n} → Expr n → Env n → Carrier
⟦ var x   ⟧ ρ = lookup ρ x
⟦ id      ⟧ ρ = ε
⟦ e₁ ⊕ e₂ ⟧ ρ = ⟦ e₁ ⟧ ρ ∙ ⟦ e₂ ⟧ ρ

------------------------------------------------------------------------
-- Normal forms

-- A normal form is a vector of multiplicities (a bag).

Normal : ℕ → Set
Normal n = Vec ℕ n

-- The semantics of a normal form.

⟦_⟧⇓ : ∀ {n} → Normal n → Env n → Carrier
⟦ []    ⟧⇓ _ = ε
⟦ n ∷ v ⟧⇓ (a ∷ ρ) = fold (⟦ v ⟧⇓ ρ) (λ b → a ∙ b) n

------------------------------------------------------------------------
-- Constructions on normal forms

-- The empty bag.

empty : ∀{n} → Normal n
empty = replicate 0

-- A singleton bag.

sg : ∀{n} (i : Fin n) → Normal n
sg zero    = 1 ∷ empty
sg (suc i) = 0 ∷ sg i

-- The composition of normal forms.

_•_  : ∀{n} (v w : Normal n) → Normal n
[]      • []      = []
(l ∷ v) • (m ∷ w) = l + m ∷ v • w

------------------------------------------------------------------------
-- Correctness of the constructions on normal forms

-- The empty bag stands for the unit ε.

empty-correct : ∀{n} (ρ : Env n) → ⟦ empty ⟧⇓ ρ ≈ ε
empty-correct [] = refl
empty-correct (a ∷ ρ) = empty-correct ρ

-- The singleton bag stands for a single variable.

sg-correct : ∀{n} (x : Fin n) (ρ : Env n) →  ⟦ sg x ⟧⇓ ρ ≈ lookup ρ x
sg-correct zero (x ∷ ρ) = begin
    x ∙ ⟦ empty ⟧⇓ ρ   ≈⟨ ∙-congˡ (empty-correct ρ) ⟩
    x ∙ ε              ≈⟨ identityʳ _ ⟩
    x                  ∎
sg-correct (suc x) (m ∷ ρ) = sg-correct x ρ

-- Normal form composition corresponds to the composition of the monoid.

comp-correct : ∀ {n} (v w : Normal n) (ρ : Env n) →
              ⟦ v • w ⟧⇓ ρ ≈ (⟦ v ⟧⇓ ρ ∙ ⟦ w ⟧⇓ ρ)
comp-correct [] [] ρ =  sym (identityˡ _)
comp-correct (l ∷ v) (m ∷ w) (a ∷ ρ) = lemma l m (comp-correct v w ρ)
  where
    flip12 : ∀ a b c → a ∙ (b ∙ c) ≈ b ∙ (a ∙ c)
    flip12 a b c = begin
        a ∙ (b ∙ c)  ≈⟨ sym (assoc _ _ _) ⟩
        (a ∙ b) ∙ c  ≈⟨ ∙-congʳ (comm _ _) ⟩
        (b ∙ a) ∙ c  ≈⟨ assoc _ _ _ ⟩
        b ∙ (a ∙ c)  ∎
    lemma : ∀ l m {d b c} (p : d ≈ b ∙ c) →
      fold d (a ∙_) (l + m) ≈ fold b (a ∙_) l ∙ fold c (a ∙_) m
    lemma zero zero p = p
    lemma zero (suc m) p = trans (∙-congˡ (lemma zero m p)) (flip12 _ _ _)
    lemma (suc l) m p = trans (∙-congˡ (lemma l m p)) (sym (assoc a _ _))

------------------------------------------------------------------------
-- Normalization

-- A normaliser.

normalise : ∀ {n} → Expr n → Normal n
normalise (var x)   = sg x
normalise id        = empty
normalise (e₁ ⊕ e₂) = normalise e₁ • normalise e₂

-- The normaliser preserves the semantics of the expression.

normalise-correct : ∀ {n} (e : Expr n) (ρ : Env n) →
    ⟦ normalise e ⟧⇓ ρ ≈ ⟦ e ⟧ ρ
normalise-correct (var x)   ρ = sg-correct x ρ
normalise-correct id        ρ = empty-correct ρ
normalise-correct (e₁ ⊕ e₂) ρ =  begin

    ⟦ normalise e₁ • normalise e₂ ⟧⇓ ρ

  ≈⟨ comp-correct (normalise e₁) (normalise e₂) ρ ⟩

    ⟦ normalise e₁ ⟧⇓ ρ ∙ ⟦ normalise e₂ ⟧⇓ ρ

  ≈⟨ ∙-cong (normalise-correct e₁ ρ) (normalise-correct e₂ ρ) ⟩

    ⟦ e₁ ⟧ ρ ∙ ⟦ e₂ ⟧ ρ
  ∎

------------------------------------------------------------------------
-- "Tactics"

open module R = Reflection
                  setoid var ⟦_⟧ (⟦_⟧⇓ ∘ normalise) normalise-correct
  public using (solve; _⊜_)

-- We can decide if two normal forms are /syntactically/ equal.

infix 5 _≟_

_≟_ : ∀ {n} (nf₁ nf₂ : Normal n) → Dec (nf₁ ≡ nf₂)
nf₁ ≟ nf₂ = Dec.map Pointwise-≡↔≡ (decidable ℕ._≟_ nf₁ nf₂)
  where open Pointwise

-- We can also give a sound, but not necessarily complete, procedure
-- for determining if two expressions have the same semantics.

prove′ : ∀ {n} (e₁ e₂ : Expr n) → Maybe (∀ ρ → ⟦ e₁ ⟧ ρ ≈ ⟦ e₂ ⟧ ρ)
prove′ e₁ e₂ =
  Maybe.map lemma (decToMaybe (normalise e₁ ≟ normalise e₂))
  where
  lemma : normalise e₁ ≡ normalise e₂ → ∀ ρ → ⟦ e₁ ⟧ ρ ≈ ⟦ e₂ ⟧ ρ
  lemma eq ρ =
    R.prove ρ e₁ e₂ (begin
      ⟦ normalise e₁ ⟧⇓ ρ  ≡⟨ P.cong (λ e → ⟦ e ⟧⇓ ρ) eq ⟩
      ⟦ normalise e₂ ⟧⇓ ρ  ∎)

-- This procedure can be combined with from-just.

prove : ∀ n (e₁ e₂ : Expr n) → From-just (prove′ e₁ e₂)
prove _ e₁ e₂ = from-just (prove′ e₁ e₂)

-- prove : ∀ n (es : Expr n × Expr n) →
--         From-just (uncurry prove′ es)
-- prove _ = from-just ∘ uncurry prove′


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Susp.Properties where

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

open import Cubical.Data.Bool
open import Cubical.HITs.Join
open import Cubical.HITs.Susp.Base

open Iso

Susp-iso-joinBool : ∀ {ℓ} {A : Type ℓ} → Iso (Susp A) (join A Bool)
fun Susp-iso-joinBool north = inr true
fun Susp-iso-joinBool south = inr false
fun Susp-iso-joinBool (merid a i) = (sym (push a true) ∙ push a false) i
inv Susp-iso-joinBool (inr true ) = north
inv Susp-iso-joinBool (inr false) = south
inv Susp-iso-joinBool (inl _) = north
inv Susp-iso-joinBool (push a true  i) = north
inv Susp-iso-joinBool (push a false i) = merid a i
rightInv Susp-iso-joinBool (inr true ) = refl
rightInv Susp-iso-joinBool (inr false) = refl
rightInv Susp-iso-joinBool (inl a) = sym (push a true)
rightInv Susp-iso-joinBool (push a true  i) j = push a true (i ∨ ~ j)
rightInv Susp-iso-joinBool (push a false i) j
  = hcomp (λ k → λ { (i = i0) → push a true (~ j)
                   ; (i = i1) → push a false k
                   ; (j = i1) → push a false (i ∧ k) })
          (push a true (~ i ∧ ~ j))
leftInv Susp-iso-joinBool north = refl
leftInv Susp-iso-joinBool south = refl
leftInv (Susp-iso-joinBool {A = A}) (merid a i) j
  = hcomp (λ k → λ { (i = i0) → transp (λ _ → Susp A) (k ∨ j) north
                   ; (i = i1) → transp (λ _ → Susp A) (k ∨ j) (merid a k)
                   ; (j = i1) → merid a (i ∧ k) })
          (transp (λ _ → Susp A) j north)

Susp≃joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≃ join A Bool
Susp≃joinBool = isoToEquiv Susp-iso-joinBool

Susp≡joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≡ join A Bool
Susp≡joinBool = isoToPath Susp-iso-joinBool

congSuspEquiv : ∀ {ℓ} {A B : Type ℓ} → A ≃ B → Susp A ≃ Susp B
congSuspEquiv {ℓ} {A} {B} h = isoToEquiv isom
  where isom : Iso (Susp A) (Susp B)
        Iso.fun isom north = north
        Iso.fun isom south = south
        Iso.fun isom (merid a i) = merid (fst h a) i
        Iso.inv isom north = north
        Iso.inv isom south = south
        Iso.inv isom (merid a i) = merid (invEq h a) i
        Iso.rightInv isom north = refl
        Iso.rightInv isom south = refl
        Iso.rightInv isom (merid a i) j = merid (retEq h a j) i
        Iso.leftInv isom north = refl
        Iso.leftInv isom south = refl
        Iso.leftInv isom (merid a i) j = merid (secEq h a j) i

suspToPropRec : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Susp A → Type ℓ'} (a : A)
                 → ((x : Susp A) → isProp (B x))
                 → B north
                 → (x : Susp A) → B x
suspToPropRec a isProp Bnorth north = Bnorth
suspToPropRec {B = B} a isProp Bnorth south = subst B (merid a) Bnorth
suspToPropRec {B = B} a isProp Bnorth (merid a₁ i) =
  isOfHLevel→isOfHLevelDep 1 isProp Bnorth (subst B (merid a) Bnorth) (merid a₁) i

suspToPropRec2 : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Susp A → Susp A → Type ℓ'} (a : A)
                 → ((x y : Susp A) → isProp (B x y))
                 → B north north
                 → (x y : Susp A) → B x y
suspToPropRec2 a isProp Bnorth =
  suspToPropRec a (λ x → isOfHLevelΠ 1 λ y → isProp x y)
                      (suspToPropRec a (λ x → isProp north x) Bnorth)


open import Relation.Binary using (Decidable; Setoid; DecSetoid)
open import Level

module CP.Session3 {a} {b} (ChanDecSetoid : DecSetoid zero a) (TypeDecSetoid : DecSetoid zero b) where

module TS = DecSetoid TypeDecSetoid

Type : Set
Type = DecSetoid.Carrier TypeDecSetoid

open DecSetoid ChanDecSetoid

Chan : Set
Chan = Carrier

module _ where
  -- type of
  infix 6 _∶_
  data TypeOf : Set a where
    _∶_ : (x : Chan) → (A : Type) → TypeOf

  chanOf : TypeOf → Chan
  chanOf (x ∶ _) = x

  import Relation.Binary.Construct.On as On

  decSetoid : DecSetoid _ _
  decSetoid = On.decSetoid ChanDecSetoid chanOf

open import Data.List.Relation.Binary.Subset.DecSetoid decSetoid
open import Data.List

Session : Set a
Session = List TypeOf

open import Relation.Nullary
open import Relation.Nullary.Decidable

open import Data.Product
open import Data.Maybe

seperate : (Γ : Session) → (x : Chan) → Maybe (∃[ Δ ] ∃[ A ] (Γ ≋ x ∶ A ∷ Δ))
seperate []          x = nothing
seperate (y ∶ A ∷ Γ) x with y ≟ x
... | yes P = just (Γ , A , ∷-cong P ≋-refl)
... | no ¬P with seperate Γ x
... | just (Δ , B , eq) = just (y ∶ A ∷ Δ , B , reasoning)
  where
    open EqReasoning
    reasoning : y ∶ A ∷ Γ ≋ x ∶ B ∷ y ∶ A ∷ Δ
    reasoning =
      begin
        y ∶ A ∷ Γ
      ≈⟨ ∷-cong refl eq ⟩
        y ∶ A ∷ x ∶ B ∷ Δ
      ≈⟨ ≋-swap ⟩
        x ∶ B ∷ y ∶ A ∷ Δ
      ∎
... | nothing = nothing

-- insertion
infixl 5 _#_
_#_ : Session → TypeOf → Session
Γ # (x ∶ A) with seperate Γ x
... | nothing = x ∶ A ∷ Γ
... | just (Δ , _ , _) = x ∶ A ∷ Δ

insert-idempotent : ∀ Γ x A → Γ # x ∶ A # x ∶ A ≋ Γ # x ∶ A
insert-idempotent Γ x A with seperate Γ x
insert-idempotent Γ x A | nothing with seperate (x ∶ A ∷ Γ) x
... | nothing = {!   !}
... | just x₁ = {!   !}
insert-idempotent Γ x A | just x₁ = {!   !}