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

open import lib.Basics
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.types.Span
open import lib.types.Paths
import lib.types.Generic1HIT as Generic1HIT

module lib.types.Pushout where

module _ {i j k} where

  postulate  -- HIT
    Pushout : (d : Span {i} {j} {k}) → Type (lmax (lmax i j) k)

  module _ {d : Span} where

    postulate  -- HIT
      left : Span.A d → Pushout d
      right : Span.B d → Pushout d
      glue : (c : Span.C d) → left (Span.f d c) == right (Span.g d c)

  module PushoutElim {d : Span} {l} {P : Pushout d → Type l}
    (left* : (a : Span.A d) → P (left a))
    (right* : (b : Span.B d) → P (right b))
    (glue* : (c : Span.C d) → left* (Span.f d c) == right* (Span.g d c) [ P ↓ glue c ]) where

    postulate  -- HIT
      f : Π (Pushout d) P
      left-β : ∀ a → f (left a) ↦ left* a
      right-β : ∀ b → f (right b) ↦ right* b
    {-# REWRITE left-β #-}
    {-# REWRITE right-β #-}

    postulate  -- HIT
      glue-β : (c : Span.C d) → apd f (glue c) == glue* c

Pushout-elim = PushoutElim.f

module PushoutRec {i j k} {d : Span {i} {j} {k}} {l} {D : Type l}
  (left* : Span.A d → D) (right* : Span.B d → D)
  (glue* : (c : Span.C d) → left* (Span.f d c) == right* (Span.g d c)) where

  private
    module M = PushoutElim left* right* (λ c → ↓-cst-in (glue* c))

  f : Pushout d → D
  f = M.f

  glue-β : (c : Span.C d) → ap f (glue c) == glue* c
  glue-β c = apd=cst-in {f = f} (M.glue-β c)

Pushout-rec = PushoutRec.f

Pushout-rec-η : ∀ {i j k} {d : Span {i} {j} {k}} {l} {D : Type l} (f : Pushout d → D)
  → Pushout-rec (f ∘ left) (f ∘ right) (ap f ∘ glue) ∼ f
Pushout-rec-η f = Pushout-elim (λ _ → idp) (λ _ → idp)
  (λ c → ↓-='-in' $ ! $ PushoutRec.glue-β (f ∘ left) (f ∘ right) (ap f ∘ glue) c)

module PushoutGeneric {i j k} {d : Span {i} {j} {k}} where

  open Span d renaming (f to g; g to h)

  open Generic1HIT (Coprod A B) C (inl ∘ g) (inr ∘ h) public

  module _ where

    module To = PushoutRec (cc ∘ inl) (cc ∘ inr) pp

    to : Pushout d → T
    to = To.f

    from-cc : Coprod A B → Pushout d
    from-cc (inl a) = left a
    from-cc (inr b) = right b

    module From = Rec from-cc glue

    from : T → Pushout d
    from = From.f

    abstract
      to-from : (x : T) → to (from x) == x
      to-from = elim to-from-cc to-from-pp where

        to-from-cc : (x : Coprod A B)
          → to (from (cc x)) == cc x
        to-from-cc (inl a) = idp
        to-from-cc (inr b) = idp

        to-from-pp :
          (c : C) → idp == idp [ (λ z → to (from z) == z) ↓ pp c ]
        to-from-pp c = ↓-∘=idf-in' to from
          (ap to (ap from (pp c))   =⟨ From.pp-β c |in-ctx ap to ⟩
           ap to (glue c)           =⟨ To.glue-β c ⟩
           pp c =∎)

      from-to : (x : Pushout d) → from (to x) == x
      from-to = Pushout-elim (λ a → idp) (λ b → idp) (λ c → ↓-∘=idf-in' from to
        (ap from (ap to (glue c))   =⟨ To.glue-β c |in-ctx ap from ⟩
         ap from (pp c)             =⟨ From.pp-β c ⟩
         glue c =∎))

  generic-pushout : Pushout d ≃ T
  generic-pushout = equiv to from to-from from-to

_⊔^[_]_/_ : ∀ {i j k} (A : Type i) (C : Type k) (B : Type j)
  (fg : (C → A) × (C → B)) → Type (lmax (lmax i j) k)
A ⊔^[ C ] B  / (f , g) = Pushout (span A B C f g)

⊙Pushout : ∀ {i j k} (d : ⊙Span {i} {j} {k}) → Ptd _
⊙Pushout d = ⊙[ Pushout (⊙Span-to-Span d) , left (pt (⊙Span.X d)) ]

module _ {i j k} (d : ⊙Span {i} {j} {k}) where

  open ⊙Span d

  ⊙left : X ⊙→ ⊙Pushout d
  ⊙left = (left , idp)

  ⊙right : Y ⊙→ ⊙Pushout d
  ⊙right =
    (right , ap right (! (snd g)) ∙ ! (glue (pt Z)) ∙' ap left (snd f))

  ⊙glue : (⊙left ⊙∘ f) == (⊙right ⊙∘ g)
  ⊙glue = pair=
    (λ= glue)
    (↓-app=cst-in $
      ap left (snd f) ∙ idp
        =⟨ ∙-unit-r _ ⟩
      ap left (snd f)
        =⟨ lemma (glue (pt Z)) (ap right (snd g)) (ap left (snd f)) ⟩
      glue (pt Z) ∙ ap right (snd g)
      ∙ ! (ap right (snd g)) ∙ ! (glue (pt Z)) ∙' ap left (snd f)
        =⟨ !-ap right (snd g)
           |in-ctx (λ w → glue (pt Z) ∙ ap right (snd g) ∙ w
                          ∙ ! (glue (pt Z)) ∙' ap left (snd f)) ⟩
      glue (pt Z) ∙ ap right (snd g)
      ∙ ap right (! (snd g)) ∙ ! (glue (pt Z)) ∙' ap left (snd f)
        =⟨ ! (app=-β glue (pt Z))
           |in-ctx (λ w → w ∙ ap right (snd g) ∙ ap right (! (snd g))
                            ∙ ! (glue (pt Z)) ∙' ap left (snd f)) ⟩
      app= (λ= glue) (pt Z) ∙ ap right (snd g)
      ∙ ap right (! (snd g)) ∙ ! (glue (pt Z)) ∙' ap left (snd f) =∎)
    where
    lemma : ∀ {i} {A : Type i} {x y z w : A}
      (p : x == y) (q : y == z) (r : x == w)
      → r == p ∙ q ∙ ! q ∙ ! p ∙' r
    lemma idp idp idp = idp

⊙pushout-J : ∀ {i j k l} (P : ⊙Span → Type l)
  → ({A : Type i} {B : Type j} (Z : Ptd k) (f : de⊙ Z → A) (g : de⊙ Z → B)
     → P (⊙span ⊙[ A , f (pt Z) ] ⊙[ B , g (pt Z) ] Z (f , idp) (g , idp)))
  → ((ps : ⊙Span) → P ps)
⊙pushout-J P t (⊙span ⊙[ _ , ._ ] ⊙[ _ , ._ ] Z (f , idp) (g , idp)) = t Z f g


{-# OPTIONS --safe #-}
module Cubical.Algebra.DirectSum.Equiv-DSHIT-DSFun where

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

open import Cubical.Relation.Nullary

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Nat renaming (_+_ to _+n_)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Sigma
open import Cubical.Data.Sum
open import Cubical.Data.Vec
open import Cubical.Data.Vec.DepVec

open import Cubical.HITs.PropositionalTruncation as PT

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.AbGroup.Instances.DirectSumFun
open import Cubical.Algebra.AbGroup.Instances.DirectSumHIT
open import Cubical.Algebra.AbGroup.Instances.NProd

open import Cubical.Algebra.DirectSum.DirectSumFun.Base
open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.DirectSum.DirectSumHIT.Properties
open import Cubical.Algebra.DirectSum.DirectSumHIT.PseudoNormalForm

private variable
  ℓ : Level

open GroupTheory
open AbGroupTheory
open AbGroupStr

-----------------------------------------------------------------------------
-- Notation

module Equiv-Properties
  (G : ℕ → Type ℓ)
  (Gstr : (n : ℕ) → AbGroupStr (G n))
  where

  -- the convention is a bit different and had a -
  -- because otherwise it is unreadable

  open AbGroupStr (snd (⊕HIT-AbGr ℕ G Gstr)) using ()
    renaming
    ( 0g       to 0⊕HIT
    ; _+_      to _+⊕HIT_
    ; -_       to -⊕HIT_
    ; +Assoc   to +⊕HIT-Assoc
    ; +IdR     to +⊕HIT-IdR
    ; +IdL     to +⊕HIT-IdL
    ; +InvR    to +⊕HIT-InvR
    ; +InvL    to +⊕HIT-InvL
    ; +Comm     to +⊕HIT-Comm
    ; is-set   to isSet⊕HIT)

  open AbGroupStr (snd (⊕Fun-AbGr G Gstr)) using ()
    renaming
    ( 0g       to 0⊕Fun
    ; _+_      to _+⊕Fun_
    ; -_       to -⊕Fun_
    ; +Assoc   to +⊕Fun-Assoc
    ; +IdR     to +⊕Fun-IdR
    ; +IdL     to +⊕Fun-IdL
    ; +InvR    to +⊕Fun-InvR
    ; +InvL    to +⊕Fun-InvL
    ; +Comm     to +⊕Fun-Comm
    ; is-set   to isSet⊕Fun)

-----------------------------------------------------------------------------
-- AbGroup on Fun -> produit ? sequence ?

  open AbGroupStr (snd (NProd-AbGroup G Gstr)) using ()
      renaming
    ( 0g       to 0Fun
    ; _+_      to _+Fun_
    ; -_       to -Fun_
    ; +Assoc   to +FunAssoc
    ; +IdR     to +FunIdR
    ; +IdL     to +FunIdL
    ; +InvR    to +FunInvR
    ; +InvL    to +FunInvL
    ; +Comm     to +FunComm
    ; is-set   to isSetFun)

-----------------------------------------------------------------------------
-- Some simplification for transport

  open SubstLemma ℕ G Gstr

  substG : (g : (n : ℕ) → G n) → {k n : ℕ} → (p : k ≡ n) → subst G p (g k) ≡ g n
  substG g {k} {n} p = J (λ n p → subst G p (g k) ≡ g n) (transportRefl _) p

-----------------------------------------------------------------------------
-- Direct Sense

  -- To facilitate the proof the translation to the function
  -- and its properties are done in two times

  ---------------------------------------------------------------------------
  -- Translation to the function

  fun-trad : (k : ℕ) → (a : G k) → (n : ℕ) → G n
  fun-trad k a n with (discreteℕ k n)
  ... | yes p = subst G p a
  ... | no ¬p = 0g (Gstr n)

  fun-trad-eq : (k : ℕ) → (a : G k) → fun-trad k a k ≡ a
  fun-trad-eq k a with discreteℕ k k
  ... | yes p = cong (λ X → subst G X a) (isSetℕ _ _ _ _) ∙ transportRefl a
  ... | no ¬p = ⊥.rec (¬p refl)

  fun-trad-neq : (k : ℕ) → (a : G k) → (n : ℕ) → (k ≡ n → ⊥) → fun-trad k a n ≡ 0g (Gstr n)
  fun-trad-neq k a n ¬q with discreteℕ k n
  ... | yes p = ⊥.rec (¬q p)
  ... | no ¬p = refl

  ⊕HIT→Fun : ⊕HIT ℕ G Gstr → (n : ℕ) → G n
  ⊕HIT→Fun = DS-Rec-Set.f _ _ _ _ isSetFun
              0Fun
              fun-trad
              _+Fun_
              +FunAssoc
              +FunIdR
              +FunComm
              (λ k → funExt (λ n → base0-eq k n))
              λ k a b → funExt (λ n → base-add-eq k a b n)
           where
           base0-eq : (k : ℕ) → (n : ℕ) → fun-trad k (0g (Gstr k)) n ≡ 0g (Gstr n)
           base0-eq k n with (discreteℕ k n)
           ... | yes p = subst0g _
           ... | no ¬p = refl

           base-add-eq : (k : ℕ) → (a b : G k) → (n : ℕ) →
                         PathP (λ _ → G n) (Gstr n ._+_ (fun-trad k a n) (fun-trad k b n))
                                                         (fun-trad k ((Gstr k + a) b) n)
           base-add-eq k a b n with (discreteℕ k n)
           ... | yes p = subst+ _ _ _
           ... | no ¬p = +IdR (Gstr n)_

  ⊕HIT→Fun-pres0 : ⊕HIT→Fun 0⊕HIT ≡ 0Fun
  ⊕HIT→Fun-pres0 = refl

  ⊕HIT→Fun-pres+ : (x y : ⊕HIT ℕ G Gstr) → ⊕HIT→Fun (x +⊕HIT y) ≡ ((⊕HIT→Fun x) +Fun (⊕HIT→Fun y))
  ⊕HIT→Fun-pres+ x y = refl

  ---------------------------------------------------------------------------
  -- Translation to the properties

  nfun-trad : (k : ℕ) → (a : G k) → AlmostNull G Gstr (fun-trad k a)
  nfun-trad k a = k , fix-eq
    where
    fix-eq : (n : ℕ) → k < n → fun-trad k a n ≡ 0g (Gstr n)
    fix-eq n q with (discreteℕ k n)
    ... | yes p = ⊥.rec (<→≢ q p)
    ... | no ¬p = refl

  ⊕HIT→⊕AlmostNull : (x : ⊕HIT ℕ G Gstr) → AlmostNullP G Gstr (⊕HIT→Fun x)
  ⊕HIT→⊕AlmostNull = DS-Ind-Prop.f _ _ _ _ (λ x → squash₁)
                      ∣ (0 , (λ n q → refl)) ∣₁
                      (λ r a → ∣ (nfun-trad r a) ∣₁)
                      λ {U} {V} → PT.elim (λ _ → isPropΠ (λ _ → squash₁))
                                   (λ { (k , nu) → PT.elim (λ _ → squash₁)
                                    λ { (l , nv) →
                                   ∣ ((k +n l) , (λ n q → cong₂ ((Gstr n)._+_) (nu n (<-+k-trans q)) (nv n (<-k+-trans q))
                                                          ∙ +IdR (Gstr n) _)) ∣₁} })

  ---------------------------------------------------------------------------
  -- Translation + Morphism

  ⊕HIT→⊕Fun : ⊕HIT ℕ G Gstr → ⊕Fun G Gstr
  ⊕HIT→⊕Fun x = (⊕HIT→Fun x) , (⊕HIT→⊕AlmostNull x)

  ⊕HIT→⊕Fun-pres0 : ⊕HIT→⊕Fun 0⊕HIT ≡ 0⊕Fun
  ⊕HIT→⊕Fun-pres0 = refl

  ⊕HIT→⊕Fun-pres+ : (x y : ⊕HIT ℕ G Gstr) → ⊕HIT→⊕Fun (x +⊕HIT y) ≡ ((⊕HIT→⊕Fun x) +⊕Fun (⊕HIT→⊕Fun y))
  ⊕HIT→⊕Fun-pres+ x y = ΣPathTransport→PathΣ _ _ (refl , (squash₁ _ _))

-----------------------------------------------------------------------------
-- Converse sense

  -----------------------------------------------------------------------------
  -- Prood that ⊕HIT→⊕Fun is injective

  open DefPNF G Gstr

  sumFun : {m : ℕ} → depVec G m → (n : ℕ) → G n
  sumFun {0} ⋆ = 0Fun
  sumFun {suc m} (a □ dv) = (⊕HIT→Fun (base m a)) +Fun (sumFun dv)

  SumHIT→SumFun : {m : ℕ} → (dv : depVec G m) → ⊕HIT→Fun (sumHIT dv) ≡ sumFun dv
  SumHIT→SumFun {0} ⋆ = refl
  SumHIT→SumFun {suc m} (a □ dv) = cong₂ _+Fun_ refl (SumHIT→SumFun dv)

  sumFun< : {m : ℕ} → (dv : depVec G m) → (i : ℕ) → (m ≤ i) → sumFun dv i ≡ 0g (Gstr i)
  sumFun< {0} ⋆ i r = refl
  sumFun< {suc m} (a □ dv) i r with discreteℕ m i
  ... | yes p = ⊥.rec (<→≢ r p)
  ... | no ¬p = +IdL (Gstr i) _ ∙ sumFun< dv i (≤-trans ≤-sucℕ r)

  sumFunHead : {m : ℕ} → (a b : (G m)) → (dva dvb : depVec G m) →
               (x : sumFun (a □ dva) ≡ sumFun (b □ dvb)) → a ≡ b
  sumFunHead {m} a b dva dvb x =
               a
                        ≡⟨ sym (+IdR (Gstr m) _) ⟩
               (Gstr m)._+_ a (0g (Gstr m))
                        ≡⟨ cong₂ (Gstr m ._+_) (sym (fun-trad-eq m a)) (sym (sumFun< dva m ≤-refl)) ⟩
               (Gstr m)._+_ (fun-trad m a m) (sumFun dva m)
                        ≡⟨ funExt⁻ x m ⟩
               (Gstr m)._+_ (fun-trad m b m) (sumFun dvb m)
                        ≡⟨ cong₂ (Gstr m ._+_) (fun-trad-eq m b) (sumFun< dvb m ≤-refl) ⟩
               (Gstr m)._+_ b (0g (Gstr m))
                        ≡⟨ +IdR (Gstr m) _ ⟩
               b ∎

  substSumFun : {m : ℕ} → (dv : depVec G m) → (n : ℕ) → (p : m ≡ n)
                → subst G p (sumFun dv m) ≡ sumFun dv n
  substSumFun {m} dv n p = J (λ n p → subst G p (sumFun dv m) ≡ sumFun dv n)
                             (transportRefl _)
                             p

  sumFunTail : {m : ℕ} → (a b : (G m)) → (dva dvb : depVec G m) →
             (x : sumFun (a □ dva) ≡ sumFun (b □ dvb)) → (n : ℕ) →
             sumFun dva n ≡ sumFun dvb n
  sumFunTail {m} a b dva dvb x n with discreteℕ m n
  ... | yes p = sumFun dva n                   ≡⟨ sym (substSumFun dva n p) ⟩
                subst G p (sumFun dva m)       ≡⟨ cong (subst G p) (sumFun< dva m ≤-refl) ⟩
                subst G p (0g (Gstr m))        ≡⟨ subst0g p ⟩
                0g (Gstr n)                    ≡⟨ sym (subst0g p) ⟩
                subst G p (0g (Gstr m))        ≡⟨ sym (cong (subst G p) (sumFun< dvb m ≤-refl)) ⟩
                subst G p (sumFun dvb m)       ≡⟨ substSumFun dvb n p ⟩
                sumFun dvb n ∎
  ... | no ¬p = sumFun dva n                                 ≡⟨ sym (+IdL (Gstr n) _) ⟩
                (Gstr n)._+_ (0g (Gstr n)) (sumFun dva n)    ≡⟨ cong (λ X → (Gstr n)._+_ X (sumFun dva n))
                                                                             (sym (fun-trad-neq m a n ¬p)) ⟩
                Gstr n ._+_ (fun-trad m a n) (sumFun dva n)  ≡⟨ funExt⁻ x n ⟩
                Gstr n ._+_ (fun-trad m b n) (sumFun dvb n)  ≡⟨ cong (λ X → Gstr n ._+_ X (sumFun dvb n))
                                                                             (fun-trad-neq m b n ¬p) ⟩
                (Gstr n)._+_ (0g (Gstr n)) (sumFun dvb n)    ≡⟨ +IdL (Gstr n) _ ⟩
                sumFun dvb n ∎

  injSumFun : {m : ℕ} → (dva dvb : depVec G m) → sumFun dva ≡ sumFun dvb → dva ≡ dvb
  injSumFun {0} ⋆ ⋆ x = refl
  injSumFun {suc m} (a □ dva) (b □ dvb) x = depVecPath.decode G (a □ dva) (b □ dvb)
                                         ((sumFunHead a b dva dvb x)
                                         , (injSumFun dva dvb (funExt (sumFunTail a b dva dvb x))))

  injSumHIT : {m : ℕ} → (dva dvb : depVec G m) → ⊕HIT→Fun (sumHIT dva) ≡ ⊕HIT→Fun (sumHIT dvb) → dva ≡ dvb
  injSumHIT dva dvb r = injSumFun dva dvb (sym (SumHIT→SumFun dva) ∙ r ∙ SumHIT→SumFun dvb)

  inj-⊕HIT→Fun : (x y : ⊕HIT ℕ G Gstr) → ⊕HIT→Fun x ≡ ⊕HIT→Fun y → x ≡ y
  inj-⊕HIT→Fun x y r = helper (⊕HIT→PNF2 x y) r
    where
    helper : PNF2 x y → ⊕HIT→Fun x ≡ ⊕HIT→Fun y → x ≡ y
    helper = PT.elim (λ _ → isPropΠ (λ _ → isSet⊕HIT _ _))
                     λ { (m , dva , dvb , p , q) r →
                         p
                         ∙ cong sumHIT (injSumHIT dva dvb (sym (cong ⊕HIT→Fun p) ∙ r ∙ cong ⊕HIT→Fun q))
                         ∙ sym q}

  inj-⊕HIT→⊕Fun : (x y : ⊕HIT ℕ G Gstr) → ⊕HIT→⊕Fun x ≡ ⊕HIT→⊕Fun y → x ≡ y
  inj-⊕HIT→⊕Fun x y p = inj-⊕HIT→Fun x y (fst (PathΣ→ΣPathTransport _ _ p))

  lemProp : (g : ⊕Fun G Gstr) → isProp (Σ[ x ∈ ⊕HIT ℕ G Gstr ] ⊕HIT→⊕Fun x ≡ g )
  lemProp g (x , p) (y , q) = ΣPathTransport→PathΣ _ _
                              ((inj-⊕HIT→⊕Fun x y (p ∙ sym q)) , isSet⊕Fun _ _ _ _)

  ---------------------------------------------------------------------------
  --  General translation for underliyng function

  Strad : (g : (n : ℕ) → G n) → (i : ℕ) → ⊕HIT ℕ G Gstr
  Strad g zero = base 0 (g 0)
  Strad g (suc i) = (base (suc i) (g (suc i))) +⊕HIT (Strad g i)

  Strad-pres+ : (f g : (n : ℕ) → G n) → (i : ℕ) → Strad (f +Fun g) i ≡ Strad f i +⊕HIT Strad g i
  Strad-pres+ f g zero = sym (base-add 0 (f 0) (g 0))
  Strad-pres+ f g (suc i) = cong₂ _+⊕HIT_ (sym (base-add _ _ _))
                                          (Strad-pres+ f g i)
                            ∙ comm-4 (⊕HIT-AbGr ℕ G Gstr) _ _ _ _

  -- Properties in the converse sens
  Strad-max : (f : (n : ℕ) → G n) → (k : ℕ) → (ng : AlmostNullProof G Gstr f k)
              → (i : ℕ) → (r : k ≤ i) → Strad f i ≡ Strad f k
  Strad-max f k ng zero r = sym (cong (Strad f) (≤0→≡0 r))
  Strad-max f k ng (suc i) r with ≤-split r
  ... | inl x = cong₂ _+⊕HIT_
                      (cong (base (suc i)) (ng (suc i) x) ∙ base-neutral (suc i))
                      (Strad-max f k ng i (pred-≤-pred x))
                ∙ +⊕HIT-IdL _
  ... | inr x = cong (Strad f) (sym x)

  -- if m < n then the translation of sum up to i is 0
  Strad-m<n : (g : (n : ℕ) → G n) → (m : ℕ) → (n : ℕ) → (r : m < n)
            → ⊕HIT→Fun (Strad g m) n ≡ 0g (Gstr n)
  Strad-m<n g zero n r with discreteℕ 0 n
  ... | yes p = ⊥.rec (<→≢ r p)
  ... | no ¬p = refl
  Strad-m<n g (suc m) n r with discreteℕ (suc m) n
  ... | yes p = ⊥.rec (<→≢ r p)
  ... | no ¬p = +IdL (Gstr n) _ ∙ Strad-m<n g m n (<-trans ≤-refl r)

  {- if n ≤ m, prove ⊕HIT→Fun (∑_{i ∈〚0, m〛} base i (g i)) ≡ g n
     then n is equal to only one〚0, m〛=> induction on m
     case 0 : ok
     case suc m : if n ≡ suc m, then the rest of the sum is 0 by trad-m<n
                  if n ≢ suc m, then it is in the rest of the sum => recursive call -}
  Strad-n≤m : (g : (n : ℕ) → G n) → (m : ℕ) → (n : ℕ) → (r : n ≤ m) → ⊕HIT→Fun (Strad g m) n ≡ g n
  Strad-n≤m g zero n r with discreteℕ 0 n
  ... | yes p = substG g p
  ... | no ¬p = ⊥.rec (¬p (sym (≤0→≡0 r)))
  Strad-n≤m g (suc m) n r with discreteℕ (suc m) n
  ... | yes p = cong₂ ((Gstr n)._+_) (substG g p) (Strad-m<n g m n (0 , p)) ∙ +IdR (Gstr n) _
  ... | no ¬p = +IdL (Gstr n) _ ∙ Strad-n≤m g m n (≤-suc-≢ r λ x → ¬p (sym x))

  ---------------------------------------------------------------------------
  -- Translation + Morphsim

  -- translation
  ⊕Fun→⊕HIT+ : (g : ⊕Fun G Gstr) → Σ[ x ∈ ⊕HIT ℕ G Gstr ] ⊕HIT→⊕Fun x ≡ g
  ⊕Fun→⊕HIT+ (g , Ang) = PT.rec (lemProp (g , Ang))
                          (λ { (k , ng)
                               → Strad g k , ΣPathTransport→PathΣ _ _
                                              ((funExt (trad-section g k ng)) , (squash₁ _ _)) })
                          Ang
             where
             trad-section : (g : (n : ℕ) → G n) → (k : ℕ) → (ng : (n : ℕ) → ( k < n) → g n ≡ 0g (Gstr n))
                            → (n : ℕ) → ⊕HIT→Fun (Strad g k) n ≡ g n
             trad-section g k ng n with splitℕ-≤ n k
             ... | inl x = Strad-n≤m g k n x
             ... | inr x = Strad-m<n g k n x ∙ sym (ng n x)

  ⊕Fun→⊕HIT : ⊕Fun G Gstr → ⊕HIT ℕ G Gstr
  ⊕Fun→⊕HIT g = fst (⊕Fun→⊕HIT+ g)

  -- morphism
  ⊕Fun→⊕HIT-pres0 : ⊕Fun→⊕HIT 0⊕Fun ≡ 0⊕HIT
  ⊕Fun→⊕HIT-pres0 = base-neutral 0

  ⊕Fun→⊕HIT-pres+ : (f g : ⊕Fun G Gstr) → ⊕Fun→⊕HIT (f +⊕Fun g) ≡ (⊕Fun→⊕HIT f) +⊕HIT (⊕Fun→⊕HIT g)
  ⊕Fun→⊕HIT-pres+ (f , Anf) (g , Ang) = PT.elim2 (λ x y → isSet⊕HIT (⊕Fun→⊕HIT ((f , x) +⊕Fun (g , y)))
                                                                   ((⊕Fun→⊕HIT (f , x)) +⊕HIT (⊕Fun→⊕HIT (g , y))))
                                                  (λ x y → AN f x g y)
                                                   Anf Ang

    where
    AN : (f : (n : ℕ) → G n) → (x : AlmostNull G Gstr f) → (g : (n : ℕ) → G n) → (y : AlmostNull G Gstr g)
                     → ⊕Fun→⊕HIT ((f , ∣ x ∣₁) +⊕Fun (g , ∣ y ∣₁)) ≡ (⊕Fun→⊕HIT (f , ∣ x ∣₁)) +⊕HIT (⊕Fun→⊕HIT (g , ∣ y ∣₁))
    AN f (k , nf) g (l , ng) = Strad-pres+ f g (k +n l)
                               ∙ cong₂ _+⊕HIT_ (Strad-max f k nf (k +n l) (l , (+-comm l k)))
                                               (Strad-max g l ng (k +n l) (k , refl))

-----------------------------------------------------------------------------
-- Section

  e-sect : (g : ⊕Fun G Gstr) → ⊕HIT→⊕Fun (⊕Fun→⊕HIT g) ≡ g
  e-sect g = snd (⊕Fun→⊕HIT+ g)

-----------------------------------------------------------------------------
-- Retraction

  lemmaSkk : (k : ℕ) → (a : G k) → (i : ℕ) → (r : i < k) → Strad (λ n → fun-trad k a n) i ≡ 0⊕HIT
  lemmaSkk k a zero r with discreteℕ k 0
  ... | yes p = ⊥.rec (<→≢ r (sym p))
  ... | no ¬p = base-neutral 0
  lemmaSkk k a (suc i) r with discreteℕ k (suc i)
  ... | yes p = ⊥.rec (<→≢ r (sym p))
  ... | no ¬p = cong₂ _+⊕HIT_ (base-neutral (suc i)) (lemmaSkk k a i (<-trans ≤-refl r)) ∙ +⊕HIT-IdR _

  lemmakk : (k : ℕ) → (a : G k) → ⊕Fun→⊕HIT (⊕HIT→⊕Fun (base k a)) ≡ base k a
  lemmakk zero a = cong (base 0) (transportRefl a)
  lemmakk (suc k) a with (discreteℕ (suc k) (suc k)) | (discreteℕ k k)
  ... | yes p | yes q = cong₂ _add_
                             (sym (constSubstCommSlice G (⊕HIT ℕ G Gstr) base (cong suc q) a))
                             (lemmaSkk (suc k) a k ≤-refl)
                        ∙ +⊕HIT-IdR _
  ... | yes p | no ¬q = ⊥.rec (¬q refl)
  ... | no ¬p | yes q = ⊥.rec (¬p refl)
  ... | no ¬p | no ¬q = ⊥.rec (¬q refl)

  e-retr : (x : ⊕HIT ℕ G Gstr) → ⊕Fun→⊕HIT (⊕HIT→⊕Fun x) ≡ x
  e-retr = DS-Ind-Prop.f _ _ _ _ (λ _ → isSet⊕HIT _ _)
           (base-neutral 0)
           lemmakk
           λ {U} {V} ind-U ind-V → cong ⊕Fun→⊕HIT (⊕HIT→⊕Fun-pres+ U V)
                                    ∙ ⊕Fun→⊕HIT-pres+ (⊕HIT→⊕Fun U) (⊕HIT→⊕Fun V)
                                    ∙ cong₂ _+⊕HIT_ ind-U ind-V

module _
  (G : ℕ → Type ℓ)
  (Gstr : (n : ℕ) → AbGroupStr (G n))
  where

  open Iso
  open Equiv-Properties G Gstr

  Equiv-DirectSum : AbGroupEquiv (⊕HIT-AbGr ℕ G Gstr) (⊕Fun-AbGr G Gstr)
  fst Equiv-DirectSum = isoToEquiv is
    where
    is : Iso (⊕HIT ℕ G Gstr) (⊕Fun G Gstr)
    fun is = ⊕HIT→⊕Fun
    Iso.inv is = ⊕Fun→⊕HIT
    rightInv is = e-sect
    leftInv is = e-retr
  snd Equiv-DirectSum = makeIsGroupHom ⊕HIT→⊕Fun-pres+


{-# OPTIONS --copatterns #-}

module HighlightCopattern where

record WrapSet : Set₂ where
  field
    wrapped : Set₁
open WrapSet

my : WrapSet
wrapped my = Set    -- 'wrapped' should be highlighted in projection color

proj : WrapSet → Set₁
proj w = wrapped w  -- 'wrapped' should be highlighted in projection color


------------------------------------------------------------------------
-- A wrapper that turns a representation of natural numbers (with a
-- unique representative for every number) into a representation that
-- computes roughly like the unary natural numbers (at least for some
-- operations)
------------------------------------------------------------------------

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

import Bijection
open import Equality
import Erased.Without-box-cong
open import Prelude hiding (zero; suc; _+_; _*_; _^_)

module Nat.Wrapper
  {c⁺}
  (eq : ∀ {a p} → Equality-with-J a p c⁺)

  -- The underlying representation of natural numbers.
  (Nat′ : Type)
  -- A bijection between this representation and the unary natural
  -- numbers.
  (open Bijection eq using (_↔_))
  (Nat′↔ℕ : Nat′ ↔ ℕ)
  where

open Derived-definitions-and-properties eq

open import Dec
import Erased.Level-1 eq as E₁
import Erased.Stability eq as ES
open import Logical-equivalence using (_⇔_)

open import Erased.Without-box-cong eq
open import Function-universe eq as F hiding (_∘_)
open import H-level eq
open import H-level.Closure eq
open import List eq
open import List.All.Recursive eq
open import Vec eq as Vec

private

  module N where
    open import Nat eq public
    open Prelude public using (zero; suc; _+_; _*_; _^_)

  variable
    A               : Type
    f f′ m n n′ hyp : A

------------------------------------------------------------------------
-- The wrapper

private

  -- Converts from the underlying representation to unary natural
  -- numbers.

  to-ℕ : Nat′ → ℕ
  to-ℕ = _↔_.to Nat′↔ℕ

-- Natural numbers built on top of Nat′, indexed by corresponding
-- unary natural numbers.

Nat-[_] : @0 ℕ → Type
Nat-[ m ] = ∃ λ (n : Nat′) → Erased (to-ℕ n ≡ m)

-- A non-indexed variant of Nat-[_].

Nat : Type
Nat = ∃ λ (n : Erased ℕ) → Nat-[ erased n ]

-- Returns the (erased) index.

@0 ⌊_⌋ : Nat → ℕ
⌊ [ n ] , _ ⌋ = n

------------------------------------------------------------------------
-- Some conversion functions

-- Nat-[ n ] is isomorphic to the type of natural numbers equal
-- (with erased equality proofs) to n.

Nat-[]↔Σℕ : {@0 n : ℕ} → Nat-[ n ] ↔ ∃ λ m → Erased (m ≡ n)
Nat-[]↔Σℕ {n = n} =
  (∃ λ (m : Nat′) → Erased (to-ℕ m ≡ n))  ↝⟨ (Σ-cong Nat′↔ℕ λ _ → F.id) ⟩□
  (∃ λ m → Erased (m ≡ n))                □

-- Nat is logically equivalent to the type of unary natural numbers.

Nat⇔ℕ : Nat ⇔ ℕ
Nat⇔ℕ =
  Nat                                                   ↔⟨⟩
  (∃ λ (n : Erased ℕ) → Nat-[ erased n ])               ↔⟨ (∃-cong λ _ → Nat-[]↔Σℕ) ⟩
  (∃ λ (n : Erased ℕ) → ∃ λ m → Erased (m ≡ erased n))  ↝⟨ Σ-Erased-Erased-singleton⇔ ⟩□
  ℕ                                                     □

-- Converts from Nat to ℕ.

Nat→ℕ : Nat → ℕ
Nat→ℕ (_ , n′ , _) = to-ℕ n′

-- Nat→ℕ is definitionally equal to the forward direction of Nat⇔ℕ.

_ : Nat→ℕ ≡ _⇔_.to Nat⇔ℕ
_ = refl _

-- Converts from ℕ to Nat.

⌈_⌉ : ℕ → Nat
⌈_⌉ = _⇔_.from Nat⇔ℕ

-- The index matches the result of Nat→ℕ.

@0 ≡⌊⌋ : ∀ n → Nat→ℕ n ≡ ⌊ n ⌋
≡⌊⌋ ([ m ] , n , eq) =
  Nat→ℕ ([ m ] , n , eq)  ≡⟨⟩
  to-ℕ n                  ≡⟨ erased eq ⟩∎
  m                       ∎

------------------------------------------------------------------------
-- Some operations for Nat-[_]

-- A helper function that can be used to define constants.

nullary-[] :
  {@0 n : ℕ}
  (n′ : Nat′) →
  @0 to-ℕ n′ ≡ n →
  Nat-[ n ]
nullary-[] n′ hyp = n′ , [ hyp ]

-- A helper function that can be used to define unary operators.

unary-[] :
  {@0 n : ℕ} {@0 f : ℕ → ℕ}
  (f′ : Nat′ → Nat′) →
  @0 (∀ n → to-ℕ (f′ n) ≡ f (to-ℕ n)) →
  Nat-[ n ] → Nat-[ f n ]
unary-[] {n = n} {f = f} f′ hyp (n′ , p) =
    f′ n′
  , [ to-ℕ (f′ n′)  ≡⟨ hyp _ ⟩
      f (to-ℕ n′)   ≡⟨ cong f (erased p) ⟩∎
      f n           ∎
    ]

-- A helper function that can be used to define n-ary operators.

n-ary-[] :
  (n : ℕ)
  {@0 ms : Vec (Erased ℕ) n}
  (@0 f : Vec ℕ n → ℕ)
  (f′ : Vec Nat′ n → Nat′) →
  @0 (∀ ms → to-ℕ (f′ ms) ≡ f (Vec.map to-ℕ ms)) →
  All (λ m → Nat-[ erased m ]) (Vec.to-list ms) →
  Nat-[ f (Vec.map erased ms) ]
n-ary-[] N.zero _ f′ hyp _ =
  nullary-[] (f′ _) (hyp _)
n-ary-[] (N.suc n) {ms = ms} f f′ hyp ((m′ , p) , ms′) =
  n-ary-[]
    n
    (f ∘ (erased (Vec.head ms) ,_))
    (λ ms′ → f′ (m′ , ms′))
    (λ ms′ →
       to-ℕ (f′ (m′ , ms′))                         ≡⟨ hyp (m′ , ms′) ⟩
       f (to-ℕ m′              , Vec.map to-ℕ ms′)  ≡⟨ cong (λ x → f (x , _)) (erased p) ⟩∎
       f (erased (Vec.head ms) , Vec.map to-ℕ ms′)  ∎)
    ms′

-- The function n-ary-[] should be normalised by the compiler.

{-# STATIC n-ary-[] #-}

-- A helper function that can be used to define binary
-- operators.

binary-[] :
  {@0 m n : ℕ} {@0 f : ℕ → ℕ → ℕ}
  (f′ : Nat′ → Nat′ → Nat′) →
  @0 (∀ m n → to-ℕ (f′ m n) ≡ f (to-ℕ m) (to-ℕ n)) →
  Nat-[ m ] → Nat-[ n ] → Nat-[ f m n ]
binary-[] f′ hyp m n =
  n-ary-[]
    2
    _
    (λ (m , n , _) → f′ m n)
    (λ (m , n , _) → hyp m n)
    (m , n , _)

-- The code below is parametrised by implementations of (and
-- correctness properties for) certain operations for Nat′.

record Operations : Type where
  infixl 8 _*2^_
  infixr 8 _^_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≟_

  field
    zero      : Nat′
    to-ℕ-zero : to-ℕ zero ≡ N.zero

    suc       : Nat′ → Nat′
    to-ℕ-suc  : ∀ n → to-ℕ (suc n) ≡ N.suc (to-ℕ n)

    _+_       : Nat′ → Nat′ → Nat′
    to-ℕ-+    : ∀ m n → to-ℕ (m + n) ≡ to-ℕ m N.+ to-ℕ n

    _*_       : Nat′ → Nat′ → Nat′
    to-ℕ-*    : ∀ m n → to-ℕ (m * n) ≡ to-ℕ m N.* to-ℕ n

    _^_       : Nat′ → Nat′ → Nat′
    to-ℕ-^    : ∀ m n → to-ℕ (m ^ n) ≡ to-ℕ m N.^ to-ℕ n

    ⌊_/2⌋     : Nat′ → Nat′
    to-ℕ-⌊/2⌋ : ∀ n → to-ℕ ⌊ n /2⌋ ≡ N.⌊ to-ℕ n /2⌋

    ⌈_/2⌉     : Nat′ → Nat′
    to-ℕ-⌈/2⌉ : ∀ n → to-ℕ ⌈ n /2⌉ ≡ N.⌈ to-ℕ n /2⌉

    _*2^_     : Nat′ → ℕ → Nat′
    to-ℕ-*2^  : ∀ m n → to-ℕ (m *2^ n) ≡ to-ℕ m N.* 2 N.^ n

    _≟_       : ∀ m n → Dec (Erased (to-ℕ m ≡ to-ℕ n))

    from-bits      : List Bool → Nat′
    to-ℕ-from-bits :
      ∀ bs →
      to-ℕ (from-bits bs) ≡
      foldl (λ n b → (if b then 1 else 0) N.+ 2 N.* n) 0 bs

    to-bits                : Nat′ → List Bool
    to-ℕ-from-bits-to-bits :
      ∀ n → to-ℕ (from-bits (to-bits n)) ≡ to-ℕ n

-- If certain operations are defined for Nat′, then they can be
-- defined for Nat-[_] as well.

module Operations-for-Nat-[] (o : Operations) where

  private

    module O = Operations o

  -- Zero.

  zero : Nat-[ N.zero ]
  zero = nullary-[] O.zero O.to-ℕ-zero

  -- The number's successor.

  suc : {@0 n : ℕ} → Nat-[ n ] → Nat-[ N.suc n ]
  suc = unary-[] O.suc O.to-ℕ-suc

  -- Addition.

  infixl 6 _+_

  _+_ : {@0 m n : ℕ} → Nat-[ m ] → Nat-[ n ] → Nat-[ m N.+ n ]
  _+_ = binary-[] O._+_ O.to-ℕ-+

  -- Multiplication.

  infixl 7 _*_

  _*_ : {@0 m n : ℕ} → Nat-[ m ] → Nat-[ n ] → Nat-[ m N.* n ]
  _*_ = binary-[] O._*_ O.to-ℕ-*

  -- Exponentiation.

  infixr 8 _^_

  _^_ : {@0 m n : ℕ} → Nat-[ m ] → Nat-[ n ] → Nat-[ m N.^ n ]
  _^_ = binary-[] O._^_ O.to-ℕ-^

  -- Division by two, rounded downwards.

  ⌊_/2⌋ : {@0 n : ℕ} → Nat-[ n ] → Nat-[ N.⌊ n /2⌋ ]
  ⌊_/2⌋ = unary-[] O.⌊_/2⌋ O.to-ℕ-⌊/2⌋

  -- Division by two, rounded upwards.

  ⌈_/2⌉ : {@0 n : ℕ} → Nat-[ n ] → Nat-[ N.⌈ n /2⌉ ]
  ⌈_/2⌉ = unary-[] O.⌈_/2⌉ O.to-ℕ-⌈/2⌉

  -- Left shift.

  infixl 8 _*2^_

  _*2^_ : {@0 m : ℕ} → Nat-[ m ] → ∀ n → Nat-[ m N.* 2 N.^ n ]
  m *2^ n = unary-[] (O._*2^ n) (flip O.to-ℕ-*2^ n) m

  -- Equality is decidable (in a certain sense).

  infix 4 _≟_

  _≟_ :
    {@0 m n : ℕ} →
    Nat-[ m ] → Nat-[ n ] →
    Dec (Erased (m ≡ n))
  _≟_ {m = m} {n = n} (m′ , [ m≡m′ ]) (n′ , [ n≡n′ ]) =
    Dec-map
      (Erased-cong-⇔ (
         to-ℕ m′ ≡ to-ℕ n′  ↝⟨ ≡⇒↝ _ (cong₂ _≡_ m≡m′ n≡n′) ⟩□
         m ≡ n              □))
      (m′ O.≟ n′)

  -- Conversion from bits. (The most significant bit comes first.)

  from-bits :
    (bs : List Bool) →
    Nat-[ foldl (λ n b → (if b then 1 else 0) N.+ 2 N.* n) 0 bs ]
  from-bits bs = nullary-[] (O.from-bits bs) (O.to-ℕ-from-bits bs)

  -- Conversion to bits. (The most significant bit comes first.)

  to-bits :
    {@0 n : ℕ} →
    Nat-[ n ] →
    ∃ λ (bs : List Bool) →
      Erased (foldl (λ n b → (if b then 1 else 0) N.+ 2 N.* n) 0 bs ≡ n)
  to-bits {n = n} (n′ , [ n′≡n ]) =
      O.to-bits n′
    , [ foldl (λ n b → (if b then 1 else 0) N.+ 2 N.* n) 0
          (O.to-bits n′)                                    ≡⟨ sym $ O.to-ℕ-from-bits _ ⟩

        to-ℕ (O.from-bits (O.to-bits n′))                   ≡⟨ O.to-ℕ-from-bits-to-bits _ ⟩

        to-ℕ n′                                             ≡⟨ n′≡n ⟩∎

        n                                                   ∎
      ]

------------------------------------------------------------------------
-- Operations for Nat

private

  -- Equality is stable for the natural numbers.

  Stable-≡-ℕ : Stable-≡ ℕ
  Stable-≡-ℕ m n = Dec→Stable (m N.≟ n)

-- A helper function that can be used to define constants.

nullary :
  (@0 n : ℕ) (n′ : Nat′) →
  @0 to-ℕ n′ ≡ n →
  Nat
nullary n n′ hyp = [ n ] , nullary-[] n′ hyp

-- A first correctness result for nullary.
--
-- Note that this result holds by definition.

private

  @0 nullary-correct′ : ⌊ nullary n n′ hyp ⌋ ≡ n
  nullary-correct′ = refl _

-- A second correctness result for nullary.

nullary-correct :
  (@0 hyp : to-ℕ n′ ≡ n) →
  Nat→ℕ (nullary n n′ hyp) ≡ n
nullary-correct {n′ = n′} {n = n} hyp =
  Stable-≡-ℕ _ _
     [ Nat→ℕ (nullary n n′ hyp)  ≡⟨ ≡⌊⌋ (nullary n n′ hyp) ⟩
       ⌊ nullary n n′ hyp ⌋      ≡⟨⟩
       n                         ∎
     ]

-- A helper function that can be used to define unary operators.

unary :
  (@0 f : ℕ → ℕ) (f′ : Nat′ → Nat′) →
  @0 (∀ n → to-ℕ (f′ n) ≡ f (to-ℕ n)) →
  Nat → Nat
unary f f′ hyp ([ n ] , n′) = ([ f n ] , unary-[] f′ hyp n′)

-- A first correctness result for unary.
--
-- Note that this result holds by definition.

private

  @0 unary-correct′ : ⌊ unary f f′ hyp n ⌋ ≡ f ⌊ n ⌋
  unary-correct′ = refl _

-- A second correctness result for unary.

unary-correct :
  (f : ℕ → ℕ) (@0 hyp : ∀ n → to-ℕ (f′ n) ≡ f (to-ℕ n)) →
  ∀ n → Nat→ℕ (unary f f′ hyp n) ≡ f (Nat→ℕ n)
unary-correct {f′ = f′} f hyp n =
  Stable-≡-ℕ _ _
    [ Nat→ℕ (unary f f′ hyp n)  ≡⟨ ≡⌊⌋ (unary f f′ hyp n) ⟩
      ⌊ unary f f′ hyp n ⌋      ≡⟨⟩
      f ⌊ n ⌋                   ≡⟨ sym $ cong f $ ≡⌊⌋ n ⟩∎
      f (Nat→ℕ n)               ∎
    ]

-- A helper function that can be used to define n-ary operators.

n-ary :
  (n : ℕ)
  (@0 f : Vec ℕ n → ℕ)
  (f′ : Vec Nat′ n → Nat′) →
  @0 (∀ ms → to-ℕ (f′ ms) ≡ f (Vec.map to-ℕ ms)) →
  Vec Nat n → Nat
n-ary n f f′ hyp ms =
    [ f (Vec.map erased (proj₁ (_↔_.to Vec-Σ ms))) ]
  , n-ary-[] n f f′ hyp (proj₂ (_↔_.to Vec-Σ ms))

-- The function n-ary should be normalised by the compiler.

{-# STATIC n-ary #-}

-- The function n-ary is correct.

n-ary-correct :
  ∀ (n : ℕ) f {f′}
  (@0 hyp : ∀ ms → to-ℕ (f′ ms) ≡ f (Vec.map to-ℕ ms)) →
  ∀ ms →
  Nat→ℕ (n-ary n f f′ hyp ms) ≡ f (Vec.map (Nat→ℕ) ms)
n-ary-correct n f {f′ = f′} hyp ms =
  Stable-≡-ℕ _ _
    [ Nat→ℕ (n-ary n f f′ hyp ms)                   ≡⟨ ≡⌊⌋ (n-ary n f f′ hyp ms) ⟩
      ⌊ n-ary n f f′ hyp ms ⌋                       ≡⟨⟩
      f (Vec.map erased (proj₁ (_↔_.to Vec-Σ ms)))  ≡⟨ cong (f ∘ Vec.map _) proj₁-Vec-Σ ⟩
      f (Vec.map erased (Vec.map proj₁ ms))         ≡⟨ cong f $ sym Vec.map-∘ ⟩
      f (Vec.map ⌊_⌋ ms)                            ≡⟨ cong f $ sym $ Vec.map-cong ≡⌊⌋ ⟩∎
      f (Vec.map (Nat→ℕ) ms)                        ∎
    ]

-- A helper function that can be used to define binary operators

binary :
  (@0 f : ℕ → ℕ → ℕ) (f′ : Nat′ → Nat′ → Nat′) →
  @0 (∀ m n → to-ℕ (f′ m n) ≡ f (to-ℕ m) (to-ℕ n)) →
  Nat → Nat → Nat
binary f g hyp m n =
  n-ary
    2
    (λ (m , n , _) → f m n)
    (λ (m , n , _) → g m n)
    (λ (m , n , _) → hyp m n)
    (m , n , _)

-- A first correctness result for binary.
--
-- Note that this result holds by definition.

private

  @0 binary-correct′ : ⌊ binary f f′ hyp m n ⌋ ≡ f ⌊ m ⌋ ⌊ n ⌋
  binary-correct′ = refl _

-- A second correctness result for binary.

binary-correct :
  (f : ℕ → ℕ → ℕ)
  (@0 hyp : ∀ m n → to-ℕ (f′ m n) ≡ f (to-ℕ m) (to-ℕ n)) →
  ∀ m n →
  Nat→ℕ (binary f f′ hyp m n) ≡ f (Nat→ℕ m) (Nat→ℕ n)
binary-correct f hyp m n =
  n-ary-correct
    2
    (λ (m , n , _) → f m n)
    (λ (m , n , _) → hyp m n)
    (m , n , _)

-- If certain operations are defined for Nat′, then they can be
-- defined for Nat-[_] as well.

module Operations-for-Nat (o : Operations) where

  private

    module O    = Operations o
    module O-[] = Operations-for-Nat-[] o

  -- Zero.

  zero : Nat
  zero = nullary N.zero O.zero O.to-ℕ-zero

  to-ℕ-zero : Nat→ℕ zero ≡ N.zero
  to-ℕ-zero = nullary-correct O.to-ℕ-zero

  -- The number's successor.

  suc : Nat → Nat
  suc = unary N.suc O.suc O.to-ℕ-suc

  to-ℕ-suc : ∀ n → Nat→ℕ (suc n) ≡ N.suc (Nat→ℕ n)
  to-ℕ-suc = unary-correct N.suc O.to-ℕ-suc

  -- Addition.

  infixl 6 _+_

  _+_ : Nat → Nat → Nat
  _+_ = binary N._+_ O._+_ O.to-ℕ-+

  to-ℕ-+ : ∀ m n → Nat→ℕ (m + n) ≡ Nat→ℕ m N.+ Nat→ℕ n
  to-ℕ-+ = binary-correct N._+_ O.to-ℕ-+

  -- Multiplication.

  infixl 7 _*_

  _*_ : Nat → Nat → Nat
  _*_ = binary N._*_ O._*_ O.to-ℕ-*

  to-ℕ-* : ∀ m n → Nat→ℕ (m * n) ≡ Nat→ℕ m N.* Nat→ℕ n
  to-ℕ-* = binary-correct N._*_ O.to-ℕ-*

  -- Multiplication.

  infixr 8 _^_

  _^_ : Nat → Nat → Nat
  _^_ = binary N._^_ O._^_ O.to-ℕ-^

  to-ℕ-^ : ∀ m n → Nat→ℕ (m ^ n) ≡ Nat→ℕ m N.^ Nat→ℕ n
  to-ℕ-^ = binary-correct N._^_ O.to-ℕ-^

  -- Division by two, rounded downwards.

  ⌊_/2⌋ : Nat → Nat
  ⌊_/2⌋ = unary N.⌊_/2⌋ O.⌊_/2⌋ O.to-ℕ-⌊/2⌋

  to-ℕ-⌊/2⌋ : ∀ n → Nat→ℕ ⌊ n /2⌋ ≡ N.⌊ Nat→ℕ n /2⌋
  to-ℕ-⌊/2⌋ = unary-correct N.⌊_/2⌋ O.to-ℕ-⌊/2⌋

  -- Division by two, rounded upwards.

  ⌈_/2⌉ : Nat → Nat
  ⌈_/2⌉ = unary N.⌈_/2⌉ O.⌈_/2⌉ O.to-ℕ-⌈/2⌉

  to-ℕ-⌈/2⌉ : ∀ n → Nat→ℕ ⌈ n /2⌉ ≡ N.⌈ Nat→ℕ n /2⌉
  to-ℕ-⌈/2⌉ = unary-correct N.⌈_/2⌉ O.to-ℕ-⌈/2⌉

  -- Left shift.

  infixl 8 _*2^_

  _*2^_ : Nat → ℕ → Nat
  m *2^ n =
    unary (λ m → m N.* 2 N.^ n) (O._*2^ n) (flip O.to-ℕ-*2^ n) m

  to-ℕ-*2^ : ∀ m n → Nat→ℕ (m *2^ n) ≡ Nat→ℕ m N.* 2 N.^ n
  to-ℕ-*2^ m n =
    unary-correct (λ m → m N.* 2 N.^ n) (flip O.to-ℕ-*2^ n) m

  -- Equality is decidable (in a certain sense).

  infix 4 _≟_

  _≟_ : (m n : Nat) → Dec (Erased (⌊ m ⌋ ≡ ⌊ n ⌋))
  (_ , m′) ≟ (_ , n′) = m′ O-[].≟ n′

  -- Conversion from bits. (The most significant bit comes first.)

  from-bits : List Bool → Nat
  from-bits bs =
    nullary
      (foldl (λ n b → (if b then 1 else 0) N.+ 2 N.* n) 0 bs)
      (O.from-bits bs)
      (O.to-ℕ-from-bits bs)

  to-ℕ-from-bits :
    ∀ bs →
    Nat→ℕ (from-bits bs) ≡
    foldl (λ n b → (if b then 1 else 0) N.+ 2 N.* n) 0 bs
  to-ℕ-from-bits bs = nullary-correct (O.to-ℕ-from-bits bs)

  -- Conversion to bits. (The most significant bit comes first.)

  to-bits : Nat → List Bool
  to-bits (_ , n′) = proj₁ (O-[].to-bits n′)

------------------------------------------------------------------------
-- Results that make use of an instantiation of the []-cong axioms

module []-cong (ax : []-cong-axiomatisation lzero) where

  open E₁.[]-cong₁ ax
  open E₁.Erased-cong ax ax
  open ES.[]-cong₁ ax
  open ES.[]-cong₂ ax ax

  ----------------------------------------------------------------------
  -- Some lemmas

  private

    -- Equality is very stable for the natural numbers.

    Very-stable-≡-ℕ : Very-stable-≡ ℕ
    Very-stable-≡-ℕ = Decidable-equality→Very-stable-≡ N._≟_

  -- Nat-[ n ] is a proposition.

  Nat-[]-propositional : {@0 n : ℕ} → Is-proposition Nat-[ n ]
  Nat-[]-propositional {n = n} =                                      $⟨ Very-stable-≡-ℕ ⟩
    Very-stable-≡ ℕ                                                   ↝⟨ Very-stable-congⁿ _ 1 (inverse Nat′↔ℕ) ⟩
    Very-stable-≡ Nat′                                                ↝⟨ Very-stable→Very-stableᴱ 1 ⟩
    Very-stableᴱ-≡ Nat′                                               ↝⟨ erased-singleton-with-erased-center-propositional ⟩
    Is-proposition (∃ λ (m : Nat′) → Erased (m ≡ _↔_.from Nat′↔ℕ n))  ↝⟨ (H-level-cong _ 1 $ ∃-cong λ _ → Erased-cong-↔ (inverse $
                                                                          from≡↔≡to (from-isomorphism $ inverse Nat′↔ℕ))) ⟩□
    Is-proposition (∃ λ (m : Nat′) → Erased (to-ℕ m ≡ n))             □

  -- There is a bijection between equality of two values of type Nat
  -- and erased equality of the corresponding unary natural number
  -- indices.

  ≡-for-indices↔≡ :
    {m n : Nat} →
    Erased (⌊ m ⌋ ≡ ⌊ n ⌋) ↔ m ≡ n
  ≡-for-indices↔≡ {m = m} {n = n} =
    Erased (⌊ m ⌋ ≡ ⌊ n ⌋)  ↝⟨ Erased-≡↔[]≡[] ⟩
    proj₁ m ≡ proj₁ n       ↝⟨ ignore-propositional-component Nat-[]-propositional ⟩□
    m ≡ n                   □

  ----------------------------------------------------------------------
  -- Another conversion function

  -- Nat is isomorphic to the type of unary natural numbers.

  Nat↔ℕ : Nat ↔ ℕ
  Nat↔ℕ =
    Nat                                                   ↔⟨⟩
    (∃ λ (n : Erased ℕ) → Nat-[ erased n ])               ↝⟨ (∃-cong λ _ → Nat-[]↔Σℕ) ⟩
    (∃ λ (n : Erased ℕ) → ∃ λ m → Erased (m ≡ erased n))  ↝⟨ Σ-Erased-Erased-singleton↔ ⟩□
    ℕ                                                     □

  -- The logical equivalence underlying Nat↔ℕ is definitionally equal
  -- to Nat⇔ℕ.

  _ : _↔_.logical-equivalence Nat↔ℕ ≡ Nat⇔ℕ
  _ = refl _

  ----------------------------------------------------------------------
  -- A correctness result related to the module Operations-for-Nat

  module Operations-for-Nat-correct (o : Operations) where

    private

      module O-[] = Operations-for-Nat-[] o

    open Operations-for-Nat o

    to-ℕ-from-bits-to-bits :
      ∀ n → Nat→ℕ (from-bits (to-bits n)) ≡ Nat→ℕ n
    to-ℕ-from-bits-to-bits n@(_ , n′) =
      cong Nat→ℕ $
        _↔_.to (≡-for-indices↔≡ {m = from-bits (to-bits n)} {n = n})
          [ ⌊ from-bits (to-bits n) ⌋  ≡⟨ erased (proj₂ (O-[].to-bits n′)) ⟩∎
            ⌊ n ⌋                      ∎
          ]

  ----------------------------------------------------------------------
  -- Some examples

  private

    module Nat-[]-examples (o : Operations) where

      open Operations-for-Nat-[] o

      -- Converts unary natural numbers to binary natural numbers.

      from-ℕ : ∀ n → Nat-[ n ]
      from-ℕ = proj₂ ∘ _↔_.from Nat↔ℕ

      -- Nat n is a proposition, so it is easy to prove that two
      -- values of this type are equal.

      example₁ : from-ℕ 4 + ⌊ from-ℕ 12 /2⌋ ≡ from-ℕ 10
      example₁ = Nat-[]-propositional _ _

      -- However, stating that two values of type Nat m and Nat n are
      -- equal, for equal natural numbers m and n, can be awkward.

      @0 example₂ :
        {@0 m n : ℕ} →
        (b : Nat-[ m ]) (c : Nat-[ n ]) →
        subst (λ n → Nat-[ n ]) (N.+-comm m) (b + c) ≡ c + b
      example₂ _ _ = Nat-[]-propositional _ _

    module Nat-examples (o : Operations) where

      open Operations-for-Nat o

      -- If Nat is used instead of Nat-[_], then it can be easier to
      -- state that two values are equal.

      example₁ : ⌈ 4 ⌉ + ⌊ ⌈ 12 ⌉ /2⌋ ≡ ⌈ 10 ⌉
      example₁ = _↔_.to ≡-for-indices↔≡ [ refl _ ]

      example₂ : ∀ m n → m + n ≡ n + m
      example₂ m n = _↔_.to ≡-for-indices↔≡
        [ ⌊ m ⌋ N.+ ⌊ n ⌋  ≡⟨ N.+-comm ⌊ m ⌋ ⟩∎
          ⌊ n ⌋ N.+ ⌊ m ⌋  ∎
        ]

      -- One can construct a proof showing that ⌈ 5 ⌉ is either equal
      -- or not equal to ⌈ 2 ⌉ + ⌈ 3 ⌉, but the proof does not compute
      -- to "inj₁ something" at compile-time.

      example₃ : Dec (⌈ 5 ⌉ ≡ ⌈ 2 ⌉ + ⌈ 3 ⌉)
      example₃ =
        Dec-map (_↔_.logical-equivalence ≡-for-indices↔≡)
          (⌈ 5 ⌉ ≟ ⌈ 2 ⌉ + ⌈ 3 ⌉)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of unique lists (setoid equality)
------------------------------------------------------------------------

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

module Data.List.Relation.Unary.Unique.Propositional.Properties where

open import Data.Fin.Base using (Fin)
open import Data.List.Base
open import Data.List.Relation.Binary.Disjoint.Propositional
open import Data.List.Relation.Unary.All as All using (All; []; _∷_)
open import Data.List.Relation.Unary.AllPairs as AllPairs using (AllPairs)
open import Data.List.Relation.Unary.Unique.Propositional
import Data.List.Relation.Unary.Unique.Setoid.Properties as Setoid
open import Data.Nat.Base
open import Data.Nat.Properties using (<⇒≢)
open import Function using (id; _∘_)
open import Relation.Binary using (Rel; Setoid)
open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; sym; setoid)
open import Relation.Unary using (Pred; Decidable)
open import Relation.Nullary using (¬_)

------------------------------------------------------------------------
-- Introduction (⁺) and elimination (⁻) rules for list operations
------------------------------------------------------------------------
-- map

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

  map⁺ : ∀ {f} → (∀ {x y} → f x ≡ f y → x ≡ y) →
         ∀ {xs} → Unique xs → Unique (map f xs)
  map⁺ = Setoid.map⁺ (setoid A) (setoid B)

------------------------------------------------------------------------
-- ++

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

  ++⁺ : ∀ {xs ys} → Unique xs → Unique ys → Disjoint xs ys → Unique (xs ++ ys)
  ++⁺ = Setoid.++⁺ (setoid A)

------------------------------------------------------------------------
-- concat

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

  concat⁺ : ∀ {xss} → All Unique xss → AllPairs Disjoint xss → Unique (concat xss)
  concat⁺ = Setoid.concat⁺ (setoid A)

------------------------------------------------------------------------
-- take & drop

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

  drop⁺ : ∀ {xs} n → Unique xs → Unique (drop n xs)
  drop⁺ = Setoid.drop⁺ (setoid A)

  take⁺ : ∀ {xs} n → Unique xs → Unique (take n xs)
  take⁺ = Setoid.take⁺ (setoid A)

------------------------------------------------------------------------
-- applyUpTo & upTo

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

  applyUpTo⁺₁ : ∀ f n → (∀ {i j} → i < j → j < n → f i ≢ f j) →
                Unique (applyUpTo f n)
  applyUpTo⁺₁ = Setoid.applyUpTo⁺₁ (setoid A)

  applyUpTo⁺₂ : ∀ f n → (∀ i j → f i ≢ f j) →
                Unique (applyUpTo f n)
  applyUpTo⁺₂ = Setoid.applyUpTo⁺₂  (setoid A)

------------------------------------------------------------------------
-- upTo

upTo⁺ : ∀ n → Unique (upTo n)
upTo⁺ n = applyUpTo⁺₁ id n (λ i<j _ → <⇒≢ i<j)

------------------------------------------------------------------------
-- applyDownFrom

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

  applyDownFrom⁺₁ : ∀ f n → (∀ {i j} → j < i → i < n → f i ≢ f j) →
                    Unique (applyDownFrom f n)
  applyDownFrom⁺₁ = Setoid.applyDownFrom⁺₁ (setoid A)

  applyDownFrom⁺₂ : ∀ f n → (∀ i j → f i ≢ f j) →
                    Unique (applyDownFrom f n)
  applyDownFrom⁺₂ = Setoid.applyDownFrom⁺₂ (setoid A)

------------------------------------------------------------------------
-- downFrom

downFrom⁺ : ∀ n → Unique (downFrom n)
downFrom⁺ n = applyDownFrom⁺₁ id n (λ j<i _ → <⇒≢ j<i ∘ sym)

------------------------------------------------------------------------
-- tabulate

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

  tabulate⁺ : ∀ {n} {f : Fin n → A} → (∀ {i j} → f i ≡ f j → i ≡ j) →
              Unique (tabulate f)
  tabulate⁺ = Setoid.tabulate⁺ (setoid A)

------------------------------------------------------------------------
-- allFin

allFin⁺ : ∀ n → Unique (allFin n)
allFin⁺ n = tabulate⁺ id

------------------------------------------------------------------------
-- filter

module _ {a p} {A : Set a} {P : Pred _ p} (P? : Decidable P) where

  filter⁺ : ∀ {xs} → Unique xs → Unique (filter P? xs)
  filter⁺ = Setoid.filter⁺ (setoid A) P?


------------------------------------------------------------------------
-- Some results related to the For-iterated-equality predicate
-- transformer
------------------------------------------------------------------------

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

open import Equality

module For-iterated-equality
  {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection eq as Bijection using (_↔_)
open import Equivalence eq as Eq using (_≃_)
open import Equivalence.Erased eq as EEq using (_≃ᴱ_)
open import Function-universe eq as F hiding (id; _∘_)
open import H-level eq
open import List eq
open import Nat eq
open import Surjection eq as Surj using (_↠_)

private
  variable
    a b ℓ p q : Level
    A B       : Type a
    P Q R     : Type p → Type p
    x y       : A
    k         : Kind
    n         : ℕ

------------------------------------------------------------------------
-- Some lemmas related to nested occurrences of For-iterated-equality

-- Nested uses of For-iterated-equality can be merged.

For-iterated-equality-For-iterated-equality′ :
  {A : Type a} →
  ∀ m n →
  For-iterated-equality m (For-iterated-equality n P) A ↝[ a ∣ a ]
  For-iterated-equality (m + n) P A
For-iterated-equality-For-iterated-equality′ zero _ _ = F.id

For-iterated-equality-For-iterated-equality′ {P = P} {A = A}
                                             (suc m) n ext =
  ((x y : A) →
   For-iterated-equality m (For-iterated-equality n P) (x ≡ y))  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                     For-iterated-equality-For-iterated-equality′ m n ext) ⟩□
  ((x y : A) → For-iterated-equality (m + n) P (x ≡ y))          □

-- A variant of the previous result.

For-iterated-equality-For-iterated-equality :
  {A : Type a} →
  ∀ m n →
  For-iterated-equality m (For-iterated-equality n P) A ↝[ a ∣ a ]
  For-iterated-equality (n + m) P A
For-iterated-equality-For-iterated-equality {P = P} {A = A}
                                            m n ext =
  For-iterated-equality m (For-iterated-equality n P) A  ↝⟨ For-iterated-equality-For-iterated-equality′ m n ext ⟩
  For-iterated-equality (m + n) P A                      ↝⟨ ≡⇒↝ _ $ cong (λ n → For-iterated-equality n P A) (+-comm m) ⟩□
  For-iterated-equality (n + m) P A                      □

------------------------------------------------------------------------
-- Preservation lemmas for For-iterated-equality

-- A preservation lemma for the predicate.

For-iterated-equality-cong₁ :
  {P Q : Type ℓ → Type ℓ} →
  Extensionality? k ℓ ℓ →
  ∀ n →
  (∀ {A} → P A ↝[ k ] Q A) →
  For-iterated-equality n P A ↝[ k ] For-iterated-equality n Q A
For-iterated-equality-cong₁ _ zero P↝Q = P↝Q

For-iterated-equality-cong₁ {A = A} {P = P} {Q = Q} ext (suc n) P↝Q =
  ((x y : A) → For-iterated-equality n P (x ≡ y))  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                       For-iterated-equality-cong₁ ext n P↝Q) ⟩□
  ((x y : A) → For-iterated-equality n Q (x ≡ y))  □

-- A variant of For-iterated-equality-cong₁.

For-iterated-equality-cong₁ᴱ-→ :
  {@0 A : Type ℓ} {@0 P Q : Type ℓ → Type ℓ} →
  ∀ n →
  (∀ {@0 A} → P A → Q A) →
  For-iterated-equality n P A → For-iterated-equality n Q A
For-iterated-equality-cong₁ᴱ-→ zero P→Q = P→Q

For-iterated-equality-cong₁ᴱ-→ {A = A} {P = P} {Q = Q} (suc n) P→Q =
  ((x y : A) → For-iterated-equality n P (x ≡ y))  →⟨ For-iterated-equality-cong₁ᴱ-→ n (λ {A} → P→Q {A = A}) ∘_ ∘_ ⟩□
  ((x y : A) → For-iterated-equality n Q (x ≡ y))  □

-- Preservation lemmas for both the predicate and the type.

For-iterated-equality-cong-→ :
  ∀ n →
  (∀ {A B} → A ↠ B → P A → Q B) →
  A ↠ B →
  For-iterated-equality n P A → For-iterated-equality n Q B
For-iterated-equality-cong-→ zero P↝Q A↠B = P↝Q A↠B

For-iterated-equality-cong-→ {P = P} {Q = Q} {A = A} {B = B}
                             (suc n) P↝Q A↠B =
  ((x y : A) → For-iterated-equality n P (x ≡ y))  ↝⟨ (Π-cong-contra-→ (_↠_.from A↠B) λ _ → Π-cong-contra-→ (_↠_.from A↠B) λ _ →
                                                       For-iterated-equality-cong-→ n P↝Q $ Surj.↠-≡ A↠B) ⟩□
  ((x y : B) → For-iterated-equality n Q (x ≡ y))  □

For-iterated-equality-cong :
  {P : Type p → Type p} {Q : Type q → Type q} →
  Extensionality? k (p ⊔ q) (p ⊔ q) →
  ∀ n →
  (∀ {A B} → A ↔ B → P A ↝[ k ] Q B) →
  A ↔ B →
  For-iterated-equality n P A ↝[ k ] For-iterated-equality n Q B
For-iterated-equality-cong _ zero P↝Q A↔B = P↝Q A↔B

For-iterated-equality-cong {A = A} {B = B} {P = P} {Q = Q}
                           ext (suc n) P↝Q A↔B =
  ((x y : A) → For-iterated-equality n P (x ≡ y))  ↝⟨ (Π-cong ext A↔B λ _ → Π-cong ext A↔B λ _ →
                                                       For-iterated-equality-cong ext n P↝Q $ inverse $ _≃_.bijection $
                                                       Eq.≃-≡ $ from-isomorphism A↔B) ⟩□
  ((x y : B) → For-iterated-equality n Q (x ≡ y))  □

------------------------------------------------------------------------
-- Some "closure properties" for the type

private

  -- A lemma.

  lift≡lift↔ : lift {ℓ = ℓ} x ≡ lift y ↔ x ≡ y
  lift≡lift↔ = inverse $ _≃_.bijection $ Eq.≃-≡ $ Eq.↔⇒≃ Bijection.↑↔

-- Closure properties for ⊤.

For-iterated-equality-↑-⊤ :
  Extensionality? k ℓ ℓ →
  ∀ n →
  (∀ {A B} → A ↔ B → P A ↝[ k ] P B) →
  P (↑ ℓ ⊤) ↝[ k ] For-iterated-equality n P (↑ ℓ ⊤)
For-iterated-equality-↑-⊤ _ zero _ = F.id

For-iterated-equality-↑-⊤ {P = P} ext (suc n) resp =
  P (↑ _ ⊤)                                                ↝⟨ For-iterated-equality-↑-⊤ ext n resp ⟩
  For-iterated-equality n P (↑ _ ⊤)                        ↝⟨ For-iterated-equality-cong ext n resp $
                                                              inverse lift≡lift↔ F.∘ inverse tt≡tt↔⊤ F.∘ Bijection.↑↔ ⟩
  For-iterated-equality n P (lift tt ≡ lift tt)            ↝⟨ inverse-ext? (λ ext → drop-⊤-left-Π ext Bijection.↑↔) ext ⟩
  ((y : ↑ _ ⊤) → For-iterated-equality n P (lift tt ≡ y))  ↝⟨ inverse-ext? (λ ext → drop-⊤-left-Π ext Bijection.↑↔) ext ⟩□
  ((x y : ↑ _ ⊤) → For-iterated-equality n P (x ≡ y))      □

For-iterated-equality-⊤ :
  Extensionality? k lzero lzero →
  ∀ n →
  (∀ {A B} → A ↔ B → P A ↝[ k ] P B) →
  P ⊤ ↝[ k ] For-iterated-equality n P ⊤
For-iterated-equality-⊤ {P = P} ext n resp =
  P ⊤                                ↝⟨ resp (inverse Bijection.↑↔) ⟩
  P (↑ _ ⊤)                          ↝⟨ For-iterated-equality-↑-⊤ ext n resp ⟩
  For-iterated-equality n P (↑ _ ⊤)  ↝⟨ For-iterated-equality-cong ext n resp Bijection.↑↔ ⟩□
  For-iterated-equality n P ⊤        □

-- Closure properties for ⊥.

For-iterated-equality-suc-⊥ :
  {P : Type p → Type p} →
  ∀ n → ⊤ ↝[ p ∣ p ] For-iterated-equality (suc n) P ⊥
For-iterated-equality-suc-⊥ {P = P} n ext =
  ⊤                                                ↝⟨ inverse-ext? Π⊥↔⊤ ext ⟩□
  ((x y : ⊥) → For-iterated-equality n P (x ≡ y))  □

For-iterated-equality-⊥ :
  {P : Type p → Type p} →
  Extensionality? k p p →
  ∀ n →
  ⊤ ↝[ k ] P ⊥ →
  ⊤ ↝[ k ] For-iterated-equality n P ⊥
For-iterated-equality-⊥ _   zero      = id
For-iterated-equality-⊥ ext (suc n) _ =
  For-iterated-equality-suc-⊥ n ext

-- A closure property for Π.

For-iterated-equality-Π :
  {A : Type a} {B : A → Type b} →
  Extensionality a b →
  ∀ n →
  (∀ {A B} → A ↔ B → Q A → Q B) →
  ({A : Type a} {B : A → Type b} →
   (∀ x → P (B x)) → Q (∀ x → B x)) →
  (∀ x → For-iterated-equality n P (B x)) →
  For-iterated-equality n Q (∀ x → B x)
For-iterated-equality-Π _ zero _ hyp = hyp

For-iterated-equality-Π {Q = Q} {P = P} {B = B} ext (suc n) resp hyp =
  (∀ x (y z : B x) → For-iterated-equality n P (y ≡ z))              ↝⟨ (λ hyp _ _ _ → hyp _ _ _) ⟩
  (∀ (f g : ∀ x → B x) x → For-iterated-equality n P (f x ≡ g x))    ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → For-iterated-equality-Π ext n resp hyp) ⟩
  ((f g : ∀ x → B x) → For-iterated-equality n Q (∀ x → f x ≡ g x))  ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → For-iterated-equality-cong _ n resp $
                                                                         from-isomorphism $ Eq.extensionality-isomorphism ext) ⟩□
  ((f g : ∀ x → B x) → For-iterated-equality n Q (f ≡ g))            □

-- A closure property for Σ.

For-iterated-equality-Σ :
  {A : Type a} {B : A → Type b} →
  ∀ n →
  (∀ {A B} → A ↔ B → R A → R B) →
  ({A : Type a} {B : A → Type b} →
   P A → (∀ x → Q (B x)) → R (Σ A B)) →
  For-iterated-equality n P A →
  (∀ x → For-iterated-equality n Q (B x)) →
  For-iterated-equality n R (Σ A B)
For-iterated-equality-Σ zero _ hyp = hyp

For-iterated-equality-Σ {R = R} {P = P} {Q = Q} {A = A} {B = B}
  (suc n) resp hyp = curry (

  ((x y : A) → For-iterated-equality n P (x ≡ y)) ×
  ((x : A) (y z : B x) → For-iterated-equality n Q (y ≡ z))            ↝⟨ (λ (hyp₁ , hyp₂) _ _ → hyp₁ _ _ , λ _ → hyp₂ _ _ _) ⟩

  (((x₁ , x₂) (y₁ , y₂) : Σ A B) →
   For-iterated-equality n P (x₁ ≡ y₁) ×
   (∀ p → For-iterated-equality n Q (subst B p x₂ ≡ y₂)))              ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → uncurry $
                                                                           For-iterated-equality-Σ n resp hyp) ⟩
  (((x₁ , x₂) (y₁ , y₂) : Σ A B) →
   For-iterated-equality n R (∃ λ (p : x₁ ≡ y₁) → subst B p x₂ ≡ y₂))  ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ →
                                                                           For-iterated-equality-cong _ n resp Bijection.Σ-≡,≡↔≡) ⟩□
  ((x y : Σ A B) → For-iterated-equality n R (x ≡ y))                  □)

-- A closure property for _×_.

For-iterated-equality-× :
  {A : Type a} {B : Type b} →
  ∀ n →
  (∀ {A B} → A ↔ B → R A → R B) →
  ({A : Type a} {B : Type b} → P A → Q B → R (A × B)) →
  For-iterated-equality n P A →
  For-iterated-equality n Q B →
  For-iterated-equality n R (A × B)
For-iterated-equality-× zero _ hyp = hyp

For-iterated-equality-× {R = R} {P = P} {Q = Q} {A = A} {B = B}
  (suc n) resp hyp = curry (

  ((x y : A) → For-iterated-equality n P (x ≡ y)) ×
  ((x y : B) → For-iterated-equality n Q (x ≡ y))      ↝⟨ (λ (hyp₁ , hyp₂) _ _ → hyp₁ _ _ , hyp₂ _ _) ⟩

  (((x₁ , x₂) (y₁ , y₂) : A × B) →
   For-iterated-equality n P (x₁ ≡ y₁) ×
   For-iterated-equality n Q (x₂ ≡ y₂))                ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ → uncurry $
                                                           For-iterated-equality-× n resp hyp) ⟩
  (((x₁ , x₂) (y₁ , y₂) : A × B) →
   For-iterated-equality n R (x₁ ≡ y₁ × x₂ ≡ y₂))      ↝⟨ (∀-cong _ λ _ → ∀-cong _ λ _ →
                                                           For-iterated-equality-cong _ n resp ≡×≡↔≡) ⟩□
  ((x y : A × B) → For-iterated-equality n R (x ≡ y))  □)

-- A closure property for ↑.

For-iterated-equality-↑ :
  {A : Type a} {Q : Type (a ⊔ ℓ) → Type (a ⊔ ℓ)} →
  Extensionality? k (a ⊔ ℓ) (a ⊔ ℓ) →
  ∀ n →
  (∀ {A B} → A ↔ B → P A ↝[ k ] Q B) →
  For-iterated-equality n P A ↝[ k ]
  For-iterated-equality n Q (↑ ℓ A)
For-iterated-equality-↑ ext n resp =
  For-iterated-equality-cong ext n resp (inverse Bijection.↑↔)

-- Closure properties for W.

For-iterated-equality-W-suc :
  {A : Type a} {B : A → Type b} →
  Extensionality b (a ⊔ b) →
  ∀ n →
  (∀ {A B} → A ↔ B → Q A → Q B) →
  ({A : Type b} {B : A → Type (a ⊔ b)} →
   (∀ x → Q (B x)) → Q (∀ x → B x)) →
  ({A : Type a} {B : A → Type (a ⊔ b)} →
   P A → (∀ x → Q (B x)) → Q (Σ A B)) →
  For-iterated-equality (suc n) P A →
  For-iterated-equality (suc n) Q (W A B)
For-iterated-equality-W-suc {Q = Q} {P = P} {B = B}
  ext n resp hyp-Π hyp-Σ fie = lemma
  where
  lemma : ∀ x y → For-iterated-equality n Q (x ≡ y)
  lemma (sup x f) (sup y g) =                                        $⟨ (λ p i → lemma (f i) _) ⟩

    (∀ p i → For-iterated-equality n Q (f i ≡ g (subst B p i)))      ↝⟨ (∀-cong _ λ _ → For-iterated-equality-Π ext n resp hyp-Π) ⟩

    (∀ p → For-iterated-equality n Q (∀ i → f i ≡ g (subst B p i)))  ↝⟨ fie _ _ ,_ ⟩

    For-iterated-equality n P (x ≡ y) ×
    (∀ p → For-iterated-equality n Q (∀ i → f i ≡ g (subst B p i)))  ↝⟨ uncurry $ For-iterated-equality-Σ n resp hyp-Σ ⟩

    For-iterated-equality n Q
      (∃ λ (p : x ≡ y) → ∀ i → f i ≡ g (subst B p i))                ↝⟨ For-iterated-equality-cong _ n resp $ _≃_.bijection $ Eq.W-≡,≡≃≡ ext ⟩□

    For-iterated-equality n Q (sup x f ≡ sup y g)                    □

For-iterated-equality-W :
  {A : Type a} {B : A → Type b} →
  Extensionality b (a ⊔ b) →
  ∀ n →
  (∀ {A B} → A ↔ B → Q A → Q B) →
  ({A : Type b} {B : A → Type (a ⊔ b)} →
   (∀ x → Q (B x)) → Q (∀ x → B x)) →
  ({A : Type a} {B : A → Type (a ⊔ b)} →
   P A → (∀ x → Q (B x)) → Q (Σ A B)) →
  (P A → Q (W A B)) →
  For-iterated-equality n P A →
  For-iterated-equality n Q (W A B)
For-iterated-equality-W _   zero    _    _     _     hyp-W = hyp-W
For-iterated-equality-W ext (suc n) resp hyp-Π hyp-Σ _     =
  For-iterated-equality-W-suc ext n resp hyp-Π hyp-Σ

-- Closure properties for _⊎_.

For-iterated-equality-⊎-suc :
  {A : Type a} {B : Type b} →
  ∀ n →
  (∀ {A B} → A ↔ B → P A → P B) →
  P ⊥ →
  For-iterated-equality (suc n) P (↑ b A) →
  For-iterated-equality (suc n) P (↑ a B) →
  For-iterated-equality (suc n) P (A ⊎ B)
For-iterated-equality-⊎-suc {P = P} n resp hyp-⊥ fie-A fie-B = λ where
  (inj₁ x) (inj₁ y) →                            $⟨ fie-A (lift x) (lift y) ⟩
    For-iterated-equality n P (lift x ≡ lift y)  ↝⟨ For-iterated-equality-cong _ n resp (Bijection.≡↔inj₁≡inj₁ F.∘ lift≡lift↔) ⟩□
    For-iterated-equality n P (inj₁ x ≡ inj₁ y)  □

  (inj₂ x) (inj₂ y) →                            $⟨ fie-B (lift x) (lift y) ⟩
    For-iterated-equality n P (lift x ≡ lift y)  ↝⟨ For-iterated-equality-cong _ n resp (Bijection.≡↔inj₂≡inj₂ F.∘ lift≡lift↔) ⟩□
    For-iterated-equality n P (inj₂ x ≡ inj₂ y)  □

  (inj₁ x) (inj₂ y) →                            $⟨ hyp-⊥ ⟩
    P ⊥                                          ↝⟨ (λ hyp → For-iterated-equality-⊥ _ n (λ _ → hyp) _) ⟩
    For-iterated-equality n P ⊥                  ↝⟨ For-iterated-equality-cong _ n resp (inverse Bijection.≡↔⊎) ⟩□
    For-iterated-equality n P (inj₁ x ≡ inj₂ y)  □

  (inj₂ x) (inj₁ y) →                            $⟨ hyp-⊥ ⟩
    P ⊥                                          ↝⟨ (λ hyp → For-iterated-equality-⊥ _ n (λ _ → hyp) _) ⟩
    For-iterated-equality n P ⊥                  ↝⟨ For-iterated-equality-cong _ n resp (inverse Bijection.≡↔⊎) ⟩□
    For-iterated-equality n P (inj₂ x ≡ inj₁ y)  □

For-iterated-equality-⊎ :
  {A : Type a} {B : Type b} →
  ∀ n →
  (∀ {A B} → A ↔ B → P A → P B) →
  P ⊥ →
  (P (↑ b A) → P (↑ a B) → P (A ⊎ B)) →
  For-iterated-equality n P (↑ b A) →
  For-iterated-equality n P (↑ a B) →
  For-iterated-equality n P (A ⊎ B)
For-iterated-equality-⊎ zero    _    _     hyp-⊎ = hyp-⊎
For-iterated-equality-⊎ (suc n) resp hyp-⊥ _     =
  For-iterated-equality-⊎-suc n resp hyp-⊥

-- Closure properties for List.

For-iterated-equality-List-suc :
  {A : Type a} →
  ∀ n →
  (∀ {A B} → A ↔ B → P A → P B) →
  P (↑ a ⊤) →
  P ⊥ →
  (∀ {A B} → P A → P B → P (A × B)) →
  For-iterated-equality (suc n) P A →
  For-iterated-equality (suc n) P (List A)
For-iterated-equality-List-suc {P = P} n resp hyp-⊤ hyp-⊥ hyp-× fie = λ where
  [] [] →                                $⟨ hyp-⊤ ⟩
    P (↑ _ ⊤)                            ↝⟨ For-iterated-equality-↑-⊤ _ n resp ⟩
    For-iterated-equality n P (↑ _ ⊤)    ↝⟨ For-iterated-equality-cong _ n resp (inverse []≡[]↔⊤ F.∘ Bijection.↑↔) ⟩□
    For-iterated-equality n P ([] ≡ [])  □

  (x ∷ xs) (y ∷ ys) →                            $⟨ For-iterated-equality-List-suc n resp hyp-⊤ hyp-⊥ hyp-× fie xs ys ⟩
    For-iterated-equality n P (xs ≡ ys)          ↝⟨ fie _ _ ,_ ⟩

    For-iterated-equality n P (x ≡ y) ×
    For-iterated-equality n P (xs ≡ ys)          ↝⟨ uncurry $ For-iterated-equality-× n resp hyp-× ⟩

    For-iterated-equality n P (x ≡ y × xs ≡ ys)  ↝⟨ For-iterated-equality-cong _ n resp (inverse ∷≡∷↔≡×≡) ⟩□

    For-iterated-equality n P (x ∷ xs ≡ y ∷ ys)  □

  [] (y ∷ ys) →                              $⟨ hyp-⊥ ⟩
    P ⊥                                      ↝⟨ (λ hyp → For-iterated-equality-⊥ _ n (λ _ → hyp) _) ⟩
    For-iterated-equality n P ⊥              ↝⟨ For-iterated-equality-cong _ n resp (inverse []≡∷↔⊥) ⟩□
    For-iterated-equality n P ([] ≡ y ∷ ys)  □

  (x ∷ xs) [] →                              $⟨ hyp-⊥ ⟩
    P ⊥                                      ↝⟨ (λ hyp → For-iterated-equality-⊥ _ n (λ _ → hyp) _) ⟩
    For-iterated-equality n P ⊥              ↝⟨ For-iterated-equality-cong _ n resp (inverse ∷≡[]↔⊥) ⟩□
    For-iterated-equality n P (x ∷ xs ≡ [])  □

For-iterated-equality-List :
  {A : Type a} →
  ∀ n →
  (∀ {A B} → A ↔ B → P A → P B) →
  P (↑ a ⊤) →
  P ⊥ →
  (∀ {A B} → P A → P B → P (A × B)) →
  (P A → P (List A)) →
  For-iterated-equality n P A →
  For-iterated-equality n P (List A)
For-iterated-equality-List zero _ _ _ _ hyp-List = hyp-List

For-iterated-equality-List (suc n) resp hyp-⊤ hyp-⊥ hyp-× _ =
  For-iterated-equality-List-suc n resp hyp-⊤ hyp-⊥ hyp-×

------------------------------------------------------------------------
-- Some "closure properties" for the predicate

-- For-iterated-equality commutes with certain type constructors
-- (assuming extensionality).

For-iterated-equality-commutes :
  Extensionality? k ℓ ℓ →
  (F : Type ℓ → Type ℓ) →
  ∀ n →
  ({A : Type ℓ} {P : A → Type ℓ} →
   F (∀ x → P x) ↝[ k ] ∀ x → F (P x)) →
  F (For-iterated-equality n P A) ↝[ k ]
  For-iterated-equality n (F ∘ P) A
For-iterated-equality-commutes _ _ zero _ = F.id

For-iterated-equality-commutes {P = P} {A = A} ext F (suc n) hyp =
  F ((x y : A) → For-iterated-equality n P (x ≡ y))            ↝⟨ hyp ⟩
  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y)))  ↝⟨ (∀-cong ext λ _ → hyp) ⟩
  ((x y : A) → F (For-iterated-equality n P (x ≡ y)))          ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → For-iterated-equality-commutes ext F n hyp) ⟩□
  ((x y : A) → For-iterated-equality n (F ∘ P) (x ≡ y))        □

