flipbased-tree: Ongoing xor proofs...

flipbased-tree: Ongoing xor proofs...

module flipbased-tree where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Nat.Properties
open import bintree
open import Data.Product

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
↺ : ∀ {a} n (A : Set a) → Set a
↺ = flip Tree

return↺ : ∀ {c a} {A : Set a} → A → ↺ c A
return↺ = leaf

runDet : ∀ {a} {A : Set a} → ↺ 0 A → A
runDet (leaf x) = x

toss : ↺ 1 Bit
toss = fork (leaf 0b) (leaf 1b)

weaken≤ : ∀ {m c a} {A : Set a} → m ≤ c → ↺ m A → ↺ c A
weaken≤ p (leaf x) = leaf x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m n = ℕ≤.trans (m≤m+n m n) (ℕ≤.reflexive (ℕ°.+-comm m n))

weaken+ : ∀ c {m a} {A : Set a} → ↺ m A → ↺ (c + m) A
weaken+ c = weaken≤ (m≤n+m _ c)

map↺ : ∀ {c a b} {A : Set a} {B : Set b} → (A → B) → ↺ c A → ↺ c B
map↺ f (leaf x) = leaf (f x)
map↺ f (fork left right) = fork (map↺ f left) (map↺ f right)

join↺ : ∀ {c₁ c₂ a} {A : Set a} → ↺ c₁ (↺ c₂ A) → ↺ (c₁ + c₂) A
join↺ {c} (leaf x)      = weaken+ c x
join↺     (fork left right) = fork (join↺ left) (join↺ right)

open flipbased ↺ toss weaken≤ leaf map↺ join↺ public

open import Data.Bool
open import Data.Bits
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

infix 4 _/2+_/2
infix 6 _/2
postulate
  [0,1] : Set
  0/1 : [0,1]
  1/1 : [0,1]
  _/2 : [0,1] → [0,1]
  _/2+_/2 : [0,1] → [0,1] → [0,1]
  _*/_ : [0,1] → [0,1] → [0,1]
  1-_ : [0,1] → [0,1]
-- sym _/2+_/2
-- 1 /2+ 1 /2 = 1/1
-- p /2+ p /2 = p
-- p /2+ (1- p) /2 = 1/2

  -- ·/1+_ : ℕ → Set
  -- /+/ : ℕ → [0,1] → [0,1] → [0,1]

  0/2+p/2≡p/2 : ∀ p → (0/1 /2+ p /2) ≡ p /2
  _/2+_/2-comm : ∀ x y → x /2+ y /2 ≡ y /2+ x /2
  1*q≡q : ∀ q → 1/1 */ q ≡ q
  0*q≡q : ∀ q → 0/1 */ q ≡ 0/1
  distr-*-/2+/2 : ∀ x y z → (x */ z) /2+ (y */ z) /2 ≡ (x /2+ y /2) */ z
  distr-/2-* : ∀ p q → (p /2) */ (q /2) ≡ ((p */ q) /2) /2
  0/2≡0 : 0/1 /2 ≡ 0/1
  1-_/2+1-_/2 : ∀ p q → (1- p) /2+ (1- q) /2 ≡ 1- (p /2+ q /2)

1/2^_ : ℕ → [0,1]
1/2^ zero = 1/1
1/2^ suc n = (1/2^ n)/2

1/2 : [0,1]
1/2 = 1/2^ 1
1/4 : [0,1]
1/4 = 1/2^ 2

data Pr[return↺_≡_]≡_ {a} {A : Set a} (x y : A) : [0,1] → Set a where
  Pr-≡ : x ≡ y → Pr[return↺ x ≡ y ]≡ 1/1
  Pr-≢ : x ≢ y → Pr[return↺ x ≡ y ]≡ 0/1

infix 2 Pr[_≡_]≡_
data Pr[_≡_]≡_ {a} {A : Set a} : ∀ {c} → ↺ c A → A → [0,1] → Set a where
  Pr-return : ∀ {c x y pr} (pf : Pr[return↺ x ≡ y ]≡ pr) → Pr[ return↺ {c = c} x ≡ y ]≡ pr

  Pr-fork : ∀ {c} {left right : ↺ c A} {x p q r}
            (eq : p /2+ q /2 ≡ r)
            (pf₀ : Pr[ left ≡ x ]≡ p)
            (pf₁ : Pr[ right ≡ x ]≡ q)
            → Pr[ fork left right ≡ x ]≡ r

Pr-fork′ : ∀ {c a} {A : Set a} {left right : ↺ c A} {x p q}
            → Pr[ left ≡ x ]≡ p
            → Pr[ right ≡ x ]≡ q
            → Pr[ fork left right ≡ x ]≡ (p /2+ q /2)
Pr-fork′ = Pr-fork refl

Pr-return-≡ : ∀ {c a} {A : Set a} {x : A} → Pr[ return↺ {c = c} x ≡ x ]≡ 1/1
Pr-return-≡ = Pr-return (Pr-≡ refl)

Pr-return-≢ : ∀ {c a} {A : Set a} {x y : A} → x ≢ y → Pr[ return↺ {c = c} x ≡ y ]≡ 0/1
Pr-return-≢ = Pr-return ∘ Pr-≢

import Function.Equality as F≡
import Function.Equivalence as F≈

_≈⇒_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈⇒ p₂ = ∀ {x pr} → Pr[ p₁ ≡ x ]≡ pr → Pr[ p₂ ≡ x ]≡ pr

_≈_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈ p₂ = ∀ {x pr} → (Pr[ p₁ ≡ x ]≡ pr) F≈.⇔ (Pr[ p₂ ≡ x ]≡ pr)

≈-refl : ∀ {c a} {A : Set a} → Reflexive {A = ↺ c A} _≈_
≈-refl = F≈.id

≈-sym : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → p₁ ≈ p₂ → p₂ ≈ p₁
≈-sym η = F≈.sym η

≈-trans : ∀ {c a} {A : Set a} → Transitive {A = ↺ c A} _≈_
≈-trans f g = g F≈.∘ f

fork-sym⇒ : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → fork p₁ p₂ ≈⇒ fork p₂ p₁
fork-sym⇒ (Pr-fork {p = p} {q} refl pf₁ pf₀) rewrite p /2+ q /2-comm = Pr-fork′ pf₀ pf₁

fork-sym : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → fork p₁ p₂ ≈ fork p₂ p₁
fork-sym = F≈.equivalence fork-sym⇒ fork-sym⇒

Pr-fork-0 : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p}
            → Pr[ left ≡ x ]≡ 0/1
            → Pr[ right ≡ x ]≡ p
            → Pr[ fork left right ≡ x ]≡ p /2
Pr-fork-0 {p = p} eq₁ eq₂ rewrite sym (0/2+p/2≡p/2 p) = Pr-fork′ eq₁ eq₂

ex₁ : ∀ x → Pr[ toss ≡ x ]≡ 1/2
ex₁ 1b = Pr-fork-0 (Pr-return-≢ (λ ())) Pr-return-≡
ex₁ 0b = F≈.Equivalence.to fork-sym F≡.⟨$⟩ (Pr-fork-0 (Pr-return-≢ (λ ())) Pr-return-≡)

Pr-map : ∀ {c a b} {A : Set a} {B : Set b} {Alg : ↺ c A} {x pr} {f : A → B} →
  (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) →
  Pr[ Alg ≡ x ]≡ pr →
  Pr[ ⟪ f · Alg ⟫ ≡ f x ]≡ pr
Pr-map f-inj (Pr-return (Pr-≡ refl)) = Pr-return (Pr-≡ refl)
Pr-map f-inj (Pr-return (Pr-≢ x≢y)) = Pr-return (Pr-≢ (x≢y ∘ f-inj))
Pr-map f-inj (Pr-fork eq pf₀ pf₁) = Pr-fork eq (Pr-map f-inj pf₀) (Pr-map f-inj pf₁)

Pr-same : ∀ {c a} {A : Set a} {Alg : ↺ c A} {x pr₀ pr₁} →
    pr₀ ≡ pr₁ →
    Pr[ Alg ≡ x ]≡ pr₀ →
    Pr[ Alg ≡ x ]≡ pr₁
