Embed62: correctness of embed (fix #62)

Embed62: correctness of embed (fix #62)

Old-commit-hash: d609ac1436ac9262b4332f8ffefc7020d487a547

module Embed62 where

open import TaggedDeltaTypes
open import ExplicitNil using (ext³)
open import Relation.Binary.PropositionalEquality
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Unit using (⊤ ; tt)
open import Data.Nat

Δ-Type : Type → Type
Δ-Type nats = (nats ⇒ nats ⇒ nats) ⇒ nats -- Church pairs
Δ-Type bags = bags
Δ-Type (σ ⇒ τ) = σ ⇒ Δ-Type σ ⇒ Δ-Type τ

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • keep τ • Γ≼ΔΓ

weak : ∀ {τ Γ} → Term Γ τ → Term (Δ-Context Γ) τ
weak = weaken Γ≼ΔΓ

deriveVar : ∀ {τ Γ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

absurd! : ∀ {A B : Set} → A → A → B → B
absurd! _ _ b = b

fst : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
snd = abs (abs (var this))

difff : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
apply : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ

apply {nats} dt t = app dt snd
apply {bags} dt t = union t dt
apply {σ ⇒ τ} dt t = abs (apply
  (app (app (weaken (drop _ • Γ≼Γ) dt)
    (var this)) (difff (var this) (var this)))
  (app (weaken (drop _ • Γ≼Γ) t) (var this)))

difff {nats} s t = abs (app (app (var this)
  (weaken (drop _ • Γ≼Γ) s)) (weaken (drop _ • Γ≼Γ) t))
difff {bags} s t = diff s t
difff {σ ⇒ τ} s t = abs (abs (difff
  (app (weaken (drop _ • drop _ • Γ≼Γ) s)
    (apply (var this) (var (that this))))
  (app (weaken (drop _ • drop _ • Γ≼Γ) t) (var (that this)))))

embed : ∀ {τ Γ} → ΔTerm Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
embed (Δnat old new) = abs (app (app (var this) (nat old)) (nat new))
embed (Δbag db) = bag db
embed (Δvar x) = var (deriveVar x)
embed (Δabs dt) = abs (abs (embed dt))
embed (Δapp ds t dt) = app (app (embed ds) (weak t)) (embed dt)
embed (Δadd ds dt) = abs (app (app (var this)
  (add (app (weaken (drop _ • Γ≼Γ) (embed ds)) fst)
       (app (weaken (drop _ • Γ≼Γ) (embed dt)) fst)))
  (add (app (weaken (drop _ • Γ≼Γ) (embed ds)) snd)
       (app (weaken (drop _ • Γ≼Γ) (embed dt)) snd)))
embed (Δmap₀ s ds t dt) = diff
  (map (apply (embed ds) (weak s)) (apply (embed dt) (weak t)))
  (weak (map s t))
embed (Δmap₁ s dt) = map (weak s) (embed dt)
embed (Δunion ds dt) = union (embed ds) (embed dt)
embed (Δdiff ds dt) = diff (embed ds) (embed dt)

⟦fst⟧ : ∀ {A : Set} → A → A → A
⟦fst⟧ a b = a
⟦snd⟧ : ∀ {A : Set} → A → A → A
⟦snd⟧ a b = b

_≈_ : ∀ {τ} → ΔVal τ → ⟦ Δ-Type τ ⟧ → Set
_≈_ {nats} (old , new) v = old ≡ v ⟦fst⟧ × new ≡ v ⟦snd⟧
_≈_ {bags} u v = u ≡ v
_≈_ {σ ⇒ τ} u v =
  (w : ⟦ σ ⟧) (dw : ΔVal σ) (dw′ : ⟦ Δ-Type σ ⟧)
  (R[w,dw] : valid w dw) (eq : dw ≈ dw′) →
  u w dw R[w,dw] ≈ v w dw′

infix 4 _≈_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ Δ-Context Γ ⟧ → Set
compatible {∅} ∅ ∅ = EmptySet
compatible {τ • Γ} (cons v dv _ ρ) (dv′ • v′ • ρ′) =
  triple (v ≡ v′) (dv ≈ dv′) (compatible ρ ρ′)

deriveVar-correct : ∀ {τ Γ} {x : Var Γ τ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ x ⟧ΔVar ρ ≈ ⟦ deriveVar x ⟧ ρ′

deriveVar-correct {x = this} -- pattern-matching on ρ, ρ′ NOT optional
  {cons _ _ _ _} {_ • _ • _} {cons _ dv≈dv′ _ _} = dv≈dv′
deriveVar-correct {x = that y}
  {cons _ _ _ ρ} {_ • _ • ρ′} {cons _ _ C _} =
  deriveVar-correct {x = y} {ρ} {ρ′} {C}

weak-id : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
weak-id {∅} {∅} = refl
weak-id {τ • Γ} {v • ρ} = cong₂ _•_ {x = v} refl (weak-id {Γ} {ρ})

weak-eq : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′

weak-eq {∅} {∅} {∅} _ = refl
weak-eq {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′} (cons v≡v′ _ C _) =
  cong₂ _•_ v≡v′ (weak-eq C)

weak-eq-term : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ′

weak-eq-term t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (weak-eq C)) (sym (weaken-sound t ρ′))

weaken-once : ∀ {τ Γ σ} {t : Term Γ τ} {v : ⟦ σ ⟧} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ≡ ⟦ weaken (drop σ • Γ≼Γ) t ⟧ (v • ρ)

weaken-once {t = t} {v} {ρ} = trans
  (cong ⟦ t ⟧ (sym weak-id))
  (sym (weaken-sound t (v • ρ)))

embed-correct : ∀ {τ Γ}
  {dt : ΔTerm Γ τ}
  {ρ : ΔEnv Γ} {V : dt is-valid-for ρ}
  {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ dt ⟧Δ ρ V ≈ ⟦ embed dt ⟧ ρ′

embed-correct {dt = Δnat old new} = refl , refl

embed-correct {dt = Δbag db} = refl

embed-correct {dt = Δvar x} {ρ} {ρ′ = ρ′} {C} =
  deriveVar-correct {x = x} {ρ} {ρ′} {C}

embed-correct {dt = Δadd ds dt} {ρ} {V} {ρ′} {C} =
  let
    s00 , s01 = ⟦ ds ⟧Δ ρ (car V)
    t00 , t01 = ⟦ dt ⟧Δ ρ (cadr V)
    s10 = ⟦ embed ds ⟧ ρ′ ⟦fst⟧
    s11 = ⟦ embed ds ⟧ ρ′ ⟦snd⟧
    t10 = ⟦ embed dt ⟧ ρ′ ⟦fst⟧
    t11 = ⟦ embed dt ⟧ ρ′ ⟦snd⟧
    rec-s = embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
    rec-t = embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C}
  in

    (begin
      s00 + t00
    ≡⟨ cong₂ _+_ (proj₁ rec-s) (proj₁ rec-t) ⟩
      s10 + t10
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦fst⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦fst⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed ds) (⟦fst⟧ • ρ′))))
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed dt) (⟦fst⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧
    ∎)
    ,
    (begin
      s01 + t01
    ≡⟨ cong₂ _+_ (proj₂ rec-s) (proj₂ rec-t) ⟩
      s11 + t11
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦snd⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦snd⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed ds) (⟦snd⟧ • ρ′))))
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed dt) (⟦snd⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧
    ∎)
  where open ≡-Reasoning

embed-correct {dt = Δunion ds dt} {ρ} {V} {ρ′} {C} = cong₂ _++_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δdiff ds dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δmap₁ s dt} {ρ} {V} {ρ′} {C} = cong₂ mapBag
  (weak-eq-term s C)
  (embed-correct {dt = dt} {ρ} {car V} {ρ′} {C})