-- A variant of For-iterated-equality-commutes.

For-iterated-equality-commutesᴱ-→ :
  {@0 A : Type ℓ} {@0 P : Type ℓ → Type ℓ}
  (@0 F : Type ℓ → Type ℓ) →
  ∀ n →
  ({@0 A : Type ℓ} {@0 P : A → Type ℓ} →
   F (∀ x → P x) → ∀ x → F (P x)) →
  F (For-iterated-equality n P A) →
  For-iterated-equality n (F ∘ P) A
For-iterated-equality-commutesᴱ-→ _ zero _ = id

For-iterated-equality-commutesᴱ-→ {A = A} {P = P} F (suc n) hyp =
  F ((x y : A) → For-iterated-equality n P (x ≡ y))            →⟨ hyp ⟩
  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y)))  →⟨ hyp ∘_ ⟩
  ((x y : A) → F (For-iterated-equality n P (x ≡ y)))          →⟨ For-iterated-equality-commutesᴱ-→ F n hyp ∘_ ∘_ ⟩□
  ((x y : A) → For-iterated-equality n (F ∘ P) (x ≡ y))        □

-- Another variant of For-iterated-equality-commutes.

For-iterated-equality-commutes-← :
  Extensionality? k ℓ ℓ →
  (F : Type ℓ → Type ℓ) →
  ∀ n →
  ({A : Type ℓ} {P : A → Type ℓ} →
   (∀ x → F (P x)) ↝[ k ] F (∀ x → P x)) →
  For-iterated-equality n (F ∘ P) A ↝[ k ]
  F (For-iterated-equality n P A)