Pr-same refl = id

Pr-weaken≤ : ∀ {c₀ c₁ a} {A : Set a} {Alg : ↺ c₀ A} {x pr} →
    (c₀≤c₁ : c₀ ≤ c₁) →
    Pr[ Alg ≡ x ]≡ pr →
    Pr[ weaken≤ c₀≤c₁ Alg ≡ x ]≡ pr
Pr-weaken≤ p (Pr-return pf) = Pr-return pf
Pr-weaken≤ (s≤s c₀≤c₁) (Pr-fork eq pf₀ pf₁)
  = Pr-fork eq (Pr-weaken≤ c₀≤c₁ pf₀) (Pr-weaken≤ c₀≤c₁ pf₁)

Pr-weaken+ : ∀ {c₀} c₁ {a} {A : Set a} {Alg : ↺ c₀ A} {x pr} →
    Pr[ Alg ≡ x ]≡ pr →
    Pr[ weaken+ c₁ Alg ≡ x ]≡ pr
Pr-weaken+ c₁ = Pr-weaken≤ (m≤n+m _ c₁)

Pr-map-0 : ∀ {c a b} {A : Set a} {B : Set b} {Alg : ↺ c A} {f : A → B} {x} → (∀ y → f y ≢ x)
           → Pr[ map↺ f Alg ≡ x ]≡ 0/1
Pr-map-0 {Alg = leaf x} f-prop = Pr-return (Pr-≢ (f-prop x))
Pr-map-0 {Alg = fork Alg Alg₁} f-prop = Pr-fork (trans (0/2+p/2≡p/2 0/1) 0/2≡0)
                                                (Pr-map-0 f-prop) (Pr-map-0 f-prop)

Pr-zip : ∀ {c₀ c₁ a b} {A : Set a} {B : Set b} {Alg₀ : ↺ c₀ A} {Alg₁ : ↺ c₁ B} {x y pr₁ pr₂} →
  Pr[ Alg₀ ≡ x ]≡ pr₁ →
  Pr[ Alg₁ ≡ y ]≡ pr₂ →
  Pr[ zip↺ Alg₀ Alg₁ ≡ (x , y) ]≡ (pr₁ */ pr₂)
Pr-zip {c₀} {pr₂ = pr₂} (Pr-return {x = x} (Pr-≡ refl)) pf₂
  rewrite 1*q≡q pr₂ = Pr-weaken+ c₀ (Pr-map {f = _,_ x} (cong proj₂) pf₂)
Pr-zip {c₀} {pr₂ = pr₂} (Pr-return {x = x} (Pr-≢ pf)) pf₂
  rewrite 0*q≡q pr₂ = Pr-weaken+ c₀ (Pr-map-0 (λ y x₁ → pf (cong proj₁ x₁)))
Pr-zip (Pr-fork refl pf₁ pf₂) pf₃ = Pr-fork (distr-*-/2+/2 _ _ _) (Pr-zip pf₁ pf₃) (Pr-zip pf₂ pf₃)

ex₂ : ∀ x y → Pr[ toss ⟨,⟩ toss ≡ (x , y) ]≡ 1/4
ex₂ x y = Pr-same (trans (distr-/2-* _ _) (cong (_/2 ∘ _/2) (1*q≡q _)))
                  (Pr-zip {Alg₀ = toss} {Alg₁ = toss} (ex₁ x) (ex₁ y))

pr-choose : ∀ {c a} {A : Set a} {p₀ p₁ : ↺ c A} {pr₀ pr₁ x}
             → Pr[ p₀ ≡ x ]≡ pr₀
             → Pr[ p₁ ≡ x ]≡ pr₁
             → Pr[ choose p₀ p₁ ≡ x ]≡ pr₀ /2+ pr₁ /2
pr-choose {c} {pr₀ = pr₀} {pr₁} pf₀ pf₁ =
  Pr-fork (pr₁ /2+ pr₀ /2-comm) (Pr-weaken+ 0 pf₁) (Pr-weaken+ 0 pf₀)

postulate
  pr-ret-xor : ∀ {x y pr} b
         → Pr[return↺ x ≡ y ]≡ pr
         → Pr[return↺ x ≡ b xor y ]≡ pr
-- pr-ret-xor b pf = {!!}

pr-xor'' : ∀ {c} {Alg : ↺ c Bit} {x pr} b
         → Pr[ Alg ≡ x ]≡ pr
         → Pr[ Alg ≡ b xor x ]≡ pr
pr-xor'' b (Pr-return pf) = Pr-return (pr-ret-xor b pf)
pr-xor'' b (Pr-fork refl pf₀ pf₁) = Pr-fork refl (pr-xor'' b pf₀) (pr-xor'' b pf₁)

pr-xor' : ∀ {c} {Alg : ↺ c Bit} {x pr b}
         → Pr[ Alg ≡ x ]≡ pr
         → Pr[ ⟪ _xor_ b · Alg ⟫ ≡ b xor x ]≡ pr
pr-xor' {b = b} = Pr-map (xor-inj {b})
  where
    -- move it!
    not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
    not-inj {true} {true} = λ _ → refl
    not-inj {true} {false} = λ ()
    not-inj {false} {true} = λ ()
    not-inj {false} {false} = λ _ → refl
    xor-inj : ∀ {b x y} → b xor x ≡ b xor y → x ≡ y
    xor-inj {true} = not-inj
    xor-inj {false} = id

postulate
  pr-ret-not : ∀ {x y pr}
         → Pr[return↺ x ≡ y ]≡ pr
         → Pr[return↺ x ≡ not y ]≡ 1- pr
-- pr-ret-not = {!!}

pr-not : ∀ {c} {Alg : ↺ c Bit} {x pr}
         → Pr[ Alg ≡ x ]≡ pr
         → Pr[ Alg ≡ not x ]≡ 1- pr
pr-not (Pr-return pf) = Pr-return (pr-ret-not pf)
pr-not (Pr-fork refl pf pf₁) = Pr-fork (1- _ /2+1- _ /2) (pr-not pf) (pr-not pf₁)

postulate
  pr-xor : ∀ {c} {Alg : ↺ c Bit} {x pr b}
         → Pr[ Alg ≡ x ]≡ pr
         → Pr[ ⟪ _xor_ b · Alg ⟫ ≡ x ]≡ pr
-- pr-xor {b = b} = {!pr-not!}

postulate
  pr-toss-xor-toss : ∀ x → Pr[ toss ⟨xor⟩ toss ≡ x ]≡ 1/2
-- pr-toss-xor-toss x = {!!}

postulate
  ex₃ : ∀ {n} (x : Bits n) → Pr[ random ≡ x ]≡ 1/2^ n

module flipbased-tree where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Nat.Properties
open import bintree
open import Data.Product

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
↺ : ∀ {a} n (A : Set a) → Set a
↺ = flip Tree

return↺ : ∀ {c a} {A : Set a} → A → ↺ c A
return↺ = leaf

runDet : ∀ {a} {A : Set a} → ↺ 0 A → A
runDet (leaf x) = x

toss : ↺ 1 Bit
toss = fork (leaf 0b) (leaf 1b)

weaken≤ : ∀ {m c a} {A : Set a} → m ≤ c → ↺ m A → ↺ c A
weaken≤ p (leaf x) = leaf x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m n = ℕ≤.trans (m≤m+n m n) (ℕ≤.reflexive (ℕ°.+-comm m n))

weaken+ : ∀ c {m a} {A : Set a} → ↺ m A → ↺ (c + m) A
weaken+ c = weaken≤ (m≤n+m _ c)

map↺ : ∀ {c a b} {A : Set a} {B : Set b} → (A → B) → ↺ c A → ↺ c B
map↺ f (leaf x) = leaf (f x)
map↺ f (fork left right) = fork (map↺ f left) (map↺ f right)