embed-correct {dt = Δmap₀ s ds t dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (cong₂ mapBag
    (extensionality (λ v →
    begin
      proj₂ (⟦ ds ⟧Δ ρ (car V) v (v , v) refl)
    ≡⟨ proj₂ (embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
        v (v , v) (λ f → f v v) refl (refl , refl)) ⟩
      ⟦ embed ds ⟧ ρ′ v (λ f → f v v) ⟦snd⟧
    ≡⟨ cong (λ hole → hole v (λ f → f v v) ⟦snd⟧)
        (weaken-once {t = embed ds} {v} {ρ′}) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (v • ρ′) v (λ f → f v v) ⟦snd⟧
    ∎))
    (cong₂ _++_
      (weak-eq-term t C)
      (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})))
  (cong₂ mapBag (weak-eq-term s C) (weak-eq-term t C))
  where open ≡-Reasoning

embed-correct {dt = Δapp ds t dt} {ρ} {cons vds vdt R[t,dt] _} {ρ′} {C}
  rewrite sym (weak-eq-term t C) =
  embed-correct {dt = ds} {ρ} {vds} {ρ′} {C}
    (⟦ t ⟧Term (ignore ρ)) (⟦ dt ⟧Δ ρ vdt) (⟦ embed dt ⟧Term ρ′)
    R[t,dt] (embed-correct {dt = dt} {ρ} {vdt} {ρ′} {C})

embed-correct {dt = Δabs dt} {ρ} {V} {ρ′} {C} = λ w dw dw′ R[w,dw] dw≈dw′ →
  embed-correct {dt = dt}
    {cons w dw R[w,dw] ρ} {V w dw R[w,dw]}
    {dw′ • w • ρ′} {cons refl dw≈dw′ C tt}

module Embed62 where

open import TaggedDeltaTypes
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)

Δ-Type : Type → Type
Δ-Type nats = (nats ⇒ nats ⇒ nats) ⇒ nats -- Church pairs
Δ-Type bags = bags
Δ-Type (σ ⇒ τ) = σ ⇒ Δ-Type σ ⇒ Δ-Type τ

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ

⟦fst⟧ : ∀ {A : Set} → A → A → A
⟦fst⟧ a b = a
⟦snd⟧ : ∀ {A : Set} → A → A → A
⟦snd⟧ a b = b

translate : ∀ {τ} → ⟦ Δ-Type τ ⟧ → ΔVal τ
translate {nats} dn = dn ⟦fst⟧ , dn ⟦snd⟧
translate {bags} db = db
translate {σ ⇒ τ} df = λ v dv R[v,dv] → translate (df v {!dv!})
-- TODO figure out what to do to dv to put it in the hole

consistent : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → Set
consistent {∅} ∅ = EmptySet
consistent {τ • Γ} (dv • v • ρ) = couple (valid v (translate dv)) (consistent ρ)

recall : ∀ {Γ} (ρ : ⟦ Δ-Context Γ ⟧) (γ : consistent ρ)  → ΔEnv Γ
recall {∅} ∅ ∅ = ∅
recall {τ • Γ} (dv • v • ρ) (cons R[v,dv] γ _ _) = {!!}

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • keep τ • Γ≼ΔΓ

weak : ∀ {τ Γ} → Term Γ τ → Term (Δ-Context Γ) τ
weak = weaken Γ≼ΔΓ

deriveVar : ∀ {τ Γ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

absurd : ∀ {A B : Set} → A → A → B → B
absurd _ _ b = b

fst : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
snd = abs (abs (var this))

difff : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
apply : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ

apply {nats} dt t = app dt snd
apply {bags} dt t = union t dt
apply {σ ⇒ τ} dt t = abs (apply
  (app (app (weaken (drop _ • Γ≼Γ) dt)
    (var this)) (difff (var this) (var this)))
  (app (weaken (drop _ • Γ≼Γ) t) (var this)))

difff {nats} s t = abs (app (app (var this)
  (weaken (drop _ • Γ≼Γ) s)) (weaken (drop _ • Γ≼Γ) t))
difff {bags} s t = diff s t
difff {σ ⇒ τ} s t = abs (abs (difff
  (app (weaken (drop _ • drop _ • Γ≼Γ) s)
    (apply (var this) (var (that this))))
  (app (weaken (drop _ • drop _ • Γ≼Γ) t) (var (that this)))))

embed : ∀ {τ Γ} → ΔTerm Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
embed (Δnat old new) = abs (app (app (var this) (nat old)) (nat new))
embed (Δbag db) = bag db
embed (Δvar x) = var (deriveVar x)
embed (Δabs dt) = abs (abs (embed dt))
embed (Δapp ds t dt) = app (app (embed ds) (weak t)) (embed dt)
embed (Δadd ds dt) = abs (app (app (var this)
  (add (app (weaken (drop _ • Γ≼Γ) (embed ds)) fst)
       (app (weaken (drop _ • Γ≼Γ) (embed dt)) fst)))
  (add (app (weaken (drop _ • Γ≼Γ) (embed ds)) snd)
       (app (weaken (drop _ • Γ≼Γ) (embed dt)) snd)))
embed (Δmap₀ s ds t dt) = diff
  (map (apply (embed ds) (weak s)) (apply (embed dt) (weak t)))
  (weak (map s t))
embed (Δmap₁ s dt) = map (weak s) (embed dt)
embed (Δunion ds dt) = union (embed ds) (embed dt)
embed (Δdiff ds dt) = diff (embed ds) (embed dt)

-- embed-correct : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv}


Desc model: rename iso2 to psi.

Desc model: rename iso2 to psi.


FunUniverse.Bits: update

FunUniverse.Bits: update