For-iterated-equality-commutes-← _ _ zero _ = F.id

For-iterated-equality-commutes-← {P = P} {A = A} ext F (suc n) hyp =
  ((x y : A) → For-iterated-equality n (F ∘ P) (x ≡ y))        ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → For-iterated-equality-commutes-← ext F n hyp) ⟩
  ((x y : A) → F (For-iterated-equality n P (x ≡ y)))          ↝⟨ (∀-cong ext λ _ → hyp) ⟩
  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y)))  ↝⟨ hyp ⟩□
  F ((x y : A) → For-iterated-equality n P (x ≡ y))            □

-- A variant of For-iterated-equality-commutes-←.

For-iterated-equality-commutesᴱ-← :
  {@0 A : Type ℓ} {@0 P : Type ℓ → Type ℓ}
  (@0 F : Type ℓ → Type ℓ) →
  ∀ n →
  ({@0 A : Type ℓ} {@0 P : A → Type ℓ} →
   (∀ x → F (P x)) → F (∀ x → P x)) →
  For-iterated-equality n (F ∘ P) A →
  F (For-iterated-equality n P A)
For-iterated-equality-commutesᴱ-← _ zero _ = id

For-iterated-equality-commutesᴱ-← {A = A} {P = P} F (suc n) hyp =
  ((x y : A) → For-iterated-equality n (F ∘ P) (x ≡ y))        →⟨ For-iterated-equality-commutesᴱ-← F n hyp ∘_ ∘_ ⟩
  ((x y : A) → F (For-iterated-equality n P (x ≡ y)))          →⟨ hyp ∘_ ⟩
  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y)))  →⟨ hyp ⟩□
  F ((x y : A) → For-iterated-equality n P (x ≡ y))            □

