Add back generic eliminators in Darkwing, now improved with generic motives.

{-# 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
open import Function
module Spire.Examples.DarkwingDuck where

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

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)

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

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Tel : Set where
  End : Tel
  Arg : (A : Set) (B : A → Tel) → Tel

Elᵀ  : Tel → Set
Elᵀ End = ⊤
Elᵀ (Arg A B) = Σ A (λ a → Elᵀ (B a))

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

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

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

ISet : Set → Set
ISet I = I → Set

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

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : Elᴰ D X i) → Set
Hyps (End j) X P i q = ⊤
Hyps (Rec j D) X P i (x , xs) = P j x × Hyps D X P i xs
Hyps (Arg A B) X P i (a , b) = Hyps (B a) X P i b

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

data μ {I : Set} (D : Desc I) (i : I) : Set where
  init : Elᴰ D (μ D) i → μ D i

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

ind : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (α : ∀ i (xs : Elᴰ D (μ D) i) (ihs : Hyps D (μ D) M i xs) → M i (init xs))
  (i : I)
  (x : μ D i)
  → M i x

prove : {I : Set} (D E : Desc I)
  (M : (i : I) → μ E i → Set)
  (α : ∀ i (xs : Elᴰ E (μ E) i) (ihs : Hyps E (μ E) M i xs) → M i (init xs))
  (i : I) (xs : Elᴰ D (μ E) i) → Hyps D (μ E) M i xs

ind D M α i (init xs) = α i xs (prove D D M α i xs)

prove (End j) E M α i q = tt
prove (Rec j D) E M α i (x , xs) = ind E M α j x , prove D E M α i xs
prove (Arg A B) E M α i (a , xs) = prove (B a) E M α i xs

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

record Data : Set where
  field
    P : Tel
    I : Elᵀ P → Tel
    E : Enum
    B : (A : Elᵀ P) → Branches E (λ _ → Desc (Elᵀ (I A)))

  C : (A : Elᵀ P) → Tag E → Desc (Elᵀ (I A))
  C A = case (λ _ → Desc (Elᵀ (I A))) (B A)

  D : (A : Elᵀ P) → Desc (Elᵀ (I A))
  D A = Arg (Tag E) (C A)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

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

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

UncurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
UncurriedElᵀ T X = (xs : Elᵀ T) → X xs

CurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
CurriedElᵀ End X = X tt
CurriedElᵀ (Arg A B) X = (a : A) → CurriedElᵀ (B a) (λ b → X (a , b))

curryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → CurriedElᵀ T X
curryElᵀ End X f = f tt
curryElᵀ (Arg A B) X f = λ a → curryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

uncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → CurriedElᵀ T X → UncurriedElᵀ T X
uncurryElᵀ End X x tt = x
uncurryElᵀ (Arg A B) X f (a , b) = uncurryElᵀ (B a) (λ b → X (a , b)) (f a) b

ICurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
ICurriedElᵀ End X = X tt
ICurriedElᵀ (Arg A B) X = {a : A} → ICurriedElᵀ (B a) (λ b → X (a , b))

icurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → ICurriedElᵀ T X
icurryElᵀ End X f = f tt
icurryElᵀ (Arg A B) X f = λ {a} → icurryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

iuncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → ICurriedElᵀ T X → UncurriedElᵀ T X
iuncurryElᵀ End X x tt = x
iuncurryElᵀ (Arg A B) X f (a , b) = iuncurryElᵀ (B a) (λ b → X (a , b)) f b

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

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

CurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedElᴰ (End i) X = X i
CurriedElᴰ (Rec i D) X = (x : X i) → CurriedElᴰ D X
CurriedElᴰ (Arg A B) X = (a : A) → CurriedElᴰ (B a) X

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

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : Elᴰ D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
CurriedHyps (End i) X P cn =
  P i (cn refl)