{-# OPTIONS --without-K #-}
module FunUniverse.Bits where

open import Data.Nat.NP using (ℕ; _*_; module ℕ°)
open import Data.Bool using (if_then_else_)
open import Data.Fin using (Fin)
open import Function using (const; _∘′_; id)
open import Data.Vec.NP using (Vec; []; _∷_; _++_; [_]; take; drop; rewire; rewireTbl)
open import Data.Product using (_×_; _,_; proj₁; proj₂; uncurry)

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

open import FunUniverse.Data
open import FunUniverse.Core
open import FunUniverse.Category
open import FunUniverse.Rewiring.Linear

bitsFunU : FunUniverse ℕ
bitsFunU = Bits-U , _→ᵇ_

module BitsFunUniverse = FunUniverse bitsFunU
open BitsFunUniverse
open Cong-*1 _`→_
open Defaults bitsFunU

bitsFunOps : FunOps bitsFunU
bitsFunOps = mk rewiring (cond , forkᵇ) (const [ 0b ]) (const [ 1b ])
  where
  fstᵇ : ∀ {A B} → A `× B `→ A
  fstᵇ {A} = take A
  sndᵇ : ∀ {B} A → A `× B `→ B
  sndᵇ A = drop A
  <_,_>ᵇ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  <_,_>ᵇ f g x = f x ++ g x
  forkᵇ : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  forkᵇ f g (b ∷ xs) = (if b then f else g) xs

  open DefaultsGroup2 id _∘′_ (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)
  open DefaultCondFromFork forkᵇ fstᵇ (λ {x} → sndᵇ x)

  cat : Category _`→_
  cat = id , _∘′_

  lin : LinRewiring bitsFunU
  lin = mk cat first (λ {x} → swap {x}) (λ {x} → assoc {x}) id id
           <_×_> (λ {x} → second {x}) id id id id

  rewiring : Rewiring bitsFunU
  rewiring = mk lin (const []) dup (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)
                (cong-*1 ∘′ rewire) (cong-*1 ∘′ rewireTbl)

bitsFunRewiring : Rewiring bitsFunU
bitsFunRewiring = FunOps.rewiring bitsFunOps

bitsFunLin : LinRewiring bitsFunU
bitsFunLin = Rewiring.linRewiring bitsFunRewiring

module BitsFunOps = FunOps bitsFunOps

{-# OPTIONS --without-K #-}
module FunUniverse.Bits where

open import Data.Nat.NP using (ℕ; _*_; module ℕ°)
open import Data.Bool using (if_then_else_)
open import Data.Fin using (Fin)
import Data.Vec.NP as V
import Function as F
import Data.Product as ×
open F using (const; _∘′_)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_; _,_; proj₁; proj₂; uncurry)

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

open import FunUniverse.Data
open import FunUniverse.Core

bitsFunU : FunUniverse ℕ
bitsFunU = Bits-U , _→ᵇ_

module BitsFunUniverse = FunUniverse bitsFunU

bitsFunOps : FunOps bitsFunU
bitsFunOps = mk rewiring (cond , forkᵇ) (const [ 0b ]) (const [ 1b ])
  where
  open BitsFunUniverse
  open F using (id; _∘′_)
  fstᵇ : ∀ {A B} → A `× B `→ A
  fstᵇ {A} = V.take A
  sndᵇ : ∀ {B} A → A `× B `→ B
  sndᵇ A = V.drop A
  <_,_>ᵇ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  <_,_>ᵇ f g x = f x ++ g x
  forkᵇ : ∀ {A B} (f g : A `→ B) → `Bit `× A `→ B
  forkᵇ f g (b ∷ xs) = (if b then f else g) xs

  cong-*1 : ∀ {i o} → i `→ o → (i * 1) `→ (o * 1)
  cong-*1 {i} {o} rewrite proj₂ ℕ°.*-identity i
                        | proj₂ ℕ°.*-identity o = id

  open Defaults bitsFunU
  open DefaultsGroup2 id _∘′_ (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)
  open DefaultCondFromFork forkᵇ fstᵇ (λ {x} → sndᵇ x)

  lin : LinRewiring bitsFunU
  lin = mk id _∘′_ first (λ {x} → swap {x}) (λ {x} → assoc {x}) id id
           <_×_> (λ {x} → second {x}) id id id id

  rewiring : Rewiring bitsFunU
  rewiring = mk lin (const []) dup (const []) <_,_>ᵇ fstᵇ (λ {x} → sndᵇ x)
                (cong-*1 ∘′ V.rewire) (cong-*1 ∘′ V.rewireTbl)

bitsFunRewiring : Rewiring bitsFunU
bitsFunRewiring = FunOps.rewiring bitsFunOps

bitsFunLin : LinRewiring bitsFunU
bitsFunLin = Rewiring.linRewiring bitsFunRewiring

module BitsFunOps = FunOps bitsFunOps


layout

layout

open import Type hiding (★)
open import Function.NP
open import Data.Product
open import Search.Type
open import Search.Searchable

module Search.Searchable.Product where

private
    Cont : ★₀ → ★₀ → ★₀
    Cont M A = (A → M) → M

    -- liftM2 _,_ in the continuation monad
    _×F_ : ∀ {A B M} → Cont M A → Cont M B → Cont M (A × B)
    (fA ×F fB) f = fA (fB ∘ curry f)
    -- (fA ×F fB) f = fA λ x → fB (f (x , y)

    ΣF : ∀ {A B M} → Cont M A → (∀ {x} → Cont M (B x)) → Cont M (Σ A B)
    ΣF fA fB f = fA (fB ∘ curry f)

ΣSearch : ∀ {A} {B : A → ★₀} → Search A → (∀ {x} → Search (B x)) → Search (Σ A B)
ΣSearch searchᴬ searchᴮ op = ΣF (searchᴬ op) (searchᴮ op)

ΣSearchInd : ∀ {A} {B : A → ★₀}
               {sᴬ : Search A} {sᴮ : ∀ {x} → Search (B x)}
             → SearchInd sᴬ → (∀ {x} → SearchInd (sᴮ {x})) → SearchInd (ΣSearch sᴬ sᴮ)
ΣSearchInd Psᴬ Psᴮ P P∙ Pf =
  Psᴬ (λ s → P (λ _ _ → s _ _)) P∙ (λ x → Psᴮ {x} (λ s → P (λ _ _ → s _ _)) P∙ (curry Pf x))

μΣ : ∀ {A} {B : A → ★ _} → Searchable A → (∀ {x} → Searchable (B x)) → Searchable (Σ A B)
μΣ μA μB = _ , ΣSearchInd (search-ind μA) (search-ind μB)

-- From now on, these are derived definitions for convenience and pedagogical reasons

ΣSum : ∀ {A} {B : A → ★₀} → Sum A → (∀ {x} → Sum (B x)) → Sum (Σ A B)
ΣSum = ΣF

infixr 4 _×Search_

_×Search_ : ∀ {A B} → Search A → Search B → Search (A × B)
searchᴬ ×Search searchᴮ = ΣSearch searchᴬ searchᴮ

infixr 4 _×μ_

_×μ_ : ∀ {A B} → Searchable A → Searchable B → Searchable (A × B)
μA ×μ μB = μΣ μA μB

infixr 4 _×Sum_

_×Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
sumᴬ ×Sum sumᴮ = ΣSum sumᴬ sumᴮ

-- Those are here only for pedagogical use
private
    ΣSum' : ∀ {A} {B : A → ★₀} → Sum A → (∀ x → Sum (B x)) → Sum (Σ A B)
    ΣSum' sumᴬ sumᴮ f = sumᴬ (λ x₀ →
                          sumᴮ x₀ (λ x₁ →
                            f (x₀ , x₁)))

    _×Search'_ : ∀ {A B} → Search A → Search B → Search (A × B)
    (searchᴬ ×Search' searchᴮ) op f = searchᴬ op (λ x → searchᴮ op (curry f x))

    _×SearchInd'_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
                    → SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ ×Search' sᴮ)
    (Psᴬ ×SearchInd' Psᴮ) P P∙ Pf =
      Psᴬ (λ s → P (λ _ _ → s _ _)) P∙ (Psᴮ (λ s → P (λ _ _ → s _ _)) P∙ ∘ curry Pf)

    -- liftM2 _,_ in the continuation monad
    _×Sum'_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
    (sumᴬ ×Sum' sumᴮ) f = sumᴬ (λ x₀ →
                            sumᴮ (λ x₁ →
                              f (x₀ , x₁)))


flat-funs: <_,_> and <_×_> shortcuts

flat-funs: <_,_> and <_×_> shortcuts

module flat-funs where

open import Data.Nat
import Level as L
open import composable
open import vcomp

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T
    _`→_  : T → T → Set

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_
  infix 0 _`→_

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  field
    idO : ∀ {A} → A `→ A
    isComposable  : Composable  _`→_
    isVComposable : VComposable _`×_ _`→_

    -- Fanout
    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

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

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = f *** g

  open Composable isComposable public
  open VComposable isVComposable public

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Product
open import Function

fun♭Funs : FlatFuns Set
fun♭Funs = mk ⊤ Bit _×_ Vec (λ A B → A → B)

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk 0 1 _+_ _*_ (λ i o → Bits i → Bits o)

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id funComp funVComp _&&&_ proj₁ proj₂
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id bitsFunComp bitsFunVComp _&&&_ (λ {A} → take A) (λ {A} → drop A)
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)

module flat-funs where

open import Data.Nat
import Level as L
open import composable
open import vcomp

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T
    _`→_  : T → T → Set

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_
  infix 0 _`→_

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  field
    idO : ∀ {A} → A `→ A
    isComposable  : Composable  _`→_
    isVComposable : VComposable _`×_ _`→_

    -- Fanout
    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

  open FlatFuns ♭Funs public
  open Composable isComposable public
  open VComposable isVComposable public

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Product
open import Function

fun♭Funs : FlatFuns Set
fun♭Funs = mk ⊤ Bit _×_ Vec (λ A B → A → B)

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk 0 1 _+_ _*_ (λ i o → Bits i → Bits o)

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id funComp funVComp _&&&_ proj₁ proj₂
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id bitsFunComp bitsFunVComp _&&&_ (λ {A} → take A) (λ {A} → drop A)
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)


Reorder

Reorder

module New.Changes where

open import Relation.Binary.PropositionalEquality
open import Level
open import Data.Unit
open import Data.Product

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  infixl 6 _⊕_ _⊝_

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a
  open ≡-Reasoning
  open import Postulate.Extensionality

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  instance
    funCA : ChAlg (A → B)
  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = λ f df → ∀ a da (v : valid a da) →
        valid (f a) (df a da) ×
        (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da
      ; ⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      } }

  nil-is-derivative : ∀ (f : A → B) → IsDerivative f (nil f)
  nil-is-derivative f a da v =
    begin
      f (a ⊕ da)
    ≡⟨ sym (cong (λ □ → □ (_⊕_ a da)) (update-nil f)) ⟩
      (f ⊕ nil f) (a ⊕ da)
    ≡⟨ proj₂ (nil-valid f a da v) ⟩
      f a ⊕ (nil f a da)
    ∎

  private
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → Ch A × Ch B
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → Ch A × Ch B → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = Ch A × Ch B
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    } }