join↺ : ∀ {c₁ c₂ a} {A : Set a} → ↺ c₁ (↺ c₂ A) → ↺ (c₁ + c₂) A
join↺ {c} (leaf x)      = weaken+ c x
join↺     (fork left right) = fork (join↺ left) (join↺ right)

open flipbased ↺ toss weaken≤ leaf map↺ join↺ public

open import Data.Bool
open import Data.Bits
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

infix 4 _/2+_/2
infix 6 _/2
postulate
  [0,1] : Set
  0/1 : [0,1]
  1/1 : [0,1]
  _/2 : [0,1] → [0,1]
  _/2+_/2 : [0,1] → [0,1] → [0,1]
  _*/_ : [0,1] → [0,1] → [0,1]
-- sym _/2+_/2
-- 1 /2+ 1 /2 = 1/1
-- p /2+ p /2 = p
-- p /2+ (1- p) /2 = 1/2

  -- ·/1+_ : ℕ → Set
  -- /+/ : ℕ → [0,1] → [0,1] → [0,1]

  0/2+p/2≡p/2 : ∀ p → (0/1 /2+ p /2) ≡ p /2
  _/2+_/2-comm : ∀ x y → x /2+ y /2 ≡ y /2+ x /2
  1*q≡q : ∀ q → 1/1 */ q ≡ q
  0*q≡q : ∀ q → 0/1 */ q ≡ 0/1
  distr-*-/2+/2 : ∀ x y z → (x */ z) /2+ (y */ z) /2 ≡ (x /2+ y /2) */ z
  distr-/2-* : ∀ p q → (p /2) */ (q /2) ≡ ((p */ q) /2) /2
  0/2≡0 : 0/1 /2 ≡ 0/1

1/2^_ : ℕ → [0,1]
1/2^ zero = 1/1
1/2^ suc n = (1/2^ n)/2

1/2 : [0,1]
1/2 = 1/2^ 1
1/4 : [0,1]
1/4 = 1/2^ 2

data Pr[return↺_≡_]≡_ {a} {A : Set a} (x y : A) : [0,1] → Set a where
  Pr-≡ : x ≡ y → Pr[return↺ x ≡ y ]≡ 1/1
  Pr-≢ : x ≢ y → Pr[return↺ x ≡ y ]≡ 0/1

infix 2 Pr[_≡_]≡_
data Pr[_≡_]≡_ {a} {A : Set a} : ∀ {c} → ↺ c A → A → [0,1] → Set a where
  Pr-return : ∀ {c x y pr} (pf : Pr[return↺ x ≡ y ]≡ pr) → Pr[ return↺ {c = c} x ≡ y ]≡ pr

  Pr-fork : ∀ {c} {left right : ↺ c A} {x p q r}
            (eq : p /2+ q /2 ≡ r)
            (pf₀ : Pr[ left ≡ x ]≡ p)
            (pf₁ : Pr[ right ≡ x ]≡ q)
            → Pr[ fork left right ≡ x ]≡ r

Pr-fork′ : ∀ {c a} {A : Set a} {left right : ↺ c A} {x p q}
            → Pr[ left ≡ x ]≡ p
            → Pr[ right ≡ x ]≡ q
            → Pr[ fork left right ≡ x ]≡ (p /2+ q /2)
Pr-fork′ = Pr-fork refl

Pr-return-≡ : ∀ {c a} {A : Set a} {x : A} → Pr[ return↺ {c = c} x ≡ x ]≡ 1/1
Pr-return-≡ = Pr-return (Pr-≡ refl)

Pr-return-≢ : ∀ {c a} {A : Set a} {x y : A} → x ≢ y → Pr[ return↺ {c = c} x ≡ y ]≡ 0/1
Pr-return-≢ = Pr-return ∘ Pr-≢

import Function.Equality as F≡
import Function.Equivalence as F≈

_≈⇒_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈⇒ p₂ = ∀ {x pr} → Pr[ p₁ ≡ x ]≡ pr → Pr[ p₂ ≡ x ]≡ pr

_≈_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈ p₂ = ∀ {x pr} → (Pr[ p₁ ≡ x ]≡ pr) F≈.⇔ (Pr[ p₂ ≡ x ]≡ pr)

≈-refl : ∀ {c a} {A : Set a} → Reflexive {A = ↺ c A} _≈_
≈-refl = F≈.id

≈-sym : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → p₁ ≈ p₂ → p₂ ≈ p₁
≈-sym η = F≈.sym η

≈-trans : ∀ {c a} {A : Set a} → Transitive {A = ↺ c A} _≈_
≈-trans f g = g F≈.∘ f

fork-sym⇒ : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → fork p₁ p₂ ≈⇒ fork p₂ p₁
fork-sym⇒ (Pr-fork {p = p} {q} refl pf₁ pf₀) rewrite p /2+ q /2-comm = Pr-fork′ pf₀ pf₁

fork-sym : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → fork p₁ p₂ ≈ fork p₂ p₁
fork-sym = F≈.equivalence fork-sym⇒ fork-sym⇒

Pr-fork-0 : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p}
            → Pr[ left ≡ x ]≡ 0/1
            → Pr[ right ≡ x ]≡ p
            → Pr[ fork left right ≡ x ]≡ p /2
Pr-fork-0 {p = p} eq₁ eq₂ rewrite sym (0/2+p/2≡p/2 p) = Pr-fork′ eq₁ eq₂

ex₁ : ∀ x → Pr[ toss ≡ x ]≡ 1/2
ex₁ 1b = Pr-fork-0 (Pr-return-≢ (λ ())) Pr-return-≡
ex₁ 0b = F≈.Equivalence.to fork-sym F≡.⟨$⟩ (Pr-fork-0 (Pr-return-≢ (λ ())) Pr-return-≡)

Pr-map : ∀ {c a b} {A : Set a} {B : Set b} {Alg : ↺ c A} {x pr} {f : A → B} →
  (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) →
  Pr[ Alg ≡ x ]≡ pr →
  Pr[ ⟪ f · Alg ⟫ ≡ f x ]≡ pr
Pr-map f-inj (Pr-return (Pr-≡ refl)) = Pr-return (Pr-≡ refl)
Pr-map f-inj (Pr-return (Pr-≢ x≢y)) = Pr-return (Pr-≢ (x≢y ∘ f-inj))
Pr-map f-inj (Pr-fork eq pf₀ pf₁) = Pr-fork eq (Pr-map f-inj pf₀) (Pr-map f-inj pf₁)

Pr-same : ∀ {c a} {A : Set a} {Alg : ↺ c A} {x pr₀ pr₁} →
    pr₀ ≡ pr₁ →
    Pr[ Alg ≡ x ]≡ pr₀ →
    Pr[ Alg ≡ x ]≡ pr₁
Pr-same refl = id

Pr-weaken≤ : ∀ {c₀ c₁ a} {A : Set a} {Alg : ↺ c₀ A} {x pr} →
    (c₀≤c₁ : c₀ ≤ c₁) →
    Pr[ Alg ≡ x ]≡ pr →
    Pr[ weaken≤ c₀≤c₁ Alg ≡ x ]≡ pr
Pr-weaken≤ p (Pr-return pf) = Pr-return pf
Pr-weaken≤ (s≤s c₀≤c₁) (Pr-fork eq pf₀ pf₁)
  = Pr-fork eq (Pr-weaken≤ c₀≤c₁ pf₀) (Pr-weaken≤ c₀≤c₁ pf₁)

Pr-weaken+ : ∀ {c₀} c₁ {a} {A : Set a} {Alg : ↺ c₀ A} {x pr} →
    Pr[ Alg ≡ x ]≡ pr →
    Pr[ weaken+ c₁ Alg ≡ x ]≡ pr
Pr-weaken+ c₁ = Pr-weaken≤ (m≤n+m _ c₁)

Pr-map-0 : ∀ {c a b} {A : Set a} {B : Set b} {Alg : ↺ c A} {f : A → B} {x} → (∀ y → f y ≢ x)
           → Pr[ map↺ f Alg ≡ x ]≡ 0/1