-- For-iterated-equality commutes with certain binary type
-- constructors (assuming extensionality).

For-iterated-equality-commutes₂ :
  Extensionality? k ℓ ℓ →
  (F : Type ℓ → Type ℓ → Type ℓ) →
  ∀ n →
  ({A : Type ℓ} {P Q : A → Type ℓ} →
   F (∀ x → P x) (∀ x → Q x) ↝[ k ] ∀ x → F (P x) (Q x)) →
  F (For-iterated-equality n P A) (For-iterated-equality n Q A) ↝[ k ]
  For-iterated-equality n (λ A → F (P A) (Q A)) A
For-iterated-equality-commutes₂ _ _ zero _ = F.id

For-iterated-equality-commutes₂ {P = P} {A = A} {Q = Q}
                                ext F (suc n) hyp =
  F ((x y : A) → For-iterated-equality n P (x ≡ y))
    ((x y : A) → For-iterated-equality n Q (x ≡ y))                    ↝⟨ hyp ⟩

  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y))
               ((y : A) → For-iterated-equality n Q (x ≡ y)))          ↝⟨ (∀-cong ext λ _ → hyp) ⟩

  ((x y : A) → F (For-iterated-equality n P (x ≡ y))
                 (For-iterated-equality n Q (x ≡ y)))                  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                           For-iterated-equality-commutes₂ ext F n hyp) ⟩□
  ((x y : A) → For-iterated-equality n (λ A → F (P A) (Q A)) (x ≡ y))  □