CurriedHyps (Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps D X P (λ xs → cn (x , xs))
CurriedHyps (Arg A B) X P cn =
  (a : A) → CurriedHyps (B a) X P (λ xs → cn (a , xs))

curryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → UncurriedHyps D X P cn
  → CurriedHyps D X P cn
curryHyps (End i) X P cn pf =
  pf i refl tt
curryHyps (Rec i D) X P cn pf =
  λ x ih → curryHyps D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps (Arg A B) X P cn pf =
  λ a → curryHyps (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps (End .i) X P cn pf i refl tt =
  pf
uncurryHyps (Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps (Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs

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

FormUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → UncurriedElᵀ (Data.I R p) λ i
  → Set
FormUncurried R p i = μ (Data.D R p) i

Form : (R : Data)
  → CurriedElᵀ (Data.P R) λ p
  → CurriedElᵀ (Data.I R p) λ i
  → Set
Form R =
  curryElᵀ (Data.P R) (λ p → CurriedElᵀ (Data.I R p) λ i → Set) λ p →
  curryElᵀ (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
injUncurried R p t = curryElᴰ (Data.C R p t)
  (μ (Data.D R p))
  (λ xs → init (t , xs))

inj : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
inj R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in CurriedElᴰ D (μ D))
  (injUncurried R)

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

indCurried : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (f : CurriedHyps D (μ D) M init)
  (i : I)
  (x : μ D i)
  → M i x
indCurried D M f i x =
  ind D M (uncurryHyps D (μ D) M init f) i x

SumCurriedHyps : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : ∀ i → μ D i → Set)
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  CurriedHyps (Data.C R p t) (μ (Data.D R p)) M (λ xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : UncurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → UncurriedBranches (Data.E R)
    (SumCurriedHyps R p M)
    (∀ i (x : μ D i) → M i x)
elimUncurried R p M cs i x =
  indCurried (Data.D R p) M
    (case (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
  → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
  in CurriedBranches (Data.E R)
     (SumCurriedHyps R p unM)
     (∀ i (x : μ D i) → unM i x)
elim R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in
    (M : CurriedElᵀ (Data.I R p) (λ i → μ D i → Set))
    → let unM = uncurryElᵀ (Data.I R p) (λ i → μ D i → Set) M
    in CurriedBranches (Data.E R)
       (SumCurriedHyps R p unM)
       (∀ i (x : μ D i) → unM i x))
  (λ p M → curryBranches
    (elimUncurried R p
      (uncurryElᵀ (Data.I R p)
        ((λ i → μ (Data.D R p) i → Set)) M)))

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

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

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

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

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

ℕR : Data
ℕR = record
  { P = End
  ; I = λ _ → End
  ; E = ℕE
  ; B = λ _ →
      End tt
    , Rec tt (End tt)
    , tt
  }

ℕ : Set
ℕ = Form ℕR

zero : ℕ
zero = inj ℕR zeroT

suc : ℕ → ℕ
suc = inj ℕR sucT

VecR : Data
VecR = record
  { P = Arg Set (λ _ → End)
  ; I = λ _ → Arg ℕ (λ _ → End)
  ; E = VecE
  ; B = λ A →
      End (zero , tt)
    , Arg ℕ (λ n → Arg (proj₁ A) λ _ → Rec (n , tt) (End (suc n , tt)))
    , tt
  }

Vec : (A : Set) → ℕ → Set
Vec = Form VecR

nil : {A : Set} → Vec A zero
nil = inj VecR nilT

cons : {A : Set} (n : ℕ) (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR consT

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

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

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

append : {A : Set} (m : ℕ) (xs : Vec A m) (n : ℕ) (ys : Vec A n) → Vec A (add m n)
append {A} m xs = elim VecR (λ m xs → (n : ℕ) (ys : Vec A n) → Vec A (add m n))
  (λ n ys → ys)
  (λ m x xs ih n ys → cons (add m n) x (ih n ys))
  (m , tt) xs

concat : {A : Set} (m n : ℕ) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat {A} m n xss = elim VecR (λ n xss → Vec A (mult n m))
  nil
  (λ n xs xss ih → append m xs (mult n m) ih)
  (n , tt) xss

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

{-# 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
open import Function
module Spire.Examples.DarkwingDuck where

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

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)

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

case : {E : Enum} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P (c , cs) here = c
case P (c , cs) (there t) = case (λ t → P (there t)) cs t

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

data Tel : Set where
  End : Tel
  Arg : (A : Set) (B : A → Tel) → Tel

Elᵀ  : Tel → Set
Elᵀ End = ⊤
Elᵀ (Arg A B) = Σ A (λ a → Elᵀ (B a))

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

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

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

ISet : Set → Set
ISet I = I → Set

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

Hyps : {I : Set} (D : Desc I) (X : ISet I) (P : (i : I) → X i → Set) (i : I) (xs : Elᴰ D X i) → Set
Hyps (End j) X P i q = ⊤
Hyps (Rec j D) X P i (x , xs) = P j x × Hyps D X P i xs
Hyps (Arg A B) X P i (a , b) = Hyps (B a) X P i b

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

data μ {I : Set} (D : Desc I) (i : I) : Set where
  init : Elᴰ D (μ D) i → μ D i

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

ind : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (α : ∀ i (xs : Elᴰ D (μ D) i) (ihs : Hyps D (μ D) M i xs) → M i (init xs))
  (i : I)
  (x : μ D i)
  → M i x

prove : {I : Set} (D E : Desc I)
  (M : (i : I) → μ E i → Set)
  (α : ∀ i (xs : Elᴰ E (μ E) i) (ihs : Hyps E (μ E) M i xs) → M i (init xs))
  (i : I) (xs : Elᴰ D (μ E) i) → Hyps D (μ E) M i xs

ind D M α i (init xs) = α i xs (prove D D M α i xs)

prove (End j) E M α i q = tt
prove (Rec j D) E M α i (x , xs) = ind E M α j x , prove D E M α i xs
prove (Arg A B) E M α i (a , xs) = prove (B a) E M α i xs

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

record Data : Set where
  field
    P : Tel
    I : Elᵀ P → Tel
    E : Enum
    B : (A : Elᵀ P) → Branches E (λ _ → Desc (Elᵀ (I A)))

  C : (A : Elᵀ P) → Tag E → Desc (Elᵀ (I A))
  C A = case (λ _ → Desc (Elᵀ (I A))) (B A)

  D : (A : Elᵀ P) → Desc (Elᵀ (I A))
  D A = Arg (Tag E) (C A)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

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

curryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → UncurriedBranches E P X → CurriedBranches E P X
curryBranches {[]} f = f tt
curryBranches {l ∷ E} f = λ c → curryBranches (λ cs → f (c , cs))

uncurryBranches : {E : Enum} {P : Tag E → Set} {X : Set}
  → CurriedBranches E P X → UncurriedBranches E P X
uncurryBranches {[]} x tt = x
uncurryBranches {l ∷ E} f (c , cs) = uncurryBranches (f c) cs

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

UncurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
UncurriedElᵀ T X = (xs : Elᵀ T) → X xs

CurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
CurriedElᵀ End X = X tt
CurriedElᵀ (Arg A B) X = (a : A) → CurriedElᵀ (B a) (λ b → X (a , b))

curryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → CurriedElᵀ T X
curryElᵀ End X f = f tt
curryElᵀ (Arg A B) X f = λ a → curryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

ICurriedElᵀ : (T : Tel) (X : Elᵀ T → Set) → Set
ICurriedElᵀ End X = X tt
ICurriedElᵀ (Arg A B) X = {a : A} → ICurriedElᵀ (B a) (λ b → X (a , b))

icurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → UncurriedElᵀ T X → ICurriedElᵀ T X
icurryElᵀ End X f = f tt
icurryElᵀ (Arg A B) X f = λ {a} → icurryElᵀ (B a) (λ b → X (a , b)) (λ b → f (a , b))

iuncurryElᵀ : (T : Tel) (X : Elᵀ T → Set)
  → ICurriedElᵀ T X → UncurriedElᵀ T X
iuncurryElᵀ End X x tt = x
iuncurryElᵀ (Arg A B) X f (a , b) = iuncurryElᵀ (B a) (λ b → X (a , b)) f b

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

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

CurriedElᴰ : {I : Set} (D : Desc I) (X : ISet I) → Set
CurriedElᴰ (End i) X = X i
CurriedElᴰ (Rec i D) X = (x : X i) → CurriedElᴰ D X
CurriedElᴰ (Arg A B) X = (a : A) → CurriedElᴰ (B a) X

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

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

UncurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
UncurriedHyps D X P cn =
  ∀ i (xs : Elᴰ D X i) (ihs : Hyps D X P i xs) → P i (cn xs)

CurriedHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → Set
CurriedHyps (End i) X P cn =
  P i (cn refl)
CurriedHyps (Rec i D) X P cn =
  (x : X i) → P i x → CurriedHyps D X P (λ xs → cn (x , xs))
CurriedHyps (Arg A B) X P cn =
  (a : A) → CurriedHyps (B a) X P (λ xs → cn (a , xs))

curryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → UncurriedHyps D X P cn
  → CurriedHyps D X P cn
curryHyps (End i) X P cn pf =
  pf i refl tt
curryHyps (Rec i D) X P cn pf =
  λ x ih → curryHyps D X P (λ xs → cn (x , xs)) (λ i xs ihs → pf i (x , xs) (ih , ihs))
curryHyps (Arg A B) X P cn pf =
  λ a → curryHyps (B a) X P (λ xs → cn (a , xs)) (λ i xs ihs → pf i (a , xs) ihs)

uncurryHyps : {I : Set} (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedElᴰ D X)
  → CurriedHyps D X P cn
  → UncurriedHyps D X P cn
uncurryHyps (End .i) X P cn pf i refl tt =
  pf
uncurryHyps (Rec j D) X P cn pf i (x , xs) (ih , ihs) =
  uncurryHyps D X P (λ ys → cn (x , ys)) (pf x ih) i xs ihs
uncurryHyps (Arg A B) X P cn pf i (a , xs) ihs =
  uncurryHyps (B a) X P (λ ys → cn (a , ys)) (pf a) i xs ihs

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

FormUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → UncurriedElᵀ (Data.I R p) λ i
  → Set
FormUncurried R p i = μ (Data.D R p) i

Form : (R : Data)
  → CurriedElᵀ (Data.P R) λ p
  → CurriedElᵀ (Data.I R p) λ i
  → Set
Form R =
  curryElᵀ (Data.P R) (λ p → CurriedElᵀ (Data.I R p) λ i → Set) λ p →
  curryElᵀ (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
injUncurried R p t = curryElᴰ (Data.C R p t)
  (μ (Data.D R p))
  (λ xs → init (t , xs))

inj : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p
  in CurriedElᴰ D (μ D)
inj R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in CurriedElᴰ D (μ D))
  (injUncurried R)

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

indCurried : {I : Set} (D : Desc I)
  (M : (i : I) → μ D i → Set)
  (f : CurriedHyps D (μ D) M init)
  (i : I)
  (x : μ D i)
  → M i x
indCurried D M f i x =
  ind D M (uncurryHyps D (μ D) M init f) i x

SumCurriedHyps : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : ∀ i → μ D i → Set)
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  CurriedHyps (Data.C R p t) (μ (Data.D R p)) M (λ xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : ∀ i → μ D i → Set)
  → UncurriedBranches (Data.E R)
    (SumCurriedHyps R p M)
    (∀ i (x : μ D i) → M i x)
elimUncurried R p M cs i x =
  indCurried (Data.D R p) M
    (case (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → ICurriedElᵀ (Data.P R) λ p
  → let D = Data.D R p in
  (M : ∀ i → μ D i → Set)
  → CurriedBranches (Data.E R)
    (SumCurriedHyps R p M)
    (∀ i (x : μ D i) → M i x)
elim R = icurryElᵀ (Data.P R)
  (λ p → let D = Data.D R p in
    (M : ∀ i → μ D i → Set) →
    CurriedBranches (Data.E R)
    (SumCurriedHyps R p M)
    (∀ i (x : μ D i) → M i x))
  (λ p M → curryBranches (elimUncurried R p M))

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

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

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

ℕT : Set
ℕT = Tag ℕE

VecT : Set
VecT = Tag VecE

zeroT : ℕT
zeroT = here

sucT : ℕT
sucT = there here

nilT : VecT
nilT = here

consT : VecT
consT = there here

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

ℕR : Data
ℕR = record
  { P = End
  ; I = λ _ → End
  ; E = ℕE
  ; B = λ _ →
      End tt
    , Rec tt (End tt)
    , tt
  }

ℕ : Set
ℕ = Form ℕR

zero : ℕ
zero = inj ℕR zeroT

suc : ℕ → ℕ
suc = inj ℕR sucT

VecR : Data
VecR = record
  { P = Arg Set (λ _ → End)
  ; I = λ _ → Arg ℕ (λ _ → End)
  ; E = VecE
  ; B = λ A →
      End (zero , tt)
    , Arg ℕ (λ n → Arg (proj₁ A) λ _ → Rec (n , tt) (End (suc n , tt)))
    , tt
  }

Vec : (A : Set) → ℕ → Set
Vec = Form VecR

nil : {A : Set} → Vec A zero
nil = inj VecR nilT

cons : {A : Set} (n : ℕ) (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR consT

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

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

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

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


Parametric.Change.Validity: Comment out bug-triggering code

This code is exported and used elsewhere :-(

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  -- change algebras

  open CA public renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

  change-algebra-family : ChangeAlgebraFamily zero ⟦_⟧Type
  change-algebra-family = family change-algebra

  -- function changes

  open FunctionChanges public using (cons)
  module _ {τ₁ τ₂ : Type} where
    open FunctionChanges.FunctionChange _ _ {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  {-
  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebra to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍  Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍ Γ ₎
  -}

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  -- change algebras

  open CA public renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

  change-algebra-family : ChangeAlgebraFamily zero ⟦_⟧Type
  change-algebra-family = family change-algebra

  -- function changes

  open FunctionChanges public using (cons)
  module _ {τ₁ τ₂ : Type} where
    open FunctionChanges.FunctionChange _ _ {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebra to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍  Γ ₎ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍ Γ ₎


Typo.

Typo.

Ignore-this: 68af14a7e65f38003c3779ccf4921770

darcs-hash:20110930182805-3bd4e-97d00b34b1a4af679e44fc8768ed579a9589a669.gz

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

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

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we chose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulated one: Using the induction
-- principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulated one: Using pattern
-- matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulated predicate to the data one.
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulated inductive principle from the data one.
indD2P : (P : D → Set) → P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n
indD2P P P0 ih Mn = indN P P0 (λ {_} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulated one.
indP2D : (P : D → Set) → P zero →
         (∀ {n} → N n → P n → P (succ n)) →
         ∀ {n} → N n → P n
indP2D P P0 ih Nn = indM P P0 (λ {_} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

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

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulated one: Using the induction
-- principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulated one: Using pattern
-- matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulated predicate to the data one.
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulated inductive principle from the data one.
indD2P : (P : D → Set) → P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n
indD2P P P0 ih Mn = indN P P0 (λ {_} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulated one.
indP2D : (P : D → Set) → P zero →
         (∀ {n} → N n → P n → P (succ n)) →
         ∀ {n} → N n → P n
indP2D P P0 ih Nn = indM P P0 (λ {_} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)


Remove no longer relevant TODO

Remove no longer relevant TODO

{-# OPTIONS --without-K #-}
module ZK.JSChecker where

open import Function         using (id; _∘′_; case_of_)
open import Data.Bool.Base   using (Bool; true; false; _∧_)
open import Data.List.Base   using (List; []; _∷_; and; foldr)
open import Data.String.Base using (String)

open import FFI.JS
open import FFI.JS.Check
-- open import FFI.JS.Proc using (URI; JSProc; showURI; server)
-- open import Control.Process.Type
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS

import FFI.JS.BigI as BigI
open BigI using (BigI; bigI)

import Crypto.JS.BigI.ZqZp as ZqZp

-- TODO dynamise me
primality-test-probability-bound : Number
primality-test-probability-bound = readNumber "10"

-- TODO: check if this is large enough
min-bits-q : Number
min-bits-q = 256N

min-bits-p : Number
min-bits-p = 2048N

bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

-- TODO bug (undefined)!
record ZK-chaum-pedersen-pok-elgamal-rnd {--(ℤq ℤp★ : Set)--} : Set where
  field
    m c s : BigI {--ℤq--}
    g p q y α β A B : BigI --ℤp★

zk-check-chaum-pedersen-pok-elgamal-rnd! : ZK-chaum-pedersen-pok-elgamal-rnd {-BigI BigI-} → JS!
zk-check-chaum-pedersen-pok-elgamal-rnd! pf
      = trace "g=" g λ _ →
        trace "p=" I.p λ _ →
        trace "q=" I.q λ _ →
        trace "y=" y λ _ →
        trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
         checks!
      >> check! "g^s==A·α^c"     ((g ^ s) == (A · (α ^ c)))        (λ _ → "")
      >> check! "y^s==B·(β/M)^c" ((y ^ s) == (B · ((β ·/ M) ^ c))) (λ _ → "")
  module ZK-check-chaum-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    params = record
      { primality-test-probability-bound = primality-test-probability-bound
      ; min-bits-q = min-bits-q
      ; min-bits-p = min-bits-p
      ; qI = I.q
      ; pI = I.p
      ; gI = I.g
      }
    open module [ℤq]ℤp★ = ZqZp params
    A = BigI▹ℤp★ I.A
    B = BigI▹ℤp★ I.B
    α = BigI▹ℤp★ I.α
    β = BigI▹ℤp★ I.β
    y = BigI▹ℤp★ I.y
    s = BigI▹ℤq  I.s
    c = BigI▹ℤq  I.c
    m = BigI▹ℤq  I.m
    M = g ^ m

zk-check! : JSValue → JS!
zk-check! arg =
    check! "type of statement" (typ === fromString cpt)
                               (λ _ → "Expected type of statement: " ++ cpt ++ " not " ++ toString typ)
 >> zk-check-chaum-pedersen-pok-elgamal-rnd! pok
 module Zk-check where
    cpt = "chaum-pedersen-pok-elgamal-rnd"
    stm = arg ·« "statement" »
    typ = stm ·« "type" »
    dat = stm ·« "data" »
    g   = bigdec (dat ·« "g" »)
    p   = bigdec (dat ·« "p" »)
    q   = bigdec (dat ·« "q" »)
    y   = bigdec (dat ·« "y" »)
    m   = bigdec (dat ·« "plain" »)
    enc = dat ·« "enc" »
    α   = bigdec (enc ·« "alpha" »)
    β   = bigdec (enc ·« "beta"  »)
    prf = arg ·« "proof" »
    com = prf ·« "commitment" »
    A   = bigdec (com ·« "A" »)
    B   = bigdec (com ·« "B" »)
    c   = bigdec (prf ·« "challenge" »)
    s   = bigdec (prf ·« "response" »)
    pok = record { g = g; p = p; q = q; y = y; α = α; β = β; A = A; B = B; c = c; s = s; m = m }

{-
srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (zk-check q))
  end
-}

-- Working around Agda.Primitive.lsuc being undefined
-- case_of_ : {A : Set} {B : Set} → A → (A → B) → B
-- case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
        Console.log "usage: No arguments"
        {- server "127.0.0.1" "1337" srv !₁ λ uri →
           Console.log (showURI uri)
         -}
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              Console.log ("Reading input file: " ++ arg) >>
              FS.readFile arg nullJS !₂ λ err dat →
                check! "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check! (JSON-parse (toString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module ZK.JSChecker where

open import Function         using (id; _∘′_; case_of_)
open import Data.Bool.Base   using (Bool; true; false; _∧_)
open import Data.List.Base   using (List; []; _∷_; and; foldr)
open import Data.String.Base using (String)

open import FFI.JS
open import FFI.JS.Check
-- open import FFI.JS.Proc using (URI; JSProc; showURI; server)
-- open import Control.Process.Type
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS

import FFI.JS.BigI as BigI
open BigI using (BigI; bigI)

import Crypto.JS.BigI.ZqZp as ZqZp

-- TODO dynamise me
primality-test-probability-bound : Number
primality-test-probability-bound = readNumber "10"

-- TODO: check if this is large enough
min-bits-q : Number
min-bits-q = 256N

min-bits-p : Number
min-bits-p = 2048N

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

-- TODO bug (undefined)!
record ZK-chaum-pedersen-pok-elgamal-rnd {--(ℤq ℤp★ : Set)--} : Set where
  field
    m c s : BigI {--ℤq--}
    g p q y α β A B : BigI --ℤp★

zk-check-chaum-pedersen-pok-elgamal-rnd! : ZK-chaum-pedersen-pok-elgamal-rnd {-BigI BigI-} → JS!
zk-check-chaum-pedersen-pok-elgamal-rnd! pf
      = trace "g=" g λ _ →
        trace "p=" I.p λ _ →
        trace "q=" I.q λ _ →
        trace "y=" y λ _ →
        trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
         checks!
      >> check! "g^s==A·α^c"     ((g ^ s) == (A · (α ^ c)))        (λ _ → "")
      >> check! "y^s==B·(β/M)^c" ((y ^ s) == (B · ((β ·/ M) ^ c))) (λ _ → "")
  module ZK-check-chaum-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    params = record
      { primality-test-probability-bound = primality-test-probability-bound
      ; min-bits-q = min-bits-q
      ; min-bits-p = min-bits-p
      ; qI = I.q
      ; pI = I.p
      ; gI = I.g
      }
    open module [ℤq]ℤp★ = ZqZp params
    A = BigI▹ℤp★ I.A
    B = BigI▹ℤp★ I.B
    α = BigI▹ℤp★ I.α
    β = BigI▹ℤp★ I.β
    y = BigI▹ℤp★ I.y
    s = BigI▹ℤq  I.s
    c = BigI▹ℤq  I.c
    m = BigI▹ℤq  I.m
    M = g ^ m

zk-check! : JSValue → JS!
zk-check! arg =
    check! "type of statement" (typ === fromString cpt)
                               (λ _ → "Expected type of statement: " ++ cpt ++ " not " ++ toString typ)
 >> zk-check-chaum-pedersen-pok-elgamal-rnd! pok
 module Zk-check where
    cpt = "chaum-pedersen-pok-elgamal-rnd"
    stm = arg ·« "statement" »
    typ = stm ·« "type" »
    dat = stm ·« "data" »
    g   = bigdec (dat ·« "g" »)
    p   = bigdec (dat ·« "p" »)
    q   = bigdec (dat ·« "q" »)
    y   = bigdec (dat ·« "y" »)
    m   = bigdec (dat ·« "plain" »)
    enc = dat ·« "enc" »
    α   = bigdec (enc ·« "alpha" »)
    β   = bigdec (enc ·« "beta"  »)
    prf = arg ·« "proof" »
    com = prf ·« "commitment" »
    A   = bigdec (com ·« "A" »)
    B   = bigdec (com ·« "B" »)
    c   = bigdec (prf ·« "challenge" »)
    s   = bigdec (prf ·« "response" »)
    pok = record { g = g; p = p; q = q; y = y; α = α; β = β; A = A; B = B; c = c; s = s; m = m }

{-
srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (zk-check q))
  end
-}

-- Working around Agda.Primitive.lsuc being undefined
-- case_of_ : {A : Set} {B : Set} → A → (A → B) → B
-- case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
        Console.log "usage: No arguments"
        {- server "127.0.0.1" "1337" srv !₁ λ uri →
           Console.log (showURI uri)
         -}
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              Console.log ("Reading input file: " ++ arg) >>
              FS.readFile arg nullJS !₂ λ err dat →
                check! "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check! (JSON-parse (toString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}


Add test

Add test

data Bool : Set where
  true  : Bool
  false : Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

infixr 5 _∷_

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ ∘

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (5 ∷ 3 ∷ 7 ∷ 7 ∷ ∘)) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (5 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (6 ∷ 3 ∷ ∘)) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (6 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ ∘) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ ∘) (3 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ ∘)) ∷
  (model (10 ∷ 9 ∷ ∘) (1 ∷ ∘)) ∷
  (model (3 ∷ 4 ∷ 11 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 7 ∷ 1 ∷ ∘) (4 ∷ 11 ∷ 8 ∷ ∘)) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ ∘) (11 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ ∘) (11 ∷ 3 ∷ ∘)) ∷
  (model (3 ∷ 6 ∷ 5 ∷ ∘) (∘)) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ ∘) (12 ∷ ∘)) ∷ ∘

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 7))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

data Bool : Set where
  true  : Bool
  false : Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

apply : {A B : Set} → (A → B) → List A → List B
apply _ ∘        = ∘
apply f (x ∷ xs) = (f x) ∷ (apply f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown


scraps

scraps

open import Prelude
open import Nat
open import List
open import core
open import contexts
open import weakening
open import exchange
open import lemmas-disjointness

module lemmas-subst-ta where
  -- todo: add a premise from a new judgement like holes disjoint that
  -- classifies pairs of dhexps that share no variable names
  -- whatsoever. that should imply freshness here. then propagate that
  -- change to preservation. this is morally what α-equiv lets us do in a
  -- real setting.

  -- the variable name x does not appear in the term d
  data var-name-new : (x : Nat) (d : dhexp) → Set where
    VNNConst : ∀{x} → var-name-new x c
    VNNVar : ∀{x y} → x ≠ y → var-name-new x (X y)
    VNNLam2 : ∀{x d y τ} → x ≠ y
                         → var-name-new x d
                         → var-name-new x (·λ_[_]_ y τ d)
    VNNHole : ∀{x u σ} → var-name-new x (⦇⦈⟨ u , σ ⟩) -- todo something about σ?
    VNNNEHole : ∀{x u σ d } →
                var-name-new x d →
                var-name-new x (⦇ d ⦈⟨ u , σ ⟩) -- todo something about σ?
    VNNAp : ∀{ x d1 d2 } →
           var-name-new x d1 →
           var-name-new x d2 →
           var-name-new x (d1 ∘ d2)
    VNNCast : ∀{x d τ1 τ2} → var-name-new x d → var-name-new x (d ⟨ τ1 ⇒ τ2 ⟩)
    VNNFailedCast : ∀{x d τ1 τ2} → var-name-new x d → var-name-new x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  -- two terms that do not share any hole names
  data var-names-disjoint : (d1 : dhexp) → (d2 : dhexp) → Set where
    VNDConst : ∀{d} → var-names-disjoint c d
    VNDVar : ∀{x d} → var-names-disjoint (X x) d
    VNDLam : ∀{x τ d1 d2} → var-names-disjoint d1 d2
                          → var-names-disjoint (·λ_[_]_ x τ d1) d2
    VNDHole : ∀{u σ d2} → var-name-new u d2
                        → var-names-disjoint (⦇⦈⟨ u , σ ⟩) d2 -- todo something about σ?
    VNDNEHole : ∀{u σ d1 d2} → var-name-new u d2
                             → var-names-disjoint d1 d2
                             → var-names-disjoint (⦇ d1 ⦈⟨ u , σ ⟩) d2 -- todo something about σ?
    VNDAp :  ∀{d1 d2 d3} → var-names-disjoint d1 d3
                         → var-names-disjoint d2 d3
                         → var-names-disjoint (d1 ∘ d2) d3

  -- all the variable names in the term are unique
  data var-names-unique : dhexp → Set where
    VNUHole : var-names-unique c
    VNUVar : ∀{x} → var-names-unique (X x)
    VNULam : {x : Nat} {τ : htyp} {d : dhexp} → var-names-unique d
                                              → var-name-new x d
                                              → var-names-unique (·λ_[_]_ x τ d)
    VNUEHole : ∀{u σ} → var-names-unique (⦇⦈⟨ u , σ ⟩) -- todo something about σ?
    VNUNEHole : ∀{u σ d} → var-names-unique d
                         → var-names-unique (⦇ d ⦈⟨ u , σ ⟩) -- todo something about σ?
    VNUAp : ∀{d1 d2} → var-names-unique d1
                     → var-names-unique d2
                     → var-names-disjoint d1 d2
                     → var-names-unique (d1 ∘ d2)
    VNUCast : ∀{d τ1 τ2} → var-names-unique d
                         → var-names-unique (d ⟨ τ1 ⇒ τ2 ⟩)
    VNUFailedCast : ∀{d τ1 τ2} → var-names-unique d
                               → var-names-unique (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  unique-fresh : ∀{Δ Γ d τ y} → Δ , Γ ⊢ d :: τ → y # Γ → var-names-unique d → fresh y d
  unique-fresh TAConst apt VNUHole = FConst
  unique-fresh (TAVar x₁) apt VNUVar = {!!}
  unique-fresh (TALam x₁ wt) apt (VNULam unq x₂) = {!!}
  unique-fresh (TAAp wt wt₁) apt (VNUAp unq unq₁ x) = {!!}
  unique-fresh (TAEHole x x₁) apt VNUEHole = {!!}
  unique-fresh (TANEHole x wt x₁) apt (VNUNEHole unq) = {!!}
  unique-fresh (TACast wt x) apt (VNUCast unq) = {!!}
  unique-fresh (TAFailedCast wt x x₁ x₂) apt (VNUFailedCast unq) = {!!}

  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
                  x # Γ →
                  Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
                  Δ , Γ ⊢ d2 :: τ1 →
                  Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst apt TAConst wt2 = TAConst
  lem-subst {x = x} apt (TAVar {x = x'} x₂) wt2 with natEQ x' x
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃
  lem-subst apt (TAVar x₃) wt2 | Inl refl | refl = wt2
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃)
  lem-subst {Δ = Δ} {Γ = Γ} {x = x} {d2 = d2} x#Γ (TALam {x = y} {τ1 = τ1} {d = d} {τ2 = τ2} x₂ wt1) wt2
    with lem-union-none {Γ = Γ} x₂
  ... |  x≠y , y#Γ with natEQ y x
  ... | Inl eq = abort (x≠y (! eq))
  ... | Inr _  = TALam y#Γ (lem-subst {Δ = Δ} {Γ = Γ ,, (y , τ1)} {x = x} {d1 = d} (apart-extend1 Γ x≠y x#Γ) (exchange-ta-Γ {Γ = Γ} x≠y wt1) (weaken-ta {!!} wt2))
  lem-subst apt (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt wt1 wt3) (lem-subst apt wt2 wt3)
  lem-subst apt (TAEHole inΔ sub) wt2 = TAEHole inΔ (STASubst sub wt2)
  lem-subst apt (TANEHole x₁ wt1 x₂) wt2 = TANEHole x₁ (lem-subst apt wt1 wt2) (STASubst x₂ wt2)
  lem-subst apt (TACast wt1 x₁) wt2 = TACast (lem-subst apt wt1 wt2) x₁
  lem-subst apt (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt wt1 wt2) x₁ x₂ x₃

open import Prelude
open import Nat
open import List
open import core
open import contexts
open import weakening
open import exchange
open import lemmas-disjointness

module lemmas-subst-ta where
  -- todo: add a premise from a new judgement like holes disjoint that
  -- classifies pairs of dhexps that share no variable names
  -- whatsoever. that should imply freshness here. then propagate that
  -- change to preservation. this is morally what α-equiv lets us do in a
  -- real setting.

  -- the variable name x does not appear in the term d
  data var-name-new : (x : Nat) (d : dhexp) → Set where
    VNNConst : ∀{x} → var-name-new x c
    VNNVar : ∀{x y} → x ≠ y → var-name-new x (X y)
    VNNLam2 : ∀{x d y τ} → x ≠ y
                         → var-name-new x d
                         → var-name-new x (·λ_[_]_ y τ d)
    VNNHole : ∀{x u σ} → var-name-new x (⦇⦈⟨ u , σ ⟩) -- todo something about σ?
    VNNNEHole : ∀{x u σ d } →
                var-name-new x d →
                var-name-new x (⦇ d ⦈⟨ u , σ ⟩) -- todo something about σ?
    VNNAp : ∀{ x d1 d2 } →
           var-name-new x d1 →
           var-name-new x d2 →
           var-name-new x (d1 ∘ d2)
    VNNCast : ∀{x d τ1 τ2} → var-name-new x d → var-name-new x (d ⟨ τ1 ⇒ τ2 ⟩)
    VNNFailedCast : ∀{x d τ1 τ2} → var-name-new x d → var-name-new x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  -- two terms that do not share any hole names
  data var-names-disjoint : (d1 : dhexp) → (d2 : dhexp) → Set where
    VNDConst : ∀{d} → var-names-disjoint c d
    VNDVar : ∀{x d} → var-names-disjoint (X x) d
    VNDLam : ∀{x τ d1 d2} → var-names-disjoint d1 d2
                          → var-names-disjoint (·λ_[_]_ x τ d1) d2
    VNDHole : ∀{u σ d2} → var-name-new u d2
                        → var-names-disjoint (⦇⦈⟨ u , σ ⟩) d2 -- todo something about σ?
    VNDNEHole : ∀{u σ d1 d2} → var-name-new u d2
                             → var-names-disjoint d1 d2
                             → var-names-disjoint (⦇ d1 ⦈⟨ u , σ ⟩) d2 -- todo something about σ?
    VNDAp :  ∀{d1 d2 d3} → var-names-disjoint d1 d3
                         → var-names-disjoint d2 d3
                         → var-names-disjoint (d1 ∘ d2) d3

  -- all the variable names in the term are unique
  data var-names-unique : dhexp → Set where
    VNUHole : var-names-unique c
    VNUVar : ∀{x} → var-names-unique (X x)
    VNULam : {x : Nat} {τ : htyp} {d : dhexp} → var-names-unique d
                                              → var-name-new x d
                                              → var-names-unique (·λ_[_]_ x τ d)
    VNUEHole : ∀{u σ} → var-names-unique (⦇⦈⟨ u , σ ⟩) -- todo something about σ?
    VNUNEHole : ∀{u σ d} → var-names-unique d
                         → var-names-unique (⦇ d ⦈⟨ u , σ ⟩) -- todo something about σ?
    VNUAp : ∀{d1 d2} → var-names-unique d1
                     → var-names-unique d2
                     → var-names-disjoint d1 d2
                     → var-names-unique (d1 ∘ d2)
    VNUCast : ∀{d τ1 τ2} → var-names-unique d
                         → var-names-unique (d ⟨ τ1 ⇒ τ2 ⟩)
    VNUFailedCast : ∀{d τ1 τ2} → var-names-unique d
                               → var-names-unique (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
                  x # Γ →
                  Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
                  Δ , Γ ⊢ d2 :: τ1 →
                  Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst apt TAConst wt2 = TAConst
  lem-subst {x = x} apt (TAVar {x = x'} x₂) wt2 with natEQ x' x
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inl refl with lem-apart-union-eq {Γ = Γ} apt x₃
  lem-subst apt (TAVar x₃) wt2 | Inl refl | refl = wt2
  lem-subst {Γ = Γ} apt (TAVar x₃) wt2 | Inr x₂ = TAVar (lem-neq-union-eq {Γ = Γ} x₂ x₃)
  lem-subst {Δ = Δ} {Γ = Γ} {x = x} {d2 = d2} x#Γ (TALam {x = y} {τ1 = τ1} {d = d} {τ2 = τ2} x₂ wt1) wt2
    with lem-union-none {Γ = Γ} x₂
  ... |  x≠y , y#Γ with natEQ y x
  ... | Inl eq = abort (x≠y (! eq))
  ... | Inr _  = TALam y#Γ (lem-subst {Δ = Δ} {Γ = Γ ,, (y , τ1)} {x = x} {d1 = d} (apart-extend1 Γ x≠y x#Γ) (exchange-ta-Γ {Γ = Γ} x≠y wt1) (weaken-ta {!!} wt2))
  lem-subst apt (TAAp wt1 wt2) wt3 = TAAp (lem-subst apt wt1 wt3) (lem-subst apt wt2 wt3)
  lem-subst apt (TAEHole inΔ sub) wt2 = TAEHole inΔ (STASubst sub wt2)
  lem-subst apt (TANEHole x₁ wt1 x₂) wt2 = TANEHole x₁ (lem-subst apt wt1 wt2) (STASubst x₂ wt2)
  lem-subst apt (TACast wt1 x₁) wt2 = TACast (lem-subst apt wt1 wt2) x₁
  lem-subst apt (TAFailedCast wt1 x₁ x₂ x₃) wt2 = TAFailedCast (lem-subst apt wt1 wt2) x₁ x₂ x₃


Callback0 -> JS!

Callback0 -> JS!

module FFI.JS.Proc where

open import FFI.JS
open import Control.Process.Type

abstract
  URI = String
  showURI : URI → String
  showURI x = x
  readURI : String → URI
  readURI x = x

JSProc = Proc URI JSValue

{-
postulate server : (ip port  : String)
                   (proc     : URI → JSProc)
                   (callback : URI → JSCmd) → JSCmd
{-# COMPILED_JS server require("proc").serverCurry #-}

postulate client : JSProc → JSCmd → JSCmd
{-# COMPILED_JS client require("proc").clientCurry #-}
-}

postulate server : (ip port  : String)
                   (proc     : URI → JSProc)
                 → Callback1 URI
{-# COMPILED_JS server require("proc").serverCurry #-}

postulate client : JSProc → JS!
{-# COMPILED_JS client require("proc").clientCurry #-}

module FFI.JS.Proc where

open import FFI.JS
open import Control.Process.Type

abstract
  URI = String
  showURI : URI → String
  showURI x = x
  readURI : String → URI
  readURI x = x

JSProc = Proc URI JSValue

{-
postulate server : (ip port  : String)
                   (proc     : URI → JSProc)
                   (callback : URI → JSCmd) → JSCmd
{-# COMPILED_JS server require("proc").serverCurry #-}

postulate client : JSProc → JSCmd → JSCmd
{-# COMPILED_JS client require("proc").clientCurry #-}
-}

postulate server : (ip port  : String)
                   (proc     : URI → JSProc)
                 → Callback1 URI
{-# COMPILED_JS server require("proc").serverCurry #-}

postulate client : JSProc → Callback0
{-# COMPILED_JS client require("proc").clientCurry #-}


Testing automatic proofs with streams.

Testing automatic proofs with streams.

Ignore-this: 19fe2f88ffe2f0b524f957d35eb3978e

darcs-hash:20110725165341-3bd4e-ffb75f484bb59247ff637ca3f5013c1e9fad2044.gz

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

module Draft.FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base

open import FOTC.Base.PropertiesATP

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

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

postulate
  helper₁ : ∀ {ws} → (∃ λ zs → ws ≈ zs) →
            ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ (∃ λ zs → ws' ≈ zs)))
{-# ATP prove helper₁ #-}

postulate
  helper₂ : ∀ {zs} → (∃ λ ws → ws ≈ zs) →
            ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ (∃ λ ws → ws ≈ zs')))
{-# ATP prove helper₂ #-}

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

module Draft.FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base

open import FOTC.Base.PropertiesATP

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

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

tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
tailS {x} {xs} h = subst Stream (sym (∧-proj₂ (∷-injective x∷xs≡e∷es))) Ses
  where
  unfold : ∃ λ e → ∃ λ es → x ∷ xs ≡ e ∷ es ∧ Stream es
  unfold = Stream-gfp₁ h

  e : D
  e = ∃-proj₁ unfold

  es : D
  es = ∃-proj₁ (∃-proj₂ unfold)

  x∷xs≡e∷es : x ∷ xs ≡ e ∷ es
  x∷xs≡e∷es = ∧-proj₁ (∃-proj₂ (∃-proj₂ unfold))

  Ses : Stream es
  Ses = ∧-proj₂ (∃-proj₂ (∃-proj₂ unfold))

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs

  postulate
    helper₁ : ∀ {ws} → P₁ ws →
              ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ P₁ ws'))
  {-# ATP prove helper₁ #-}

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs

  postulate
    helper₂ : ∀ {zs} → P₂ zs → ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ P₂ zs'))
  {-# ATP prove helper₂ #-}


Added Stream-build.

Added Stream-build.

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

-- Based on (Vene, 2000).

module Functors where

infixr 1 _+_
infixr 2 _×_

data Bool : Set where
  false true : Bool

data _+_  (A B : Set) : Set where
  inl : A → A + B
  inr : B → A + B

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

-- The terminal object.
data ⊤ : Set where
   <> : ⊤

postulate
  -- The least fixed-point.

  -- Haskell definitions:

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  μ    : (Set → Set) → Set
  In   : {F : Set → Set} → F (μ F) → μ F
  unIn : {F : Set → Set} → μ F → F (μ F)

postulate
  -- The greatest fixed-point.

  -- Haskell definitions:

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  ν    : (Set → Set) → Set
  Wrap : {F : Set → Set} → F (ν F) → ν F
  out  : {F : Set → Set} → ν F → F (ν F)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = ⊤ + X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = ⊤ + A × X

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = μ IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = μ NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl <>)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = μ (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl <>)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = ν IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conat type is a greatest fixed-point.
Conat : Set
Conat = ν NatF

zeroC : Conat
zeroC = Wrap (inl <>)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- The pred function is the conat destructor.
pred : Conat → ⊤ + Conat
pred cn with out cn
... | inl _ = inl <>
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = ν (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl <>)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = ν (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

-- From (Leclerc and Paulin-Mohring 1994, p. 195).
{-# NO_TERMINATION_CHECK #-}
Stream-build :
  {A X : Set} →
  (X → StreamF A X) →
  X → Stream A
Stream-build f x with f x
... | a , x' = Wrap (a , Stream-build f x')

------------------------------------------------------------------------------
-- References
--
-- Leclerc, F. and Paulin-Mohring, C. (1994). Programming with Streams
-- in Coq. A case study : the Sieve of Eratosthenes. In: Types for
-- Proofs and Programs (TYPES ’93). Ed. by Barendregt, H. and Nipkow,
-- T. Vol. 806. LNCS. Springer, pp. 191–212.
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.

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

-- Based on (Vene, 2000).

module Functors where

infixr 1 _+_
infixr 2 _×_

data Bool : Set where
  false true : Bool

data _+_  (A B : Set) : Set where
  inl : A → A + B
  inr : B → A + B

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

-- The terminal object.
data ⊤ : Set where
   <> : ⊤

postulate
  -- The least fixed-point.

  -- Haskell definitions:

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  μ    : (Set → Set) → Set
  In   : {F : Set → Set} → F (μ F) → μ F
  unIn : {F : Set → Set} → μ F → F (μ F)

postulate
  -- The greatest fixed-point.

  -- Haskell definitions:

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  ν    : (Set → Set) → Set
  Wrap : {F : Set → Set} → F (ν F) → ν F
  out  : {F : Set → Set} → ν F → F (ν F)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = ⊤ + X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = ⊤ + A × X

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = μ IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = μ NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl <>)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = μ (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl <>)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = ν IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conat type is a greatest fixed-point.
Conat : Set
Conat = ν NatF

zeroC : Conat
zeroC = Wrap (inl <>)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- The pred function is the conat destructor.
pred : Conat → ⊤ + Conat
pred cn with out cn
... | inl _ = inl <>
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = ν (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl <>)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = ν (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

------------------------------------------------------------------------------
-- References
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.


Fixed typo.

Fixed typo.

------------------------------------------------------------------------------
-- Distributive laws properties
------------------------------------------------------------------------------

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

module DistributiveLaws.PropertiesI where

open import DistributiveLaws.Base

------------------------------------------------------------------------------
-- Congruence properties

-- The propositional equality is compatible with the binary operation.

-- ·-cong : ∀ {a b c d} → a ≡ b → c ≡ d → a · c ≡ b · d
-- ·-cong = cong₂ _·_

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong refl = refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong refl = refl

------------------------------------------------------------------------------
-- Group theory properties
------------------------------------------------------------------------------

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

module DistributiveLaws.PropertiesI where

open import DistributiveLaws.Base

------------------------------------------------------------------------------
-- Congruence properties

-- The propositional equality is compatible with the binary operation.

-- ·-cong : ∀ {a b c d} → a ≡ b → c ≡ d → a · c ≡ b · d
-- ·-cong = cong₂ _·_

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong refl = refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong refl = refl


Added missing modules to README.agda

Added missing modules to README.agda

Ignore-this: fb16a8a7c5d2c7e33af18e9d9645d7a7

darcs-hash:20110517124334-3bd4e-4e668149cae7521fd5188937e01c04544df7bcb8.gz


Drop (unused) System L

Drop (unused) System L

import Parametric.Syntax.Type as Type

{--
-- Encoding types of polarized System L, as described in "A dissection of L".
-- However, I formalized contexts in a wrong way, hence there are problems.
--}

module Parametric.Syntax.LType where

-- The treatment of base type seems questionable. We might want instead to
-- distinguish base value types and base computation types. Or not, I'm not
-- sure.

module Structure (Base : Type.Structure) where
  open Type.Structure Base

  mutual
    -- Polarized L.
    --  Values (positive types)
    data VType : Set where
      vB : (ι : Base) → VType

      _⊗_ : (τ₁ : VType) → (τ₂ : VType) → VType
      vUnit : VType

      _⊕_ : (τ₁ : VType) → (τ₂ : VType) → VType
      vZero : VType

      ! : VType → VType
      ↓ : (c : CType) → VType

    data CType : Set where
      cB : (ι : Base) → CType

      _⅋_ : CType → CType → CType
      c⊥ : CType

      _&_ : CType → CType → CType
      c⊤ : CType

      ¿ : CType → CType
      ↑ : VType → CType

  _†v : VType → CType
  _†c : CType → VType

  vB ι †v = cB ι
  (v₁ ⊗ v₂) †v = (v₁ †v) ⅋ (v₂ †v)
  vUnit †v = c⊥
  (v₁ ⊕ v₂) †v = (v₁ †v) & (v₂ †v)
  vZero †v = c⊤
  ! v †v = ¿ (v †v)
  ↓ c †v = ↑ (c †c)

  cB ι †c = vB ι
  (c₁ ⅋ c₂) †c = c₁ †c ⊗ c₂ †c
  c⊥ †c = vUnit
  (c₁ & c₂) †c = (c₁ †c) ⊕ (c₂ †c)
  c⊤ †c = vZero
  ¿ c †c = ! (c †c)
  ↑ v †c = ↓ (v †v)

  open import Relation.Binary.PropositionalEquality

  -- This proof really calls for tactics, doesn't it?
  invV : ∀ {v} → v ≡ v †v †c
  invC : ∀ {c} → c ≡ c †c †v

  invV {vB ι} = refl
  invV {v₁ ⊗ v₂} = cong₂ _⊗_ invV invV
  invV {vUnit} = refl
  invV {v₁ ⊕ v₂} = cong₂ _⊕_ invV invV
  invV {vZero} = refl
  invV { ! v} = cong ! invV
  invV {↓ c} = cong ↓ invC

  invC {cB ι} = refl
  invC {c₁ ⅋ c₂} = cong₂ _⅋_ invC invC
  invC {c⊥} = refl
  invC {c₁ & c₂} = cong₂ _&_ invC invC
  invC {c⊤} = refl
  invC {¿ c} = cong ¿ invC
  invC {↑ x} = cong ↑ invV

  open import Base.Syntax.Context VType public
    using ()
    renaming
      ( ∅ to ∅∅
      ; _•_ to _••_
      ; _⋎_ to _⋎⋎_
      ; mapContext to mapVCtx
      ; Var to VVar
      ; Context to VContext
      ; this to vThis; that to vThat)

  fromVar : ∀ {Γ τ} → (f : Type → VType) → Var Γ τ → VVar (mapVCtx f Γ) (f τ)
  fromVar {x • Γ} f this = vThis
  fromVar {x • Γ} f (that v) = vThat (fromVar f v)

  data VTerm : (Ξ : VContext) → (Γ : VContext) → VType → Set
  data CTerm : (Ξ : VContext) → (Γ : VContext) → CType → Set

  -- Each constructor of the following types encodes a rule from the paper (Fig.
  -- 4); the original names are given in comments at the end of each row.

  data Cmd : (Ξ : VContext) → (Γ : VContext) → Set where
    -- I swapped the operands compared to the cut rule in the paper (Fig. 4),
    -- but this should be purely cosmetic.
    ⟨_∣_⟩ : ∀ {Ξ Γ Δ τ} → (v : CTerm Ξ Δ (τ †v)) → (u : VTerm Ξ Γ τ) → Cmd Ξ (Γ ⋎⋎ Δ) -- cut

  data VTerm where
    lvar : ∀ {Ξ A} → VTerm Ξ (A •• ∅∅) A        -- id
    vvar : ∀ {Ξ A} → VVar Ξ A → VTerm Ξ ∅∅ A   -- id'
    μ⇑_ : ∀ {Ξ Γ N} → Cmd Ξ (N †c •• Γ) → VTerm Ξ Γ (↓ N) -- ↓

    -- Multiplicative fragment
    _,_ : ∀ {Ξ Γ Δ A B} → VTerm Ξ Γ A → VTerm Ξ Δ B → VTerm Ξ (Γ ⋎⋎ Δ) (A ⊗ B) -- ⊗
    ⟨⟩ : ∀ {Ξ} → VTerm Ξ ∅∅ vUnit --1

    -- Additive fragment
    _₁as_ : ∀ {Ξ Γ A} → VTerm Ξ Γ A → ∀ B → VTerm Ξ Γ (A ⊕ B) -- ⊕L
    _₂as_ : ∀ {Ξ Γ B} → VTerm Ξ Γ B → ∀ A → VTerm Ξ Γ (A ⊕ B) -- ⊕R

    -- No rule for vZero

    -- Exponential fragment (in the sense of linear logic)

    ⦃⦄_ : ∀ {Ξ A} → VTerm Ξ ∅∅ A → VTerm Ξ ∅∅ (! A) -- !
    -- : ∀ {Ξ Γ A} →

  -- Compared to the paper, we avoid using † in indexes of the result, and
  -- exploit the fact that † is involutive. See for instance μ
  data CTerm where
    μ : ∀ {Ξ Γ N} → Cmd Ξ (N †c •• Γ) → CTerm Ξ Γ N
    ⇑ : ∀ {Ξ Γ A} → VTerm Ξ Γ A → CTerm Ξ Γ (↑ A) -- ↑

    -- Multiplicative fragment
    μ, : ∀ {Ξ Γ N M} → Cmd Ξ (N †c •• M †c •• Γ) → CTerm Ξ Γ (N ⅋ M) -- ⅋
    μ⟨⟩ : ∀ {Ξ Γ} → Cmd Ξ Γ → CTerm Ξ Γ c⊥ -- ⊥

    -- Additive fragment
    μ₁_μ₂_ : ∀ {Ξ Γ N M} → Cmd Ξ (N †c •• Γ) → Cmd Ξ (M †c •• Γ) → CTerm Ξ Γ (N & M)

    -- Exponential fragment (in the sense of linear logic)
    μ⦃⦄ : ∀ {Ξ Γ N} → Cmd (N †c •• Ξ) Γ → CTerm Ξ Γ (¿ N) -- ?

    -- : ∀ {Ξ Γ τ} →

  cast-invV : ∀ {Ξ Γ N} → VTerm Ξ Γ N → VTerm Ξ Γ ((N †v) †c)
  cast-invV {Ξ} {Γ} t = subst (VTerm Ξ Γ) invV t

  cast-invV2 : ∀ {Ξ Γ N} → VTerm Ξ Γ ((N †v) †c) → VTerm Ξ Γ N
  cast-invV2 {Ξ} {Γ} t = subst (VTerm Ξ Γ) (sym invV) t

  cast-invC : ∀ {Ξ Γ N} → CTerm Ξ Γ N → CTerm Ξ Γ ((N †c) †v)
  cast-invC {Ξ} {Γ} t = subst (CTerm Ξ Γ) invC t

  -- Check that type rules match by doing eta-expansion.
  -- (Is this checking harmony?)
  η-μ : ∀ {Ξ Γ N} → CTerm Ξ Γ N → CTerm Ξ Γ N
  η-μ t = μ ⟨ cast-invC t ∣ lvar ⟩

  maybe-η-μ⇑ : ∀ {Ξ Γ A} → VTerm Ξ Γ A → VTerm Ξ Γ (↓ (↑ A))
  maybe-η-μ⇑ t = μ⇑ ⟨ cast-invC (⇑ t) ∣ lvar ⟩

  -- A "thunk" combinator (from paper)
  ⇓ : ∀ {Ξ Γ N} → CTerm Ξ Γ N → VTerm Ξ Γ (↓ N)
  ⇓ t = μ⇑ ⟨ cast-invC t ∣ lvar ⟩

  open import UNDEFINED

  -- from paper
  force : ∀ {Ξ Γ N} → VTerm Ξ Γ (↓ N) → CTerm Ξ Γ N
  force t = reveal UNDEFINED -- {! μ ⟨ ⇑ lvar ∣ t ⟩ !}

  -- XXX Here we "just" need to reorder variables in contexts. OMG, I screwed up
  -- (which is bad), or they use implicit exchange (which would be worse).
  η-μ⇑ : ∀ {Ξ Γ N} → VTerm Ξ Γ (↓ N) → VTerm Ξ Γ (↓ N)
  η-μ⇑ t = μ⇑ (reveal UNDEFINED) -- {! ⟨ ⇑ lvar ∣ t ⟩ !}

  n-μ, : ∀ {Ξ Γ N M} → CTerm Ξ Γ (N ⅋ M) → CTerm Ξ Γ (N ⅋ M)
  n-μ, t = μ, ⟨ cast-invC t ∣ lvar , lvar ⟩ -- The two lvars are in different contexts, so they have different types!

  η-μ⟨⟩ : ∀ {Ξ Γ} → CTerm Ξ Γ c⊥ → CTerm Ξ Γ c⊥
  η-μ⟨⟩ t = μ⟨⟩ ⟨ t ∣ ⟨⟩ ⟩

  η-μ⦃⦄ : ∀ {Ξ Γ N} → CTerm Ξ Γ (¿ N) → CTerm Ξ Γ (¿ N)
  η-μ⦃⦄ t = μ⦃⦄ ⟨  cast-invC (reveal UNDEFINED) {- weaken t -} ∣ ⦃⦄ (vvar vThis) ⟩

  β-expand-μ⟨⟩ : ∀ {Ξ Γ} → Cmd Ξ Γ → Cmd Ξ Γ
  β-expand-μ⟨⟩ c = ⟨ μ⟨⟩ c ∣ ⟨⟩ ⟩

  -- η-rules for sums look different.
  maybe-η-μ₁ : ∀ {Ξ Γ N M} → CTerm Ξ Γ N → CTerm Ξ Γ M → CTerm Ξ Γ (N & M)
  maybe-η-μ₁ t₁ t₂ = μ₁ ⟨ cast-invC t₁ ∣ lvar ⟩ μ₂  ⟨ cast-invC t₂ ∣ lvar ⟩

  η-μ₁ : ∀ {Ξ Γ N M} → CTerm Ξ Γ N → CTerm Ξ Γ M → CTerm Ξ Γ N
  η-μ₁ {M = M} t₁ t₂ =
    μ ⟨
      μ₁ ⟨ cast-invC (cast-invC t₁) ∣ lvar ⟩  μ₂ ⟨ cast-invC (cast-invC t₂) ∣ lvar ⟩
    ∣
      lvar ₁as (M †c)
    ⟩

  η-μ₂ : ∀ {Ξ Γ N M} → CTerm Ξ Γ N → CTerm Ξ Γ M → CTerm Ξ Γ M
  η-μ₂ {N = N} t₁ t₂ =
    μ ⟨
      μ₁ ⟨ cast-invC (cast-invC t₁) ∣ lvar ⟩  μ₂ ⟨ cast-invC (cast-invC t₂) ∣ lvar ⟩
    ∣
      lvar ₂as (N †c)
    ⟩

  -- Some syntactic sugar.
  _⊸_ : VType → CType → CType
  σ ⊸ τ = (σ †v) ⅋ τ

  _⇛_ : VType → CType → CType
  σ ⇛ τ = ! σ ⊸ τ

  -- Not checked again yet. This code comes from CBPV and was refactored for
  -- renamings done to get polarized L, so it might or might not work.

  cbnToCType : Type → CType
  cbnToCType (base ι) = ↑ (vB ι)
  cbnToCType (σ ⇒ τ) = ↓ (cbnToCType σ) ⇛ cbnToCType τ

  cbvToVType : Type → VType
  cbvToVType (base ι) = vB ι
  cbvToVType (σ ⇒ τ) = ↓ (cbvToVType σ ⇛ ↑ (cbvToVType τ))

  cbnToVType : Type → VType
  cbnToVType τ = ↓ (cbnToCType τ)

  cbvToCType : Type → CType
  cbvToCType τ = ↑ (cbvToVType τ)

  fromCBNCtx : Context → VContext
  fromCBNCtx Γ = mapVCtx cbnToVType Γ

  fromCBVCtx : Context → VContext
  fromCBVCtx Γ = mapVCtx cbvToVType Γ

  open import Data.List
  open Data.List using (List) public
  fromCBVToCompList : Context → List CType
  fromCBVToCompList Γ = mapVCtx cbvToCType Γ


FunExt: add a version with implicit arguments

{-# OPTIONS --without-K #-}
module Function.Extensionality where

open import Function.NP
open import Relation.Binary.PropositionalEquality.NP  -- renaming (subst to tr)

happly : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}
  → f ≡ g → (x : A) → f x ≡ g x
happly p x = ap (λ f → f x) p

postulate
    FunExt : Set
    λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f₀ f₁ : (x : A) → B x}{{fe : FunExt}}
           (f= : ∀ x → f₀ x ≡ f₁ x) → f₀ ≡ f₁

    happly-λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
      (fg : ∀ x → f x ≡ g x) → happly (λ= fg) ≡ fg

    λ=-happly : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
      (α : f ≡ g) → λ= (happly α) ≡ α

    -- This should be derivable if I had a proper proof of λ=
    tr-λ= : ∀ {a b p}{A : Set a}{B : A → Set b}{x}(P : B x → Set p)
              {f g : (x : A) → B x}{{fe : FunExt}}(fg : (x : A) → f x ≡ g x)
            → tr (λ f → P (f x)) (λ= fg) ≡ tr P (fg x)

!-α-λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
  (α : f ≡ g) → ! α ≡ λ= (!_ ∘ happly α)
!-α-λ= refl = ! λ=-happly refl

!-λ= : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x}{{fe : FunExt}}
  (fg : ∀ x → f x ≡ g x) → ! (λ= fg) ≡ λ= (!_ ∘ fg)
!-λ= fg = !-α-λ= (λ= fg) ∙ ap λ= (λ= (λ x → ap !_ (happly (happly-λ= fg) x)))

module _ {a b}{A : Set a}{B : A → Set b}{f₀ f₁ : (x : A) → B x}{{fe : FunExt}} where
  λ=ⁱ : (f= : ∀ {x} → f₀ x ≡ f₁ x) → f₀ ≡ f₁
  λ=ⁱ f= = λ= λ x → f= {x}


[ notes ] Commented out an unprovable conjecture

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

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

module FOT.FOTC.Data.Nat.Pow where

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

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

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

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

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

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

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

module FOT.FOTC.Data.Nat.Pow where

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

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

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

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

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