open import Data.Integer
open import Theorem.Groups-Nehemiah

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b} } }

module New.Changes where

open import Relation.Binary.PropositionalEquality
open import Level
open import Data.Unit
open import Data.Product

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  infixl 6 _⊕_ _⊝_

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a
  open ≡-Reasoning
  open import Postulate.Extensionality

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  instance
    funCA : ChAlg (A → B)
  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = λ f df → ∀ a da (v : valid a da) →
        valid (f a) (df a da) ×
        (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da
      ; ⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      } }

  nil-is-derivative : ∀ (f : A → B) → IsDerivative f (nil f)
  nil-is-derivative f a da v =
    begin
      f (a ⊕ da)
    ≡⟨ sym (cong (λ □ → □ (_⊕_ a da)) (update-nil f)) ⟩
      (f ⊕ nil f) (a ⊕ da)
    ≡⟨ proj₂ (nil-valid f a da v) ⟩
      f a ⊕ (nil f a da)
    ∎

  private
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → Ch A × Ch B
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → Ch A × Ch B → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = Ch A × Ch B
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    } }

open import Data.Integer
open import Theorem.Groups-Nehemiah

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b} } }


Added nest-≤.

Added nest-≤.

Ignore-this: 66798d074a18d6463535b689c1646140

darcs-hash:20110405141851-3bd4e-7fe2b36202a77d7104679148f24241e6b1336d6c.gz

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-N : ∀ {d} → Dom d → N (nest d)
nest-N dom0           = subst N (sym nest-0) zN
nest-N (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-N h₂)