Pr-map-0 {Alg = leaf x} f-prop = Pr-return (Pr-≢ (f-prop x))
Pr-map-0 {Alg = fork Alg Alg₁} f-prop = Pr-fork (trans (0/2+p/2≡p/2 0/1) 0/2≡0)
                                                (Pr-map-0 f-prop) (Pr-map-0 f-prop)

Pr-zip : ∀ {c₀ c₁ a b} {A : Set a} {B : Set b} {Alg₀ : ↺ c₀ A} {Alg₁ : ↺ c₁ B} {x y pr₁ pr₂} →
  Pr[ Alg₀ ≡ x ]≡ pr₁ →
  Pr[ Alg₁ ≡ y ]≡ pr₂ →
  Pr[ zip↺ Alg₀ Alg₁ ≡ (x , y) ]≡ (pr₁ */ pr₂)
Pr-zip {c₀} {pr₂ = pr₂} (Pr-return {x = x} (Pr-≡ refl)) pf₂
  rewrite 1*q≡q pr₂ = Pr-weaken+ c₀ (Pr-map {f = _,_ x} (cong proj₂) pf₂)
Pr-zip {c₀} {pr₂ = pr₂} (Pr-return {x = x} (Pr-≢ pf)) pf₂
  rewrite 0*q≡q pr₂ = Pr-weaken+ c₀ (Pr-map-0 (λ y x₁ → pf (cong proj₁ x₁)))
Pr-zip (Pr-fork refl pf₁ pf₂) pf₃ = Pr-fork (distr-*-/2+/2 _ _ _) (Pr-zip pf₁ pf₃) (Pr-zip pf₂ pf₃)

ex₂ : ∀ x y → Pr[ toss ⟨,⟩ toss ≡ (x , y) ]≡ 1/4
ex₂ x y = Pr-same (trans (distr-/2-* _ _) (cong (_/2 ∘ _/2) (1*q≡q _)))
                  (Pr-zip {Alg₀ = toss} {Alg₁ = toss} (ex₁ x) (ex₁ y))

postulate
  ex₃ : ∀ {n} (x : Bits n) → Pr[ random ≡ x ]≡ 1/2^ n


Reemphasize the importance of "import Everything".

Old-commit-hash: d6200d73c289f7ab4460589159b8380be47e083b

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda, the Agda standard library (version 0.7), generate Everything.agda
-- with the attached Haskell helper, and finally run Agda on this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- We use Agda HEAD from September 2013; Agda 2.3.2.1 might happen to work, but
-- has some bugs with serialization of code using some recent syntactic sugar
-- which we use (https://code.google.com/p/agda/issues/detail?id=756), so it
-- might work or not. When it does not, removing Agda caches (.agdai files)
-- appears to often help. You can use "find . -name '*.agdai' | xargs rm" to do
-- that.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- (This import is also important to ensure that if we typecheck
-- README.agda, we also typecheck every other file of our
-- formalization).

-- THE AGDA CODE
-- =============

import Postulate.Extensionality

import Base.Data.DependentList

-- Variables and contexts
import Base.Syntax.Context

-- Sets of variables
import Base.Syntax.Vars

import Base.Denotation.Notation

-- Environments
import Base.Denotation.Environment

-- Change contexts
import Base.Change.Context

-- # Base, parametric proof.
--
-- This is for a parametric calculus where:
-- types are parametric in base types
-- terms are parametric in constants
--
--
-- Modules are ordered and grouped according to what they represent.

-- ## Definitions

import Parametric.Syntax.Type
import Parametric.Syntax.Term

import Parametric.Denotation.Value
import Parametric.Denotation.Evaluation

import Parametric.Change.Type
import Parametric.Change.Term

import Parametric.Change.Derive

import Parametric.Change.Value
import Parametric.Change.Evaluation

-- ## Proofs

import Parametric.Change.Validity
import Parametric.Change.Specification
import Parametric.Change.Implementation
import Parametric.Change.Correctness

-- # Nehemiah plugin
--
-- The structure is the same as the parametric proof (down to the
-- order and the grouping of modules), except for the postulate module.

-- Postulate an abstract data type for integer Bags.
import Postulate.Bag-Nehemiah

-- ## Definitions
import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation

import Nehemiah.Change.Term
import Nehemiah.Change.Type

import Nehemiah.Change.Derive

import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- ## Proofs

import Nehemiah.Change.Validity
import Nehemiah.Change.Specification
import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda, the Agda standard library (version 0.7), generate Everything.agda
-- with the attached Haskell helper, and finally run Agda on this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- We use Agda HEAD from September 2013; Agda 2.3.2.1 might happen to work, but
-- has some bugs with serialization of code using some recent syntactic sugar
-- which we use (https://code.google.com/p/agda/issues/detail?id=756), so it
-- might work or not. When it does not, removing Agda caches (.agdai files)
-- appears to often help. You can use "find . -name '*.agdai' | xargs rm" to do
-- that.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- THE AGDA CODE
-- =============

import Postulate.Extensionality

import Base.Data.DependentList

-- Variables and contexts
import Base.Syntax.Context

-- Sets of variables
import Base.Syntax.Vars

import Base.Denotation.Notation

-- Environments
import Base.Denotation.Environment

-- Change contexts
import Base.Change.Context

-- # Base, parametric proof.
--
-- This is for a parametric calculus where:
-- types are parametric in base types
-- terms are parametric in constants
--
--
-- Modules are ordered and grouped according to what they represent.

-- ## Definitions

import Parametric.Syntax.Type
import Parametric.Syntax.Term

import Parametric.Denotation.Value
import Parametric.Denotation.Evaluation

import Parametric.Change.Type
import Parametric.Change.Term

import Parametric.Change.Derive

import Parametric.Change.Value
import Parametric.Change.Evaluation

-- ## Proofs

import Parametric.Change.Validity
import Parametric.Change.Specification
import Parametric.Change.Implementation
import Parametric.Change.Correctness

-- # Nehemiah plugin
--
-- The structure is the same as the parametric proof (down to the
-- order and the grouping of modules), except for the postulate module.

-- Postulate an abstract data type for integer Bags.
import Postulate.Bag-Nehemiah

-- ## Definitions
import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation

import Nehemiah.Change.Term
import Nehemiah.Change.Type

import Nehemiah.Change.Derive

import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- ## Proofs

import Nehemiah.Change.Validity
import Nehemiah.Change.Specification
import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness


ToNat: + ≤-⊔

ToNat: + ≤-⊔

import Data.Nat.NP as ℕ
open ℕ using (ℕ; zero; suc; module ℕ≤)
open import Data.Bool
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum renaming (map to ⊎-map)
open import Function
open import Relation.Binary
open import Algebra.FunctionProperties
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Relation.Binary.ToNat {a} {A : Set a} (f : A → ℕ) (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) where

_<=_ : A → A → Bool
_<=_ = ℕ._<=_ on f

_≤_ : A → A → Set
x ≤ y = T (x <= y)

_⊓_ : A → A → A
x ⊓ y = if x <= y then x else y

_⊔_ : A → A → A
x ⊔ y = if x <= y then y else x

isPreorder : IsPreorder _≡_ _≤_
isPreorder = record { isEquivalence = ≡.isEquivalence
                    ; reflexive = reflexive
                    ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
  where open ℕ.<=
        reflexive : ∀ {i j} → i ≡ j → i ≤ j
        reflexive {i} ≡.refl = complete (ℕ≤.refl {f i})
        trans : Transitive _≤_
        trans {x} {y} {z} p q = complete (ℕ≤.trans (sound (f x) (f y) p) (sound (f y) (f z) q))

isPartialOrder : IsPartialOrder _≡_ _≤_
isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }
  where open ℕ.<= using (sound)
        antisym : Antisymmetric _≡_ _≤_
        antisym {x} {y} p q = f-inj (ℕ≤.antisym (sound (f x) (f y) p) (sound (f y) (f x) q))

isTotalOrder : IsTotalOrder _≡_ _≤_
isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total (f x) (f y)) }
  where open ℕ.<= using (complete)

open IsTotalOrder isTotalOrder