-- A variant of For-iterated-equality-commutes₂.

For-iterated-equality-commutes₂ᴱ-→ :
  {@0 A : Type ℓ} {@0 P Q : Type ℓ → Type ℓ}
  (@0 F : Type ℓ → Type ℓ → Type ℓ) →
  ∀ n →
  ({@0 A : Type ℓ} {@0 P Q : A → Type ℓ} →
   F (∀ x → P x) (∀ x → Q x) → ∀ x → F (P x) (Q x)) →
  F (For-iterated-equality n P A) (For-iterated-equality n Q A) →
  For-iterated-equality n (λ A → F (P A) (Q A)) A
For-iterated-equality-commutes₂ᴱ-→ _ zero _ = id

For-iterated-equality-commutes₂ᴱ-→ {A = A} {P = P} {Q = Q}
                                   F (suc n) hyp =
  F ((x y : A) → For-iterated-equality n P (x ≡ y))
    ((x y : A) → For-iterated-equality n Q (x ≡ y))                    →⟨ hyp ⟩

  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y))
               ((y : A) → For-iterated-equality n Q (x ≡ y)))          →⟨ hyp ∘_ ⟩

  ((x y : A) → F (For-iterated-equality n P (x ≡ y))
                 (For-iterated-equality n Q (x ≡ y)))                  →⟨ For-iterated-equality-commutes₂ᴱ-→ F n hyp ∘_ ∘_ ⟩□
  ((x y : A) → For-iterated-equality n (λ A → F (P A) (Q A)) (x ≡ y))  □