nest-≤ : ∀ {n} → N n → Dom n → LE (nest n) n
nest-≤ Nz dom0           =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ NSn (domS n h₁ h₂) =
  ≤-trans (nest-N (domS n h₁ h₂)) (nest-N h₁) NSn prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ (dom-N (nest n) h₂) h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N h₁) Nn NSn (nest-≤ Nn h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N dn-x) (x≤y→x<Sy (nest-N dn-x) Nx (nest-≤ Nx dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-N : ∀ {d} → Dom d → N (nest d)
nest-N dom0           = subst N (sym nest-0) zN
nest-N (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-N h₂)

postulate
  nest-≤ : ∀ {n} → N n → LE (nest n) n

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h = domS x dn-x (h (nest-N dn-x)
                                      (x≤y→x<Sy (nest-N dn-x) Nx (nest-≤ Nx)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)


close #18

close #18

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + d casterr[ Δ ] + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    E : ∀{d Δ} → d casterr → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
  -- constants
  progress TAConst = V (BVVal VConst)

  -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

  -- lambdas
  progress (TALam wt) = V (BVVal VLam)

  -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
  progress (TAAp wt1 wt2) | S x | ih2 = {!!}
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
  progress (TAAp wt1 wt2) | I x | ih2 = {!!}
  progress (TAAp wt1 wt2) | V x | ih2 = {!!}

  -- empty holes
  progress (TAEHole x x₁) = I IEHole

  -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (d' , Step x y z) = S (_ , Step {!!} {!!} {!!})
  ... | E x = E (CECong (FHNEHole FHOuter) x)
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

  -- casts
  progress (TACast wt y)
    with progress wt
  ... | S x = {!!}
  ... | E x = E (CECong (FHCast FHOuter) x)
  ... | I x = {!x!}
  ... | V x = {!!}

  -- -- applications
  -- progress (TAAp D1 x D2)
  --   with progress D1 | progress D2
  --   -- left applicand value
  -- progress (TAAp TAConst () D2) | V VConst | _
  -- progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | V x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FVal x₁)) {!!} )
  -- progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | I x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!} )
  --   -- errors propagate
  -- progress (TAAp D1 x₂ D2) | V x | E x₁ = E (EAp2 (FVal x) x₁)
  -- progress (TAAp D1 x₂ D2) | I x | E x₁ = E (EAp2 (FIndet x) x₁)
  -- progress (TAAp D1 x₂ D2) | E x | E x₁ = E (EAp1 x) -- NB: could have picked the other one here, too; this is a source of non-determinism
  -- progress (TAAp D1 x₂ D2) | S x | E x₁ = S {!!}
  -- progress (TAAp D1 x₂ D2) | E x | _    = E (EAp1 x)
  --   -- indeterminates
  -- progress (TAAp D1 x₂ D2) | I i | V v = I (IAp i  (FVal v))
  -- progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
  --   -- either applicand steps
  -- progress (TAAp D1 x₃ D2) | S (d1' , Step x x₁ x₂)  | _ = S (_ , Step (FHAp2 x) x₁ (FHAp2 x₂))
  -- progress (TAAp D1 x₄ D2) | _ | S (d2' , Step x₁ x₂ x₃) = S (_ , Step (FHAp1 {!!} x₁) x₂ (FHAp1 {!!} x₃))

  -- -- non-empty holes
  -- progress (TANEHole x D x₁)
  --   with progress D
  -- progress (TANEHole x₁ D x₂) | V v = I (INEHole (FVal v))
  -- progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  -- progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  -- progress (TANEHole x₃ D x₄) | S (_ , Step x x₁ x₂) = S (_ , Step (FHNEHole x) x₁ (FHNEHole x₂))

  -- -- casts
  -- progress (TACast D x)
  --   with progress D
  -- progress (TACast TAConst con) | V VConst = S (c , Step (FHCastFinal (FVal VConst)) (ITCast (FVal VConst) TAConst con) (FHFinal (FVal VConst)))
  -- progress (TACast D m)  | V VLam = S (_ , Step (FHCastFinal (FVal VLam)) (ITCast (FVal VLam) D m) (FHFinal (FVal VLam)))
  -- progress (TACast D x₁) | I x = I (ICast x)
  -- progress (TACast D x₁) | E x = E (ECastProp x)
  -- progress (TACast D x₃) | S (d , Step x x₁ x₂) = S (_ , Step (FHCast x) x₁ (FHCast x₂))

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    E : ∀{d Δ} → d casterr → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
  -- constants
  progress TAConst = V (BVVal VConst)

  -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

  -- lambdas
  progress (TALam wt) = V (BVVal VLam)

  -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
  progress (TAAp wt1 wt2) | S x | ih2 = {!!}
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
  progress (TAAp wt1 wt2) | I x | ih2 = {!!}
  progress (TAAp wt1 wt2) | V x | ih2 = {!!}

  -- empty holes
  progress (TAEHole x x₁) = I IEHole

  -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (d' , Step x y z) = S (_ , Step {!!} {!!} {!!})
  ... | E x = E (CECong (FHNEHole FHOuter) x)
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

  -- casts
  progress (TACast wt y)
    with progress wt
  ... | S x = {!!}
  ... | E x = E (CECong (FHCast FHOuter) x)
  ... | I x = {!x!}
  ... | V x = {!!}

  -- -- applications
  -- progress (TAAp D1 x D2)
  --   with progress D1 | progress D2
  --   -- left applicand value
  -- progress (TAAp TAConst () D2) | V VConst | _
  -- progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | V x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FVal x₁)) {!!} )
  -- progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | I x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!} )
  --   -- errors propagate
  -- progress (TAAp D1 x₂ D2) | V x | E x₁ = E (EAp2 (FVal x) x₁)
  -- progress (TAAp D1 x₂ D2) | I x | E x₁ = E (EAp2 (FIndet x) x₁)
  -- progress (TAAp D1 x₂ D2) | E x | E x₁ = E (EAp1 x) -- NB: could have picked the other one here, too; this is a source of non-determinism
  -- progress (TAAp D1 x₂ D2) | S x | E x₁ = S {!!}
  -- progress (TAAp D1 x₂ D2) | E x | _    = E (EAp1 x)
  --   -- indeterminates
  -- progress (TAAp D1 x₂ D2) | I i | V v = I (IAp i  (FVal v))
  -- progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
  --   -- either applicand steps
  -- progress (TAAp D1 x₃ D2) | S (d1' , Step x x₁ x₂)  | _ = S (_ , Step (FHAp2 x) x₁ (FHAp2 x₂))
  -- progress (TAAp D1 x₄ D2) | _ | S (d2' , Step x₁ x₂ x₃) = S (_ , Step (FHAp1 {!!} x₁) x₂ (FHAp1 {!!} x₃))

  -- -- non-empty holes
  -- progress (TANEHole x D x₁)
  --   with progress D
  -- progress (TANEHole x₁ D x₂) | V v = I (INEHole (FVal v))
  -- progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  -- progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  -- progress (TANEHole x₃ D x₄) | S (_ , Step x x₁ x₂) = S (_ , Step (FHNEHole x) x₁ (FHNEHole x₂))

  -- -- casts
  -- progress (TACast D x)
  --   with progress D
  -- progress (TACast TAConst con) | V VConst = S (c , Step (FHCastFinal (FVal VConst)) (ITCast (FVal VConst) TAConst con) (FHFinal (FVal VConst)))
  -- progress (TACast D m)  | V VLam = S (_ , Step (FHCastFinal (FVal VLam)) (ITCast (FVal VLam) D m) (FHFinal (FVal VLam)))
  -- progress (TACast D x₁) | I x = I (ICast x)
  -- progress (TACast D x₁) | E x = E (ECastProp x)
  -- progress (TACast D x₃) | S (d , Step x x₁ x₂) = S (_ , Step (FHCast x) x₁ (FHCast x₂))


ZK.GroupHom: can swap transcripts to refine their order, also make ^-−ᶜ ^-^-1/ more precise

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function using (flip; case_of_)
open import Data.Sum.NP
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Data.Bool.Base using (Bool) renaming (T to ✓)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; idp; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Homomorphism
import ZK.SigmaProtocol.KnownStatement

module ZK.GroupHom
    {G+ G* : Type} (grp-G+ : Group G+) (grp-G* : Group G*)
    (_==_ : G* → G* → Bool)
    (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
    (==-✓ : ∀ {x y} → ✓ (x == y) → x ≡ y)

    (open Additive-Group grp-G+ hiding (_⊗_))
    (open Multiplicative-Group grp-G* hiding (_^_))

    {C : Type} -- e.g. C ⊆ ℕ
    (_>_ : C → C → Type)
    (swap? : {c₀ c₁ : C} → c₀ ≢ c₁ → (c₀ > c₁) ⊎ (c₁ > c₀))
    (_⊗_ : G+ → C → G+)
    (_^_ : G* → C → G*)
    (_−ᶜ_ : C → C → C)
    (1/ : C → C)

    (φ : G+ → G*) -- For instance φ(x) = g^x
    (φ-hom : GroupHomomorphism grp-G+ grp-G* φ)
    (φ-hom-iterated : ∀ {x c} → φ (x ⊗ c) ≡ φ x ^ c)

    (Y : G*)

    (^-−ᶜ  : ∀ {c₀ c₁}(c> : c₀ > c₁) → Y ^(c₀ −ᶜ c₁) ≡ (Y ^ c₀) / (Y ^ c₁))
    (^-^-1/ : ∀ {c₀ c₁}(c> : c₀ > c₁) → (Y ^(c₀ −ᶜ c₁))^(1/(c₀ −ᶜ c₁)) ≡ Y)
    where

  Commitment = G*
  Challenge  = C
  Response   = G+
  Witness    = G+
  Randomness = G+
  _∈y : Witness → Type
  x ∈y = φ x ≡ Y

  open ZK.SigmaProtocol.KnownStatement Commitment Challenge Response Randomness Witness _∈y public

  prover : Prover
  prover a x = φ a , response
     where response : Challenge → Response
           response c = (x ⊗ c) + a

  verifier : Verifier
  verifier (mk A c s) = φ s == ((Y ^ c) * A)

  -- We still call it Schnorr since essentially not much changed.
  -- The scheme abstracts away g^ as an homomorphism called φ
  -- and one get to distinguish between the types C vs G+ and
  -- their operations _⊗_ vs _*_.
  Schnorr : Σ-Protocol
  Schnorr = (prover , verifier)

  -- The simulator shows why it is so important for the
  -- challenge to be picked once the commitment is known.
  -- To fake a transcript, the challenge and response can
  -- be arbitrarily chosen. However to be indistinguishable
  -- from a valid proof they need to be picked at random.
  simulator : Simulator
  simulator c s = A
      where
        -- Compute A, such that the verifier accepts!
        A = (Y ^ c)⁻¹ * φ s

  swap-t²? : Transcript²[ _≢_ ] verifier → Transcript²[ _>_ ] verifier
  swap-t²? t² = t²'
      module Swap? where
        open Transcript² t² public
          using (verify₀; verify₁; c₀≢c₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   )
        t²' = case swap? c₀≢c₁ of λ
              { (inl c₀>c₁) → mk A c₀ c₁ c₀>c₁ r₀ r₁ verify₀ verify₁
              ; (inr c₀<c₁) → mk A c₁ c₀ c₀<c₁ r₁ r₀ verify₁ verify₀
              }

  -- The extractor shows the importance of never reusing a
  -- commitment. If the prover answers to two different challenges
  -- comming from the same commitment then the knowledge of the
  -- prover (the witness) can be extracted.
  extractor : Extractor verifier
  extractor t² = x'
      module Witness-extractor where
        open Transcript² (swap-t²? t²) public
          using (verify₀; verify₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   ; c₀≢c₁ to c₀>c₁
                   )
        rd   = r₀ − r₁
        cd   = c₀ −ᶜ c₁
        1/cd = 1/ cd
        x'   = rd ⊗ 1/cd

  open ≡-Reasoning
  open GroupHomomorphism φ-hom

  correct : Correct Schnorr
  correct x a c w
    = ✓-== (φ((x ⊗ c) + a)  ≡⟨ hom ⟩
            φ(x ⊗ c)  * A   ≡⟨ *= φ-hom-iterated idp ⟩
            (φ x ^ c) * A   ≡⟨ ap (λ z → (z ^ c) * A) w ⟩
            (Y ^ c)   * A   ∎)
    where
      A = φ a

  shvzk : Special-Honest-Verifier-Zero-Knowledge Schnorr
  shvzk = record { simulator = simulator
                 ; correct-simulator =
                    λ _ _ → ✓-== (! elim-*-!assoc= (snd ⁻¹-inverse)) }

  module _ (t² : Transcript² verifier) where
    open Witness-extractor t²

    φrd≡ycd : _
    φrd≡ycd
      = φ rd                        ≡⟨by-definition⟩
        φ (r₀ − r₁)                 ≡⟨ −-/ ⟩
        φ r₀ / φ r₁                 ≡⟨ /= (==-✓ verify₀) (==-✓ verify₁) ⟩
        (Y ^ c₀ * A) / (Y ^ c₁ * A) ≡⟨ elim-*-right-/ ⟩
        Y ^ c₀ / Y ^ c₁             ≡⟨ ! ^-−ᶜ c₀>c₁ ⟩
        Y ^(c₀ −ᶜ c₁)               ≡⟨by-definition⟩
        Y ^ cd                      ∎

    -- The extracted x is correct
    extractor-ok : φ x' ≡ Y
    extractor-ok
      = φ(rd ⊗ 1/cd)    ≡⟨ φ-hom-iterated ⟩
        φ rd ^ 1/cd     ≡⟨ ap₂ _^_ φrd≡ycd idp ⟩
        (Y ^ cd)^ 1/cd  ≡⟨ ^-^-1/ c₀>c₁ ⟩
        Y               ∎

  special-soundness : Special-Soundness Schnorr
  special-soundness = record { extractor = extractor
                             ; extract-valid-witness = extractor-ok }

  special-Σ-protocol : Special-Σ-Protocol
  special-Σ-protocol = record { Σ-protocol = Schnorr ; correct = correct ; shvzk = shvzk ; ssound = special-soundness }
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function using (flip)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Data.Bool.Base using (Bool) renaming (T to ✓)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; idp; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Homomorphism
import ZK.SigmaProtocol.KnownStatement

module ZK.GroupHom
    {G+ G* : Type} (grp-G+ : Group G+) (grp-G* : Group G*)
    (_==_ : G* → G* → Bool)
    (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
    (==-✓ : ∀ {x y} → ✓ (x == y) → x ≡ y)

    (open Additive-Group grp-G+ hiding (_⊗_))
    (open Multiplicative-Group grp-G* hiding (_^_))

    {C D : Type} -- e.g. C ⊆ ℕ, D = C/0
    (_⊗_ : G+ → C → G+)
    (_^_ : G* → C → G*)
    (_−ᶜ_ : C → C → D)
    (1* 1/ : D → C) -- Two ways to go from D to C, 1*d embeds D in C, 1/d does the inverse operation
    (^-−ᶜ  : ∀ {b x y}(x≢y : x ≢ y) → b ^ 1*(x −ᶜ y) ≡ (b ^ x) / (b ^ y))
    (^-^-1/ : ∀ {b x y}(x≢y : x ≢ y) → (b ^ 1*(x −ᶜ y))^(1/(x −ᶜ y)) ≡ b)

    (φ : G+ → G*) -- For instance φ(x) = g^x
    (φ-hom : GroupHomomorphism grp-G+ grp-G* φ)
    (φ-hom-iterated : ∀ {x c} → φ (x ⊗ c) ≡ φ x ^ c)

    (y : G*)
    where

  Commitment = G*
  Challenge  = C
  Response   = G+
  Witness    = G+
  Randomness = G+
  _∈y : Witness → Type
  x ∈y = φ x ≡ y

  open ZK.SigmaProtocol.KnownStatement Commitment Challenge Response Randomness Witness _∈y public

  prover : Prover
  prover a x = φ a , response
     where response : Challenge → Response
           response c = (x ⊗ c) + a

  verifier : Verifier
  verifier (mk A c s) = φ s == ((y ^ c) * A)

  -- We still call it Schnorr since essentially not much changed.
  -- The scheme abstracts away g^ as an homomorphism called φ
  -- and one get to distinguish between the types C vs G+ and
  -- their operations _⊗_ vs _*_.
  Schnorr : Σ-Protocol
  Schnorr = (prover , verifier)

  -- The simulator shows why it is so important for the
  -- challenge to be picked once the commitment is known.
  -- To fake a transcript, the challenge and response can
  -- be arbitrarily chosen. However to be indistinguishable
  -- from a valid proof they need to be picked at random.
  simulator : Simulator
  simulator c s = A
      where
        -- Compute A, such that the verifier accepts!
        A = (y ^ c)⁻¹ * φ s

  -- The extractor shows the importance of never reusing a
  -- commitment. If the prover answers to two different challenges
  -- comming from the same commitment then the knowledge of the
  -- prover (the witness) can be extracted.
  extractor : Extractor verifier
  extractor t² = x'
      module Witness-extractor where
        open Transcript² t² public
          using (verify₀; verify₁; c₀≢c₁)
          renaming ( get-A to A
                   ; get-f₀ to r₀; get-f₁ to r₁
                   ; get-c₀ to c₀; get-c₁ to c₁
                   )
        rd   = r₀ − r₁
        cd   = c₀ −ᶜ c₁
        1/cd = 1/ cd
        x'   = rd ⊗ 1/cd

  open ≡-Reasoning
  open GroupHomomorphism φ-hom

  correct : Correct Schnorr
  correct x a c w
    = ✓-== (φ((x ⊗ c) + a)  ≡⟨ hom ⟩
            φ(x ⊗ c)  * A   ≡⟨ *= φ-hom-iterated idp ⟩
            (φ x ^ c) * A   ≡⟨ ap (λ z → (z ^ c) * A) w ⟩
            (y ^ c)   * A   ∎)
    where
      A = φ a

  shvzk : Special-Honest-Verifier-Zero-Knowledge Schnorr
  shvzk = record { simulator = simulator
                 ; correct-simulator =
                    λ _ _ → ✓-== (! elim-*-!assoc= (snd ⁻¹-inverse)) }

  module _ (t² : Transcript² verifier) where
    open Witness-extractor t²

    φrd≡ycd : _
    φrd≡ycd
      = φ rd                        ≡⟨by-definition⟩
        φ (r₀ − r₁)                 ≡⟨ −-/ ⟩
        φ r₀ / φ r₁                 ≡⟨ /= (==-✓ verify₀) (==-✓ verify₁) ⟩
        (y ^ c₀ * A) / (y ^ c₁ * A) ≡⟨ elim-*-right-/ ⟩
        y ^ c₀ / y ^ c₁             ≡⟨ ! ^-−ᶜ c₀≢c₁ ⟩
        y ^ 1*(c₀ −ᶜ c₁)            ≡⟨by-definition⟩
        y ^ 1* cd                   ∎

    -- The extracted x is correct
    extractor-ok : φ x' ≡ y
    extractor-ok
      = φ(rd ⊗ 1/cd)       ≡⟨ φ-hom-iterated ⟩
        φ rd ^ 1/cd        ≡⟨ ap₂ _^_ φrd≡ycd idp ⟩
        (y ^ 1* cd)^ 1/cd  ≡⟨ ^-^-1/ c₀≢c₁ ⟩
        y                  ∎

  special-soundness : Special-Soundness Schnorr
  special-soundness = record { extractor = extractor
                             ; extract-valid-witness = extractor-ok }

  special-Σ-protocol : Special-Σ-Protocol
  special-Σ-protocol = record { Σ-protocol = Schnorr ; correct = correct ; shvzk = shvzk ; ssound = special-soundness }
-- -}
-- -}
-- -}
-- -}