⊔-spec : ∀ {x y} → x ≤ y → x ⊔ y ≡ y
⊔-spec {x} {y} p with x <= y
⊔-spec _    | true = ≡.refl
⊔-spec ()   | false

⊓-spec : ∀ {x y} → x ≤ y → x ⊓ y ≡ x
⊓-spec {x} {y} p with x <= y
⊓-spec _    | true = ≡.refl
⊓-spec ()   | false

⊓-comm : Commutative _≡_ _⊓_
⊓-comm x y with x <= y | y <= x | antisym {x} {y} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊔-comm : Commutative _≡_ _⊔_
⊔-comm x y with x <= y | y <= x | antisym {y} {x} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊓-≤ : ∀ x y → (x ⊓ y) ≤ y
⊓-≤ x y with total x y
⊓-≤ x y | inj₁ p rewrite ⊓-spec p = p
⊓-≤ x y | inj₂ p rewrite ⊓-comm x y | ⊓-spec p = refl

≤-⊔ : ∀ x y → x ≤ (y ⊔ x)
≤-⊔ x y with total x y
≤-⊔ x y | inj₁ p rewrite ⊔-comm y x | ⊔-spec p = p
≤-⊔ x y | inj₂ p rewrite ⊔-spec p = refl

≤-<_,_> : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ⊓ z)
≤-<_,_> {x} {y} {z} x≤y y≤z with total y z
... | inj₁ p rewrite ⊓-spec p = x≤y
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = y≤z

≤-[_,_] : ∀ {x y z} → x ≤ z → y ≤ z → (x ⊔ y) ≤ z
≤-[_,_] {x} {y} {z} x≤z y≤z with total x y
... | inj₁ p rewrite ⊔-spec p = y≤z
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = x≤z

≤-⊓₀ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ y
≤-⊓₀ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = id
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = flip trans p

≤-⊓₁ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ z
≤-⊓₁ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = flip trans p
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = id

≤-⊔₀ : ∀ {x y z} → (x ⊔ y) ≤ z → x ≤ z
≤-⊔₀ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = trans p
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = id

≤-⊔₁ : ∀ {x y z} → (x ⊔ y) ≤ z → y ≤ z
≤-⊔₁ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = id
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = trans p

import Data.Nat.NP as ℕ
open ℕ using (ℕ; zero; suc; module ℕ≤)
open import Data.Bool
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum renaming (map to ⊎-map)
open import Function
open import Relation.Binary
open import Algebra.FunctionProperties
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)

module Relation.Binary.ToNat {a} {A : Set a} (f : A → ℕ) (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) where

_<=_ : A → A → Bool
_<=_ = ℕ._<=_ on f

_≤_ : A → A → Set
x ≤ y = T (x <= y)

_⊓_ : A → A → A
x ⊓ y = if x <= y then x else y

_⊔_ : A → A → A
x ⊔ y = if x <= y then y else x

isPreorder : IsPreorder _≡_ _≤_
isPreorder = record { isEquivalence = ≡.isEquivalence
                    ; reflexive = reflexive
                    ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
  where open ℕ.<=
        reflexive : ∀ {i j} → i ≡ j → i ≤ j
        reflexive {i} ≡.refl = complete (ℕ≤.refl {f i})
        trans : Transitive _≤_
        trans {x} {y} {z} p q = complete (ℕ≤.trans (sound (f x) (f y) p) (sound (f y) (f z) q))

isPartialOrder : IsPartialOrder _≡_ _≤_
isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }
  where open ℕ.<= using (sound)
        antisym : Antisymmetric _≡_ _≤_
        antisym {x} {y} p q = f-inj (ℕ≤.antisym (sound (f x) (f y) p) (sound (f y) (f x) q))

isTotalOrder : IsTotalOrder _≡_ _≤_
isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total (f x) (f y)) }
  where open ℕ.<= using (complete)

open IsTotalOrder isTotalOrder

⊔-spec : ∀ {x y} → x ≤ y → x ⊔ y ≡ y
⊔-spec {x} {y} p with x <= y
⊔-spec _    | true = ≡.refl
⊔-spec ()   | false

⊓-spec : ∀ {x y} → x ≤ y → x ⊓ y ≡ x
⊓-spec {x} {y} p with x <= y
⊓-spec _    | true = ≡.refl
⊓-spec ()   | false

⊓-comm : Commutative _≡_ _⊓_
⊓-comm x y with x <= y | y <= x | antisym {x} {y} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊔-comm : Commutative _≡_ _⊔_
⊔-comm x y with x <= y | y <= x | antisym {y} {x} | total x y
... | true | true   | p | _ = p _ _
... | true | false  | _ | _ = ≡.refl
... | false | true  | _ | _ = ≡.refl
... | false | false | _ | p = ⊥-elim ([ id , id ] p)

⊓-≤ : ∀ x y → (x ⊓ y) ≤ y
⊓-≤ x y with total x y
⊓-≤ x y | inj₁ p rewrite ⊓-spec p = p
⊓-≤ x y | inj₂ p rewrite ⊓-comm x y | ⊓-spec p = refl

≤-<_,_> : ∀ {x y z} → x ≤ y → x ≤ z → x ≤ (y ⊓ z)
≤-<_,_> {x} {y} {z} x≤y y≤z with total y z
... | inj₁ p rewrite ⊓-spec p = x≤y
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = y≤z

≤-[_,_] : ∀ {x y z} → x ≤ z → y ≤ z → (x ⊔ y) ≤ z
≤-[_,_] {x} {y} {z} x≤z y≤z with total x y
... | inj₁ p rewrite ⊔-spec p = y≤z
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = x≤z

≤-⊓₀ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ y
≤-⊓₀ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = id
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = flip trans p

≤-⊓₁ : ∀ {x y z} → x ≤ (y ⊓ z) → x ≤ z
≤-⊓₁ {x} {y} {z} with total y z
... | inj₁ p rewrite ⊓-spec p = flip trans p
... | inj₂ p rewrite ⊓-comm y z | ⊓-spec p = id

≤-⊔₀ : ∀ {x y z} → (x ⊔ y) ≤ z → x ≤ z
≤-⊔₀ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = trans p
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = id

≤-⊔₁ : ∀ {x y z} → (x ⊔ y) ≤ z → y ≤ z
≤-⊔₁ {x} {y} {z} with total x y
... | inj₁ p rewrite ⊔-spec p = id
... | inj₂ p rewrite ⊔-comm x y | ⊔-spec p = trans p


Desc model: implicit box

Desc model: implicit box


Removed general hints.

Removed general hints.

Ignore-this: 2f7102a575b4c2fdb80e99fde9cc97f0

darcs-hash:20100710142946-3bd4e-567a84c7ee48f426f69c53a0b41c8fb40007e53b.gz

------------------------------------------------------------------------------
-- The booleans properties
------------------------------------------------------------------------------

module LTC.Data.Bool.Properties where

open import LTC.Minimal
open import LTC.Data.Bool
open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.Properties using ( ≤-SS ; S≰0 )

------------------------------------------------------------------------------
-- Basic properties.