-- Another variant of For-iterated-equality-commutes₂.

For-iterated-equality-commutes₂-← :
  Extensionality? k ℓ ℓ →
  (F : Type ℓ → Type ℓ → Type ℓ) →
  ∀ n →
  ({A : Type ℓ} {P Q : A → Type ℓ} →
   (∀ x → F (P x) (Q x)) ↝[ k ] F (∀ x → P x) (∀ x → Q x)) →
  For-iterated-equality n (λ A → F (P A) (Q A)) A ↝[ k ]
  F (For-iterated-equality n P A) (For-iterated-equality n Q A)
For-iterated-equality-commutes₂-← _ _ zero _ = F.id

For-iterated-equality-commutes₂-← {P = P} {Q = Q} {A = A}
                                  ext F (suc n) hyp =
  ((x y : A) → For-iterated-equality n (λ A → F (P A) (Q A)) (x ≡ y))  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                           For-iterated-equality-commutes₂-← ext F n hyp) ⟩
  ((x y : A) → F (For-iterated-equality n P (x ≡ y))
                 (For-iterated-equality n Q (x ≡ y)))                  ↝⟨ (∀-cong ext λ _ → hyp) ⟩

  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y))
               ((y : A) → For-iterated-equality n Q (x ≡ y)))          ↝⟨ hyp ⟩□

  F ((x y : A) → For-iterated-equality n P (x ≡ y))
    ((x y : A) → For-iterated-equality n Q (x ≡ y))                    □