Removed note on induction principles for N.

------------------------------------------------------------------------------
-- Arithmetic properties: Testing the induction principle
------------------------------------------------------------------------------

module FOT.FOTC.Data.Nat.Induction.AdditionalHypothesis.PropertiesByInductionI
  where

open import FOTC.Base
open import FOTC.Data.Nat hiding ( N-ind )

------------------------------------------------------------------------------
-- Induction principle with the additional hypothesis.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- Induction principle without the additional hypothesis.
N-ind₂ : (A : D → Set) →
        A zero →
        (∀ {n} → A n → A (succ₁ n)) →
        ∀ {n} → N n → A n
N-ind₂ A A0 h nzero      = A0
N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

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

pred-N₁ : ∀ {n} → N n → N (pred₁ n)
pred-N₁ = N-ind₁ A A0 is
  where
  A : D → Set
  A i = N (pred₁ i)

  A0 : A zero
  A0 = subst N (sym pred-0) nzero

  is : ∀ {i} → N i → A i → A (succ₁ i)
  is {i} Ni ih = subst N (sym (pred-S i)) Ni

-- It is not possible to prove pred-N using N-ind₂.
-- pred-N₂ : ∀ {n} → N n → N (pred₁ n)
-- pred-N₂ = N-ind₂ A A0 is
--   where
--   A : D → Set
--   A i = N (pred₁ i)

--   A0 : A zero
--   A0 = subst N (sym pred-0) nzero

--   -- We need the hypothesis N i.
--   is : ∀ {i} → A i → A (succ₁ i)
--   is {i} ih = subst N (sym (pred-S i)) {!!}

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ {n = n} Nm Nn = N-ind₁ A A0 is Nm
  where
  A : D → Set
  A i = N (i + n)

  A0 : A zero
  A0 = subst N (sym (+-0x n)) Nn

  is : ∀ {i} → N i → A i → A (succ₁ i)
  is {i} _ ih = subst N (sym (+-Sx i n)) (nsucc ih)