&&-Bool : {b₁ b₂ : D} → Bool b₁ → Bool b₂ → Bool (b₁ && b₂)
&&-Bool tB tB = prf
  where
    postulate prf : Bool (true && true)
    {-# ATP prove prf #-}
&&-Bool tB fB = prf
  where
    postulate prf : Bool (true && false)
    {-# ATP prove prf #-}
&&-Bool fB tB = prf
  where
    postulate prf : Bool (false && true)
    {-# ATP prove prf #-}
&&-Bool fB fB = prf
  where
    postulate prf : Bool (false && false)
    {-# ATP prove prf #-}

x&&y≡true→x≡true : {b₁ b₂ : D} → Bool b₁ → Bool b₂ → b₁ && b₂ ≡ true →
                   b₁ ≡ true
x&&y≡true→x≡true tB _ _    = refl
x&&y≡true→x≡true fB tB prf = ⊥-elim (true≠false (trans (sym prf) &&-ft))
x&&y≡true→x≡true fB fB prf = ⊥-elim (true≠false (trans (sym prf) &&-ff))

x&&y≡true→y≡true : {b₁ b₂ : D} → Bool b₁ → Bool b₂ → b₁ && b₂ ≡ true →
                   b₂ ≡ true
x&&y≡true→y≡true _  tB _   = refl
x&&y≡true→y≡true tB fB prf = ⊥-elim (true≠false (trans (sym prf) &&-tf))
x&&y≡true→y≡true fB fB prf = ⊥-elim (true≠false (trans (sym prf) &&-ff))

------------------------------------------------------------------------------
-- Properties with inequalities

≤-Bool : {m n : D} → N m → N n → Bool (m ≤ n)
≤-Bool {n = n} zN Nn = prf
  where
    postulate prf : Bool (zero ≤ n)
    {-# ATP prove prf #-}
≤-Bool (sN {m} Nm) zN = prf
  where
    postulate prf : Bool (succ m ≤ zero)
    {-# ATP prove prf S≰0 #-}
≤-Bool (sN {m} Nm) (sN {n} Nn) = prf (≤-Bool Nm Nn)
  where
    postulate prf : Bool (m ≤ n) → Bool (succ m ≤ succ n)
    {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- The booleans properties
------------------------------------------------------------------------------

module LTC.Data.Bool.Properties where

open import LTC.Minimal
open import LTC.Data.Bool
open import LTC.Data.Nat
open import LTC.Data.Nat.Inequalities
open import LTC.Data.Nat.Inequalities.Properties using ( ≤-SS ; S≰0 )

------------------------------------------------------------------------------
-- Basic properties.

-- This function is a general hint.
&&-Bool : {b₁ b₂ : D} → Bool b₁ → Bool b₂ → Bool (b₁ && b₂)
&&-Bool tB tB = prf
  where
    postulate prf : Bool (true && true)
    {-# ATP prove prf #-}
&&-Bool tB fB = prf
  where
    postulate prf : Bool (true && false)
    {-# ATP prove prf #-}
&&-Bool fB tB = prf
  where
    postulate prf : Bool (false && true)
    {-# ATP prove prf #-}
&&-Bool fB fB = prf
  where
    postulate prf : Bool (false && false)
    {-# ATP prove prf #-}
{-# ATP hint &&-Bool #-}

x&&y≡true→x≡true : {b₁ b₂ : D} → Bool b₁ → Bool b₂ → b₁ && b₂ ≡ true →
                   b₁ ≡ true
x&&y≡true→x≡true tB _ _    = refl
x&&y≡true→x≡true fB tB prf = ⊥-elim (true≠false (trans (sym prf) &&-ft))
x&&y≡true→x≡true fB fB prf = ⊥-elim (true≠false (trans (sym prf) &&-ff))

x&&y≡true→y≡true : {b₁ b₂ : D} → Bool b₁ → Bool b₂ → b₁ && b₂ ≡ true →
                   b₂ ≡ true
x&&y≡true→y≡true _  tB _   = refl
x&&y≡true→y≡true tB fB prf = ⊥-elim (true≠false (trans (sym prf) &&-tf))
x&&y≡true→y≡true fB fB prf = ⊥-elim (true≠false (trans (sym prf) &&-ff))

------------------------------------------------------------------------------
-- Properties with inequalities

-- This function is a general hint.
≤-Bool : {m n : D} → N m → N n → Bool (m ≤ n)
≤-Bool {n = n} zN Nn = prf
  where
    postulate prf : Bool (zero ≤ n)
    {-# ATP prove prf #-}
≤-Bool (sN {m} Nm) zN = prf
  where
    postulate prf : Bool (succ m ≤ zero)
    {-# ATP prove prf S≰0 #-}
≤-Bool (sN {m} Nm) (sN {n} Nn) = prf (≤-Bool Nm Nn)
  where
    postulate prf : Bool (m ≤ n) → Bool (succ m ≤ succ n)
    {-# ATP prove prf #-}
{-# ATP hint ≤-Bool #-}


Modified a test.

Modified a test.

Ignore-this: e571f29238bfd5b15fa8eb93e8a0edc4

darcs-hash:20100803142440-3bd4e-1d6f95a0094c35a9ec7f3ad30fa19b594c8fe390.gz

module Test.Succeed.DefinitionsInsideWhereClauses where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_  : D → D → D
  +-0x : (d : D) → zero + d     ≡ d
  +-Sx : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

+-rightIdentity : {n : D} → N n → n + zero ≡ n
+-rightIdentity {n} Nn = indN P P0 iStep Nn
  where
    P : D → Set
    P i = i + zero ≡ i
    {-# ATP definition P #-}

    postulate
      P0 : P zero
    {-# ATP prove P0 #-}

    postulate
      iStep : {i : D} → N i → P i → P (succ i)
    {-# ATP prove iStep #-}

module Test.Succeed.DefinitionsInsideWhereClauses where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_  : D → D → D
  +-0x : (d : D) → zero + d     ≡ d
  +-Sx : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

+-rightIdentity : {n : D} → N n → n + zero ≡ n
+-rightIdentity {n} Nn = indN Q Q0 iStep Nn
  where
    Q : D → Set
    Q i = i + zero ≡ i
    {-# ATP definition Q #-}

    postulate
      Q0 : Q zero
    {-# ATP prove Q0 #-}

    postulate
      iStep : {i : D} → N i → Q i → Q (succ i)
    {-# ATP prove iStep #-}


Avoid const in favor of lift-η-const.

Avoid const in favor of lift-η-const.

This commit prepares for changing the type of const.

Old-commit-hash: d7ebdbeb22d70fa60c6ce08ebf4832f56797b59a

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

open import Syntax.Type.Plotkin Atlas-type

data Atlas-const : Type → Set where
  true  : Atlas-const
    (base Bool)

  false : Atlas-const
    (base Bool)

  xor   : Atlas-const
    (base Bool ⇒ base Bool ⇒ base Bool)

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
    (base (Map κ ι))

  -- `update key val my-map` would
  -- - insert if `key` is not present in `my-map`
  -- - delete if `val` is the neutral element
  -- - make an update otherwise

  update : ∀ {κ ι : Atlas-type} → Atlas-const
    (base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι))

  lookup : ∀ {κ ι : Atlas-type} → Atlas-const
    (base κ ⇒ base (Map κ ι) ⇒ base ι)

  -- Model of zip = Haskell Data.List.zipWith
  --
  -- zipWith :: (a → b → c) → [a] → [b] → [c]
  --
  -- Behavioral difference: all key-value pairs present
  -- in *either* (m₁ : Map κ a) *or* (m₂ : Map κ b) will
  -- be iterated over. Neutral element of type `a` or `b`
  -- will be supplied if the key is missing in the
  -- corresponding map.

  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const
    ((base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
     base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c))

  -- Model of fold = Haskell Data.Map.foldWithKey
  --
  -- foldWithKey :: (k → a → b → b) → b → Map k a → b

  fold   : ∀ {κ a b : Atlas-type} → Atlas-const
   ((base κ ⇒ base a ⇒ base b ⇒ base b) ⇒
    base b ⇒ base (Map κ a) ⇒ base b)

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type → Type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

open import Syntax.Context {Type}
open import Syntax.Term.Plotkin {Atlas-type} {Atlas-const}

-- Shorthands of constants
true! : ∀ {Γ} →
  Term Γ (base Bool)
true! = lift-η-const true

false! : ∀ {Γ} →
  Term Γ (base Bool)
false! = lift-η-const false

xor! : ∀ {Γ} →
  Term Γ (base Bool) → Term Γ (base Bool) →
  Term Γ (base Bool)
xor! = lift-η-const xor

empty! : ∀ {κ ι Γ} →
  Term Γ (base (Map κ ι))
empty! = lift-η-const empty

update! : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (base (Map κ ι)) →
  Term Γ (base (Map κ ι))
update! = lift-η-const update

lookup! : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base (Map κ ι)) →
  Term Γ (base ι)
lookup! = lift-η-const lookup

zip! : ∀ {κ a b c Γ} →
  Term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Term Γ (base (Map κ a)) → Term Γ (base (Map κ b)) →
  Term Γ (base (Map κ c))
zip! = lift-η-const zip

fold! : ∀ {κ a b Γ} →
  Term Γ (base κ ⇒ base a ⇒ base b ⇒ base b) →
  Term Γ (base b) → Term Γ (base (Map κ a)) →
  Term Γ (base b)
fold! = lift-η-const fold

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const (base ι)
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Term Γ (base ι)
neutral-term {Bool}   = lift-η-const (neutral {Bool})
neutral-term {Map κ ι} = lift-η-const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const (base (Atlas-Δbase ι))
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = lift-η-const (nil-const {Bool})
nil-term {Map κ ι} = lift-η-const (nil-const {Map κ ι})

-- Nonfunctional products can be encoded.
-- The incremental behavior of products thus encoded is weird:
-- Δ(α × β) = α × Δβ
Pair : Atlas-type → Atlas-type → Atlas-type
Pair α β = Map α β

pair : ∀ {α β Γ} →
  Term Γ (base α) → Term Γ (base β) →
  Term Γ (base (Pair α β))
pair s t = update! s t empty!

pair-term : ∀ {α β Γ} →
  Term Γ (base α ⇒ base β ⇒ base (Pair α β))
pair-term = abs (abs (pair (var (that this)) (var this)))

uncurry : ∀ {α β γ Γ} →
  Term Γ (base α ⇒ base β ⇒ base γ) →
  Term Γ (base (Pair α β)) →
  Term Γ (base γ)
uncurry f p =
  let
    a = var (that (that this))
    b = var (that this)
    g = abs (abs (abs (app₂ (weaken₃ f) a b)))
  in
    fold! g neutral-term p

zip-pair : ∀ {κ a b Γ} →
  Term Γ (base (Map κ a)) → Term Γ (base (Map κ b)) →
  Term Γ (base (Map κ (Pair a b)))
zip-pair = zip! (abs pair-term)

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = abs (abs (lift-η-const xor (var (that this)) (var this)))
Atlas-diff {Map κ ι} = abs (abs (lift-η-const zip (abs Atlas-diff) (var (that this)) (var this)))

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs (abs (lift-η-const xor (var (that this)) (var this)))
Atlas-apply {Map κ ι} = abs (abs (lift-η-const zip (abs Atlas-apply) (var (that this)) (var this)))

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (Atlas-Δtype τ)
diff = app₂ (lift-diff Atlas-diff Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (Atlas-Δtype τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply Atlas-diff Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (Atlas-Δtype (base (Map κ ι))) →
  Term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (Atlas-Δtype (base (Map κ ι))) →
  Term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Term Γ (base ι)
  in
    Term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

-- zip₄ f m₁ m₂ m₃ m₄ =
-- zip (λ k p₁₂ p₃₄ → uncurry (λ v₁ v₂ → uncurry (λ v₃ v₄ →
--       f k v₁ v₂ v₃ v₄)
--       p₃₄) p₁₂)
--     (zip-pair m₁ m₂) (zip-pair m₃ m₄)

zip4! f m₁ m₂ m₃ m₄ =
  let
    f′ = weaken₃ (weaken₃ (weaken₁ f))
    k = var (that (that (that (that (that (that this))))))
    p₁₂ = var (that this)
    p₃₄ = var (that (that this))
    v₁ = var (that (that (that this)))
    v₂ = var (that (that this))
    v₃ = var (that this)
    v₄ = var this
    g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
        (app₅ f′ k v₁ v₂ v₃ v₄)))
        p₃₄))) p₁₂)))
  in
    zip! g (zip-pair m₁ m₂) (zip-pair m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ τ} → (c : Atlas-const τ) →
  Term Γ (Atlas-Δtype τ)

Atlas-Δconst true  = false!
Atlas-Δconst false = false!

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (xor! Δx Δy))))

Atlas-Δconst empty = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
Atlas-Δconst lookup =
  let
    k  = var (that (that (that this)))
    Δk = var (that (that this))
    m  = var (that this)
    Δm = var this
    k′ = apply Δk k
  in
    abs (abs (abs (abs
      (diff (apply (lookup! k′ Δm) (lookup! k′ m))
            (lookup! k m)))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app₂ (weaken₁ Δf) (var this) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

-- Δfold f Δf z Δz m Δm = proj₂
--   (fold (λ k [a,Δa] [b,Δb] →
--           uncurry (λ a Δa → uncurry (λ b Δb →
--             pair (f k a b) (Δf k nil a Δa b Δb))
--             [b,Δb]) [a,Δa])
--        (pair z Δz)
--        (zip-pair m Δm))
--
-- Δfold is efficient only if evaluation is lazy and Δf is
-- self-maintainable: it doesn't look at the argument
-- (b = fold f k a b₀) at all.
Atlas-Δconst (fold {κ} {α} {β}) =
    let -- TODO (tedius): write weaken₇
      f  = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that (that this))))))))
      Δf = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that this)))))))
      z  = var (that (that (that this)))
      Δz = var (that (that this))
      m  = var (that this)
      Δm = var this
      k = weaken₃ (weaken₁ (var (that (that this))))
      [a,Δa] = var (that this)
      [b,Δb] = var this
      a  = var (that (that (that this)))
      Δa = var (that (that this))
      b  = var (that this)
      Δb = var this
      g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
            (pair (app₃ f k a b)
                  (app₆ Δf k nil-term a Δa b Δb))))
            (weaken₂ [b,Δb])))) [a,Δa])))
      proj₂ = uncurry (abs (abs (var this)))
    in
      abs (abs (abs (abs (abs (abs
        (proj₂ (fold! g (pair z Δz) (zip-pair m Δm))))))))