-- A variant of For-iterated-equality-commutes₂-←.

For-iterated-equality-commutes₂ᴱ-← :
  {@0 A : Type ℓ} {@0 P Q : Type ℓ → Type ℓ}
  (@0 F : Type ℓ → Type ℓ → Type ℓ) →
  ∀ n →
  ({@0 A : Type ℓ} {@0 P Q : A → Type ℓ} →
   (∀ x → F (P x) (Q x)) → F (∀ x → P x) (∀ x → Q x)) →
  For-iterated-equality n (λ A → F (P A) (Q A)) A →
  F (For-iterated-equality n P A) (For-iterated-equality n Q A)
For-iterated-equality-commutes₂ᴱ-← _ zero _ = id

For-iterated-equality-commutes₂ᴱ-← {A = A} {P = P} {Q = Q}
                                   F (suc n) hyp =
  ((x y : A) → For-iterated-equality n (λ A → F (P A) (Q A)) (x ≡ y))  →⟨ For-iterated-equality-commutes₂ᴱ-← F n hyp ∘_ ∘_ ⟩
  ((x y : A) → F (For-iterated-equality n P (x ≡ y))
                 (For-iterated-equality n Q (x ≡ y)))                  →⟨ hyp ∘_ ⟩

  ((x : A) → F ((y : A) → For-iterated-equality n P (x ≡ y))
               ((y : A) → For-iterated-equality n Q (x ≡ y)))          →⟨ hyp ⟩□

  F ((x y : A) → For-iterated-equality n P (x ≡ y))
    ((x y : A) → For-iterated-equality n Q (x ≡ y))                    □

-- A corollary of For-iterated-equality-commutes₂.

For-iterated-equality-commutes-× :
  {A : Type a} →
  ∀ n →
  For-iterated-equality n P A × For-iterated-equality n Q A ↝[ a ∣ a ]
  For-iterated-equality n (λ A → P A × Q A) A
For-iterated-equality-commutes-× n ext =
  For-iterated-equality-commutes₂ ext _×_ n
    (from-isomorphism $ inverse ΠΣ-comm)

-- Some corollaries of For-iterated-equality-commutes₂ᴱ-→.

For-iterated-equality-commutesᴱ-×-→ :
  {@0 A : Type ℓ} {@0 P Q : Type ℓ → Type ℓ} →
  ∀ n →
  For-iterated-equality n P A × For-iterated-equality n Q A →
  For-iterated-equality n (λ A → P A × Q A) A
For-iterated-equality-commutesᴱ-×-→ n =
  For-iterated-equality-commutes₂ᴱ-→ _×_ n
    (λ (f , g) x → f x , g x)

For-iterated-equality-commutes-⊎ :
  {@0 A : Type ℓ} {@0 P Q : Type ℓ → Type ℓ} →
  ∀ n →
  For-iterated-equality n P A ⊎ For-iterated-equality n Q A →
  For-iterated-equality n (λ A → P A ⊎ Q A) A
For-iterated-equality-commutes-⊎ n =
  For-iterated-equality-commutes₂ᴱ-→ _⊎_ n
    [ (λ f x → inj₁ (f x)) , (λ f x → inj₂ (f x)) ]