+-N₂ : ∀ {m n} → N m → N n → N (m + n)
+-N₂ {n = n} Nm Nn = N-ind₂ A A0 is Nm
  where
  A : D → Set
  A i = N (i + n)

  A0 : A zero
  A0 = subst N (sym (+-0x n)) Nn

  is : ∀ {i} → A i → A (succ₁ i)
  is {i} ih = subst N (sym (+-Sx i n)) (nsucc ih)


ClientServer: some renamings

ClientServer: some renamings

open import Type
open import Function.NP
open import Data.Nat
open import Data.Product.NP using (_,_)

open import Control.Protocol.Core
open import Control.Protocol.Sequence

module Control.Protocol.ClientServer (Query : ★₀) (Resp : Query → ★₀) where
    ClientRound ServerRound : Proto
    ClientRound = send λ (q : Query) → recv λ (r : Resp q) → end
    ServerRound = dual ClientRound

    ClientRounds ServerRounds : ℕ → Proto
    ClientRounds n = replicateᴾ n ClientRound
    ServerRounds = dual ∘ ClientRounds

    Server Client : Proto
    Client = send λ n →
             ClientRounds n
    Server = recv λ n →
             ServerRounds n

    module PureServer (serve : Π Query Resp) where
      server : ⟦ Server ⟧
      server zero      = _
      server (suc n) q = serve q , server n

open import Type
open import Function.NP
open import Data.Nat
open import Data.Product.NP using (_,_)

open import Control.Protocol.Core
open import Control.Protocol.Sequence

module Control.Protocol.ClientServer (Query : ★₀) (Resp : Query → ★₀) where
    ClientRound ServerRound : Proto
    ClientRound = send λ (q : Query) → recv λ (r : Resp q) → end
    ServerRound = dual ClientRound

    Client Server : ℕ → Proto
    Client n = replicateᴾ n ClientRound
    Server = dual ∘ Client

    DynamicServer StaticServer : Proto
    DynamicServer = recv λ n →
                    Server n
    StaticServer  = send λ n →
                    Server n

    module PureServer (serve : Π Query Resp) where
      server : ∀ n → ⟦ Server n ⟧
      server zero      = _
      server (suc n) q = serve q , server n


Added theorem 0^0≡1.

Added theorem 0^0≡1.

------------------------------------------------------------------------------
-- Some proofs related to the power function
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.Pow where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

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

infixr 11 _^_

postulate
  _^_ : D → D → D
  ^-0 : ∀ n → n ^ zero      ≡ 1'
  ^-S : ∀ m n → m ^ succ₁ n ≡ m * m ^ n
{-# ATP axioms ^-0 ^-S #-}

postulate 0^0≡1 : 0' ^ 0' ≡ 1'
{-# ATP prove 0^0≡1 #-}

thm₁ : ∀ {n} → N n → 5' ≤ n → n ^ 5' ≤ 5' ^ n
thm₁ nzero h = prf
  where postulate prf : zero ^ 5' ≤ 5' ^ zero
        {-# ATP prove prf #-}
thm₁ (nsucc {n} Nn) h = prf (thm₁ Nn)
  where
  postulate prf : (5' ≤ n → n ^ 5' ≤ 5' ^ n) → (succ₁ n) ^ 5' ≤ 5' ^ (succ₁ n)
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf 5-N #-}

thm₂ : ∀ {n} → N n →
       ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡ 2' ^ (n + 1') ∸ 1'
thm₂ nzero = prf
  where
  postulate prf : ((2' ^ zero) ∸ 1') + 1' + ((2' ^ zero) ∸ 1') ≡
                  2' ^ (zero + 1') ∸ 1'
  {-# ATP prove prf #-}
thm₂ (nsucc {n} Nn) = prf (thm₂ Nn)
  where
  postulate prf : ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡
                  2' ^ (n + 1') ∸ 1' →
                  ((2' ^ succ₁ n) ∸ 1') + 1' + ((2' ^ succ₁ n) ∸ 1') ≡
                  2' ^ (succ₁ n + 1') ∸ 1'
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Some proofs related to the power function
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOT.FOTC.Data.Nat.Pow where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

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

infixr 11 _^_

postulate
  _^_ : D → D → D
  ^-0 : ∀ n → n ^ zero      ≡ 1'
  ^-S : ∀ m n → m ^ succ₁ n ≡ m * m ^ n
{-# ATP axioms ^-0 ^-S #-}

thm₁ : ∀ {n} → N n → 5' ≤ n → n ^ 5' ≤ 5' ^ n
thm₁ nzero h = prf
  where postulate prf : zero ^ 5' ≤ 5' ^ zero
        {-# ATP prove prf #-}
thm₁ (nsucc {n} Nn) h = prf (thm₁ Nn)
  where
  postulate prf : (5' ≤ n → n ^ 5' ≤ 5' ^ n) → (succ₁ n) ^ 5' ≤ 5' ^ (succ₁ n)
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf 5-N #-}

thm₂ : ∀ {n} → N n →
       ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡ 2' ^ (n + 1') ∸ 1'
thm₂ nzero = prf
  where
  postulate prf : ((2' ^ zero) ∸ 1') + 1' + ((2' ^ zero) ∸ 1') ≡
                  2' ^ (zero + 1') ∸ 1'
  {-# ATP prove prf #-}
thm₂ (nsucc {n} Nn) = prf (thm₂ Nn)
  where
  postulate prf : ((2' ^ n) ∸ 1') + 1' + ((2' ^ n) ∸ 1') ≡
                  2' ^ (n + 1') ∸ 1' →
                  ((2' ^ succ₁ n) ∸ 1') + 1' + ((2' ^ succ₁ n) ∸ 1') ≡
                  2' ^ (succ₁ n + 1') ∸ 1'
  -- 06 January 2016: The ATPs could not prove the theorem (240 sec).
  -- {-# ATP prove prf #-}


pushing whitespace etc.

pushing whitespace etc.

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁) with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {e = c} (ASubsume D x₁)                    | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = e ·: x} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = X x} (ASubsume D x₁)                  | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x e} (ASubsume D x₁)               | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume D x₂)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {e = e1 ∘ e2} (ASubsume D x₁)              | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume _ _ )              | _ , _ , _  = _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e ⦈[ x ]} (ASubsume (SNEHole wt) _) | _ , _ , _  = _ , _ , _ , EANEHole (π2( π2 (expandability-synth wt)))
    -- the lambda cases
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = _ , _ , ESAsc2 D
    ... | Inr x = _ , _ , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = _ , _ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = _ , _ , ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = _ , _ , ESAp2 {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = _ , _ , ESAp3 {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = e} (ASubsume D x₁) with expandability-synth D
    -- these cases just pass through, but we need to pattern match so we can prove things aren't holes
    expandability-ana {Γ} {c} (ASubsume D x₁)             | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {e ·: x} (ASubsume D x₁)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {X x} (ASubsume D x₁)           | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {·λ x e} (ASubsume D x₁)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    expandability-ana {Γ} {·λ x [ x₁ ] e} (ASubsume D x₂) | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₂
    expandability-ana {Γ} {e ∘ e₁} (ASubsume D x₁)        | _ , _ , D' = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) D' x₁
    -- the two holes are special-cased
    expandability-ana {Γ} {⦇⦈[ x ]} (ASubsume _ _ )       | _ , _ , _ = _ , _ , _ , EAEHole
    expandability-ana {Γ} {⦇ e ⦈[ x ]} (ASubsume (SNEHole wt) _) | _ , _ , _ = _ , _ , _ , EANEHole (π2( π2 (expandability-synth wt)))
    -- the lambda cases
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALamHole x₁ D'
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | _ , _ , _ , D' = _ , _ , _ , EALam x₁ D'


knocking out some easy cases of expansion unicity, hoping to figure out more about whats wrong with the ap rules

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import correspondence
open import synth-unicity

module expansion-unicity where
  ⦇⦈≠arr : ∀{t1 t2} → t1 ==> t2 == ⦇⦈ → ⊥
  ⦇⦈≠arr ()

  mutual
    expansion-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    expansion-unicity-synth ESConst ESConst = refl , refl , refl
    expansion-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl
    expansion-unicity-synth (ESLam apt1 d1) (ESLam apt2 d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = ap1 _ ih1  , ap1 _ ih2 , ih3
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp1 x₄ x₅ x₆ x₇)
      with expansion-unicity-ana x₃ x₇ | expansion-unicity-ana x₂ x₆
    ... | refl , refl , refl , refl | refl , refl , refl , refl = refl , refl , refl
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp2 x₄ d5 x₅ x₆) = abort (⦇⦈≠arr (synthunicity (correspondence-synth d5) x₁))
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp3 x₄ d5 x₅) = abort (⦇⦈≠arr (synthunicity (correspondence-synth d5) x₁))
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp1 x₃ x₄ x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp2 x₃ d6 x₄ x₅)
      with expansion-unicity-synth d5 d6 | expansion-unicity-ana x₄ x₁
    ... | refl , refl , refl | refl , refl , refl , refl = refl , refl , refl
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp3 x₃ d6 x₄)
      with expansion-unicity-synth d5 d6 | expansion-unicity-ana x₄ x₁
    ...| refl , refl , refl | refl , refl , refl , refl  = abort (x₂ refl)
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp1 x₂ x₃ x₄ x₅) = abort (⦇⦈≠arr (synthunicity (correspondence-synth d5) x₃))
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp2 x₂ d6 x₃ x₄)
      with expansion-unicity-synth d5 d6 | expansion-unicity-ana x₃ x₁
    ...| refl , refl , refl | refl , refl , refl , refl  = abort (x₄ refl)
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp3 x₂ d6 x₃)
      with expansion-unicity-synth d5 d6 | expansion-unicity-ana x₃ x₁
    ... | refl , refl , refl | refl , refl , refl , refl = refl , refl , refl
    expansion-unicity-synth ESEHole ESEHole = refl , refl , refl
    expansion-unicity-synth (ESNEHole d1) (ESNEHole d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc1 x₂ x₃)
      with expansion-unicity-ana x x₂
    ... | refl , refl , refl , refl = refl , refl , refl
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc2 x₂)
      with expansion-unicity-ana x x₂
    ... | refl , refl , refl , refl = refl , {!!} , refl -- should fail, can't show it though
    expansion-unicity-synth (ESAsc2 x) (ESAsc1 x₁ x₂)
      with expansion-unicity-ana x x₁
    ... | refl , refl , refl , refl = refl , {!!} , refl  -- ditto
    expansion-unicity-synth (ESAsc2 x) (ESAsc2 x₁)
      with expansion-unicity-ana x x₁
    ... | refl , refl , refl , refl = refl , refl , refl

    expansion-unicity-ana : {Γ : tctx} {e : hexp} {τ1 τ1' τ2 τ2' : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                          Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' ⊣ Δ1 →
                          Γ ⊢ e ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
                          τ1 == τ2 × d1 == d2 × τ1' == τ2' × Δ1 == Δ2
    expansion-unicity-ana (EALam apt1 d1) (EALam apt2 d2) = {!expansion-unicity-ana d1 d2!} -- doesn't go because the contexts are different
    expansion-unicity-ana (EALam apt1 d1) (EASubsume x₁ x₂ () x₄)
    expansion-unicity-ana (EASubsume x₁ x₂ () x₄) (EALam apt2 d2)
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇)
      with expansion-unicity-synth x₆ x₂
    ... | refl , refl , refl = {!!} , refl , refl , refl
    expansion-unicity-ana (EASubsume x x₁ ESEHole x₃) EAEHole = abort (x _ refl)
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole x₄) = abort (x₁ _ _ refl)
    expansion-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = abort (x _ refl)
    expansion-unicity-ana EAEHole EAEHole = {!!} , refl , {!!} , {!!}
    expansion-unicity-ana (EANEHole x) (EASubsume x₂ x₃ x₄ x₅) = abort (x₃ _ _ refl)
    expansion-unicity-ana (EANEHole x) (EANEHole x₁) =  {!!}
    expansion-unicity-ana (EALam x₁ x₂) (EALamHole x₃ y) = {!!} -- should be an abort
    expansion-unicity-ana (EALamHole x₁ x₂) (EALam x₃ y) = {!!} -- should be same abort
    expansion-unicity-ana (EALamHole x₁ x₂) (EALamHole x₃ y)
      with expansion-unicity-ana x₂ y
    ... | refl , refl , refl , refl = refl , refl , refl , refl
    expansion-unicity-ana (EALamHole x₁ x₂) (EASubsume x₃ x₄ () x₆)
    expansion-unicity-ana (EASubsume x₁ x₂ () x₄) (EALamHole x₅ y)

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