open import Syntax.Language.Calculus

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-Δtype
  Atlas-Δconst

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

open import Syntax.Type.Plotkin Atlas-type

data Atlas-const : Type → Set where
  true  : Atlas-const
    (base Bool)

  false : Atlas-const
    (base Bool)

  xor   : Atlas-const
    (base Bool ⇒ base Bool ⇒ base Bool)

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
    (base (Map κ ι))

  -- `update key val my-map` would
  -- - insert if `key` is not present in `my-map`
  -- - delete if `val` is the neutral element
  -- - make an update otherwise

  update : ∀ {κ ι : Atlas-type} → Atlas-const
    (base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι))

  lookup : ∀ {κ ι : Atlas-type} → Atlas-const
    (base κ ⇒ base (Map κ ι) ⇒ base ι)

  -- Model of zip = Haskell Data.List.zipWith
  --
  -- zipWith :: (a → b → c) → [a] → [b] → [c]
  --
  -- Behavioral difference: all key-value pairs present
  -- in *either* (m₁ : Map κ a) *or* (m₂ : Map κ b) will
  -- be iterated over. Neutral element of type `a` or `b`
  -- will be supplied if the key is missing in the
  -- corresponding map.

  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const
    ((base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
     base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c))

  -- Model of fold = Haskell Data.Map.foldWithKey
  --
  -- foldWithKey :: (k → a → b → b) → b → Map k a → b

  fold   : ∀ {κ a b : Atlas-type} → Atlas-const
   ((base κ ⇒ base a ⇒ base b ⇒ base b) ⇒
    base b ⇒ base (Map κ a) ⇒ base b)

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type → Type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

open import Syntax.Context {Type}
open import Syntax.Term.Plotkin {Atlas-type} {Atlas-const}

-- Shorthands of constants
true! : ∀ {Γ} →
  Term Γ (base Bool)
true! = lift-η-const true

false! : ∀ {Γ} →
  Term Γ (base Bool)
false! = lift-η-const false

xor! : ∀ {Γ} →
  Term Γ (base Bool) → Term Γ (base Bool) →
  Term Γ (base Bool)
xor! = lift-η-const xor

empty! : ∀ {κ ι Γ} →
  Term Γ (base (Map κ ι))
empty! = lift-η-const empty

update! : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (base (Map κ ι)) →
  Term Γ (base (Map κ ι))
update! = lift-η-const update

lookup! : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base (Map κ ι)) →
  Term Γ (base ι)