{-

Half adjoint equivalences ([HAEquiv])

- Iso to HAEquiv ([iso→HAEquiv])
- Equiv to HAEquiv ([equiv→HAEquiv])
- Cong is an equivalence ([congEquiv])

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.HAEquiv where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Nat

record isHAEquiv {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) : Type (ℓ-max ℓ ℓ') where
  field
    g : B → A
    sec : ∀ a → g (f a) ≡ a
    ret : ∀ b → f (g b) ≡ b
    com : ∀ a → cong f (sec a) ≡ ret (f a)

  -- from redtt's ha-equiv/symm
  com-op : ∀ b → cong g (ret b) ≡ sec (g b)
  com-op b j i = hcomp (λ k → λ { (i = i0) → sec (g b) (j ∧ (~ k))
                                ; (j = i0) → g (ret b i)
                                ; (j = i1) → sec (g b) (i ∨ (~ k))
                                ; (i = i1) → g b })
                       (cap1 j i)

    where cap0 : Square {- (i = i0) -} (λ j → f (sec (g b) j))
                        {- (j = i0) -} (λ i → f (g (ret b i)))
                        {- (j = i1) -} (λ i → ret b i)
                        {- (i = i1) -} (λ j → ret b j)

          cap0 j i = hcomp (λ k → λ { (i = i0) → com (g b) (~ k) j
                                    ; (j = i0) → f (g (ret b i))
                                    ; (j = i1) → ret b i
                                    ; (i = i1) → ret b j })
                           (ret (ret b i) j)

          filler : I → I → A
          filler j i = hfill (λ k → λ { (i = i0) → g (ret b k)
                                      ; (i = i1) → g b })
                             (inS (sec (g b) i)) j

          cap1 : Square {- (i = i0) -} (λ j → sec (g b) j)
                        {- (j = i0) -} (λ i → g (ret b i))
                        {- (j = i1) -} (λ i → g b)
                        {- (i = i1) -} (λ j → g b)

          cap1 j i = hcomp (λ k → λ { (i = i0) → sec (sec (g b) j) k
                                    ; (j = i0) → sec (g (ret b i)) k
                                    ; (j = i1) → filler i k
                                    ; (i = i1) → filler j k })
                           (g (cap0 j i))

HAEquiv : ∀ {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') → Type (ℓ-max ℓ ℓ')
HAEquiv A B = Σ (A → B) λ f → isHAEquiv f

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ
    B : Type ℓ'

iso→HAEquiv : Iso A B → HAEquiv A B
iso→HAEquiv {A = A} {B = B} (iso f g ε η) = f , (record { g = g ; sec = η ; ret = ret ; com = com })
  where
    sides : ∀ b i j → Partial (~ i ∨ i) B
    sides b i j = λ { (i = i0) → ε (f (g b)) j
                    ; (i = i1) → ε b j }

    bot : ∀ b i → B
    bot b i = cong f (η (g b)) i

    ret : (b : B) → f (g b) ≡ b
    ret b i = hcomp (sides b i) (bot b i)

    com : (a : A) → cong f (η a) ≡ ret (f a)
    com a i j = hcomp (λ k → λ { (i = i0) → ε (f (η a j)) k
                               ; (i = i1) → hfill (sides (f a) j) (inS (bot (f a) j)) k
                               ; (j = i0) → ε (f (g (f a))) k
                               ; (j = i1) → ε (f a) k})
                      (cong (cong f) (sym (Hfa≡fHa (λ x → g (f x)) η a)) i j)

equiv→HAEquiv : A ≃ B → HAEquiv A B
equiv→HAEquiv e = iso→HAEquiv (equivToIso e)

congEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} {x y : A} (e : A ≃ B) → (x ≡ y) ≃ (e .fst x ≡ e .fst y)
congEquiv {A = A} {B} {x} {y} e = isoToEquiv (iso intro elim intro-elim elim-intro)
  where
    e' : HAEquiv A B
    e' = equiv→HAEquiv e

    f : A → B
    f = e' .fst

    g : B → A
    g = isHAEquiv.g (e' .snd)

    sec : ∀ a → g (f a) ≡ a
    sec = isHAEquiv.sec (e' .snd)

    ret : ∀ b → f (g b) ≡ b
    ret = isHAEquiv.ret (e' .snd)

    com : ∀ a → cong f (sec a) ≡ ret (f a)
    com = isHAEquiv.com (e' .snd)

    intro : x ≡ y → f x ≡ f y
    intro = cong f

    elim-sides : ∀ p i j → Partial (~ i ∨ i) A
    elim-sides p i j = λ { (i = i0) → sec x j
                         ; (i = i1) → sec y j }

    elim-bot : ∀ p i → A
    elim-bot p i = cong g p i

    elim : f x ≡ f y → x ≡ y
    elim p i = hcomp (elim-sides p i) (elim-bot p i)

    intro-elim : ∀ p → intro (elim p) ≡ p
    intro-elim p i j =
      hcomp (λ k → λ { (i = i0) → f (hfill (elim-sides p j)
                                    (inS (elim-bot p j)) k)
                     ; (i = i1) → ret (p j) k
                     ; (j = i0) → com x i k
                     ; (j = i1) → com y i k })
            (f (g (p j)))

    elim-intro : ∀ p → elim (intro p) ≡ p
    elim-intro p i j =
      hcomp (λ k → λ { (i = i0) → hfill (λ l → λ { (j = i0) → secEq e x l
                                                 ; (j = i1) → secEq e y l })
                                        (inS (cong (λ z → g (f z)) p j)) k
                     ; (i = i1) → p j
                     ; (j = i0) → secEq e x (i ∨ k)
                     ; (j = i1) → secEq e y (i ∨ k) })
            (secEq e (p j) i)


{-# OPTIONS --guardedness #-}

module Cubical.Codata.Stream where

open import Cubical.Codata.Stream.Base public

open import Cubical.Codata.Stream.Properties public


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

open import Cubical.HITs.Torus.Base public

-- open import Cubical.HITs.Torus.Properties public


open import Prelude hiding (abs)
open import Container.List
open import Container.Traversable
open import Tactic.Reflection hiding (substArgs) renaming (unify to unifyTC)
open import Tactic.Reflection.Equality
open import Tactic.Deriving

module Tactic.Deriving.Eq where

_∋_ : ∀ {a} (A : Set a) → A → A
A ∋ x = x

private
  -- Pattern synonyms --
  infix 5 _`≡_
  pattern _`≡_ x y = def₂ (quote _≡_) x y
  pattern `subst x y z = def₃ (quote transport) x y z
  pattern `refl = con (quote refl) []

  pattern `Eq a = def (quote Eq) (vArg a ∷ [])

  pattern vLam s t = lam visible (abs s t)

  -- Helper functions --

  nLam : ∀ {A} → List (Arg A) → Term → Term
  nLam [] t = t
  nLam (arg (arg-info v _) s ∷ tel) t = lam v (abs "x" (nLam tel t))

  nPi : ∀ {A} → List (Arg A) → Term → Term
  nPi [] t = t
  nPi (arg i _ ∷ tel) t = pi (arg i unknown) (abs "x" (nPi tel t))

  newArgs : ∀ {A} → List (Arg A) → List (Arg Term)
  newArgs {A} tel = newArgsFrom (length tel) tel
    where
      newArgsFrom : Nat → List (Arg A) → List (Arg Term)
      newArgsFrom (suc n) (arg i _ ∷ tel) = arg i (var n []) ∷ newArgsFrom n tel
      newArgsFrom _ _ = []

  hideTel : ∀ {A} → List (Arg A) → List (Arg A)
  hideTel [] = []
  hideTel (arg (arg-info _ r) t ∷ tel) = arg (arg-info hidden r) t ∷ hideTel tel

  weakenTelFrom : (from n : Nat) → Telescope → Telescope
  weakenTelFrom from n [] = []
  weakenTelFrom from n (t ∷ tel) = weakenFrom from n t ∷ weakenTelFrom (suc from) n tel

  weakenTel : (n : Nat) → Telescope → Telescope
  weakenTel 0 = id
  weakenTel n = weakenTelFrom 0 n

  #pars : (d : Name) → TC Nat
  #pars = getParameters

  argsTel : (c : Name) → TC Telescope
  argsTel c = caseM telView <$> getType c of λ
    { (tel , def d ixs) → flip drop tel <$> #pars d
    ; (tel , _        ) → pure tel
    }

  #args : (c : Name) → TC Nat
  #args c = length <$> argsTel c

  params : (c : Name) → TC (List (Arg Type))
  params c = telView <$> getType c >>= λ
    { (tel , def d ixs) → flip take tel <$> #pars d
    ; _                 → pure []
    }

  -- Parallel substitution --

  Substitution : Set
  Substitution = List (Nat × Term)

  underLambda : Substitution → Substitution
  underLambda = map (λ { (i , t) → suc i , weaken 1 t })

  {-# TERMINATING #-}
  subst : Substitution → Term → Term
  apply : Term → List (Arg Term) → Term
  substArgs : Substitution → List (Arg Term) → List (Arg Term)

  subst sub (var x args) = case (lookup sub x) of λ
    { (just s) → apply s (substArgs sub args)
    ; nothing  → var x (substArgs sub args)
    }
  subst sub (con c args) = con c (substArgs sub args)
  subst sub (def f args) = def f (substArgs sub args)
  subst sub (lam v t)    = lam v (fmap (subst (underLambda sub)) t)
  subst sub (lit l)      = lit l
  subst sub _            = unknown -- TODO

  apply f [] = f
  apply (var x args) xs = var x (args ++ xs)
  apply (con c args) xs = con c (args ++ xs)
  apply (def f args) xs = def f (args ++ xs)
  apply (lam _ (abs _ t)) (arg _ x ∷ xs) = case (strengthen 1 (subst ((0 , weaken 1 x) ∷ []) t)) of λ
    { (just f) → apply f xs
    ; nothing  → unknown
    }
  apply _ _ = unknown -- TODO

  substArgs sub = map (fmap (subst sub))

  -- Unification of datatype indices --

  data Unify : Set where
    positive : List (Nat × Term) → Unify
    negative : Unify

  failure : ∀ {a} {A : Set a} → String → TC A
  failure s = typeErrorS ("Unification error when deriving Eq: " & s)

  _&U_ : Unify → Unify → Unify
  (positive xs) &U (positive ys) = positive (xs ++ ys)
  (positive _)  &U negative      = negative
  negative      &U (positive _)  = negative
  negative      &U negative      = negative

  {-# TERMINATING #-}
  unify : Term → Term → TC Unify
  unifyArgs : List (Arg Term) → List (Arg Term) → TC Unify

  unify s            t            with s == t
  unify s            t            | yes _ = pure (positive [])
  unify (var x [])   (var y [])   | no  _ =
    if (x <? y) -- In var-var case, instantiate the one that is bound the closest to us.
    then pure (positive ((x , var y []) ∷ []))
    else pure (positive ((y , var x []) ∷ []))
  unify (var x [])   t            | no  _ =
    if (elem x (freeVars t))
    then failure "cyclic occurrence" -- We don't currently know if the occurrence is rigid or not
    else pure (positive ((x , t) ∷ []))
  unify t            (var x [])   | no  _ =
    if (elem x (freeVars t))
    then failure "cyclic occurrence"
    else pure (positive ((x , t) ∷ []))
  unify (con c₁ xs₁) (con c₂ xs₂) | no  _ =
    if (isYes (c₁ == c₂))
    then unifyArgs xs₁ xs₂
    else pure negative
  unify _ _                       | no  _ = failure "not a constructor or a variable"

  unifyArgs [] [] = pure (positive [])
  unifyArgs [] (_ ∷ _) = failure "panic: different number of arguments"
  unifyArgs (_ ∷ _) [] = failure "panic: different number of arguments"
  unifyArgs (arg v₁ x ∷ xs) (arg v₂ y ∷ ys) =
    if isYes (_==_ {{EqArgInfo}} v₁ v₂)
    then (unify x y >>= λ
      { (positive sub) → (positive sub &U_) <$> unifyArgs (substArgs sub xs) (substArgs sub ys)
      ; negative       → pure negative
      })
    else failure "panic: hiding mismatch"

  unifyIndices : (c₁ c₂ : Name) → TC Unify
  unifyIndices c₁ c₂ = do
    let panic = failure "panic: constructor type doesn't end in a def"
    tel₁ , def d₁ xs₁ ← telView <$> getType c₁ where _ → panic
    tel₂ , def d₂ xs₂ ← telView <$> getType c₂ where _ → panic
    n₁ ← #pars d₁
    n₂ ← #pars d₂
    let ixs₁ = drop n₁ xs₁
        ixs₂ = drop n₂ xs₂
    unifyArgs (weaken                        (length tel₂ - n₂) ixs₁)
            -- weaken all variables of first constructor by number of arguments of second constructor
              (weakenFrom (length tel₂ - n₂) (length tel₁ - n₁) ixs₂)
            -- weaken parameters of second constructor by number of arguments of first constructor

  -- Analysing constructor types --

  forcedArgs : (c : Name) → TC (List Nat)
  forcedArgs c = caseM (unifyIndices c c) of λ
    { (positive xs) → pure (map fst xs)
    ; _             → pure []
    }

  data Forced : Set where forced free : Forced

  instance
    DeBruijnForced : DeBruijn Forced
    strengthenFrom {{DeBruijnForced}} _ _ = just
    weakenFrom     {{DeBruijnForced}} _ _ = id

    DeBruijnProd : {A B : Set} {{_ : DeBruijn A}} {{_ : DeBruijn B}} → DeBruijn (A × B)
    strengthenFrom {{DeBruijnProd}} m n (x , y) = ⦇ strengthenFrom m n x , strengthenFrom m n y ⦈
    weakenFrom     {{DeBruijnProd}} m n (x , y) = weakenFrom m n x , weakenFrom m n y

  RemainingArgs : Nat → Set
  RemainingArgs = Vec (Arg (Forced × Term × Term))

  leftArgs : ∀ {n} → RemainingArgs n → List (Arg Term)
  leftArgs = map (fmap (fst ∘ snd)) ∘ vecToList

  rightArgs : ∀ {n} → RemainingArgs n → List (Arg Term)
  rightArgs = map (fmap (snd ∘ snd)) ∘ vecToList

  classifyArgs : (c : Name) → TC (Σ Nat RemainingArgs)
  classifyArgs c = do
      #argsc  ← #args c
      forcedc ← forcedArgs c
      let #freec = #argsc - length forcedc
      _,_ _ ∘ classify #freec forcedc (#argsc - 1) (#freec - 1) <$> argsTel c
  -- The final argument should be (weakenTel (#argsc + #freec) (argsTel c)),
  -- but we don't really care about the types of the arguments anyway.
    where
      classify : Nat → List Nat → (m n : Nat) (tel : List (Arg Type)) → RemainingArgs (length tel)
      classify _ _ m n [] = []
      classify #freec forcedc m n (arg i ty ∷ tel) =
        if (elem m forcedc)
        then arg i (forced , var (#freec + m) [] , var (#freec + m) []) ∷
             classify #freec forcedc (m - 1) n       tel
        else arg i (free   , var (#freec + m) [] , var n            []) ∷
             classify #freec forcedc (m - 1) (n - 1) tel

  rightArgsFree : ∀ {n} → RemainingArgs n → List (Arg Term)
  rightArgsFree [] = []
  rightArgsFree (arg _ (forced , _ , _) ∷ xs) = rightArgsFree xs
  rightArgsFree (arg i (free   , _ , x) ∷ xs) = arg i x ∷ rightArgsFree xs

  countFree : ∀ {n} → RemainingArgs n → Nat
  countFree xs = length (rightArgsFree xs)

  refreshArgs : ∀ {n} → RemainingArgs n → RemainingArgs n
  refreshArgs xs = refresh (nfree - 1) xs
    where
      nfree = countFree xs

      refresh : ∀ {n} → Nat → RemainingArgs n → RemainingArgs n
      refresh n [] = []
      refresh n (arg i (forced , x , y) ∷ xs) = arg i (forced , x , y) ∷ refresh n xs
      refresh n (arg i (free   , x , y) ∷ xs) = arg i (free , x , var n []) ∷ refresh (n - 1) xs

  -- Matching constructor case --

  caseDec : ∀ {a b} {A : Set a} {B : Set b} → Dec A → (A → B) → (¬ A → B) → B
  caseDec (yes x) y n = y x
  caseDec (no x)  y n = n x

  checkEqArgs : ∀ {n} (c : Name) (xs : List (Arg Term)) (ys : RemainingArgs n) → Term
  checkEqArgs c xs (arg i (forced , y , z) ∷ args) =
    checkEqArgs c (xs ++ [ arg i y ]) args
  checkEqArgs {suc remainingArgs} c xs (arg i (free , y , z) ∷ args) =
    def₃ (quote caseDec)
      (def₂ (quote _==_) y z)
      (vLam "x≡y" checkEqArgsYes)
      (vLam "x≢y" checkEqArgsNo)
    where
      remainingFree = countFree args

      wk : {A : Set} {{_ : DeBruijn A}} → Nat → A → A
      wk k = weaken (k + remainingFree)

      checkEqArgsYes : Term
      checkEqArgsYes =
        def (quote transport) (
          (vArg (vLam "x" (nPi (rightArgsFree args) (def₁ (quote Dec)
            (wk 2
               (con c (xs ++ arg i y ∷ (leftArgs args)))
             `≡
             con c (wk 2 xs ++
                    arg i (var remainingFree []) ∷
                    rightArgs (refreshArgs (wk 2 args)))))))) ∷
          (vArg (var 0 [])) ∷
          (vArg (nLam (rightArgsFree args)
            (checkEqArgs c
              (wk 1 (xs ++ [ arg i y ]))
              (refreshArgs (wk 1 args))))) ∷
          weaken 1 (rightArgsFree args))

      checkEqArgsNo : Term
      checkEqArgsNo =
        con₁ (quote no) (vLam "eq" (var 1 (vArg (def₃ (quote _∋_)
          (nPi (hideTel (arg i z ∷ rightArgsFree args))
            (weaken (3 + remainingFree) (con c (xs ++ arg i y ∷ leftArgs args))
              `≡ con c (wk 3 xs ++
                        arg i (var remainingFree []) ∷
                        rightArgs (refreshArgs (wk 3 args)))
            `→
             wk 4 y `≡ var (1 + remainingFree) []))
          (pat-lam (clause
            (replicate (1 + remainingFree) (hArg dot) ++ vArg `refl ∷ [])
            `refl ∷ []) [])
          (var 0 [])) ∷ [])))

  checkEqArgs _ _ _ = con₁ (quote yes) (con₀ (quote refl))

  matchingClause : (c : Name) → TC Clause
  matchingClause c = do
      _ , args ← classifyArgs c
      paramPats ← map (fmap λ _ → var "A") ∘ hideTel <$> params c
      params    ← makeParams args
      pure (clause (paramPats ++
                  vArg (con c (makeLeftPattern args)) ∷
                  vArg (con c (makeRightPattern args)) ∷ [])
                 (checkEqArgs c params args))
    where
      args = classifyArgs c

      makeParamsPats : TC (List (Arg Pattern))
      makeParamsPats = map (fmap λ _ → var "A") ∘ hideTel <$> params c

      makeParams : ∀ {n} → RemainingArgs n → TC (List (Arg Term))
      makeParams args = do
        ps ← params c
        pure (weaken (length (vecToList args) + countFree args) (newArgs ps))

      makeLeftPattern : ∀ {n} → RemainingArgs n → List (Arg Pattern)
      makeLeftPattern [] = []
      makeLeftPattern (arg i _ ∷ xs) = arg i (var "x") ∷ makeLeftPattern xs

      makeRightPattern : ∀ {n} → RemainingArgs n → List (Arg Pattern)
      makeRightPattern [] = []
      makeRightPattern (arg i (forced , _ , _) ∷ xs) = arg i dot ∷ makeRightPattern xs
      makeRightPattern (arg i (free   , _ , _) ∷ xs) = arg i (var "y") ∷ makeRightPattern xs

  -- Mismatching constructor case --

  mismatchingClause : (c₁ c₂ : Name) (fs : List Nat) → TC Clause
  mismatchingClause c₁ c₂ fs = do
      args₁ ← argsTel c₁
      args₂ ← argsTel c₂
      let #args₁ = length args₁
          #args₂ = length args₂
      pure (clause (vArg (con c₁ (makePattern (#args₁ + #args₂ - 1) args₁)) ∷
                     vArg (con c₂ (makePattern (#args₂ - 1) args₂)) ∷ [])
                    (con (quote no) ([ vArg (pat-lam ([ absurd-clause ([ vArg absurd ]) ]) []) ])))
    where
      makePattern : (k : Nat) (args : List (Arg Type)) → List (Arg Pattern)
      makePattern k [] = []
      makePattern k (arg i _ ∷ args) = (if (elem k fs) then (arg i dot) else arg i (var "x"))
                                         ∷ makePattern (k - 1) args

  -- Clauses --

  makeClause : (c₁ c₂ : Name) → TC (List Clause)
  makeClause c₁ c₂ = case (c₁ == c₂) of λ
    { (yes _) → _∷ [] <$> matchingClause c₁
    ; (no  _) → caseM (unifyIndices c₁ c₂) of λ
      { (positive fs) → _∷ [] <$> mismatchingClause c₁ c₂ (map fst fs)
      ; _             → pure []
      }
    }

  constructorPairs : (d : Name) → TC (List (Name × Name))
  constructorPairs d = caseM getDefinition d of λ
    { (data-type _ cs) → pure $ concat (map (λ c₁ → map (_,_ c₁) cs) cs)
    ; _ → pure []
    }

  eqDefinition : (d : Name) → TC (List Clause)
  eqDefinition d = concat <$> (mapM (uncurry makeClause) =<< constructorPairs d)

  makeArgs : Nat → List (Arg Nat) → List (Arg Term)
  makeArgs n xs = reverse $ map (fmap (λ i → var (n - i - 1) [])) xs

  computeInstanceType : Nat → List (Arg Nat) → Type → Maybe Term
  computeInstanceType n xs (agda-sort _) =
    just (`Eq (var n (makeArgs n xs)))
  computeInstanceType n xs (pi a (abs s b)) =
    pi (hArg (unArg a)) ∘ abs s <$> computeInstanceType (suc n) ((n <$ a) ∷ xs) b
  computeInstanceType _ _ _ = nothing

  computeType : Name → Nat → List (Arg Nat) → Telescope → Telescope → Term
  computeType d n xs is [] =
    telPi (reverse is) $
    def d (makeArgs (n + k) xs) `→ def d (makeArgs (n + k + 1) xs) `→
    def₁ (quote Dec) (var 1 [] `≡ var 0 [])
    where k = length is
  computeType d n xs is (a ∷ tel) =
    unArg a `→ʰ
    (case computeInstanceType 0 [] (weaken 1 $ unArg a) of
     λ { (just i) → computeType d (1 + n) ((n <$ a) ∷ xs) (iArg (weaken (length is) i) ∷ weaken 1 is) tel
       ; nothing →  computeType d (1 + n) ((n <$ a) ∷ xs) (weaken 1 is) tel })

eqType : Name → TC Type
eqType d = computeType d 0 [] [] ∘ fst ∘ telView <$> getType d

macro
  deriveEqType : Name → Tactic
  deriveEqType d hole = unifyTC hole =<< (computeType d 0 [] [] ∘ fst ∘ telView <$> getType d)

deriveEqDef : Name → Name → TC ⊤
deriveEqDef i d = defineFun i =<< eqDefinition d

declareEqInstance : Name → Name → TC ⊤
declareEqInstance iname d =
  declareDef (iArg iname) =<< instanceType d (quote Eq)

defineEqInstance : Name → Name → TC ⊤
defineEqInstance iname d = do
  fname ← freshName ("_==[" & show d & "]_")
  declareDef (vArg fname) =<< eqType d
  dictCon ← recordConstructor (quote Eq)
  defineFun iname (clause [] (con₁ dictCon (def₀ fname)) ∷ [])
  defineFun fname =<< eqDefinition d
  return _

deriveEq : Name → Name → TC ⊤
deriveEq iname d =
  declareEqInstance iname d >>
  defineEqInstance  iname d