adding a few more exchange properties

adding a few more exchange properties

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness

module exchange where
  -- exchanging just two disequal elements produces the same context
  swap-little : {A : Set} {x y : Nat} {τ1 τ2 : A} → (x ≠ y) →
    ((■ (x , τ1)) ,, (y , τ2)) == ((■ (y , τ2)) ,, (x , τ1))
  swap-little {A} {x} {y} {τ1} {τ2} neq = ∪comm (■ (x , τ1))
                                                (■ (y , τ2))
                                                (disjoint-singles neq)

  -- really the core of all the exchange arguments: contexts with two
  -- disequal elements exchanged are the same. we reassociate the unions,
  -- swap as above, and then associate them back.
  --
  -- note that this is generic in the contents of the context. the proofs
  -- below show the exchange properties that we actually need in the
  -- various other proofs; the remaning exchange properties for both Δ and
  -- Γ positions for all the other hypothetical judgements are exactly in
  -- this pattern.
  swap : {A : Set} {x y : Nat} {τ1 τ2 : A} (Γ : A ctx) (x≠y : x == y → ⊥) →
         ((Γ ,, (x , τ1)) ,, (y , τ2)) == ((Γ ,, (y , τ2)) ,, (x , τ1))
  swap {A} {x} {y} {τ1} {τ2} Γ neq =
                        (∪assoc Γ (■ (x , τ1)) (■ (y , τ2)) (disjoint-singles neq) ) ·
                        (ap1 (λ qq → Γ ∪ qq) (swap-little neq) ·
                        ! (∪assoc Γ (■ (y , τ2)) (■ (x , τ1)) (disjoint-singles (flip neq))))

  -- the above exchange principle used via transport in the judgements we needed
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y =
    tr (λ qq → Δ , qq ⊢ σ :s: Γ') (swap Γ x≠y)

  exchange-synth : ∀{Γ x y τ τ1 τ2 e}
                       → x ≠ y
                       → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e => τ
                       → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e => τ
  exchange-synth {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq  =
    tr (λ qq → qq ⊢ e => τ) (swap Γ neq)

  exchange-ana : ∀{Γ x y τ τ1 τ2 e}
                       → x ≠ y
                       → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e <= τ
                       → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e <= τ
  exchange-ana {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq  =
    tr (λ qq → qq ⊢ e <= τ) (swap Γ neq)

  exchange-expand-synth : ∀{Γ x y τ1 τ2 e τ d Δ} →
                        x ≠ y →
                        (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e ⇒ τ ~> d ⊣ Δ →
                        (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e ⇒ τ ~> d ⊣ Δ
  exchange-expand-synth {Γ = Γ} {e = e} {τ = τ} {d = d } {Δ = Δ} neq =
    tr (λ qq → qq ⊢ e ⇒ τ ~> d ⊣ Δ) (swap Γ neq)

  exchange-expand-ana : ∀ {Γ x y τ1 τ2 τ τ' d e Δ} →
                      x ≠ y →
                      (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                      (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
  exchange-expand-ana {Γ = Γ} {τ = τ} {τ' = τ'} {d = d} {e = e} {Δ = Δ} neq =
    tr (λ qq → qq ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ) (swap Γ neq)

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness

module exchange where
  -- exchanging just two disequal elements produces the same context
  swap-little : {A : Set} {x y : Nat} {τ1 τ2 : A} → (x ≠ y) →
    ((■ (x , τ1)) ,, (y , τ2)) == ((■ (y , τ2)) ,, (x , τ1))
  swap-little {A} {x} {y} {τ1} {τ2} neq = ∪comm (■ (x , τ1))
                                                (■ (y , τ2))
                                                (disjoint-singles neq)

  -- really the core of all the exchange arguments: contexts with two
  -- disequal elements exchanged are the same. we reassociate the unions,
  -- swap as above, and then associate them back.
  --
  -- note that this is generic in the contents of the context. the proofs
  -- below show the exchange properties that we actually need in the
  -- various other proofs; the remaning exchange properties for both Δ and
  -- Γ positions for all the other hypothetical judgements are exactly in
  -- this pattern.
  swap : {A : Set} {x y : Nat} {τ1 τ2 : A} (Γ : A ctx) (x≠y : x == y → ⊥) →
         ((Γ ,, (x , τ1)) ,, (y , τ2)) == ((Γ ,, (y , τ2)) ,, (x , τ1))
  swap {A} {x} {y} {τ1} {τ2} Γ neq =
                        (∪assoc Γ (■ (x , τ1)) (■ (y , τ2)) (disjoint-singles neq) ) ·
                        (ap1 (λ qq → Γ ∪ qq) (swap-little neq) ·
                        ! (∪assoc Γ (■ (y , τ2)) (■ (x , τ1)) (disjoint-singles (flip neq))))

  -- the above exchange principle used via transport in the judgements we needed
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y xy =
    tr (λ qq → Δ , qq ⊢ σ :s: Γ') (swap Γ x≠y) xy

  exchange-synth : ∀{Γ x y τ τ1 τ2 e}
                       → x ≠ y
                       → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e => τ
                       → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e => τ
  exchange-synth {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq synth =
    tr (λ qq → qq ⊢ e => τ) (swap Γ neq) synth

  exchange-ana : ∀{Γ x y τ τ1 τ2 e}
                       → x ≠ y
                       → (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ e <= τ
                       → (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ e <= τ
  exchange-ana {Γ} {x} {y} {τ} {τ1} {τ2} {e} neq ana =
    tr (λ qq → qq ⊢ e <= τ) (swap Γ neq) ana


Added doc.

Added doc.

------------------------------------------------------------------------------
-- Conversion rules for the recursive operator rec
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module LTC-PCF.Data.Nat.Rec.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning
open import Common.Function

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Rec

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

private
  -- We follow the same methodology used in
  -- LTC-PCF.Program.Division.EquationsI (see it for the
  -- documentation).

  ----------------------------------------------------------------------------
  -- The steps

  -- Initially, the conversion rule fix-eq is applied.
  rec-s₁ : D → D → D → D
  rec-s₁ n a f = rech (fix rech) · n · a · f

  -- First argument application.
  rec-s₂ : D → D
  rec-s₂ n = lam (λ a → lam (λ f →
                    (if (iszero₁ n)
                        then a
                        else f · pred₁ n · (fix rech · pred₁ n · a · f))))

  -- Second argument application.
  rec-s₃ : D → D → D
  rec-s₃ n a = lam (λ f →
                   (if (iszero₁ n)
                       then a
                       else f · pred₁ n · (fix rech · pred₁ n · a · f)))

  -- Third argument application.
  rec-s₄ : D → D → D → D
  rec-s₄ n a f = if (iszero₁ n)
                     then a
                     else f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction iszero₁ n ≡ b.
  rec-s₅ : D → D → D → D → D
  rec-s₅ n a f b = if b
                      then a
                      else f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction of iszero₁ n ≡ true
  --
  -- It should be
  -- rec-s₆ : D → D → D → D
  -- rec-s₆ n a f = a
  --
  -- but we do not give a name to this step.

  -- Reduction iszero₁ n ≡ false.
  rec-s₆ : D → D → D → D
  rec-s₆ n a f = f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction pred₁ (succ n) ≡ n.
  rec-s₇ : D → D → D → D
  rec-s₇ n a f = f · n · (fix rech · n · a · f)

  ----------------------------------------------------------------------------
  -- The execution steps

  -- We follow the same methodology used in
  -- LTC-PCF.Program.Division.EquationsI (see it for the
  -- documentation).

  -- Application of the conversion rule fix-eq.
  proof₀₋₁ : ∀ n a f → fix rech · n · a · f ≡ rec-s₁ n a f
  proof₀₋₁ n a f = subst (λ x → x · n · a · f ≡
                                rech (fix rech) · n · a · f )
                         (sym (fix-eq rech))
                         refl

  -- Application of the first argument.
  proof₁₋₂ : ∀ n a f → rec-s₁ n a f ≡ rec-s₂ n · a · f
  proof₁₋₂ n a f = subst (λ x → x · a · f ≡ rec-s₂ n · a · f)
                         (sym (beta rec-s₂ n))
                         refl

  -- Application of the second argument.
  proof₂₋₃ : ∀ n a f → rec-s₂ n · a · f ≡ rec-s₃ n a · f
  proof₂₋₃ n a f = subst (λ x → x · f ≡ rec-s₃ n a · f)
                         (sym (beta (rec-s₃ n) a))
                         refl

  -- Application of the third argument.
  proof₃₋₄ : ∀ n a f → rec-s₃ n a · f ≡ rec-s₄ n a f
  proof₃₋₄ n a f = beta (rec-s₄ n a) f

  -- 01 June 2013. This proof could use pattern matching on _≡_. See
  -- Agda issue 865.
  --
  -- Cases iszero₁ n ≡ b using that proof.
  proof₄₋₅ : ∀ n a f b → iszero₁ n ≡ b → rec-s₄ n a f ≡ rec-s₅ n a f b
  proof₄₋₅ n a f b h = subst (λ x → rec-s₅ n a f x ≡ rec-s₅ n a f b)
                             (sym h)
                             refl

  -- Reduction of if true ... using the conversion rule if-true.
  proof₅₊ : ∀ n a f → rec-s₅ n a f true ≡ a
  proof₅₊ n a f = if-true a

   -- Reduction of if false ... using the conversion rule if-false.
  proof₅₋₆ : ∀ n a f → rec-s₅ n a f false ≡ rec-s₆ n a f
  proof₅₋₆ n a f = if-false (rec-s₆ n a f)

  -- Reduction pred₁ (succ n) ≡ n using the conversion rule pred₁-S.
  proof₆₋₇ : ∀ n a f → rec-s₆ (succ₁ n) a f ≡ rec-s₇ n a f
  proof₆₋₇ n a f = subst (λ x → rec-s₇ x a f ≡ rec-s₇ n a f)
                         (sym (pred-S n))
                         refl

------------------------------------------------------------------------------
-- The conversion rules for rec.

rec-0 : ∀ a {f} → rec zero a f ≡ a
rec-0 a {f} =
  fix rech · zero · a · f  ≡⟨ proof₀₋₁ zero a f ⟩
  rec-s₁ zero a f          ≡⟨ proof₁₋₂ zero a f ⟩
  rec-s₂ zero · a · f      ≡⟨ proof₂₋₃ zero a f ⟩
  rec-s₃ zero a · f        ≡⟨ proof₃₋₄ zero a f ⟩
  rec-s₄ zero a f          ≡⟨ proof₄₋₅ zero a f true iszero-0 ⟩
  rec-s₅ zero a f true     ≡⟨ proof₅₊ zero a f ⟩
  a                        ∎

rec-S : ∀ n a f → rec (succ₁ n) a f ≡ f · n · (rec n a f)
rec-S n a f =
  fix rech · (succ₁ n) · a · f  ≡⟨ proof₀₋₁ (succ₁ n) a f ⟩
  rec-s₁ (succ₁ n) a f          ≡⟨ proof₁₋₂ (succ₁ n) a f ⟩
  rec-s₂ (succ₁ n) · a · f      ≡⟨ proof₂₋₃ (succ₁ n) a f ⟩
  rec-s₃ (succ₁ n) a · f        ≡⟨ proof₃₋₄ (succ₁ n) a f ⟩
  rec-s₄ (succ₁ n) a f          ≡⟨ proof₄₋₅ (succ₁ n) a f false (iszero-S n) ⟩
  rec-s₅ (succ₁ n) a f false    ≡⟨ proof₅₋₆ (succ₁ n) a f ⟩
  rec-s₆ (succ₁ n) a f          ≡⟨ proof₆₋₇ n a f ⟩
  rec-s₇ n a f                  ∎

------------------------------------------------------------------------------
-- Conversion rules for the recursive operator rec
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module LTC-PCF.Data.Nat.Rec.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning
open import Common.Function

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Rec

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

private
  -- We follow the same methodology used in
  -- LTC-PCF.Program.Division.EquationsI (see it for the
  -- documentation).

  ----------------------------------------------------------------------------
  -- The steps

  -- Initially, the conversion rule fix-eq is applied.
  rec-s₁ : D → D → D → D
  rec-s₁ n a f = rech (fix rech) · n · a · f

  -- First argument application.
  rec-s₂ : D → D
  rec-s₂ n = lam (λ a → lam (λ f →
                    (if (iszero₁ n)
                        then a
                        else f · pred₁ n · (fix rech · pred₁ n · a · f))))

  -- Second argument application.
  rec-s₃ : D → D → D
  rec-s₃ n a = lam (λ f →
                   (if (iszero₁ n)
                       then a
                       else f · pred₁ n · (fix rech · pred₁ n · a · f)))

  -- Third argument application.
  rec-s₄ : D → D → D → D
  rec-s₄ n a f = if (iszero₁ n)
                     then a
                     else f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction iszero₁ n ≡ b.
  rec-s₅ : D → D → D → D → D
  rec-s₅ n a f b = if b
                      then a
                      else f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction of iszero₁ n ≡ true
  --
  -- It should be
  -- rec-s₆ : D → D → D → D
  -- rec-s₆ n a f = a
  --
  -- but we do not give a name to this step.

  -- Reduction iszero₁ n ≡ false.
  rec-s₆ : D → D → D → D
  rec-s₆ n a f = f · pred₁ n · (fix rech · pred₁ n · a · f)

  -- Reduction pred₁ (succ n) ≡ n.
  rec-s₇ : D → D → D → D
  rec-s₇ n a f = f · n · (fix rech · n · a · f)

  ----------------------------------------------------------------------------
  -- The execution steps

  -- We follow the same methodology used in
  -- LTC-PCF.Program.Division.EquationsI (see it for the
  -- documentation).

  -- Application of the conversion rule fix-eq.
  proof₀₋₁ : ∀ n a f → fix rech · n · a · f ≡ rec-s₁ n a f
  proof₀₋₁ n a f = subst (λ x → x · n · a · f ≡ rech (fix rech) · n · a · f )
                         (sym (fix-eq rech))
                         refl

  -- Application of the first argument.
  proof₁₋₂ : ∀ n a f → rec-s₁ n a f ≡ rec-s₂ n · a · f
  proof₁₋₂ n a f = subst (λ x → x · a · f ≡ rec-s₂ n · a · f)
                         (sym (beta rec-s₂ n))
                         refl

  -- Application of the second argument.
  proof₂₋₃ : ∀ n a f → rec-s₂ n · a · f ≡ rec-s₃ n a · f
  proof₂₋₃ n a f = subst (λ x → x · f ≡ rec-s₃ n a · f)
                         (sym (beta (rec-s₃ n) a))
                         refl

  -- Application of the third argument.
  proof₃₋₄ : ∀ n a f → rec-s₃ n a · f ≡ rec-s₄ n a f
  proof₃₋₄ n a f = beta (rec-s₄ n a) f

  -- Cases iszero₁ n ≡ b using that proof.
  proof₄₋₅ : ∀ n a f b → iszero₁ n ≡ b → rec-s₄ n a f ≡ rec-s₅ n a f b
  proof₄₋₅ n a f b h = subst (λ x → rec-s₅ n a f x ≡ rec-s₅ n a f b)
                             (sym h)
                             refl

  -- Reduction of if true ... using the conversion rule if-true.
  proof₅₊ : ∀ n a f → rec-s₅ n a f true ≡ a
  proof₅₊ n a f = if-true a

   -- Reduction of if false ... using the conversion rule if-false.
  proof₅₋₆ : ∀ n a f → rec-s₅ n a f false ≡ rec-s₆ n a f
  proof₅₋₆ n a f = if-false (rec-s₆ n a f)

  -- Reduction pred₁ (succ n) ≡ n using the conversion rule pred₁-S.
  proof₆₋₇ : ∀ n a f → rec-s₆ (succ₁ n) a f ≡ rec-s₇ n a f
  proof₆₋₇ n a f = subst (λ x → rec-s₇ x a f ≡ rec-s₇ n a f)
                         (sym (pred-S n))
                         refl

------------------------------------------------------------------------------
-- The conversion rules for rec.

rec-0 : ∀ a {f} → rec zero a f ≡ a
rec-0 a {f} =
  fix rech · zero · a · f  ≡⟨ proof₀₋₁ zero a f ⟩
  rec-s₁ zero a f          ≡⟨ proof₁₋₂ zero a f ⟩
  rec-s₂ zero · a · f      ≡⟨ proof₂₋₃ zero a f ⟩
  rec-s₃ zero a · f        ≡⟨ proof₃₋₄ zero a f ⟩
  rec-s₄ zero a f          ≡⟨ proof₄₋₅ zero a f true iszero-0 ⟩
  rec-s₅ zero a f true     ≡⟨ proof₅₊ zero a f ⟩
  a                        ∎

rec-S : ∀ n a f → rec (succ₁ n) a f ≡ f · n · (rec n a f)
rec-S n a f =
  fix rech · (succ₁ n) · a · f  ≡⟨ proof₀₋₁ (succ₁ n) a f ⟩
  rec-s₁ (succ₁ n) a f          ≡⟨ proof₁₋₂ (succ₁ n) a f ⟩
  rec-s₂ (succ₁ n) · a · f      ≡⟨ proof₂₋₃ (succ₁ n) a f ⟩
  rec-s₃ (succ₁ n) a · f        ≡⟨ proof₃₋₄ (succ₁ n) a f ⟩
  rec-s₄ (succ₁ n) a f          ≡⟨ proof₄₋₅ (succ₁ n) a f false (iszero-S n) ⟩
  rec-s₅ (succ₁ n) a f false    ≡⟨ proof₅₋₆ (succ₁ n) a f ⟩
  rec-s₆ (succ₁ n) a f          ≡⟨ proof₆₋₇ n a f ⟩
  rec-s₇ n a f                  ∎


Updated an issue.

Updated an issue.

Ignore-this: 6271a60d2dbe3a0f1d5d53e46e39ae9b

darcs-hash:20110820132419-3bd4e-4a602e1125c80e4134202edb8306da90d9c4f9ad.gz

------------------------------------------------------------------------------
-- Testing the erasure of proof terms
------------------------------------------------------------------------------

-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/AgdaLib/Syntax/DeBruijn.hs:417

module Issues.ProofTerm where

postulate
  D   : Set
  N   : D → Set
  _≡_ : D → D → Set
  _∷_ : D → D → D

data ListN : D → Set where
  consLN : ∀ {n ns} → N n → (LNns : ListN ns) → ListN (n ∷ ns)
{-# ATP axiom consLN #-}

-- We need to have at least one conjecture to generate a TPTP file.
postulate refl : ∀ d → d ≡ d
{-# ATP prove refl #-}

------------------------------------------------------------------------------
-- Testing the erasure of proof terms
------------------------------------------------------------------------------

module Issues.Tmp.ProofTerm where

postulate
  D   : Set
  N   : D → Set
  _≡_ : D → D → Set
  _∷_ : D → D → D

data ListN : D → Set where
  consLN : ∀ {n ns} → N n → (LNns : ListN ns) → ListN (n ∷ ns)
{-# ATP axiom consLN #-}

-- We need to have at least one conjecture to generate a TPTP file.
postulate refl : ∀ d → d ≡ d
{-# ATP prove refl #-}


some syntax to match the paper, more rules

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_&_]  : Nat → subst → ë
    ⦇_⦈[_&_] : ë → Nat → subst → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< e2' > t2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u & id Γ ] ⊣ (∅ ,, (u ::[ Γ ] ⦇⦈))
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u & id Γ ] ⊣ (Δ ,, (u ::[ Γ ] ⦇⦈))
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< e' > t) ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      -- EALam :
      -- EASubsume :
      -- EAEHole :
      -- EANEHole :

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  -- error
  data _err[_] : ë → hctx → Set where -- todo not a context

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u & σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u & σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- small step semantics
  data _↦_ : ë → ë → Set where

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_&_]  : Nat → subst → ë
    ⦇_⦈[_&_] : ë → Nat → subst → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ (e1 ∘ e2) ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      -- ESAp2
      -- ESAp3
      -- ESEHole
      -- ESNEHole
      -- ESAsc1
      -- ESAsc2

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      -- EALam
      -- EASubsume
      -- EAEHole
      -- EANEHole

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where

  -- todo: ugh
  postulate
    [_]_ : subst → ë → ë

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  -- error
  data _err[_] : ë → hctx → Set where -- todo not a context

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u & σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u & σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- small step semantics
  data _↦_ : ë → ë → Set where


FunUniverse: not was broken

FunUniverse: not was broken

module FunUniverse.Core where

open import Type
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_)
import Data.Bool.NP as B
open B using (if_then_else_; true; false)
open import Data.Unit using (⊤)
open import Data.Fin using (Fin)
open import Function using (_∘′_; flip)
import Data.Vec.NP as V
import Level as L
open V using (Vec; []; _∷_)

open import Data.Bit using (Bit; 0b; 1b)
open import Data.Bits using (Bits; _→ᵇ_; RewireTbl; 0ⁿ; 1ⁿ)

import FunUniverse.BinTree as Tree
open Tree using (Tree)
open import FunUniverse.Data

open import FunUniverse.Types public
import FunUniverse.Defaults.FirstPart as Defaults⟨first-part⟩
open import FunUniverse.Rewiring.Linear

record HasBijFork {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU
  field
    -- bijFork f₀ f₁ (0' , x) = 0' , f₀ x
    -- bijFork f₀ f₁ (1' , x) = 1' , f₁ x
    bijFork : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ `Bit `× B

  -- bijFork′ f₀ f₁ (0' , x) = 0' , f₀ 0' x
  -- bijFork′ f₀ f₁ (1' , x) = 1' , f₁ 1' x
  bijFork′ : ∀ {A B} → (Bit → A `→ B) → `Bit `× A `→ `Bit `× B
  bijFork′ f = bijFork (f 0b) (f 1b)

record HasFork {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor _,_
  open FunUniverse funU
  field
    -- cond (0' , x₀ , x₁) = x₀
    -- cond (1' , x₀ , x₁) = x₁
    -- See Defaults.DefaultCond
    cond : ∀ {A} → `Bit `× A `× A `→ A

    -- fork f₀ f₁ (0' , x) = f₀ x
    -- fork f₀ f₁ (1' , x) = f₁ x
    -- See Defaults.DefaultFork
    fork : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B

  fork′ : ∀ {A B} → (Bit → A `→ B) → `Bit `× A `→ B
  fork′ f = fork (f 0b) (f 1b)

record HasXor {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU
  field
    xor : ∀ {n} → Bits n → `Endo (`Bits n)

  vnot : ∀ {n} → `Endo (`Bits n)
  vnot = xor 1ⁿ

  ⟨⊕_⟩ : ∀ {n} → Bits n → `Endo (`Bits n)
  ⟨⊕ xs ⟩ = xor xs

record Bijective {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk

  field
    linRewiring : LinRewiring funU
    hasBijFork  : HasBijFork  funU
    hasXor      : HasXor      funU

record Rewiring {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU

  field
    linRewiring : LinRewiring funU

    -- Unit (ignoring its argument)
    tt : ∀ {_⊤} → _⊤ `→ `⊤

    -- Products (all that comes from LinRewiring)
    dup : ∀ {A} → A `→ A `× A

    -- Vectors
    <[]> : ∀ {_⊤ A} → _⊤ `→ `Vec A 0
    -- * <∷> and uncons come from LinRewiring

    -- Products (group 1 primitive functions or derived from group 2)
    <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
    fst   : ∀ {A B} → A `× B `→ A
    snd   : ∀ {A B} → A `× B `→ B

    rewire    : ∀ {i o} → (Fin o → Fin i) → i `→ᵇ o
    rewireTbl : ∀ {i o} → RewireTbl i o    → i `→ᵇ o

  open LinRewiring linRewiring public

  proj : ∀ {A} → Bit → (A `× A) `→ A
  proj true  = fst
  proj false = snd

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons ⁏ fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons ⁏ snd

  constVec : ∀ {n a _⊤} {A : Set a} {B} → (A → `⊤ `→ B) → Vec A n → _⊤ `→ `Vec B n
  constVec f vec = tt ⁏ constVec⊤ f vec

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = <[]>
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail ⁏ drop m

  msb : ∀ m {n} → (m + n) `→ᵇ m
  msb m = take m

  lsb : ∀ {n} k → (n + k) `→ᵇ k
  lsb {n} _ = drop n

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = <[]>
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail ⁏ last

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = <[]>
  replicate {suc n} = < id , replicate > ⁏ <∷>

  constBits′ : ∀ {n A} → Bits n → (A `× A) `→ `Vec A n
  constBits′ [] = <[]>
  constBits′ (b ∷ xs) = dup ⁏ < proj b ∷′ constBits′ xs >

record FunOps {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU

  field
    rewiring : Rewiring funU
    hasFork  : HasFork  funU

    -- Bit
    <0b> <1b> : ∀ {_⊤} → _⊤ `→ `Bit

    -- Products
    -- * <_×_>; first; second; swap; assoc; <tt,id>; snd<tt,> come from LinRewiring
    -- * dup; <_,_>; fst; snd come from Rewiring

    -- Vectors
    -- <[]>; <∷>; uncons come from Rewiring

  open Defaults⟨first-part⟩ funU
  open Rewiring rewiring public
  open HasFork  hasFork  public

  -- Bad idea™
  <if_then_else_> : ∀ {A B} (b : A `→ `Bit) (f g : A `→ B) → A `→ B
  <if b then if-1 else if-0 > = < b , id > ⁏ fork if-0 if-1

  not : `Bit `→ `Bit
  not = <id,tt> ⁏ fork <1b> <0b>

  -- We might want it to be part of the interface
  hasXor : HasXor funU
  hasXor = mk (DefaultXor.xor id not <_⊛>)

  hasBijFork : HasBijFork funU
  hasBijFork = mk (DefaultBijForkFromFork.bijFork <_,_> fst fork)

  bijective : Bijective funU
  bijective = mk linRewiring hasBijFork hasXor

  open HasXor     hasXor public
  open HasBijFork hasBijFork public

  infixr 3 _&&&_
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  constBit : ∀ {_⊤} → Bit → _⊤ `→ `Bit
  constBit b = if b then <1b> else <0b>

  -- Notice that this one costs 1 unit of space.
  dup⁏<_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                         → A `→ `Vec B (1 + n)
  dup⁏< f ∷′ g > = dup ⁏ < f ∷′ g >

  <0,_> : ∀ {A B} → (A `→ B) → A `→ `Bit `× B
  <0, f > = <tt⁏ <0b> , f >

  <1,_> : ∀ {A B} → (A `→ B) → A `→ `Bit `× B
  <1, f > = <tt⁏ <1b> , f >

  <0,> : ∀ {A} → A `→ `Bit `× A
  <0,> = <0, id >

  <1,> : ∀ {A} → A `→ `Bit `× A
  <1,> = <1, id >

  <0,1> : ∀ {_⊤} → _⊤ `→ `Bit `× `Bit
  <0,1> = <0, <1b> >

  <0∷_> : ∀ {n A} → (A `→ `Bits n) → A `→ `Bits (1 + n)
  <0∷ f > = <tt⁏ <0b> ∷′ f >

  <1∷_> : ∀ {n A} → (A `→ `Bits n) → A `→ `Bits (1 + n)
  <1∷ f > = <tt⁏ <1b> ∷′ f >

  <0∷> : ∀ {n} → n `→ᵇ (1 + n)
  <0∷> = <0∷ id >

  <1∷> : ∀ {n} → n `→ᵇ (1 + n)
  <1∷> = <1∷ id >

  constBits : ∀ {n _⊤} → Bits n → _⊤ `→ `Bits n
  constBits = constVec constBit

  <0ⁿ> : ∀ {n _⊤} → _⊤ `→ `Bits n
  <0ⁿ> = constBits 0ⁿ

  <1ⁿ> : ∀ {n _⊤} → _⊤ `→ `Bits n
  <1ⁿ> = constBits 1ⁿ

  constBits′′ : ∀ {n _⊤} → Bits n → _⊤ `→ `Bits n
  constBits′′ bs = <0,1> ⁏ constBits′ bs

  `Maybe : T → T
  `Maybe A = `Bit `× A

  <nothing> : ∀ {A} → A `→ `Maybe A
  <nothing> = <0,>

  <just> : ∀ {A} → A `→ `Maybe A
  <just> = <1,>

  <is-just?_∶_> : ∀ {A B C} → (f : A `× B `→ C) (g : B `→ C) → `Maybe A `× B `→ C
  <is-just? f ∶ g > = <if fst ⁏ fst then first snd ⁏ f else snd ⁏ g >

  _∣?_ : ∀ {A} → `Maybe A `× `Maybe A `→ `Maybe A
  _∣?_ = <is-just? fst ⁏ <just> ∶ id >

  _`→?_ : T → T → Set
  A `→? B = A `→ `Maybe B

  search : ∀ {n A} → (A `× A `→ A) → (`Bits n `→ A) → `⊤ `→ A
  search {zero}  _  f = <[]> ⁏ f
  search {suc n} op f = <tt⁏ search op (f ∘ <0∷>) , search op (f ∘ <1∷>) > ⁏ op

  find? : ∀ {n A} → (`Bits n `→? A) → `⊤ `→? A
  find? = search _∣?_

  findB : ∀ {n} → (`Bits n `→ `Bit) → `⊤ `→? `Bits n
  findB pred = find? <if pred then <just> else <nothing> >

  fromTree : ∀ {n A} → Tree (`⊤ `→ A) n → `Bits n `→ A
  fromTree (Tree.leaf x) = tt ⁏ x
  fromTree (Tree.fork t₀ t₁) = uncons ⁏ fork (fromTree t₀) (fromTree t₁)

  fromFun : ∀ {n A} → (Bits n → `⊤ `→ A) → `Bits n `→ A
  fromFun = fromTree ∘′ Tree.fromFun

  fromBitsFun : ∀ {i o} → (i →ᵇ o) → i `→ᵇ o
  fromBitsFun f = fromFun (constBits ∘′ f)

  <xor> : `Bit `× `Bit `→ `Bit
  <xor> = fork id not

  <or> : `Bit `× `Bit `→ `Bit
  <or> = fork id <1b>

  <and> : `Bit `× `Bit `→ `Bit
  <and> = fork <0b> id

  <==ᵇ> : `Bit `× `Bit `→ `Bit
  <==ᵇ> = <xor> ⁏ not

  <==> : ∀ {n} → `Bits n `× `Bits n `→ `Bit
  <==> {zero}  = <1b>
  <==> {suc n} = < uncons × uncons > ⁏ < <==ᵇ> `zip` <==> {n} > ⁏ <or>

  <⊕> : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
  <⊕> = zipWith <xor>

  -- vnot : ∀ {n} → `Endo (`Bits n)
  -- vnot = map not

  allBits : ∀ n → `⊤ `→ `Vec (`Bits n) (2^ n)
  allBits zero    = < <[]> ∷[]>
  allBits (suc n) = < bs ⁏ map <0∷> ++ bs ⁏ map <1∷> >
    where bs = allBits n

  sucBCarry : ∀ {n} → `Bits n `→ `Bits (1 + n)
  sucBCarry {zero}  = < <0b> ∷[]>
  sucBCarry {suc n} = uncons
                    ⁏ fork <0∷ sucBCarry >
                          (sucBCarry ⁏ uncons ⁏ fork <0∷ <1∷> > <1∷ <0∷> >)

  sucB : ∀ {n} → `Bits n `→ `Bits n
  sucB = sucBCarry ⁏ tail

  half-adder : `Bit `× `Bit `→ `Bit `× `Bit
  half-adder = < <xor> , <and> >

  full-adder : `Bit `× `Bit `× `Bit `→ `Bit `× `Bit
  full-adder = < (sc₂ ⁏ fst) , < (sc₁ ⁏ snd) , (sc₂ ⁏ snd) > ⁏ <or> >
    where a   = snd ⁏ fst
          b   = snd ⁏ snd
          cᵢₙ = fst
          sc₁ = < a , b > ⁏ half-adder
          sc₂ = < (sc₁ ⁏ fst) , cᵢₙ > ⁏ half-adder

  lookupTbl : ∀ {n A} → `Bits n `× `Vec A (2^ n) `→ A
  lookupTbl {zero} = snd ⁏ head
  lookupTbl {suc n}
    = first uncons
    ⁏ assoc
    ⁏ fork (second (take (2^ n)) ⁏ lookupTbl)
           (second (drop (2^ n)) ⁏ lookupTbl)

  funFromTbl : ∀ {n A} → Vec (`⊤ `→ A) (2^ n) → (`Bits n `→ A)
  funFromTbl {zero} (x ∷ []) = tt ⁏ x
  funFromTbl {suc n} tbl
    = uncons ⁏ fork (funFromTbl (V.take (2^ n) tbl))
                    (funFromTbl (V.drop (2^ n) tbl))

  tblFromFun : ∀ {n A} → (`Bits n `→ A) → `⊤ `→ `Vec A (2^ n)
  tblFromFun {zero}  f = < <[]> ⁏ f ∷[]>
  tblFromFun {suc n} f = < tblFromFun (<0∷> ⁏ f) ++
                           tblFromFun (<1∷> ⁏ f) >

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _⊤} → _⊤ `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = <[]>
    tabulate {suc n} f = <tt⁏ fz ⁏ f ∷′ tabulate (fs ⁏ f) >

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst ⁏ elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail ⁏ lookup)

    allFin : ∀ {n _⊤} → _⊤ `→ `Vec (`Fin n) n
    allFin = tabulate id

module Defaults {t} {T : Set t} (funU : FunUniverse T) where
  open FunUniverse funU
  open Defaults⟨first-part⟩ funU public

  module RewiringDefaults
    (linRewiring : LinRewiring funU)
    (tt       : ∀ {_⊤} → _⊤ `→ `⊤)
    (dup      : ∀ {A} → A `→ A `× A)
    (rewire   : ∀ {i o} → (Fin o → Fin i) → i `→ᵇ o) where

    open LinRewiring linRewiring
    open DefaultsGroup1 _∘_ tt snd<tt,> dup swap first public
    <[]> : ∀ {_⊤ A} → _⊤ `→ `Vec A 0
    <[]> = tt ⁏ tt→[]
    open DefaultRewireTbl rewire public
-- -}

module FunUniverse.Core where

open import Type
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2^_)
import Data.Bool.NP as B
open B using (if_then_else_; true; false)
open import Data.Unit using (⊤)
open import Data.Fin using (Fin)
open import Function using (_∘′_; flip)
import Data.Vec.NP as V
import Level as L
open V using (Vec; []; _∷_)

open import Data.Bit using (Bit; 0b; 1b)
open import Data.Bits using (Bits; _→ᵇ_; RewireTbl; 0ⁿ; 1ⁿ)

import FunUniverse.BinTree as Tree
open Tree using (Tree)
open import FunUniverse.Data

open import FunUniverse.Types public
import FunUniverse.Defaults.FirstPart as Defaults⟨first-part⟩
open import FunUniverse.Rewiring.Linear

record HasBijFork {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU
  field
    -- bijFork f₀ f₁ (0' , x) = 0' , f₀ x
    -- bijFork f₀ f₁ (1' , x) = 1' , f₁ x
    bijFork : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ `Bit `× B

  -- bijFork′ f₀ f₁ (0' , x) = 0' , f₀ 0' x
  -- bijFork′ f₀ f₁ (1' , x) = 1' , f₁ 1' x
  bijFork′ : ∀ {A B} → (Bit → A `→ B) → `Bit `× A `→ `Bit `× B
  bijFork′ f = bijFork (f 0b) (f 1b)

record HasFork {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor _,_
  open FunUniverse funU
  field
    -- cond (0' , x₀ , x₁) = x₀
    -- cond (1' , x₀ , x₁) = x₁
    -- See Defaults.DefaultCond
    cond : ∀ {A} → `Bit `× A `× A `→ A

    -- fork f₀ f₁ (0' , x) = f₀ x
    -- fork f₀ f₁ (1' , x) = f₁ x
    -- See Defaults.DefaultFork
    fork : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B

  fork′ : ∀ {A B} → (Bit → A `→ B) → `Bit `× A `→ B
  fork′ f = fork (f 0b) (f 1b)

record HasXor {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU
  field
    xor : ∀ {n} → Bits n → `Endo (`Bits n)

  vnot : ∀ {n} → `Endo (`Bits n)
  vnot = xor 1ⁿ

  ⟨⊕_⟩ : ∀ {n} → Bits n → `Endo (`Bits n)
  ⟨⊕ xs ⟩ = xor xs

record Bijective {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk

  field
    linRewiring : LinRewiring funU
    hasBijFork  : HasBijFork  funU
    hasXor      : HasXor      funU

record Rewiring {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU

  field
    linRewiring : LinRewiring funU

    -- Unit (ignoring its argument)
    tt : ∀ {_⊤} → _⊤ `→ `⊤

    -- Products (all that comes from LinRewiring)
    dup : ∀ {A} → A `→ A `× A

    -- Vectors
    <[]> : ∀ {_⊤ A} → _⊤ `→ `Vec A 0
    -- * <∷> and uncons come from LinRewiring

    -- Products (group 1 primitive functions or derived from group 2)
    <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
    fst   : ∀ {A B} → A `× B `→ A
    snd   : ∀ {A B} → A `× B `→ B

    rewire    : ∀ {i o} → (Fin o → Fin i) → i `→ᵇ o
    rewireTbl : ∀ {i o} → RewireTbl i o    → i `→ᵇ o

  open LinRewiring linRewiring public

  proj : ∀ {A} → Bit → (A `× A) `→ A
  proj true  = fst
  proj false = snd

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons ⁏ fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons ⁏ snd

  constVec : ∀ {n a _⊤} {A : Set a} {B} → (A → `⊤ `→ B) → Vec A n → _⊤ `→ `Vec B n
  constVec f vec = tt ⁏ constVec⊤ f vec

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = <[]>
  take (suc m) = < id ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = id
  drop (suc m) = tail ⁏ drop m

  msb : ∀ m {n} → (m + n) `→ᵇ m
  msb m = take m

  lsb : ∀ {n} k → (n + k) `→ᵇ k
  lsb {n} _ = drop n

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = <[]>
  init {suc n} = < id ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail ⁏ last

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = <[]>
  replicate {suc n} = < id , replicate > ⁏ <∷>

  constBits′ : ∀ {n A} → Bits n → (A `× A) `→ `Vec A n
  constBits′ [] = <[]>
  constBits′ (b ∷ xs) = dup ⁏ < proj b ∷′ constBits′ xs >

record FunOps {t} {T : Set t} (funU : FunUniverse T) : Set t where
  constructor mk
  open FunUniverse funU

  field
    rewiring : Rewiring funU
    hasFork  : HasFork  funU

    -- Bit
    <0b> <1b> : ∀ {_⊤} → _⊤ `→ `Bit

    -- Products
    -- * <_×_>; first; second; swap; assoc; <tt,id>; snd<tt,> come from LinRewiring
    -- * dup; <_,_>; fst; snd come from Rewiring

    -- Vectors
    -- <[]>; <∷>; uncons come from Rewiring

  open Defaults⟨first-part⟩ funU
  open Rewiring rewiring public
  open HasFork  hasFork  public

  -- Bad idea™
  <if_then_else_> : ∀ {A B} (b : A `→ `Bit) (f g : A `→ B) → A `→ B
  <if b then if-1 else if-0 > = < b , id > ⁏ fork if-0 if-1

  not : `Bit `→ `Bit
  not = <id,tt> ⁏ fork <0b> <1b>

  -- We might want it to be part of the interface
  hasXor : HasXor funU
  hasXor = mk (DefaultXor.xor id not <_⊛>)

  hasBijFork : HasBijFork funU
  hasBijFork = mk (DefaultBijForkFromFork.bijFork <_,_> fst fork)

  bijective : Bijective funU
  bijective = mk linRewiring hasBijFork hasXor

  open HasXor     hasXor public
  open HasBijFork hasBijFork public

  infixr 3 _&&&_
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  f &&& g = < f , g >

  constBit : ∀ {_⊤} → Bit → _⊤ `→ `Bit
  constBit b = if b then <1b> else <0b>

  -- Notice that this one costs 1 unit of space.
  dup⁏<_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                         → A `→ `Vec B (1 + n)
  dup⁏< f ∷′ g > = dup ⁏ < f ∷′ g >

  <0,_> : ∀ {A B} → (A `→ B) → A `→ `Bit `× B
  <0, f > = <tt⁏ <0b> , f >

  <1,_> : ∀ {A B} → (A `→ B) → A `→ `Bit `× B
  <1, f > = <tt⁏ <1b> , f >

  <0,> : ∀ {A} → A `→ `Bit `× A
  <0,> = <0, id >

  <1,> : ∀ {A} → A `→ `Bit `× A
  <1,> = <1, id >

  <0,1> : ∀ {_⊤} → _⊤ `→ `Bit `× `Bit
  <0,1> = <0, <1b> >

  <0∷_> : ∀ {n A} → (A `→ `Bits n) → A `→ `Bits (1 + n)
  <0∷ f > = <tt⁏ <0b> ∷′ f >

  <1∷_> : ∀ {n A} → (A `→ `Bits n) → A `→ `Bits (1 + n)
  <1∷ f > = <tt⁏ <1b> ∷′ f >

  <0∷> : ∀ {n} → n `→ᵇ (1 + n)
  <0∷> = <0∷ id >

  <1∷> : ∀ {n} → n `→ᵇ (1 + n)
  <1∷> = <1∷ id >

  constBits : ∀ {n _⊤} → Bits n → _⊤ `→ `Bits n
  constBits = constVec constBit

  <0ⁿ> : ∀ {n _⊤} → _⊤ `→ `Bits n
  <0ⁿ> = constBits 0ⁿ

  <1ⁿ> : ∀ {n _⊤} → _⊤ `→ `Bits n
  <1ⁿ> = constBits 1ⁿ

  constBits′′ : ∀ {n _⊤} → Bits n → _⊤ `→ `Bits n
  constBits′′ bs = <0,1> ⁏ constBits′ bs

  `Maybe : T → T
  `Maybe A = `Bit `× A

  <nothing> : ∀ {A} → A `→ `Maybe A
  <nothing> = <0,>

  <just> : ∀ {A} → A `→ `Maybe A
  <just> = <1,>

  <is-just?_∶_> : ∀ {A B C} → (f : A `× B `→ C) (g : B `→ C) → `Maybe A `× B `→ C
  <is-just? f ∶ g > = <if fst ⁏ fst then first snd ⁏ f else snd ⁏ g >

  _∣?_ : ∀ {A} → `Maybe A `× `Maybe A `→ `Maybe A
  _∣?_ = <is-just? fst ⁏ <just> ∶ id >

  _`→?_ : T → T → Set
  A `→? B = A `→ `Maybe B

  search : ∀ {n A} → (A `× A `→ A) → (`Bits n `→ A) → `⊤ `→ A
  search {zero}  _  f = <[]> ⁏ f
  search {suc n} op f = <tt⁏ search op (f ∘ <0∷>) , search op (f ∘ <1∷>) > ⁏ op

  find? : ∀ {n A} → (`Bits n `→? A) → `⊤ `→? A
  find? = search _∣?_

  findB : ∀ {n} → (`Bits n `→ `Bit) → `⊤ `→? `Bits n
  findB pred = find? <if pred then <just> else <nothing> >

  fromTree : ∀ {n A} → Tree (`⊤ `→ A) n → `Bits n `→ A
  fromTree (Tree.leaf x) = tt ⁏ x
  fromTree (Tree.fork t₀ t₁) = uncons ⁏ fork (fromTree t₀) (fromTree t₁)

  fromFun : ∀ {n A} → (Bits n → `⊤ `→ A) → `Bits n `→ A
  fromFun = fromTree ∘′ Tree.fromFun

  fromBitsFun : ∀ {i o} → (i →ᵇ o) → i `→ᵇ o
  fromBitsFun f = fromFun (constBits ∘′ f)

  <xor> : `Bit `× `Bit `→ `Bit
  <xor> = fork id not

  <or> : `Bit `× `Bit `→ `Bit
  <or> = fork id <1b>

  <and> : `Bit `× `Bit `→ `Bit
  <and> = fork <0b> id

  <==ᵇ> : `Bit `× `Bit `→ `Bit
  <==ᵇ> = <xor> ⁏ not

  <==> : ∀ {n} → `Bits n `× `Bits n `→ `Bit
  <==> {zero}  = <1b>
  <==> {suc n} = < uncons × uncons > ⁏ < <==ᵇ> `zip` <==> {n} > ⁏ <or>

  <⊕> : ∀ {n} → `Bits n `× `Bits n `→ `Bits n
  <⊕> = zipWith <xor>

  -- vnot : ∀ {n} → `Endo (`Bits n)
  -- vnot = map not

  allBits : ∀ n → `⊤ `→ `Vec (`Bits n) (2^ n)
  allBits zero    = < <[]> ∷[]>
  allBits (suc n) = < bs ⁏ map <0∷> ++ bs ⁏ map <1∷> >
    where bs = allBits n

  sucBCarry : ∀ {n} → `Bits n `→ `Bits (1 + n)
  sucBCarry {zero}  = < <0b> ∷[]>
  sucBCarry {suc n} = uncons
                    ⁏ fork <0∷ sucBCarry >
                          (sucBCarry ⁏ uncons ⁏ fork <0∷ <1∷> > <1∷ <0∷> >)

  sucB : ∀ {n} → `Bits n `→ `Bits n
  sucB = sucBCarry ⁏ tail

  half-adder : `Bit `× `Bit `→ `Bit `× `Bit
  half-adder = < <xor> , <and> >

  full-adder : `Bit `× `Bit `× `Bit `→ `Bit `× `Bit
  full-adder = < (sc₂ ⁏ fst) , < (sc₁ ⁏ snd) , (sc₂ ⁏ snd) > ⁏ <or> >
    where a   = snd ⁏ fst
          b   = snd ⁏ snd
          cᵢₙ = fst
          sc₁ = < a , b > ⁏ half-adder
          sc₂ = < (sc₁ ⁏ fst) , cᵢₙ > ⁏ half-adder

  lookupTbl : ∀ {n A} → `Bits n `× `Vec A (2^ n) `→ A
  lookupTbl {zero} = snd ⁏ head
  lookupTbl {suc n}
    = first uncons
    ⁏ assoc
    ⁏ fork (second (take (2^ n)) ⁏ lookupTbl)
           (second (drop (2^ n)) ⁏ lookupTbl)

  funFromTbl : ∀ {n A} → Vec (`⊤ `→ A) (2^ n) → (`Bits n `→ A)
  funFromTbl {zero} (x ∷ []) = tt ⁏ x
  funFromTbl {suc n} tbl
    = uncons ⁏ fork (funFromTbl (V.take (2^ n) tbl))
                    (funFromTbl (V.drop (2^ n) tbl))

  tblFromFun : ∀ {n A} → (`Bits n `→ A) → `⊤ `→ `Vec A (2^ n)
  tblFromFun {zero}  f = < <[]> ⁏ f ∷[]>
  tblFromFun {suc n} f = < tblFromFun (<0∷> ⁏ f) ++
                           tblFromFun (<1∷> ⁏ f) >

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _⊤} → _⊤ `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = <[]>
    tabulate {suc n} f = <tt⁏ fz ⁏ f ∷′ tabulate (fs ⁏ f) >

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst ⁏ elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail ⁏ lookup)

    allFin : ∀ {n _⊤} → _⊤ `→ `Vec (`Fin n) n
    allFin = tabulate id

module Defaults {t} {T : Set t} (funU : FunUniverse T) where
  open FunUniverse funU
  open Defaults⟨first-part⟩ funU public

  module RewiringDefaults
    (linRewiring : LinRewiring funU)
    (tt       : ∀ {_⊤} → _⊤ `→ `⊤)
    (dup      : ∀ {A} → A `→ A `× A)
    (rewire   : ∀ {i o} → (Fin o → Fin i) → i `→ᵇ o) where

    open LinRewiring linRewiring
    open DefaultsGroup1 _∘_ tt snd<tt,> dup swap first public
    <[]> : ∀ {_⊤ A} → _⊤ `→ `Vec A 0
    <[]> = tt ⁏ tt→[]
    open DefaultRewireTbl rewire public
-- -}


Make _⊕_ more coherent with _⊝_

Make _⊕_ more coherent with _⊝_

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes (Fig. 3).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

-- Extension point 1: A term for ⊝ on base types.
DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

-- Extension point 2: A term for ⊕ on base types.
ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  -- We provide: terms for ⊕ and ⊝ on arbitrary types.
  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    (let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       absV 4 (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x))

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    (let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       absV 3 (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

  diff : ∀ τ {Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff _ = app₂ diff-term

  apply : ∀ τ {Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply _ = app₂ apply-term

  infixl 6 apply diff
  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_
  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = apply τ

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes (Fig. 3).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

-- Extension point 1: A term for ⊝ on base types.
DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

-- Extension point 2: A term for ⊕ on base types.
ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  -- We provide: terms for ⊕ and ⊝ on arbitrary types.
  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    (let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       absV 4 (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x))

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    (let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       absV 3 (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

  diff : ∀ τ {Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff _ = app₂ diff-term

  apply : ∀ τ {Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply _ = app₂ apply-term

  infixl 6 apply diff
  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_
  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = app₂ apply-term


Fixed doc.

Fixed doc.

------------------------------------------------------------------------------
-- The FOTC co-inductive natural numbers type
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- N.B. This module is re-exported by FOTC.Data.Conat.

-- Adapted from (Sander 1992).

-- References:
--
-- • Herbert P. Sander. A logic of functional programs with an
--   application to concurrency. PhD thesis, Chalmers University of
--   Technology and University of Gothenburg, Department of Computer
--   Sciences, 1992.

module FOTC.Data.Conat.Type where

open import FOTC.Base

------------------------------------------------------------------------------
-- The FOTC co-inductive natural numbers type (co-inductive predicate
-- for total co-inductive natural)

-- Functional for the NatF predicate.
-- NatF : (D → Set) → D → Set
-- NatF P n = n = zero ∨ (∃[ n' ] P n' ∧ n = succ n')

-- Conat is the greatest fixed-point of NatF (by Conat-unf and
-- Conat-coind).

postulate Conat : D → Set

-- Conat is a post-fixed point of NatF, i.e.
--
-- Conat ≤ NatF Conat.
postulate
  Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')
{-# ATP axiom Conat-unf #-}

-- Conat is the greatest post-fixed point of NatF, i.e
--
-- ∀ P. P ≤ NatF P ⇒ P ≤ Conat.
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  Conat-coind : ∀ (A : D → Set) {n} →
                -- A is post-fixed point of NatF.
                (A n → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n')) →
                -- Conat is greater than A.
                A n → Conat n

-- Because a greatest post-fixed point is a fixed-point, then the
-- Conat predicate is also a pre-fixed point of the functional NatF,
-- i.e,
--
-- NatF Conat ≤ Conat.
Conat-pre-fixed : ∀ {n} →
                  (n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')) →
                  Conat n
Conat-pre-fixed {n} h = Conat-coind A prf h
  where
  A : D → Set
  A m = m ≡ zero ∨ (∃[ m' ] Conat m' ∧ m ≡ succ₁ m')

  prf : A n → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n')
  prf (inj₁ n≡0) = inj₁ n≡0
  prf (inj₂ (n' , CNn' , n≡Sn')) = inj₂ (n' , Conat-unf CNn' , n≡Sn')

------------------------------------------------------------------------------
-- The FOTC co-inductive natural numbers type
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- N.B. This module is re-exported by FOTC.Data.Conat.

-- Adapted from (Sander 1992).

-- References:
--
-- • Herbert P. Sander. A logic of functional programs with an
--   application to concurrency. PhD thesis, Chalmers University of
--   Technology and University of Gothenburg, Department of Computer
--   Sciences, 1992.

module FOTC.Data.Conat.Type where

open import FOTC.Base

------------------------------------------------------------------------------
-- The FOTC co-inductive natural numbers type (co-inductive predicate
-- for total co-inductive natural)

-- Functional for the ConatF predicate.
-- ConatF : (D → Set) → D → Set
-- ConatF P n = n = zero ∨ (∃[ n' ] P n' ∧ n = succ n')

-- Conat is the greatest fixed-point of ConatF (by Conat-unf and
-- Conat-coind).

postulate Conat : D → Set

-- Conat is a post-fixed point of ConatF, i.e.
--
-- Conat ≤ ConatF Stream.
postulate
  Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')
{-# ATP axiom Conat-unf #-}

-- Conat is the greatest post-fixed point of ConatF, i.e
--
-- ∀ P. P ≤ ConatF P ⇒ P ≤ Conat.
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  Conat-coind : ∀ (A : D → Set) {n} →
                -- A is post-fixed point of ConatF.
                (A n → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n')) →
                -- Conat is greater than A.
                A n → Conat n

-- Because a greatest post-fixed point is a fixed-point, then the
-- Conat predicate is also a pre-fixed point of the functional ConatF,
-- i.e,
--
-- ConatF Conat ≤ Conat.
Conat-pre-fixed : ∀ {n} →
                  (n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')) →
                  Conat n
Conat-pre-fixed {n} h = Conat-coind A prf h
  where
  A : D → Set
  A m = m ≡ zero ∨ (∃[ m' ] Conat m' ∧ m ≡ succ₁ m')

  prf : A n → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n')
  prf (inj₁ n≡0) = inj₁ n≡0
  prf (inj₂ (n' , CNn' , n≡Sn')) = inj₂ (n' , Conat-unf CNn' , n≡Sn')


Add comment

Add comment

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

UncurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedCases E P X = Cases E P → X

CurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedCases [] P X = X
CurriedCases (l ∷ E) P X = P here → CurriedCases E (λ t → P (there t)) X

curryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : UncurriedCases E P X) → CurriedCases E P X
curryCases [] P X f = f tt
curryCases (l ∷ E) P X f = λ c → curryCases E (λ t → P (there t)) X (λ cs → f (c , cs))

uncurryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : CurriedCases E P X) → UncurriedCases E P X
uncurryCases [] P X x tt = x
uncurryCases (l ∷ E) P X f (c , cs) = uncurryCases E (λ t → P (there t)) X (f c) cs

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`End j) X P i q = ⊤
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`Arg A B) X P i (a , b) = All I (B a) X P i b
All I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × All I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

data μ (I : Set) (D : Desc I) (i : I) : Set where
  -- this equals UncurriedEl I D (μ I D)
  con : El I D (μ I D) i → μ I D i

con2 : (I : Set) (D : Desc I) → CurriedEl I D (μ I D)
con2 I D = curryEl I D (μ I D) con

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

UncurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : {i : I} → El I D X i → X i)
  → Set
UncurriedAll I D X P cn =
  (i : I) (xs : El I D X i) → All I D X P i xs → P i (cn xs)

CurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedAll I (`End i) X P cn =
  P i (cn refl)
CurriedAll I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedAll I D X P (λ xs → cn (x , xs))
CurriedAll I (`Arg A B) X P cn =
  (a : A) → CurriedAll I (B a) X P (λ xs → cn (a , xs))
CurriedAll I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedAll I D X P (λ xs → cn (f , xs))

curryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedAll I D X P cn)
  → CurriedAll I D X P cn
curryAll I (`End i) X P cn pf =
  pf i refl tt
curryAll I (`Rec i D) X P cn pf =
  λ x ih → curryAll I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryAll I (`Arg A B) X P cn pf =
  λ a → curryAll I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryAll I (`RecFun A B D) X P cn pf =
  λ f ihf → curryAll I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedAll I D X P cn)
  → UncurriedAll I D X P cn
uncurryAll I (`End .i) X P cn pf i refl tt =
  pf
uncurryAll I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryAll I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryAll I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryAll I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryAll I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryAll I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : UncurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : UncurriedAll I D₁ (μ I D₁) P con)
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

ind2 :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : CurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x
ind2 I D P pcon i x = ind I D P (uncurryAll I D (μ I D) P con pcon) i x

elim :
  (I : Set)
  (E : Enum)
  (Cs : Tag E → Desc I)
  → let D = `Arg (Tag E) Cs in
  (P : (i : I) → μ I D i → Set)
  → UncurriedCases E
    (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs)))
    ((i : I) (x : μ I D i) → P i x)
elim I E Cs P cs i x =
  let D = `Arg (Tag E) Cs in
  ind2 I D P (case E (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs))) cs) i x

elim2 :
  (I : Set)
  (E : Enum)
  (Cs : Tag E → Desc I)
  → let D = `Arg (Tag E) Cs in
  (P : (i : I) → μ I D i → Set)
  → let Q = (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs)))
        X = ((i : I) (x : μ I D i) → P i x)
  in CurriedCases E Q X
elim2 I E Cs P =
  let D = `Arg (Tag E) Cs
      Q = (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs)))
      X = ((i : I) (x : μ I D i) → P i x)
  in curryCases E Q X (elim I E Cs P)

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) m)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) n)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

  module GenericEliminator where

    add : ℕ tt → ℕ tt → ℕ tt
    add = elim2 ⊤ ℕT ℕC _
      (λ n → n)
      (λ m ih n → suc (ih n))
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elim2 ⊤ ℕT ℕC _
      (λ n → zero)
      (λ m ih n → add n (ih n))
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elim2 (ℕ tt) VecT (VecC A) _
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elim2 (ℕ tt) VecT (VecC (Vec A m)) _
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

{-# OPTIONS --type-in-type #-}
open import Data.Unit
open import Data.Product hiding ( curry ; uncurry )
open import Data.List hiding ( concat )
open import Data.String
open import Relation.Binary.PropositionalEquality
module Spire.Examples.PropositionalDesc where

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

elimEq : (A : Set) (x : A) (P : (y : A) → x ≡ y → Set)
  → P x refl
  → (y : A) (p : x ≡ y) → P y p
elimEq A .x P prefl x refl = prefl

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

Label : Set
Label = String

Enum : Set
Enum = List Label

data Tag : Enum → Set where
  here : ∀{l E} → Tag (l ∷ E)
  there : ∀{l E} → Tag E → Tag (l ∷ E)

Cases : (E : Enum) (P : Tag E → Set) → Set
Cases [] P = ⊤
Cases (l ∷ E) P = P here × Cases E λ t → P (there t)

case : (E : Enum) (P : Tag E → Set) (cs : Cases E P) (t : Tag E) → P t
case (l ∷ E) P (c , cs) here = c
case (l ∷ E) P (c , cs) (there t) = case E (λ t → P (there t)) cs t

UncurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedCases E P X = Cases E P → X

CurriedCases : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedCases [] P X = X
CurriedCases (l ∷ E) P X = P here → CurriedCases E (λ t → P (there t)) X

curryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : UncurriedCases E P X) → CurriedCases E P X
curryCases [] P X f = f tt
curryCases (l ∷ E) P X f = λ c → curryCases E (λ t → P (there t)) X (λ cs → f (c , cs))

uncurryCases : (E : Enum) (P : Tag E → Set) (X : Set)
  (f : CurriedCases E P X) → UncurriedCases E P X
uncurryCases [] P X x tt = x
uncurryCases (l ∷ E) P X f (c , cs) = uncurryCases E (λ t → P (there t)) X (f c) cs

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

data Desc (I : Set) : Set₁ where
  `End : (i : I) → Desc I
  `Rec : (i : I) (D : Desc I) → Desc I
  `Arg : (A : Set) (B : A → Desc I) → Desc I
  `RecFun : (A : Set) (B : A → I) (D : Desc I) → Desc I

ISet : Set → Set₁
ISet I = I → Set

El : (I : Set) (D : Desc I) (X : ISet I) → ISet I
El I (`End j) X i = j ≡ i
El I (`Rec j D) X i = X j × El I D X i
El I (`Arg A B) X i = Σ A (λ a → El I (B a) X i)
El I (`RecFun A B D) X i = ((a : A) → X (B a)) × El I D X i

data μ (I : Set) (D : Desc I) (i : I) : Set where
  con : El I D (μ I D) i → μ I D i

All : (I : Set) (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : El I D X i) → Set
All I (`End j) X P i q = ⊤
All I (`Rec j D) X P i (x , xs) = P j x × All I D X P i xs
All I (`Arg A B) X P i (a , b) = All I (B a) X P i b
All I (`RecFun A B D) X P i (f , xs) = ((a : A) → P (B a) (f a)) × All I D X P i xs

caseD : (E : Enum) (I : Set) (cs : Cases E (λ _ → Desc I)) (t : Tag E) → Desc I
caseD E I cs t = case E (λ _ → Desc I) cs t

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

UncurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedEl I D X = {i : I} → El I D X i → X i

CurriedEl : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedEl I (`End i) X = X i
CurriedEl I (`Rec j D) X = (x : X j) → CurriedEl I D X
CurriedEl I (`Arg A B) X = (a : A) → CurriedEl I (B a) X
CurriedEl I (`RecFun A B D) X = ((a : A) → X (B a)) → CurriedEl I D X

curryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : UncurriedEl I D X) → CurriedEl I D X
curryEl I (`End i) X cn = cn refl
curryEl I (`Rec i D) X cn = λ x → curryEl I D X (λ xs → cn (x , xs))
curryEl I (`Arg A B) X cn = λ a → curryEl I (B a) X (λ xs → cn (a , xs))
curryEl I (`RecFun A B D) X cn = λ f → curryEl I D X (λ xs → cn (f , xs))

uncurryEl : (I : Set) (D : Desc I) (X : ISet I)
  (cn : CurriedEl I D X) → UncurriedEl I D X
uncurryEl I (`End i) X cn refl = cn
uncurryEl I (`Rec i D) X cn (x , xs) = uncurryEl I D X (cn x) xs
uncurryEl I (`Arg A B) X cn (a , xs) = uncurryEl I (B a) X (cn a) xs
uncurryEl I (`RecFun A B D) X cn (f , xs) = uncurryEl I D X (cn f) xs

con2 : (I : Set) (D : Desc I) → CurriedEl I D (μ I D)
con2 I D = curryEl I D (μ I D) con

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

UncurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : {i : I} → El I D X i → X i)
  → Set
UncurriedAll I D X P cn =
  (i : I) (xs : El I D X i) → All I D X P i xs → P i (cn xs)

CurriedAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  → Set
CurriedAll I (`End i) X P cn =
  P i (cn refl)
CurriedAll I (`Rec i D) X P cn =
  (x : X i) → P i x → CurriedAll I D X P (λ xs → cn (x , xs))
CurriedAll I (`Arg A B) X P cn =
  (a : A) → CurriedAll I (B a) X P (λ xs → cn (a , xs))
CurriedAll I (`RecFun A B D) X P cn =
  (f : (a : A) → X (B a)) (ihf : (a : A) → P (B a) (f a)) → CurriedAll I D X P (λ xs → cn (f , xs))

curryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : UncurriedAll I D X P cn)
  → CurriedAll I D X P cn
curryAll I (`End i) X P cn pf =
  pf i refl tt
curryAll I (`Rec i D) X P cn pf =
  λ x ih → curryAll I D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryAll I (`Arg A B) X P cn pf =
  λ a → curryAll I (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)
curryAll I (`RecFun A B D) X P cn pf =
  λ f ihf → curryAll I D X P (λ xs → cn (f , xs)) (λ i xs ihs → pf i (f , xs) (ihf , ihs))

uncurryAll : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedEl I D X)
  (pf : CurriedAll I D X P cn)
  → UncurriedAll I D X P cn
uncurryAll I (`End .i) X P cn pf i refl tt =
  pf
uncurryAll I (`Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryAll I D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryAll I (`Arg A B) X P cn pf i (a , xs) ihs =
  uncurryAll I (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs
uncurryAll I (`RecFun A B D) X P cn pf i (f , xs) (ihf , ihs) =
  uncurryAll I D X P (λ ys → cn (f , ys)) (pf f ihf) i xs ihs

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

ind :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : UncurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x

hyps :
  (I : Set)
  (D₁ : Desc I)
  (P : (i : I) → μ I D₁ i → Set)
  (pcon : UncurriedAll I D₁ (μ I D₁) P con)
  (D₂ : Desc I)
  (i : I)
  (xs : El I D₂ (μ I D₁) i)
  → All I D₂ (μ I D₁) P i xs

ind I D P pcon i (con xs) = pcon i xs (hyps I D P pcon D i xs)

hyps I D P pcon (`End j) i q = tt
hyps I D P pcon (`Rec j A) i (x , xs) = ind I D P pcon j x , hyps I D P pcon A i xs
hyps I D P pcon (`Arg A B) i (a , b) = hyps I D P pcon (B a) i b
hyps I D P pcon (`RecFun A B E) i (f , xs) = (λ a → ind I D P pcon (B a) (f a)) , hyps I D P pcon E i xs

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

ind2 :
  (I : Set)
  (D : Desc I)
  (P : (i : I) → μ I D i → Set)
  (pcon : CurriedAll I D (μ I D) P con)
  (i : I)
  (x : μ I D i)
  → P i x
ind2 I D P pcon i x = ind I D P (uncurryAll I D (μ I D) P con pcon) i x

elim :
  (I : Set)
  (E : Enum)
  (Cs : Tag E → Desc I)
  → let D = `Arg (Tag E) Cs in
  (P : (i : I) → μ I D i → Set)
  → UncurriedCases E
    (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs)))
    ((i : I) (x : μ I D i) → P i x)
elim I E Cs P cs i x =
  let D = `Arg (Tag E) Cs in
  ind2 I D P (case E (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs))) cs) i x

elim2 :
  (I : Set)
  (E : Enum)
  (Cs : Tag E → Desc I)
  → let D = `Arg (Tag E) Cs in
  (P : (i : I) → μ I D i → Set)
  → let Q = (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs)))
        X = ((i : I) (x : μ I D i) → P i x)
  in CurriedCases E Q X
elim2 I E Cs P =
  let D = `Arg (Tag E) Cs
      Q = (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs)))
      X = ((i : I) (x : μ I D i) → P i x)
  in curryCases E Q X (elim I E Cs P)

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

module Sugared where

  data ℕT : Set where `zero `suc : ℕT
  data VecT : Set where `nil `cons : VecT

  ℕD : Desc ⊤
  ℕD = `Arg ℕT λ
    { `zero → `End tt
    ; `suc → `Rec tt (`End tt)
    }

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (`zero , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (`suc , n , refl)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg VecT λ
    { `nil  → `End zero
    ; `cons → `Arg (ℕ tt) λ n → `Arg A λ _ → `Rec n (`End (suc n))
    }

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (`nil , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (`cons , n , x , xs , refl)

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

  add : ℕ tt → ℕ tt → ℕ tt
  add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → n
      ; tt (`suc , m , q) (ih , tt) n → suc (ih n)
      }
    )
    tt

  mult : ℕ tt → ℕ tt → ℕ tt
  mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
    (λ
      { tt (`zero , q) tt n → zero
      ; tt (`suc , m , q) (ih , tt) n → add n (ih n)
      }
    )
    tt

  append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
  append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
    (λ
      { .(con (`zero , refl)) (`nil , refl) ih n ys → ys
      ; .(con (`suc , m , refl)) (`cons , m , x , xs , refl) (ih , tt) n ys → cons A (add m n) x (ih n ys)
      }
    )

  concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
  concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
    (λ
      { .(con (`zero , refl)) (`nil , refl) tt → nil A
      ; .(con (`suc , n , refl)) (`cons , n , xs , xss , refl) (ih , tt) → append A m xs (mult n m) ih
      }
    )

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

module Desugared where

  ℕT : Enum
  ℕT = "zero" ∷ "suc" ∷ []

  VecT : Enum
  VecT = "nil" ∷ "cons" ∷ []

  ℕC : Tag ℕT → Desc ⊤
  ℕC = caseD ℕT ⊤
    ( `End tt
    , `Rec tt (`End tt)
    , tt
    )

  ℕD : Desc ⊤
  ℕD = `Arg (Tag ℕT) ℕC

  ℕ : ⊤ → Set
  ℕ = μ ⊤ ℕD

  zero : ℕ tt
  zero = con (here , refl)

  suc : ℕ tt → ℕ tt
  suc n = con (there here , n , refl)

  zero2 : ℕ tt
  zero2 = con2 ⊤ ℕD here

  suc2 : ℕ tt → ℕ tt
  suc2 = con2 ⊤ ℕD (there here)

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = caseD VecT (ℕ tt)
    ( `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt
    )

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = `Arg (Tag VecT) (VecC A)

  Vec : (A : Set) (n : ℕ tt) → Set
  Vec A n = μ (ℕ tt) (VecD A) n

  nil : (A : Set) → Vec A zero
  nil A = con (here , refl)

  cons : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons A n x xs = con (there here , n , x , xs , refl)

  nil2 : (A : Set) → Vec A zero
  nil2 A = con2 (ℕ tt) (VecD A) here

  cons2 : (A : Set) (n : ℕ tt) (x : A) (xs : Vec A n) → Vec A (suc n)
  cons2 A = con2 (ℕ tt) (VecD A) (there here)

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

  module Induction where

    add : ℕ tt → ℕ tt → ℕ tt
    add = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → n)
        , (λ m,q ih,tt n → suc (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind ⊤ ℕD (λ _ _ → ℕ tt → ℕ tt)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → ℕ u → ℕ u) u (t , c))
               → ℕ u → ℕ u
        )
        ( (λ q ih n → zero)
        , (λ m,q ih,tt n → add n (proj₁ ih,tt n))
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind (ℕ tt) (VecD A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ m t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) m)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)) m (t , c))
               (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
        )
        ( (λ q ih n ys → subst (λ m → Vec A (add m n)) q ys)
        , (λ m',x,xs,q ih,tt n ys →
            let m' = proj₁ m',x,xs,q
                x = proj₁ (proj₂ m',x,xs,q)
                q = proj₂ (proj₂ (proj₂ m',x,xs,q))
                ih = proj₁ ih,tt
            in
            subst (λ m → Vec A (add m n)) q (cons A (add m' n) x (ih n ys))
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind (ℕ tt) (VecD (Vec A m)) (λ n xss → Vec A (mult n m))
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC (Vec A m) t) (Vec (Vec A m)) n)
               (ih : All (ℕ tt) (VecD (Vec A m)) (Vec (Vec A m)) (λ n xss → Vec A (mult n m)) n (t , c))
               → Vec A (mult n m)
        )
        ( (λ q ih → subst (λ n → Vec A (mult n m)) q (nil A))
        , (λ n',xs,xss,q ih,tt →
            let n' = proj₁ n',xs,xss,q
                xs = proj₁ (proj₂ n',xs,xss,q)
                q = proj₂ (proj₂ (proj₂ n',xs,xss,q))
                ih = proj₁ ih,tt
            in
            subst (λ n → Vec A (mult n m)) q (append A m xs (mult n' m) ih)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

  module Eliminator where

    elimℕ : (P : (ℕ tt) → Set)
      (pzero : P zero)
      (psuc : (m : ℕ tt) → P m → P (suc m))
      (n : ℕ tt)
      → P n
    elimℕ P pzero psuc = ind ⊤ ℕD (λ u n → P n)
      (λ u t,c → case ℕT
        (λ t → (c : El ⊤ (ℕC t) ℕ u)
               (ih : All ⊤ ℕD ℕ (λ u n → P n) u (t , c))
               → P (con (t , c))
        )
        ( (λ q ih →
            elimEq ⊤ tt (λ u q → P (con (here , q)))
              pzero
              u q
          )
        , (λ n,q ih,tt →
            elimEq ⊤ tt (λ u q → P (con (there here , proj₁ n,q , q)))
              (psuc (proj₁ n,q) (proj₁ ih,tt))
              u (proj₂ n,q)
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )
      tt

    elimVec : (A : Set) (P : (n : ℕ tt) → Vec A n → Set)
      (pnil : P zero (nil A))
      (pcons : (n : ℕ tt) (a : A) (xs : Vec A n) → P n xs → P (suc n) (cons A n a xs))
      (n : ℕ tt)
      (xs : Vec A n)
      → P n xs
    elimVec A P pnil pcons = ind (ℕ tt) (VecD A) (λ n xs → P n xs)
      (λ n t,c → case VecT
        (λ t → (c : El (ℕ tt) (VecC A t) (Vec A) n)
               (ih : All (ℕ tt) (VecD A) (Vec A) (λ n xs → P n xs) n (t , c))
               → P n (con (t , c))
        )
        ( (λ q ih →
            elimEq (ℕ tt) zero (λ n q → P n (con (here , q)))
              pnil
              n q
          )
        , (λ n',x,xs,q ih,tt →
            let n' = proj₁ n',x,xs,q
                x = proj₁ (proj₂ n',x,xs,q)
                xs = proj₁ (proj₂ (proj₂ n',x,xs,q))
                q = proj₂ (proj₂ (proj₂ n',x,xs,q))
                ih = proj₁ ih,tt
            in
            elimEq (ℕ tt) (suc n') (λ n q → P n (con (there here , n' , x , xs , q)))
              (pcons n' x xs ih )
              n q
          )
        , tt
        )
        (proj₁ t,c)
        (proj₂ t,c)
      )

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

    add : ℕ tt → ℕ tt → ℕ tt
    add = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → n)
      (λ m ih n → suc (ih n))

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elimℕ (λ _ → ℕ tt → ℕ tt)
      (λ n → zero)
      (λ m ih n → add n (ih n))

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elimVec A (λ m xs → (n : ℕ tt) (ys : Vec A n) → Vec A (add m n))
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elimVec (Vec A m) (λ n xss → Vec A (mult n m))
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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

  module GenericEliminator where

    add : ℕ tt → ℕ tt → ℕ tt
    add = elim2 ⊤ ℕT ℕC _
      (λ n → n)
      (λ m ih n → suc (ih n))
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elim2 ⊤ ℕT ℕC _
      (λ n → zero)
      (λ m ih n → add n (ih n))
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = elim2 (ℕ tt) VecT (VecC A) _
      (λ n ys → ys)
      (λ m x xs ih n ys → cons A (add m n) x (ih n ys))

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = elim2 (ℕ tt) VecT (VecC (Vec A m)) _
      (nil A)
      (λ n xs xss ih → append A m xs (mult n m) ih)

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


Binary: +Equivalence-Reasoning

Binary: +Equivalence-Reasoning

{-# OPTIONS --universe-polymorphism #-}
module Relation.Binary.NP where

open import Level
open import Relation.Binary public
import Relation.Binary.PropositionalEquality as PropEq

-- could this be moved in place of Trans is Relation.Binary.Core
Trans' : ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
        REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _
Trans' P Q R = ∀ {i j k} (x : P i j) (xs : Q j k) → R i k

substitutive-to-reflexive : ∀ {a ℓ ℓ'} {A : Set a} {≈ : Rel A ℓ} {≡ : Rel A ℓ'}
                            → Substitutive ≡ ℓ → Reflexive ≈ → ≡ ⇒ ≈
substitutive-to-reflexive {≈ = ≈} ≡-subst ≈-refl xᵣ = ≡-subst (≈ _) xᵣ ≈-refl

substitutive⇒≡ : ∀ {a ℓ} {A : Set a} {≡ : Rel A ℓ} → Substitutive ≡ a → ≡ ⇒ PropEq._≡_
substitutive⇒≡ subst = substitutive-to-reflexive {≈ = PropEq._≡_} subst PropEq.refl

record Equality {a ℓ} {A : Set a} (_≡_ : Rel A ℓ) : Set (suc a ⊔ ℓ) where
  field
    isEquivalence : IsEquivalence _≡_
    subst : Substitutive _≡_ a

  open IsEquivalence isEquivalence public

  to-reflexive : ∀ {≈} → Reflexive ≈ → _≡_ ⇒ ≈
  to-reflexive = substitutive-to-reflexive subst

  to-propositional : _≡_ ⇒ PropEq._≡_
  to-propositional = substitutive⇒≡ subst

-- Equational reasoning combinators.

module Trans-Reasoning {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) (trans : Transitive _≈_) where

  infix  2 finally
  infixr 2 _≈⟨_⟩_

  _≈⟨_⟩_ : ∀ x {y z : A} → x ≈ y → y ≈ z → x ≈ z
  _ ≈⟨ x≈y ⟩ y≈z = trans x≈y y≈z

  -- When there is no reflexivty available this
  -- combinator can be used to end the reasoning.
  finally : ∀ (x y : A) → x ≈ y → x ≈ y
  finally _ _ x≈y = x≈y

  syntax finally x y x≈y = x ≈⟨ x≈y ⟩∎ y ∎

module Equivalence-Reasoning
         {a ℓ} {A : Set a} {_≈_ : Rel A ℓ}
         (E : IsEquivalence _≈_) where
  open IsEquivalence E
  open Trans-Reasoning _≈_ trans public hiding (finally)

  infix  2 _∎

  _∎ : ∀ x → x ≈ x
  _ ∎ = refl

module Preorder-Reasoning
         {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where
  open Preorder P
  open Equivalence-Reasoning isEquivalence public renaming (_≈⟨_⟩_ to _∼⟨_⟩_)

module Setoid-Reasoning {a ℓ} (s : Setoid a ℓ) where
  open Preorder-Reasoning (Setoid.preorder s) public renaming (_∼⟨_⟩_ to _≈⟨_⟩_)

{-# OPTIONS --universe-polymorphism #-}
module Relation.Binary.NP where

open import Level
open import Relation.Binary public
import Relation.Binary.PropositionalEquality as PropEq

-- could this be moved in place of Trans is Relation.Binary.Core
Trans' : ∀ {a b c ℓ₁ ℓ₂ ℓ₃} {A : Set a} {B : Set b} {C : Set c} →
        REL A B ℓ₁ → REL B C ℓ₂ → REL A C ℓ₃ → Set _
Trans' P Q R = ∀ {i j k} (x : P i j) (xs : Q j k) → R i k

substitutive-to-reflexive : ∀ {a ℓ ℓ'} {A : Set a} {≈ : Rel A ℓ} {≡ : Rel A ℓ'}
                            → Substitutive ≡ ℓ → Reflexive ≈ → ≡ ⇒ ≈
substitutive-to-reflexive {≈ = ≈} ≡-subst ≈-refl xᵣ = ≡-subst (≈ _) xᵣ ≈-refl

substitutive⇒≡ : ∀ {a ℓ} {A : Set a} {≡ : Rel A ℓ} → Substitutive ≡ a → ≡ ⇒ PropEq._≡_
substitutive⇒≡ subst = substitutive-to-reflexive {≈ = PropEq._≡_} subst PropEq.refl

record Equality {a ℓ} {A : Set a} (_≡_ : Rel A ℓ) : Set (suc a ⊔ ℓ) where
  field
    isEquivalence : IsEquivalence _≡_
    subst : Substitutive _≡_ a

  open IsEquivalence isEquivalence public

  to-reflexive : ∀ {≈} → Reflexive ≈ → _≡_ ⇒ ≈
  to-reflexive = substitutive-to-reflexive subst

  to-propositional : _≡_ ⇒ PropEq._≡_
  to-propositional = substitutive⇒≡ subst

-- Equational reasoning combinators.

module Trans-Reasoning {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) (trans : Transitive _≈_) where

  infix  2 finally
  infixr 2 _≈⟨_⟩_

  _≈⟨_⟩_ : ∀ x {y z : A} → x ≈ y → y ≈ z → x ≈ z
  _ ≈⟨ x≈y ⟩ y≈z = trans x≈y y≈z

  -- When there is no reflexivty available this
  -- combinator can be used to end the reasoning.
  finally : ∀ (x y : A) → x ≈ y → x ≈ y
  finally _ _ x≈y = x≈y

  syntax finally x y x≈y = x ≈⟨ x≈y ⟩∎ y ∎

module Preorder-Reasoning
         {p₁ p₂ p₃} (P : Preorder p₁ p₂ p₃) where
  open Preorder P
  open Trans-Reasoning _∼_ trans public hiding (finally) renaming (_≈⟨_⟩_ to _∼⟨_⟩_)

  infix  2 _∎

  _∎ : ∀ x → x ∼ x
  _ ∎ = refl

module Setoid-Reasoning {a ℓ} (s : Setoid a ℓ) where
  open Preorder-Reasoning (Setoid.preorder s) public renaming (_∼⟨_⟩_ to _≈⟨_⟩_)