lookup! = lift-η-const lookup

zip! : ∀ {κ a b c Γ} →
  Term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Term Γ (base (Map κ a)) → Term Γ (base (Map κ b)) →
  Term Γ (base (Map κ c))
zip! = lift-η-const zip

fold! : ∀ {κ a b Γ} →
  Term Γ (base κ ⇒ base a ⇒ base b ⇒ base b) →
  Term Γ (base b) → Term Γ (base (Map κ a)) →
  Term Γ (base b)
fold! = lift-η-const fold

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const (base ι)
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Term Γ (base ι)
neutral-term {Bool}   = const (neutral {Bool})
neutral-term {Map κ ι} = const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const (base (Atlas-Δbase ι))
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Nonfunctional products can be encoded.
-- The incremental behavior of products thus encoded is weird:
-- Δ(α × β) = α × Δβ
Pair : Atlas-type → Atlas-type → Atlas-type
Pair α β = Map α β

pair : ∀ {α β Γ} →
  Term Γ (base α) → Term Γ (base β) →
  Term Γ (base (Pair α β))
pair s t = update! s t empty!

pair-term : ∀ {α β Γ} →
  Term Γ (base α ⇒ base β ⇒ base (Pair α β))
pair-term = abs (abs (pair (var (that this)) (var this)))

uncurry : ∀ {α β γ Γ} →
  Term Γ (base α ⇒ base β ⇒ base γ) →
  Term Γ (base (Pair α β)) →
  Term Γ (base γ)
uncurry f p =
  let
    a = var (that (that this))
    b = var (that this)
    g = abs (abs (abs (app₂ (weaken₃ f) a b)))
  in
    fold! g neutral-term p

zip-pair : ∀ {κ a b Γ} →
  Term Γ (base (Map κ a)) → Term Γ (base (Map κ b)) →
  Term Γ (base (Map κ (Pair a b)))
zip-pair = zip! (abs pair-term)

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = const xor
Atlas-diff {Map κ ι} = app (const zip) (abs Atlas-diff)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = const xor
Atlas-apply {Map κ ι} = app (const zip) (abs Atlas-apply)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Term Γ τ → Term Γ τ →
  Term Γ (Atlas-Δtype τ)
diff = app₂ (lift-diff Atlas-diff Atlas-apply)

apply : ∀ {τ Γ} →
  Term Γ (Atlas-Δtype τ) → Term Γ τ →
  Term Γ τ
apply = app₂ (lift-apply Atlas-diff Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (Atlas-Δtype (base (Map κ ι))) →
  Term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (Atlas-Δtype (base (Map κ ι))) →
  Term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Term Γ (base ι)
  in
    Term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

-- zip₄ f m₁ m₂ m₃ m₄ =
-- zip (λ k p₁₂ p₃₄ → uncurry (λ v₁ v₂ → uncurry (λ v₃ v₄ →
--       f k v₁ v₂ v₃ v₄)
--       p₃₄) p₁₂)
--     (zip-pair m₁ m₂) (zip-pair m₃ m₄)

zip4! f m₁ m₂ m₃ m₄ =
  let
    f′ = weaken₃ (weaken₃ (weaken₁ f))
    k = var (that (that (that (that (that (that this))))))
    p₁₂ = var (that this)
    p₃₄ = var (that (that this))
    v₁ = var (that (that (that this)))
    v₂ = var (that (that this))
    v₃ = var (that this)
    v₄ = var this
    g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
        (app₅ f′ k v₁ v₂ v₃ v₄)))
        p₃₄))) p₁₂)))
  in
    zip! g (zip-pair m₁ m₂) (zip-pair m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ τ} → (c : Atlas-const τ) →
  Term Γ (Atlas-Δtype τ)

Atlas-Δconst true  = false!
Atlas-Δconst false = false!

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (xor! Δx Δy))))

Atlas-Δconst empty = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
Atlas-Δconst lookup =
  let
    k  = var (that (that (that this)))
    Δk = var (that (that this))
    m  = var (that this)
    Δm = var this
    k′ = apply Δk k
  in
    abs (abs (abs (abs
      (diff (apply (lookup! k′ Δm) (lookup! k′ m))
            (lookup! k m)))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app₂ (weaken₁ Δf) (var this) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

-- Δfold f Δf z Δz m Δm = proj₂
--   (fold (λ k [a,Δa] [b,Δb] →
--           uncurry (λ a Δa → uncurry (λ b Δb →
--             pair (f k a b) (Δf k nil a Δa b Δb))
--             [b,Δb]) [a,Δa])
--        (pair z Δz)
--        (zip-pair m Δm))
--
-- Δfold is efficient only if evaluation is lazy and Δf is
-- self-maintainable: it doesn't look at the argument
-- (b = fold f k a b₀) at all.
Atlas-Δconst (fold {κ} {α} {β}) =
    let -- TODO (tedius): write weaken₇
      f  = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that (that this))))))))
      Δf = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that this)))))))
      z  = var (that (that (that this)))
      Δz = var (that (that this))
      m  = var (that this)
      Δm = var this
      k = weaken₃ (weaken₁ (var (that (that this))))
      [a,Δa] = var (that this)
      [b,Δb] = var this
      a  = var (that (that (that this)))
      Δa = var (that (that this))
      b  = var (that this)
      Δb = var this
      g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
            (pair (app₃ f k a b)
                  (app₆ Δf k nil-term a Δa b Δb))))
            (weaken₂ [b,Δb])))) [a,Δa])))
      proj₂ = uncurry (abs (abs (var this)))
    in
      abs (abs (abs (abs (abs (abs
        (proj₂ (fold! g (pair z Δz) (zip-pair m Δm))))))))

open import Syntax.Language.Calculus

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-Δtype
  Atlas-Δconst


Add tagged descriptions to model.

Add tagged descriptions to model.

This lets elim just take a single "Desc" arg.

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

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

TagDesc : (I : Set) → Set
TagDesc I = Σ Enum (λ E → Cases E (λ _ → Desc I))

toCase : (I : Set) (E,cs : TagDesc I) → Tag (proj₁ E,cs) → Desc I
toCase I (E , cs) = case E (λ _ → Desc I) cs

toDesc : (I : Set) → TagDesc I → Desc I
toDesc I (E , cs) = `Arg (Tag E) (toCase I (E , cs))

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

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 → Set where
  con : UncurriedEl I D (μ I D)

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)
  (TD : TagDesc I)
  → let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
  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 UncurriedCases E Q X
elim I TD P cs i x =
  let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
    p = case E (λ t → CurriedAll I (Cs t) (μ I D) P (λ xs → con (t , xs))) cs
  in ind2 I D P p i x

elim2 :
  (I : Set)
  (TD : TagDesc I)
  → let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
  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 TD P =
  let
    D = toDesc I TD
    E = proj₁ TD
    Cs = toCase I TD
    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 TD 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" ∷ []

  ℕTD : TagDesc ⊤
  ℕTD = ℕT
    , `End tt
    , `Rec tt (`End tt)
    , tt

  ℕC : Tag ℕT → Desc ⊤
  ℕC = toCase ⊤ ℕTD

  ℕD : Desc ⊤
  ℕD = toDesc ⊤ ℕTD

  ℕ : ⊤ → 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)

  VecTD : (A : Set) → TagDesc (ℕ tt)
  VecTD A = VecT
    , `End zero
    , `Arg (ℕ tt) (λ n → `Arg A λ _ → `Rec n (`End (suc n)))
    , tt

  VecC : (A : Set) → Tag VecT → Desc (ℕ tt)
  VecC A = toCase (ℕ tt) (VecTD A)

  VecD : (A : Set) → Desc (ℕ tt)
  VecD A = toDesc (ℕ tt) (VecTD 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 ⊤ ℕTD _
      (λ n → n)
      (λ m ih n → suc (ih n))
      tt

    mult : ℕ tt → ℕ tt → ℕ tt
    mult = elim2 ⊤ ℕTD _
      (λ 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) (VecTD 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) (VecTD (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

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 → Set where
  con : UncurriedEl I D (μ I D)

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)

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