module expansion-unicity where
  mutual
    expansion-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    expansion-unicity-synth ESConst ESConst = refl , refl , refl
    expansion-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl
    expansion-unicity-synth (ESLam apt1 d1) (ESLam apt2 d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = ap1 _ ih1  , ap1 _ ih2 , {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp1 x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp2 x₄ d5 x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp3 x₄ d5 x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp1 x₃ x₄ x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp2 x₃ d6 x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp3 x₃ d6 x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp1 x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp2 x₂ d6 x₃ x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp3 x₂ d6 x₃) = {!!}
    expansion-unicity-synth ESEHole ESEHole = refl , refl , refl
    expansion-unicity-synth (ESNEHole d1) (ESNEHole d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc1 x₂ x₃) = {!!}
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc2 x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc1 x₁ x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc2 x₁) = {!!}

    expansion-unicity-ana : {Γ : tctx} {e : hexp} {τ1 τ1' τ2 τ2' : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                          Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' ⊣ Δ1 →
                          Γ ⊢ e ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
                          τ1 == τ2 × d1 == d2 × τ1' == τ2' × Δ1 == Δ2
    expansion-unicity-ana (EALam apt1 d1) (EALam apt2 d2) = {!!}
    expansion-unicity-ana (EALam apt1 d1) (EASubsume x₁ x₂ x₃ x₄) = {!!}
    expansion-unicity-ana (EASubsume x₁ x₂ x₃ x₄) (EALam apt2 d2) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole x₄) = {!!}
    expansion-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = {!!}
    expansion-unicity-ana EAEHole EAEHole = {!!}
    expansion-unicity-ana (EANEHole x) (EASubsume x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-ana (EANEHole x) (EANEHole x₁) = {!!}
    expansion-unicity-ana (EALam x₁ x₂) (EALamHole x₃ y) = {!!}
    expansion-unicity-ana (EALamHole x₁ x₂) (EALam x₃ y) = {!!}
    expansion-unicity-ana (EALamHole x₁ x₂) (EALamHole x₃ y) = {!!}
    expansion-unicity-ana (EALamHole x₁ x₂) (EASubsume x₃ x₄ x₅ x₆) = {!!}
    expansion-unicity-ana (EASubsume x₁ x₂ x₃ x₄) (EALamHole x₅ y) = {!!}


Give examples of using the new generic Desc eliminator.

{-# 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

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

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

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

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 = ind2 ⊤ ℕD _
      (case ℕT _
        ( (λ n → n)
        , (λ m ih n → suc (ih n))
        , tt
        )
      )
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = ind2 ⊤ ℕD _
      (case ℕT _
        ( (λ n → zero)
        , (λ m ih n → add n (ih n))
        , tt
        )
      )
      tt

    append : (A : Set) (m : ℕ tt) (xs : Vec A m) (n : ℕ tt) (ys : Vec A n) → Vec A (add m n)
    append A = ind2 (ℕ tt) (VecD A) _
      (case VecT _
        ( (λ n ys → ys)
        , (λ m x xs ih n ys → cons A (add m n) x (ih n ys))
        , tt
        )
      )

    concat : (A : Set) (m n : ℕ tt) (xss : Vec (Vec A m) n) → Vec A (mult n m)
    concat A m = ind2 (ℕ tt) (VecD (Vec A m)) _
      (case VecT _
        ( (nil A)
        , (λ n xs xss ih → append A m xs (mult n m) ih)
        , tt
        )
      )

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