Show what would happen with fixpoints

Show what would happen with fixpoints

I looked on paper at what would happen with fixpoints for typed lambda calculus,
and we'd immediately need to use well-founded recursion to prove the fundamental
property. I conjecture that would go through, and Ahmed does use similar tricks.
At least, that might be less ugly than defining the relation via
well-founded induction, which still does not appear necessary.

Here I mark the corresponding location in the formal proof.

I haven't redone in full on paper the appplication case, but looking at
definitions and at the formalized proof, it appears I would incur no further
obligation: if we have related functions `(k, f1, df, f2) \in RV[sigma -> tau]`,
applying them now puts f1, df and f2 in the environment when evaluating their
body, but in the definition I sketched it does not require reproving that
`(j, f1, df, f2) \in RV[sigma -> tau]` for some `j < k`, while it requires for
the argument that `(j, v1, dv, v2) \in RV[sigma]`.

module Thesis.SIRelBigStep.FundamentalProperty where

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

open import Thesis.SIRelBigStep.IlcSILR

rfundamentalV3v : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
rfundamentalV3v x n ρ1 dρ ρ2 ρρ = ⟦ x ⟧RelVar3 ρρ

rfundamental3constV : ∀ {τ} k (c : Const τ) →
  rrelV3 τ (eval-const c) (deval (derive-const c) ∅ ∅) (eval-const c) k
rfundamental3constV k (lit n) = refl

rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k

rfundamental3svv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelV3 τ (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k
rfundamental3svv k (var x) ρ1 dρ ρ2 ρρ = rfundamentalV3v x k ρ1 dρ ρ2 ρρ
rfundamental3svv k (cons sv1 sv2) ρ1 dρ ρ2 ρρ = rfundamental3svv k sv1 ρ1 dρ ρ2 ρρ , rfundamental3svv k sv2 ρ1 dρ ρ2 ρρ
rfundamental3svv k (const c) ρ1 dρ ρ2 ρρ rewrite deval-derive-const-inv c ρ1 dρ = rfundamental3constV k c
rfundamental3svv k (abs t) ρ1 dρ ρ2 ρρ = (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ j j<k v1 dv v2 vv →
    -- If we replace abs t by rec t, here we would need to invoke (by
    -- well-founded recursion) rfundamental3svv on (abs t) at a smaller j, as follows:
    --   rfundamental3svv j (abs t) ρ1 dρ ρ2 (rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)
    -- As you'd expect, Agda's termination checker does not accept that call directly.
      rfundamental3 j t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)

rfundamental3sv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelT3 (val sv) (dval (derive-dsval sv)) (val sv) ρ1 dρ ρ2 k
rfundamental3sv k sv ρ1 dρ ρ2 ρρ .(eval sv ρ1) .(eval sv ρ2) .0 j<k (val .sv) (val .sv) = deval (derive-dsval sv) ρ1 dρ , dval (derive-dsval sv) , rfundamental3svv k sv ρ1 dρ ρ2 ρρ

open import Theorem.Groups-Nehemiah
rfundamental3primv : ∀ {σ τ} k p →
  ∀ v1 dv v2 → (vv : rrelV3 σ v1 dv v2 k) →
  rrelV3 τ (eval-primitive p v1) (deval-primitive p v1 dv) (eval-primitive p v2) k
rfundamental3primv k succ (natV n₁) (bang .(natV n)) (natV n) refl = refl
rfundamental3primv k succ (natV n) (dnatV dn) (natV .(dn + n)) refl = +-suc dn n
rfundamental3primv k add (pairV (natV a1) (natV b1))
  (dpairV (dnatV da) (dnatV db))
  (pairV (natV .(da + a1)) (natV .(db + b1)))
  (refl , refl) = ℕ-mn·pq=mp·nq {da} {db} {a1} {b1}
rfundamental3primv k add (pairV a1 b1)
  (dpairV (dnatV da) (bang b2))
  (pairV a2 .b2) (aa , refl) rewrite rrelV3→⊕ a1 (dnatV da) a2 aa = refl
rfundamental3primv k add (pairV a1 b1)
  (dpairV (bang a2) db)
  (pairV .a2 b2) (refl , bb) rewrite rrelV3→⊕ b1 db b2 bb = refl
rfundamental3primv k add (pairV a1 b1) (bang p2) .p2 refl = refl

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 k (val sv) = rfundamental3sv k sv
rfundamental3 (suc k) (primapp p sv) ρ1 dρ ρ2 ρρ
  .(eval-primitive p (eval sv ρ1)) .(eval-primitive p (eval sv ρ2)) .1 (s≤s j<k) (primapp .p .sv) (primapp .p .sv) =
   deval-primitive p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) , dprimapp p sv (derive-dsval sv) ,
     rfundamental3primv k p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2)
       (rfundamental3svv k sv ρ1 dρ ρ2 (rrelρ3-mono k (suc k) (≤-step ≤-refl) _ ρ1 dρ ρ2 ρρ))
-- (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k

rfundamental3 (suc (suc k)) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s (s≤s j<k))
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app n₁ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc (suc k)) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3 (suc (suc k)) (val vt) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | bang f2 , vs↓dsv , refl | dtv , vt↓dvv , dtvv
      rewrite sym (rrelV3→⊕ vtv1 dtv vtv2 dtvv) =
        bang v2 , bangapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv (suc k) ≤-refl vtv1 dtv vtv2
           (rrelV3-mono (suc k) (suc (suc k)) (s≤s (≤-step ≤-refl)) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j (s≤s j<k) ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv =
      dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv

rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ v1 dv v2 dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl

module Thesis.SIRelBigStep.FundamentalProperty where

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

open import Thesis.SIRelBigStep.IlcSILR

rfundamentalV3v : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
rfundamentalV3v x n ρ1 dρ ρ2 ρρ = ⟦ x ⟧RelVar3 ρρ

rfundamental3constV : ∀ {τ} k (c : Const τ) →
  rrelV3 τ (eval-const c) (deval (derive-const c) ∅ ∅) (eval-const c) k
rfundamental3constV k (lit n) = refl

rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k

rfundamental3svv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelV3 τ (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k
rfundamental3svv k (var x) ρ1 dρ ρ2 ρρ = rfundamentalV3v x k ρ1 dρ ρ2 ρρ
rfundamental3svv k (cons sv1 sv2) ρ1 dρ ρ2 ρρ = rfundamental3svv k sv1 ρ1 dρ ρ2 ρρ , rfundamental3svv k sv2 ρ1 dρ ρ2 ρρ
rfundamental3svv k (const c) ρ1 dρ ρ2 ρρ rewrite deval-derive-const-inv c ρ1 dρ = rfundamental3constV k c
rfundamental3svv k (abs t) ρ1 dρ ρ2 ρρ = (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ j j<k v1 dv v2 vv →
      rfundamental3 j t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)

rfundamental3sv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelT3 (val sv) (dval (derive-dsval sv)) (val sv) ρ1 dρ ρ2 k
rfundamental3sv k sv ρ1 dρ ρ2 ρρ .(eval sv ρ1) .(eval sv ρ2) .0 j<k (val .sv) (val .sv) = deval (derive-dsval sv) ρ1 dρ , dval (derive-dsval sv) , rfundamental3svv k sv ρ1 dρ ρ2 ρρ

open import Theorem.Groups-Nehemiah
rfundamental3primv : ∀ {σ τ} k p →
  ∀ v1 dv v2 → (vv : rrelV3 σ v1 dv v2 k) →
  rrelV3 τ (eval-primitive p v1) (deval-primitive p v1 dv) (eval-primitive p v2) k
rfundamental3primv k succ (natV n₁) (bang .(natV n)) (natV n) refl = refl
rfundamental3primv k succ (natV n) (dnatV dn) (natV .(dn + n)) refl = +-suc dn n
rfundamental3primv k add (pairV (natV a1) (natV b1))
  (dpairV (dnatV da) (dnatV db))
  (pairV (natV .(da + a1)) (natV .(db + b1)))
  (refl , refl) = ℕ-mn·pq=mp·nq {da} {db} {a1} {b1}
rfundamental3primv k add (pairV a1 b1)
  (dpairV (dnatV da) (bang b2))
  (pairV a2 .b2) (aa , refl) rewrite rrelV3→⊕ a1 (dnatV da) a2 aa = refl
rfundamental3primv k add (pairV a1 b1)
  (dpairV (bang a2) db)
  (pairV .a2 b2) (refl , bb) rewrite rrelV3→⊕ b1 db b2 bb = refl
rfundamental3primv k add (pairV a1 b1) (bang p2) .p2 refl = refl

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 k (val sv) = rfundamental3sv k sv
rfundamental3 (suc k) (primapp p sv) ρ1 dρ ρ2 ρρ
  .(eval-primitive p (eval sv ρ1)) .(eval-primitive p (eval sv ρ2)) .1 (s≤s j<k) (primapp .p .sv) (primapp .p .sv) =
   deval-primitive p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) , dprimapp p sv (derive-dsval sv) ,
     rfundamental3primv k p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2)
       (rfundamental3svv k sv ρ1 dρ ρ2 (rrelρ3-mono k (suc k) (≤-step ≤-refl) _ ρ1 dρ ρ2 ρρ))
-- (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k

rfundamental3 (suc (suc k)) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s (s≤s j<k))
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app n₁ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc (suc k)) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3 (suc (suc k)) (val vt) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | bang f2 , vs↓dsv , refl | dtv , vt↓dvv , dtvv
      rewrite sym (rrelV3→⊕ vtv1 dtv vtv2 dtvv) =
        bang v2 , bangapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv (suc k) ≤-refl vtv1 dtv vtv2
           (rrelV3-mono (suc k) (suc (suc k)) (s≤s (≤-step ≤-refl)) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j (s≤s j<k) ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv =
      dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv

rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ v1 dv v2 dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl


Simplify code

Simplify code

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Bags of integers, for Nehemiah plugin.
--
-- This module imports postulates about bags of integers
-- with negative multiplicities as a group under additive union.
------------------------------------------------------------------------

module Structure.Bag.Nehemiah where

open import Postulate.Bag-Nehemiah public

open import Relation.Binary.PropositionalEquality
open import Algebra using (CommutativeRing)
open import Algebra.Structures
open import Data.Integer
open import Data.Integer.Properties
  using ()
  renaming (commutativeRing to ℤ-is-commutativeRing)
open import Data.Product

infixl 9 _\\_ -- same as Data.Map.(\\)
_\\_ : Bag → Bag → Bag
d \\ b = d ++ (negateBag b)

-- Useful properties of abelian groups
commutative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (m n : A) → f m n ≡ f n m
commutative = IsAbelianGroup.comm

associative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (k m n : A) → f (f k m) n ≡ f k (f m n)
associative abelian = IsAbelianGroup.assoc abelian

left-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f (neg n) n ≡ z
left-inverse abelian = proj₁ (IsAbelianGroup.inverse abelian)
right-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n (neg n) ≡ z
right-inverse abelian = proj₂ (IsAbelianGroup.inverse abelian)

left-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f z n ≡ n
left-identity abelian = proj₁ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))
right-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n z ≡ n
right-identity abelian = proj₂ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))

instance
  abelian-int : IsAbelianGroup _≡_ _+_ (+ 0) (-_)
  abelian-int =
    CommutativeRing.+-isAbelianGroup ℤ-is-commutativeRing

commutative-int : (m n : ℤ) → m + n ≡ n + m
commutative-int = commutative abelian-int
associative-int : (k m n : ℤ) → (k + m) + n ≡ k + (m + n)
associative-int = associative abelian-int
right-inv-int : (n : ℤ) → n - n ≡ + 0
right-inv-int = right-inverse abelian-int
left-id-int : (n : ℤ) → (+ 0) + n ≡ n
left-id-int = left-identity abelian-int
right-id-int : (n : ℤ) → n + (+ 0) ≡ n
right-id-int = right-identity abelian-int

commutative-bag : (a b : Bag) → a ++ b ≡ b ++ a
commutative-bag = commutative abelian-bag
associative-bag : (a b c : Bag) → (a ++ b) ++ c ≡ a ++ (b ++ c)
associative-bag = associative abelian-bag
right-inv-bag : (b : Bag) → b \\ b ≡ emptyBag
right-inv-bag = right-inverse abelian-bag
left-id-bag : (b : Bag) → emptyBag ++ b ≡ b
left-id-bag = left-identity abelian-bag
right-id-bag : (b : Bag) → b ++ emptyBag ≡ b
right-id-bag = right-identity abelian-bag

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Bags of integers, for Nehemiah plugin.
--
-- This module imports postulates about bags of integers
-- with negative multiplicities as a group under additive union.
------------------------------------------------------------------------

module Structure.Bag.Nehemiah where

open import Postulate.Bag-Nehemiah public

open import Relation.Binary.PropositionalEquality
open import Algebra using (CommutativeRing)
open import Algebra.Structures
open import Data.Integer
open import Data.Integer.Properties
  using ()
  renaming (commutativeRing to ℤ-is-commutativeRing)
open import Data.Product

infixl 9 _\\_ -- same as Data.Map.(\\)
_\\_ : Bag → Bag → Bag
d \\ b = d ++ (negateBag b)

-- Useful properties of abelian groups
commutative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (m n : A) → f m n ≡ f n m
commutative = IsAbelianGroup.comm

associative : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (k m n : A) → f (f k m) n ≡ f k (f m n)
associative abelian = IsAbelianGroup.assoc abelian

left-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f (neg n) n ≡ z
left-inverse abelian = proj₁ (IsAbelianGroup.inverse abelian)
right-inverse : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n (neg n) ≡ z
right-inverse abelian = proj₂ (IsAbelianGroup.inverse abelian)

left-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f z n ≡ n
left-identity abelian = proj₁ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))
right-identity : ∀ {A : Set} {f : A → A → A} {z neg} →
  IsAbelianGroup _≡_ f z neg → (n : A) → f n z ≡ n
right-identity abelian = proj₂ (IsMonoid.identity
  (IsGroup.isMonoid (IsAbelianGroup.isGroup abelian)))

instance
  abelian-int : IsAbelianGroup _≡_ _+_ (+ 0) (-_)
  abelian-int =
    IsRing.+-isAbelianGroup
    (IsCommutativeRing.isRing
    (CommutativeRing.isCommutativeRing
    ℤ-is-commutativeRing))
commutative-int : (m n : ℤ) → m + n ≡ n + m
commutative-int = commutative abelian-int
associative-int : (k m n : ℤ) → (k + m) + n ≡ k + (m + n)
associative-int = associative abelian-int
right-inv-int : (n : ℤ) → n - n ≡ + 0
right-inv-int = right-inverse abelian-int
left-id-int : (n : ℤ) → (+ 0) + n ≡ n
left-id-int = left-identity abelian-int
right-id-int : (n : ℤ) → n + (+ 0) ≡ n
right-id-int = right-identity abelian-int

commutative-bag : (a b : Bag) → a ++ b ≡ b ++ a
commutative-bag = commutative abelian-bag
associative-bag : (a b c : Bag) → (a ++ b) ++ c ≡ a ++ (b ++ c)
associative-bag = associative abelian-bag
right-inv-bag : (b : Bag) → b \\ b ≡ emptyBag
right-inv-bag = right-inverse abelian-bag
left-id-bag : (b : Bag) → emptyBag ++ b ≡ b
left-id-bag = left-identity abelian-bag
right-id-bag : (b : Bag) → b ++ emptyBag ≡ b
right-id-bag = right-identity abelian-bag


Added doc.

Added doc.

Ignore-this: c1455481229df75e5be9f89856ffb5de

darcs-hash:20110301054603-3bd4e-4ac1de2906d09058197378b316fe83b04bd5c72c.gz

----------------------------------------------------------------------------
-- Well-founded induction on the relation MCR
----------------------------------------------------------------------------

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.MCR.Induction.Acc.WellFoundedInductionATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFounded
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers

open import FOTC.Program.McCarthy91.MCR
open import FOTC.Program.McCarthy91.MCR.PropertiesATP

import FOTC.Data.Nat.Induction.Acc.WellFoundedInduction
open module WF-LT =
  FOTC.Data.Nat.Induction.Acc.WellFoundedInduction.WF-LT₂
  x<0→⊥ x≤y→x<y∨x≡y x<Sy→x≤y

open module II =
  FOTC.Data.Nat.Induction.Acc.WellFounded.InverseImage {LT} MCR-f MCR-f-N

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

-- The relation MCR is well-founded.
wf-MCR : WellFounded MCR
wf-MCR Nn = wellFounded wf-LT Nn

-- Well-founded induction on the relation MCR.
wfInd-MCR : (P : D → Set) →
            (∀ {n} → N n → (∀ {m} → N m → MCR m n → P m) → P n) →
            ∀ {n} → N n → P n
wfInd-MCR P = WellFoundedInduction wf-MCR

----------------------------------------------------------------------------
-- Well-founded induction on the relation MCR
----------------------------------------------------------------------------

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.MCR.Induction.Acc.WellFoundedInductionATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFounded
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers

open import FOTC.Program.McCarthy91.MCR
open import FOTC.Program.McCarthy91.MCR.PropertiesATP

import FOTC.Data.Nat.Induction.Acc.WellFoundedInduction
open module WF-LT =
  FOTC.Data.Nat.Induction.Acc.WellFoundedInduction.WF-LT₂
  x<0→⊥ x≤y→x<y∨x≡y x<Sy→x≤y

open module II =
  FOTC.Data.Nat.Induction.Acc.WellFounded.InverseImage {LT} MCR-f MCR-f-N

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

wf-MCR : WellFounded MCR
wf-MCR Nn = wellFounded wf-LT Nn

wfInd-MCR : (P : D → Set) →
            (∀ {n} → N n → (∀ {m} → N m → MCR m n → P m) → P n) →
            ∀ {n} → N n → P n
wfInd-MCR P = WellFoundedInduction wf-MCR


FLABloM: error in fromNat?

FLABloM: error in fromNat?

module Shape where
open import Data.Product
open import Data.Maybe

-- shape of matrix
data Shape : Set where
  -- 1
  L : Shape
  -- s₁ + s₂
  B : (s₁ s₂ : Shape) → Shape

open import Data.Nat

toNat : Shape → ℕ
toNat L         = 1
toNat (B s s₁)  = toNat s + toNat s₁

-- | Divide in two (almost) equal parts
split : ℕ  ->  ℕ × ℕ
split zero       = (zero , zero)
split (suc zero) = (suc zero , zero)
split (suc (suc n)) with split n
... | (n1 , n2)  = (suc n1 , suc n2)

{-# NO_TERMINATION_CHECK #-}
-- Compute a balanced shape
fromNat : ℕ → Maybe Shape
fromNat zero     = nothing
fromNat (suc n)  with split n
... | (n1 , n2) with fromNat n1 | fromNat n2
...   | nothing  | nothing  = nothing
...   | just s1  | nothing  = just s1
...   | nothing  | just s2  = just s2
...   | just s1  | just s2  = just (B s1 s2)

-- TODO: perhaps add an empty shape (but probably in a separate
-- experiment file because many things change in the matrix
-- representation).

-- TODO: `∀ n → fromNat n ≡ nothing` seems like its true


Another more specialized type example in the tactics file.

{-
This file demonstrates a technique that simulates the ability to
pattern match against function calls rather than just variables
or constructors.

This technique is necessary to write certain kinds of tactics
as generic functions.
-}

module TacticsMatchingFunctionCalls where
open import Data.Bool hiding ( _≟_ )
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Product hiding ( map )
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function

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

{-
Zero is the right identity of addition on the natural numbers.
-}

plusrident : (n : ℕ) → n ≡ n + 0
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

{-
Arith is a universe of codes representing the natural numbers
along with a limited set of functions over them. We would like to write
tactics that pattern match against types indexed by applications of
these functions.
-}

data Arith : Set where
  `zero : Arith
  `suc : (a : Arith) → Arith
  _`+_ _`*_ : (a₁ a₂ : Arith) → Arith

eval : Arith → ℕ
eval `zero = zero
eval (`suc a) = suc (eval a)
eval (a₁ `+ a₂) = eval a₁ + eval a₂
eval (a₁ `* a₂) = eval a₁ * eval a₂

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

{-
Φ (standing for *function*-indexed types)
represents an indexed type, but we *can* pattern
match on function calls in its index position.

A - The type of codes, including constructors and functions.
  i.e. Arith
A′ - The model underlying the codes.
  i.e. ℕ
el - The evaluation function from code values to model values.
  i.e. eval
B - The genuine indexed datatype that Φ represents.
  i.e. Fin
a - The index value as a code, which may be a function call and hence supports
    pattern matching.
  i.e. (a `+ `zero)
-}

data Φ (A A′ : Set) (el : A → A′) (B : A′ → Set) (a : A) : Set where
  φ : (b : B (el a)) → Φ A A′ el B a

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

{-
Alternatively, we can specialize Φ to our Arith universe. This may be
a good use of our ability to cheaply define new datatypes via Desc.
-}

data ΦArith (B : ℕ → Set) (a : Arith) : Set where
  φ : (b : B (eval a)) → ΦArith B a

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

{-
Going further, we could even specialize B in ΦArith to Fin.
-}

data Fin₂ (a : Arith) : Set where
  fin : (i : Fin (eval a)) → Fin₂ a

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

{-
A small universe of dependent types that is sufficient for the
examples given below.
-}

data Type : Set
⟦_⟧ : Type → Set

data Type where
  `Bool `ℕ `Arith : Type
  `Fin : (n : ℕ) → Type
  `Φ : (A A′ : Type)
    (el : ⟦ A ⟧ → ⟦ A′ ⟧)
    (B : ⟦ A′ ⟧ → Type)
    (a : ⟦ A ⟧)
    → Type
  `ΦArith : (B : ℕ → Type) (a : Arith) → Type
  `Fin₂ : (a : Arith) → Type
  `Π `Σ : (A : Type) (B : ⟦ A ⟧ → Type) → Type
  `Id : (A : Type) (x y : ⟦ A ⟧) → Type

⟦ `Bool ⟧ = Bool
⟦ `ℕ ⟧ = ℕ
⟦ `Arith ⟧ = Arith
⟦ `Fin n ⟧ = Fin n
⟦ `Φ A A′ el B a ⟧ = Φ ⟦ A ⟧ ⟦ A′ ⟧ el (λ a → ⟦ B a ⟧) a
⟦ `ΦArith B a ⟧ = ΦArith (λ x → ⟦ B x ⟧) a
⟦ `Fin₂ a ⟧ = Fin₂ a
⟦ `Π A B ⟧ = (a : ⟦ A ⟧) → ⟦ B a ⟧
⟦ `Σ A B ⟧ = Σ ⟦ A ⟧ (λ a → ⟦ B a ⟧)
⟦ `Id A x y ⟧ = x ≡ y

_`→_ : (A B : Type) → Type
A `→ B = `Π A (const B)

_`×_ : (A B : Type) → Type
A `× B = `Σ A (const B)

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

{-
Tactics are represented as generic functions taking a Dynamic value (of
any type), and returning a Dynamic value (at a possibly different type).
The convention is to behave like the identity function if the tactic
doesn't match the current value or fails.

In practice, the context will be a List of Dynamic values, and a tactic
will map a Context to a Context. For simplicity, the tactics I give below
only map a Dynamic to a Dynamic.
-}

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

{-
Here is an example of a tactic that only needs to pattern match on a
variable or constructor, but not a function. We don't encounter
any problems when writing this kind of a tactic.

The tactic below changes a `Fin n` value into a `Fin (n + 0)` value.
-}

add-plus0-Fin : Tactic
add-plus0-Fin (`Fin n , i) = `Fin (n + 0) , subst Fin (plusrident n) i
add-plus0-Fin x = x

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

{-
In contrast, it is not straightforward to write tactics that need
to pattern match on function calls.
For example, below is ideally what we want to write to change
a value of `Fin (n + 0)` to a value of `Fin n`.
-}

-- rm-plus0-Fin : Tactic
-- rm-plus0-Fin (`Fin (n + 0) , i) = `Fin n , subst Fin (sym (plusrident n)) i
-- rm-plus0-Fin x = x

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

{-
Instead of matching directly on `Fin, we can match on a `Φ that
represents `Fin. This allows us to match on the the `+ function call
in the index position.

Because we cannot match against the function `el` (we would like to match
it against `eval`), we add to our return type that proves the
extentional equality between `el` and `eval`.

Also note that the tactic below can be used for any type indexed by
ℕ, not just Fin.
-}

rm-plus0 : Tactic
rm-plus0 (`Φ `Arith `ℕ el B (a `+ `zero) , φ b) =
  `Π `Arith (λ x → `Id `ℕ (el x) (eval x))
  `→
  `Φ `Arith `ℕ el B a
  ,
  λ f → φ
  (subst (λ x → ⟦ B x ⟧)
         (sym (f a))
         (subst (λ x → ⟦ B x ⟧)
                (sym (plusrident (eval a)))
                (subst (λ x → ⟦ B x ⟧)
                       (f (a `+ `zero))
                       b)))
rm-plus0 x = x

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

{-
Now it is possible to apply the generic tactic to a specific
value and have the desired behavior occur. Notice that the generated
extentional equality premise is trivially provable because
eval is always equal to eval.
-}

eg-rm-plus0 : (a : Arith)
  → ⟦ `Φ `Arith `ℕ eval `Fin (a `+ `zero) ⟧
  → ⟦ `Φ `Arith `ℕ eval `Fin a ⟧
eg-rm-plus0 a (φ i) = proj₂
  (rm-plus0 (`Φ `Arith `ℕ eval `Fin (a `+ `zero) , φ i))
  (λ _ → refl)

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

{-
Here is the same tactic but using the specialized ΦArith type.
-}

rm-plus0-Arith : Tactic
rm-plus0-Arith (`ΦArith B (a `+ `zero) , φ i) =
  `ΦArith B a
  ,
  φ (subst (λ x → ⟦ B x ⟧) (sym (plusrident (eval a))) i)
rm-plus0-Arith x = x

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

{-
And the same example usage, this time without needing to prove a premise.
-}

eg-rm-plus0-Arith : (a : Arith)
  → ⟦ `ΦArith `Fin (a `+ `zero) ⟧
  → ⟦ `ΦArith `Fin a ⟧
eg-rm-plus0-Arith a (φ i) = proj₂
  (rm-plus0-Arith (`ΦArith `Fin (a `+ `zero) , φ i))

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

{-
Finally, here is the same tactic but using the even more
specialized Fin₂ type.
-}

rm-plus0-Fin : Tactic
rm-plus0-Fin (`Fin₂ (a `+ `zero) , fin i) =
  `Fin₂ a
  ,
  fin (subst (λ x → ⟦ `Fin x ⟧) (sym (plusrident (eval a))) i)
rm-plus0-Fin x = x

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

eg-rm-plus0-Fin : (a : Arith)
  → ⟦ `Fin₂ (a `+ `zero) ⟧
  → ⟦ `Fin₂ a ⟧
eg-rm-plus0-Fin a (fin i) = proj₂
  (rm-plus0-Fin (`Fin₂ (a `+ `zero) , fin i))

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

{-
This file demonstrates a technique that simulates the ability to
pattern match against function calls rather than just variables
or constructors.

This technique is necessary to write certain kinds of tactics
as generic functions.
-}

module TacticsMatchingFunctionCalls where
open import Data.Bool hiding ( _≟_ )
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Product hiding ( map )
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function

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

{-
Zero is the right identity of addition on the natural numbers.
-}

plusrident : (n : ℕ) → n ≡ n + 0
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

{-
Arith is a universe of codes representing the natural numbers
along with a limited set of functions over them. We would like to write
tactics that pattern match against types indexed by applications of
these functions.
-}

data Arith : Set where
  `zero : Arith
  `suc : (a : Arith) → Arith
  _`+_ _`*_ : (a₁ a₂ : Arith) → Arith

eval : Arith → ℕ
eval `zero = zero
eval (`suc a) = suc (eval a)
eval (a₁ `+ a₂) = eval a₁ + eval a₂
eval (a₁ `* a₂) = eval a₁ * eval a₂

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

{-
Φ (standing for *function*-indexed types)
represents an indexed type, but we *can* pattern
match on function calls in its index position.

A - The type of codes, including constructors and functions.
  i.e. Arith
A′ - The model underlying the codes.
  i.e. ℕ
el - The evaluation function from code values to model values.
  i.e. eval
B - The genuine indexed datatype that Φ represents.
  i.e. Fin
a - The index value as a code, which may be a function call and hence supports
    pattern matching.
  i.e. (a `+ `zero)
-}

data Φ (A A′ : Set) (el : A → A′) (B : A′ → Set) (a : A) : Set where
  φ : (b : B (el a)) → Φ A A′ el B a

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

{-
Alternatively, we can specialize Φ to our Arith universe. This may be
a good use of our ability to cheaply define new datatypes via Desc.
-}

data ΦArith (B : ℕ → Set) (a : Arith) : Set where
  φ : (b : B (eval a)) → ΦArith B a

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

{-
A small universe of dependent types that is sufficient for the
examples given below.
-}

data Type : Set
⟦_⟧ : Type → Set

data Type where
  `Bool `ℕ `Arith : Type
  `Fin : (n : ℕ) → Type
  `Φ : (A A′ : Type)
    (el : ⟦ A ⟧ → ⟦ A′ ⟧)
    (B : ⟦ A′ ⟧ → Type)
    (a : ⟦ A ⟧)
    → Type
  `ΦArith : (B : ℕ → Type) (a : Arith) → Type
  `Π `Σ : (A : Type) (B : ⟦ A ⟧ → Type) → Type
  `Id : (A : Type) (x y : ⟦ A ⟧) → Type

⟦ `Bool ⟧ = Bool
⟦ `ℕ ⟧ = ℕ
⟦ `Arith ⟧ = Arith
⟦ `Fin n ⟧ = Fin n
⟦ `Φ A A′ el B a ⟧ = Φ ⟦ A ⟧ ⟦ A′ ⟧ el (λ a → ⟦ B a ⟧) a
⟦ `ΦArith B a ⟧ = ΦArith (λ x → ⟦ B x ⟧) a
⟦ `Π A B ⟧ = (a : ⟦ A ⟧) → ⟦ B a ⟧
⟦ `Σ A B ⟧ = Σ ⟦ A ⟧ (λ a → ⟦ B a ⟧)
⟦ `Id A x y ⟧ = x ≡ y

_`→_ : (A B : Type) → Type
A `→ B = `Π A (const B)

_`×_ : (A B : Type) → Type
A `× B = `Σ A (const B)

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

{-
Tactics are represented as generic functions taking a Dynamic value (of
any type), and returning a Dynamic value (at a possibly different type).
The convention is to behave like the identity function if the tactic
doesn't match the current value or fails.

In practice, the context will be a List of Dynamic values, and a tactic
will map a Context to a Context. For simplicity, the tactics I give below
only map a Dynamic to a Dynamic.
-}

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

{-
Here is an example of a tactic that only needs to pattern match on a
variable or constructor, but not a function. We don't encounter
any problems when writing this kind of a tactic.

The tactic below changes a `Fin n` value into a `Fin (n + 0)` value.
-}

add-plus0-Fin : Tactic
add-plus0-Fin (`Fin n , i) = `Fin (n + 0) , subst Fin (plusrident n) i
add-plus0-Fin x = x

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

{-
In contrast, it is not straightforward to write tactics that need
to pattern match on function calls.
For example, below is ideally what we want to write to change
a value of `Fin (n + 0)` to a value of `Fin n`.
-}

-- rm-plus0-Fin : Tactic
-- rm-plus0-Fin (`Fin (n + 0) , i) = `Fin n , subst Fin (sym (plusrident n)) i
-- rm-plus0-Fin x = x

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

{-
Instead of matching directly on `Fin, we can match on a `Φ that
represents `Fin. This allows us to match on the the `+ function call
in the index position.

Because we cannot match against the function `el` (we would like to match
it against `eval`), we add to our return type that proves the
extentional equality between `el` and `eval`.

Also note that the tactic below can be used for any type indexed by
ℕ, not just Fin.
-}

rm-plus0 : Tactic
rm-plus0 (`Φ `Arith `ℕ el B (a `+ `zero) , φ b) =
  `Π `Arith (λ x → `Id `ℕ (el x) (eval x))
  `→
  `Φ `Arith `ℕ el B a
  ,
  λ f → φ
  (subst (λ x → ⟦ B x ⟧)
         (sym (f a))
         (subst (λ x → ⟦ B x ⟧)
                (sym (plusrident (eval a)))
                (subst (λ x → ⟦ B x ⟧)
                       (f (a `+ `zero))
                       b)))
rm-plus0 x = x

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

{-
Now it is possible to apply the generic tactic to a specific
value and have the desired behavior occur. Notice that the generated
extentional equality premise is trivially provable because
eval is always equal to eval.
-}

eg-rm-plus0 : (a : Arith)
  → ⟦ `Φ `Arith `ℕ eval `Fin (a `+ `zero) ⟧
  → ⟦ `Φ `Arith `ℕ eval `Fin a ⟧
eg-rm-plus0 a (φ i) = proj₂
  (rm-plus0 (`Φ `Arith `ℕ eval `Fin (a `+ `zero) , φ i))
  (λ _ → refl)

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

{-
Here is the same tactic but using the specialized ΦArith type.
-}

rm-plus0-Arith : Tactic
rm-plus0-Arith (`ΦArith B (a `+ `zero) , φ b) =
  `ΦArith B a
  ,
  φ (subst (λ x → ⟦ B x ⟧) (sym (plusrident (eval a))) b)
rm-plus0-Arith x = x

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

{-
And the same example usage, this time without needing to prove a premise.
-}

eg-rm-plus0-Arith : (a : Arith)
  → ⟦ `ΦArith `Fin (a `+ `zero) ⟧
  → ⟦ `ΦArith `Fin a ⟧
eg-rm-plus0-Arith a (φ i) = proj₂
  (rm-plus0-Arith (`ΦArith `Fin (a `+ `zero) , φ i))

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


refactoring a bit #4

refactoring a bit #4

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

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- values and indeterminates are disjoint
  vi : ∀{d} → d val → d indet → ⊥
  vi VConst ()
  vi VLam ()

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- todo: these are bad names
  lem2 : ∀{d Δ d'} → d indet → Δ ⊢ d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp () x₁) (ITLam x₂)

  lem3 : ∀{d Δ d'} → d val → Δ ⊢ d →> d' → ⊥
  lem3 VConst ()
  lem3 VLam ()

  lem1 : ∀{d Δ d'} → d final → Δ ⊢ d →> d' → ⊥
  lem1 (FVal x) st = lem3 x st
  lem1 (FIndet x) st = lem2 x st

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (_ , Step (FHFinal x) q _) = lem1 x q
  is IEHole (_ , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (_ , Step (FHFinal x₁) q _) = lem1 x₁ q
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (_ , Step (FHFinal x₁) q _) = lem1 x₁ q
  is (IAp i x) (_ , Step (FHAp1 x₁ p) q (FHAp1 x₂ r)) = {!!}
  is (IAp i x) (_ , Step (FHAp2 p) q (FHAp2 r)) = {!!}

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  es (ECastError x x₁) (d' , Step (FHFinal (FVal ())) x₃ x₄)
  es (ECastError x x₁) (d' , Step (FHFinal (FIndet ())) x₃ x₄)
--  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}

  es (ECastError x x₁) (d' , Step (FHCastFinal (FVal x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (ECastError x x₁) (d' , Step (FHCastFinal (FIndet x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (EAp1 e) (d , Step (FHFinal (FVal x)) x₁ q) = vs x (d , Step (FHFinal (FVal x)) x₁ q)
  es (EAp1 e) (d , Step (FHFinal (FIndet x)) x₁ q) = is x (d , Step (FHFinal (FIndet x)) x₁ q)
  es (EAp1 e) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = {!!}
  es (EAp1 e) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = {!!}
  es (EAp2 e) s = {!!}

  --es (ENEHole e) x = {!e!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step FHNEHoleEvaled x₂ x₃) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleInside x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  -- es (ENEHole e) (d' , Step (FHFinal (FVal ())) x₁ x₂)
  -- es (ENEHole e) (d' , Step (FHFinal (FIndet (INEHole x))) () x₂)
  -- es (ENEHole e) (d' , Step FHNEHoleEvaled () x₂)
  -- es (ENEHole e) (_ , Step (FHNEHoleInside x) x₁ (FHNEHoleInside x₂)) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FVal ())))
  -- es (ENEHole (ECastError x x₁)) (_ , Step (FHNEHoleFinal x₂) (ITNEHole x₃) (FHFinal (FIndet (INEHole x₄)))) = {!x₁!}
  -- es (ENEHole (EAp1 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (EAp2 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ENEHole e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ECastProp e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) FHNEHoleEvaled) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FVal x)) (ITCast x₁ x₂ x₃) x₄) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FIndet x)) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}

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

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that values, indeterminates, errors, and
-- expressions that step are pairwise disjoint. (note that as a consequence
-- of currying and comutativity of products, this means that there are six
-- theorems to prove)
module progress-checks where
  -- values and indeterminates are disjoint
  vi : ∀{d} → d val → d indet → ⊥
  vi VConst ()
  vi VLam ()

  -- values and errors are disjoint
  ve : ∀{d Δ} → d val → Δ ⊢ d err → ⊥
  ve VConst ()
  ve VLam ()

  -- values and expressions that step are disjoint
  vs : ∀{d Δ} → d val → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  vs VConst (d , Step (FHFinal x) () (FHFinal x₂))
  vs VConst (_ , Step (FHFinal x) () FHEHole)
  vs VConst (_ , Step (FHFinal x) () FHNEHoleEvaled)
  vs VConst (_ , Step (FHFinal x) () (FHNEHoleFinal x₂))
  vs VConst (_ , Step (FHFinal x) () (FHCastFinal x₂))
  vs VLam (d , Step (FHFinal x₁) () (FHFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () FHEHole)
  vs VLam (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  vs VLam (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₃))
  vs VLam (_ , Step (FHFinal x₁) () (FHCastFinal x₃))

  -- indeterminates and errors are disjoint
  ie : ∀{d Δ} → d indet → Δ ⊢ d err → ⊥
  ie IEHole ()
  ie (INEHole (FVal x)) (ENEHole e) = ve x e
  ie (INEHole (FIndet x)) (ENEHole e) = ie x e
  ie (IAp i x) (EAp1 e) = ie i e
  ie (IAp i (FVal x)) (EAp2 e) = ve x e
  ie (IAp i (FIndet x)) (EAp2 e) = ie x e

  -- indeterminates and expressions that step are disjoint
  is : ∀{d Δ} → d indet → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  is IEHole (d0' , Step (FHFinal x) () (FHFinal x₁))
  is IEHole (d0' , Step FHEHole () (FHFinal x))
  is IEHole (_ , Step (FHFinal x) () FHEHole)
  is IEHole (_ , Step FHEHole () FHEHole)
  is IEHole (_ , Step (FHFinal x) () FHNEHoleEvaled)
  is IEHole (_ , Step FHEHole () FHNEHoleEvaled)
  is IEHole (_ , Step (FHFinal x) () (FHNEHoleFinal x₁))
  is IEHole (_ , Step FHEHole () (FHNEHoleFinal x))
  is IEHole (_ , Step (FHFinal x) () (FHCastFinal x₁))
  is IEHole (_ , Step FHEHole () (FHCastFinal x))
  is (INEHole x) (d , Step (FHFinal x₁) () (FHFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () FHEHole)
  is (INEHole x) (_ , Step (FHFinal x₁) () FHNEHoleEvaled)
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHNEHoleFinal x₂))
  is (INEHole x) (_ , Step (FHFinal x₁) () (FHCastFinal x₂))
  is (INEHole x) (d , Step FHNEHoleEvaled () (FHFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHEHole)
  is (INEHole x) (_ , Step FHNEHoleEvaled () FHNEHoleEvaled)
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHNEHoleFinal x₁))
  is (INEHole x) (_ , Step FHNEHoleEvaled () (FHCastFinal x₁))
  is (IAp i x) (d' , Step p q r) = {!!}

  -- errors and expressions that step are disjoint
  es : ∀{d Δ} → Δ ⊢ d err → (Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')) → ⊥
  es (ECastError x x₁) (d' , Step (FHFinal (FVal ())) x₃ x₄)
  es (ECastError x x₁) (d' , Step (FHFinal (FIndet ())) x₃ x₄)
--  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}
  es (ECastError x x₁) (_ , Step (FHCast x₂) x₃ (FHCast x₄)) = {!x₂!}

  es (ECastError x x₁) (d' , Step (FHCastFinal (FVal x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (ECastError x x₁) (d' , Step (FHCastFinal (FIndet x₂)) (ITCast x₃ x₄ x₅) x₆)
    with type-assignment-unicity x x₄
  ... | refl = ~apart x₁ x₅
  es (EAp1 e) (d , Step (FHFinal (FVal x)) x₁ q) = vs x (d , Step (FHFinal (FVal x)) x₁ q)
  es (EAp1 e) (d , Step (FHFinal (FIndet x)) x₁ q) = is x (d , Step (FHFinal (FIndet x)) x₁ q)
  es (EAp1 e) (_ , Step (FHAp1 x x₁) x₂ (FHAp1 x₃ x₄)) = {!!}
  es (EAp1 e) (_ , Step (FHAp2 x) x₁ (FHAp2 x₂)) = {!!}
  es (EAp2 e) s = {!!}

  --es (ENEHole e) x = {!e!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step FHNEHoleEvaled x₂ x₃) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleInside x₂) x₃ x₄) = {!!}
  es (ENEHole (ECastError x x₁)) (d' , Step (FHNEHoleFinal x₂) x₃ x₄) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp1 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (EAp2 e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ENEHole e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHFinal x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step FHNEHoleEvaled x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleInside x) x₁ x₂) = {!!}
  es (ENEHole (ECastProp e)) (d' , Step (FHNEHoleFinal x) x₁ x₂) = {!!}
  -- es (ENEHole e) (d' , Step (FHFinal (FVal ())) x₁ x₂)
  -- es (ENEHole e) (d' , Step (FHFinal (FIndet (INEHole x))) () x₂)
  -- es (ENEHole e) (d' , Step FHNEHoleEvaled () x₂)
  -- es (ENEHole e) (_ , Step (FHNEHoleInside x) x₁ (FHNEHoleInside x₂)) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FVal ())))
  -- es (ENEHole (ECastError x x₁)) (_ , Step (FHNEHoleFinal x₂) (ITNEHole x₃) (FHFinal (FIndet (INEHole x₄)))) = {!x₁!}
  -- es (ENEHole (EAp1 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (EAp2 e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ENEHole e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole (ECastProp e)) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) (FHFinal (FIndet (INEHole x₂)))) = {!!}
  -- es (ENEHole e) (_ , Step (FHNEHoleFinal x) (ITNEHole x₁) FHNEHoleEvaled) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FVal x)) (ITCast x₁ x₂ x₃) x₄) = {!!}
  es (ECastProp e) (d' , Step (FHFinal (FIndet x)) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCast x) x₁ x₂) = {!!}
  es (ECastProp e) (d' , Step (FHCastFinal x) x₁ x₂) = {!!}


Prove congruence for diff-term and apply-term.

Old-commit-hash: 1c6b015a57f1d5bf9fb8e40745a8350e352fc478

module Syntactic.Changes where

-- TERMS that operate on CHANGES
--
-- This module defines terms that correspond to the basic change
-- operations, as well as some other helper terms.

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Changes

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
-- Other problem: in fact, Δ t is not the nil change of t, in this context. That's a problem.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs (abs (var this xor-term var (that this)))

apply-pure-term {τ₁ ⇒ τ₂} {Γ} =
-- λdf. λf.  λx.            apply          (          df                       x          (x ⊖ x))                             (     f                x        )
   abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) (diff-term (var this) (var this)))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = λ df f → app (app apply-pure-term df) f
apply-term {bool} = _xor-term_

diff-term {τ ⇒ τ₁} =
  λ f₁ f₂ →
  -- The following can be written as:
  -- * Using Unicode symbols for change operations:
  -- λ x dx. (f1 (dx ⊕ x)) ⊝ (f2 x)
  -- * In lambda calculus with names:
  --λx.  λdx. diff           (     f₁                   (apply      dx         x))                 (f₂                        x)
  -- * As a deBrujin-encoded term in Agda:
    abs (abs (diff-term {τ₁} (app (weaken ≼-in-body f₁) (apply-term (var this) (var (that this)))) (app (weaken ≼-in-body f₂) (var (that this)))))
  where
    ≼-in-body = drop (Δ-Type τ) • (drop τ • ≼-refl)

diff-term {bool} = _xor-term_

-- Derived CONGRUENCE RULES
module _ where
  open import Denotational.Equivalence

  _≈-and_ : ∀ {Γ} {t₁ t₂ t₃ t₄ : Term Γ bool} →
    t₁ ≈ t₂ → t₃ ≈ t₄ → (t₁ and t₃) ≈ (t₂ and t₄)
  _≈-and_ ≈₁ ≈₂ = ≈-if ≈₁ ≈₂ ≈-false

  ≈-!_ : ∀ {Γ} {t₁ t₂ : Term Γ bool} →
    t₁ ≈ t₂ → ! t₁ ≈ ! t₂
  ≈-!_ ≈₁ = ≈-if ≈₁ ≈-false ≈-true

  _≈-xor-term_ : ∀ {Γ} {t₁ t₂ t₃ t₄ : Term Γ bool} →
    t₁ ≈ t₂ → t₃ ≈ t₄ → (t₁ xor-term t₃) ≈ (t₂ xor-term t₄)
  _≈-xor-term_ ≈₁ ≈₂ = ≈-if ≈₁ (≈-! ≈₂) ≈₂

  ≈-diff-term : ∀ {τ Γ} {t₁ t₂ t₃ t₄ : Term Γ τ} →
    t₁ ≈ t₂ → t₃ ≈ t₄ → diff-term t₁ t₃ ≈ diff-term t₂ t₄
  ≈-diff-term {τ₁ ⇒ τ₂} ≈₁ ≈₂ =
    ≈-abs (≈-abs
      (≈-diff-term
        (≈-app (≈-weaken Γ″ ≈₁) ≈-refl)
        (≈-app (≈-weaken Γ″ ≈₂) ≈-refl)))
    where
      Γ″ = drop (Δ-Type τ₁) • (drop τ₁ • ≼-refl)
  ≈-diff-term {bool} ≈₁ ≈₂ = ≈₁ ≈-xor-term ≈₂

  ≈-apply-term : ∀ {τ Γ} {t₁ t₂ : Term Γ (Δ-Type τ)} {t₃ t₄ : Term Γ τ} →
    t₁ ≈ t₂ → t₃ ≈ t₄ → apply-term t₁ t₃ ≈ apply-term t₂ t₄
  ≈-apply-term {τ₁ ⇒ τ₂} ≈₁ ≈₂ = ≈-app (≈-app ≈-refl ≈₁) ≈₂
  ≈-apply-term {bool} ≈₁ ≈₂ = ≈₁ ≈-xor-term ≈₂


ZK/JSChecker: avoid what seems to be a bug in JS extraction (open public)

{-# 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
  hiding (check; trace)
  renaming (_*_ to _*Number_)
-- 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 FiniteField.JS as 𝔽

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

trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
trace _ inp f = f inp

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

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

record ZK-chaum-pedersen-pok-elgamal-rnd (ℤq ℤp★ : Set) : Set where
  field
    m c s : ℤq
    g p q y α β A B : ℤp★

-- TODO dynamise me
t : Number
t = 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

check : (title  : String)
        (pred   : Bool)
        (errmsg : 𝟙 → String)
     → JS!
check title true  errmsg = Console.log (title ++ ": PASS")
check title false errmsg = Console.log (title ++ ": FAIL [" ++ errmsg _ ++ "]")

check-size : Number → String → BigI → JS!
check-size min-bits name value =
  check ("check size of " ++ name)
        (len ≥Number min-bits)
        (λ _ → name ++ " is not a necessarily a safe prime: "
             ++ BigI.toString value    ++ " has "
             ++ Number▹String len      ++ " bits which is less than "
             ++ Number▹String min-bits ++ " bits")
  module Check-size where
    len = BigI.byteLength value *Number 8N

check-pq-relation : (p q : BigI) → JS!
check-pq-relation p q =
  check ("check p and q relation p-1/q=" ++ BigI.toString s)
        (equals r 0I)
        (λ _ → "Not necessarily a safe group: (p-1) mod q != 0\np="
             ++ BigI.toString p
             ++ ", q=" ++ BigI.toString q)
  module Check-pq-relation where
    open BigI
    p-1 = subtract p 1I
    r   = mod    p-1 q
    s   = divide p-1 q

check-primality : String → BigI → JS!
check-primality name value =
  check ("check primality of " ++ name)
        (BigI.isProbablePrime value t)
        (λ _ → "Not a prime number: " ++ BigI.toString value)

check-generator-group-order : (g q p : BigI) → JS!
check-generator-group-order g q p =
  check "check generator & group order"
        (BigI.equals (BigI.modPow g q p) BigI.1I)
        (λ _ → "Not a generator of a group of order q: modPow "
             ++ BigI.toString g ++ " " ++ BigI.toString q ++ " "
             ++ BigI.toString p)

module [ℤq]ℤp★ (qI pI gI : BigI) where

  checks : JS!
  checks =
    check-pq-relation      pI qI >>
    check-size min-bits-q "q" qI >>
    check-size min-bits-p "p" pI >>
    check-primality       "q" qI >>
    check-primality       "p" pI >>
    check-generator-group-order gI qI pI

  module ℤq = 𝔽 qI
    using (0#; 1#; _+_; _−_; _*_; _/_)
    renaming (𝔽 to ℤq; fromBigI to BigI▹ℤq; repr to ℤq-repr)
  module ℤp★ = 𝔽 pI
    using (_==_)
    renaming ( fromBigI to BigI▹ℤp★; 𝔽 to ℤp★; _*_ to _·_
             ; repr to ℤp★-repr; _/_ to _·/_)

  open ℤq  -- public -- <- BUG
  open ℤp★ public

  g : ℤp★
  g = BigI▹ℤp★ gI

  _^_ : ℤp★ → ℤq → ℤp★
  b ^ e = BigI▹ℤp★ (BigI.modPow (ℤp★-repr b) (ℤq-repr e) pI)

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-chaume-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    open [ℤq]ℤp★ I.q I.p I.g
    open ℤq
--  open ℤp★ -- <- BUG
    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 "chaum-pedersen-pok-elgamal-rnd")
                              (λ _ → "")
 >> zk-check-chaum-pedersen-pok-elgamal-rnd pok
 module Zk-check where
    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 λ {
            [] →
              FS.readFile arg nullJS !₂ λ err dat →
                check "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check (JSON-parse (castString 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
  hiding (check; trace)
  renaming (_*_ to _*Number_)
-- 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 FiniteField.JS as 𝔽

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

trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
trace _ inp f = f inp

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

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

record ZK-chaum-pedersen-pok-elgamal-rnd (ℤq ℤp★ : Set) : Set where
  field
    m c s : ℤq
    g p q y α β A B : ℤp★

-- TODO dynamise me
t : Number
t = 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

check : (title  : String)
        (pred   : Bool)
        (errmsg : 𝟙 → String)
     → JS!
check title true  errmsg = Console.log (title ++ ": PASS")
check title false errmsg = Console.log (title ++ ": FAIL [" ++ errmsg _ ++ "]")

check-size : Number → String → BigI → JS!
check-size min-bits name value =
  check ("check size of " ++ name)
        (len ≥Number min-bits)
        (λ _ → name ++ " is not a necessarily a safe prime: "
             ++ BigI.toString value    ++ " has "
             ++ Number▹String len      ++ " bits which is less than "
             ++ Number▹String min-bits ++ " bits")
  module Check-size where
    len = BigI.byteLength value *Number 8N

check-pq-relation : (p q : BigI) → JS!
check-pq-relation p q =
  check ("check p and q relation p-1/q=" ++ BigI.toString s)
        (equals r 0I)
        (λ _ → "Not necessarily a safe group: (p-1) mod q != 0\np="
             ++ BigI.toString p
             ++ ", q=" ++ BigI.toString q)
  module Check-pq-relation where
    open BigI
    p-1 = subtract p 1I
    r   = mod    p-1 q
    s   = divide p-1 q

check-primality : String → BigI → JS!
check-primality name value =
  check ("check primality of " ++ name)
        (BigI.isProbablePrime value t)
        (λ _ → "Not a prime number: " ++ BigI.toString value)

check-generator-group-order : (g q p : BigI) → JS!
check-generator-group-order g q p =
  check "check generator & group order"
        (BigI.equals (BigI.modPow g q p) BigI.1I)
        (λ _ → "Not a generator of a group of order q: modPow "
             ++ BigI.toString g ++ " " ++ BigI.toString q ++ " "
             ++ BigI.toString p)

module [ℤq]ℤp★ (qI pI gI : BigI) where

  checks : JS!
  checks =
    check-pq-relation      pI qI >>
    check-size min-bits-q "q" qI >>
    check-size min-bits-p "p" pI >>
    check-primality       "q" qI >>
    check-primality       "p" pI >>
    check-generator-group-order gI qI pI

  open 𝔽 qI
    public
    using (0#; 1#; _+_; _−_; _*_; _/_)
    renaming (𝔽 to ℤq; fromBigI to BigI▹ℤq; repr to ℤq-repr)

  open 𝔽 pI
    public
    using (_==_)
    renaming ( fromBigI to BigI▹ℤp★; 𝔽 to ℤp★; _*_ to _·_
             ; repr to ℤp★-repr; _/_ to _·/_)

  g : ℤp★
  g = BigI▹ℤp★ gI

  _^_ : ℤp★ → ℤq → ℤp★
  b ^ e = BigI▹ℤp★ (BigI.modPow (ℤp★-repr b) (ℤq-repr e) pI)

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-chaume-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    open [ℤq]ℤp★ I.q I.p I.g
    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 "chaum-pedersen-pok-elgamal-rnd")
                              (λ _ → "")
 >> zk-check-chaum-pedersen-pok-elgamal-rnd pok
 module Zk-check where
    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 λ {
            [] →
              FS.readFile arg nullJS !₂ λ err dat →
                check "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check (JSON-parse (castString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}


Added Even→N.

Added Even→N.

------------------------------------------------------------------------------
-- Even predicate
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.Even where

open import FOTC.Base
open import FOTC.Data.Nat.Type

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

data Even : D → Set where
  ezero :                  Even zero
  enext : ∀ {n} → Even n → Even (succ₁ (succ₁ n))

Even-ind : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ (succ₁ n))) →
           ∀ {n} → Even n → A n
Even-ind A A0 h ezero      = A0
Even-ind A A0 h (enext En) = h (Even-ind A A0 h En)

Even→N : ∀ {n} → Even n → N n
Even→N ezero      = nzero
Even→N (enext En) = nsucc (nsucc (Even→N En))


Homogenous again

Homogenous again

module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count; countᶠ)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
    ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
    ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h

  ]-[-cong-right-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ]-[ g → g ≈⅁ h → f ]-[ h
  ]-[-cong-right-≈↺ pf pf' = ]-[-sym (]-[-cong-left-≈↺ (sym pf') (]-[-sym pf))

  ]-[-cong-≗↺ : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong-≗↺ {c} {c'} {f} {g} {f'} {g'} f≗g f'≗g' pf
     = ]-[-cong-left-≈↺ {f = g} {g = f} {h = g'}
         ((≗⇒≈⅁ (λ x → sym (f≗g x)))) (]-[-cong-right-≈↺ pf (≗⇒≈⅁ f'≗g'))

  breaks : ∀ {c} (EXP : Bit → ⅁ c) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ⅁ c₀) (⅁₁ : Bit → ⅁ c₁) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ⅁ c}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong-≗↺ (same-games 0b) (same-games 1b)

module HomImplem k where
  --  | Pr[ f ≡ 1 ] - Pr[ g ≡ 1 ] | ≥ ε            [ on reals ]
  --  dist Pr[ f ≡ 1 ] Pr[ g ≡ 1 ] ≥ ε             [ on reals ]
  --  dist (#1 f / 2^ c) (#1 g / 2^ c) ≥ ε          [ on reals ]
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c where ε = 2^ -k [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(-k) * 2^ c            [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c - k)                [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c ∸ k)               [ on natural ]
  _]-[_ : ∀ {n} (f g : ⅁ n) → Set
  _]-[_ {n} f g = dist (count↺ f) (count↺ g) ≥ 2^(n ∸ k)

  ]-[-sym : ∀ {n} {f g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {n} {f} {g} f]-[g rewrite dist-sym (count↺ f) (count↺ g) = f]-[g

  ]-[-cong-left-≈↺ : ∀ {n} {f g h : ⅁ n} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {n} {f} {g} f≈g g]-[h rewrite ≈⅁⇒≈⅁′ {n} {f} {g} f≈g = g]-[h
  -- dist #g #h ≥ 2^(n ∸ k)
  -- dist #f #h ≥ 2^(n ∸ k)

module Implem k where
  _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
  _]-[_ {m} {n} f g = dist (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) ≥ 2^((m + n) ∸ k)

  ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {m} {n} {f} {g} f]-[g rewrite dist-sym (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) | ℕ°.+-comm m n = f]-[g

  postulate
      helper : ∀ x y z t → x + ((y + z) ∸ t) ≡ y + ((x + z) ∸ t)

  ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} f≈g g]-[h
      with 2^*-mono m g]-[h
  ... | q rewrite sym (dist-2^* m (⟨2^ o ⟩* (count↺ g)) (⟨2^ n ⟩* (count↺ h)))
                | 2^-comm m o (count↺ g)
                | sym f≈g
                | 2^-comm o n (count↺ f)
                | 2^-comm m n (count↺ h)
                | dist-2^* n (⟨2^ o ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ h))
                | 2^-+ m (n + o ∸ k) 1
                | helper m n o k
                | sym (2^-+ n (m + o ∸ k) 1)
                = 2^*-mono′ n q

  prgDist : PrgDist
  prgDist = mk _]-[_ (λ {m n f g} x → ]-[-sym {m} {n} {f} {g} x) (λ {m n o f g h} x y → ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} x y)

module program-distance where

open import flipbased-implem
open import Data.Bits
open import Data.Bool
open import Data.Vec.NP using (Vec; count; countᶠ)
open import Data.Nat.NP
open import Data.Nat.Properties
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
import Data.Fin as Fin

record PrgDist : Set₁ where
  constructor mk
  field
    _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
    ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
    ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h

  ]-[-cong-right-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ]-[ g → g ≈⅁ h → f ]-[ h
  ]-[-cong-right-≈↺ pf pf' = ]-[-sym (]-[-cong-left-≈↺ (sym pf') (]-[-sym pf))

  ]-[-cong-≗↺ : ∀ {c c'} {f g : ⅁ c} {f' g' : ⅁ c'} → f ≗↺ g → f' ≗↺ g' → f ]-[ f' → g ]-[ g'
  ]-[-cong-≗↺ {c} {c'} {f} {g} {f'} {g'} f≗g f'≗g' pf
     = ]-[-cong-left-≈↺ {f = g} {g = f} {h = g'}
         ((≗⇒≈⅁ (λ x → sym (f≗g x)))) (]-[-cong-right-≈↺ pf (≗⇒≈⅁ f'≗g'))

  breaks : ∀ {c} (EXP : Bit → ⅁ c) → Set
  breaks ⅁ = ⅁ 0b ]-[ ⅁ 1b

  -- An wining adversary for game ⅁₀ reduces to a wining adversary for game ⅁₁
  _⇓_ : ∀ {c₀ c₁} (⅁₀ : Bit → ⅁ c₀) (⅁₁ : Bit → ⅁ c₁) → Set
  ⅁₀ ⇓ ⅁₁ = breaks ⅁₀ → breaks ⅁₁

  extensional-reduction : ∀ {c} {⅁₀ ⅁₁ : Bit → ⅁ c}
                          → ⅁₀ ≗⅁ ⅁₁ → ⅁₀ ⇓ ⅁₁
  extensional-reduction same-games = ]-[-cong-≗↺ (same-games 0b) (same-games 1b)

module Implem k where
  --  | Pr[ f ≡ 1 ] - Pr[ g ≡ 1 ] | ≥ ε            [ on reals ]
  --  dist Pr[ f ≡ 1 ] Pr[ g ≡ 1 ] ≥ ε             [ on reals ]
  --  dist (#1 f / 2^ c) (#1 g / 2^ c) ≥ ε          [ on reals ]
  --  dist (#1 f) (#1 g) ≥ ε * 2^ c where ε = 2^ -k [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(-k) * 2^ c            [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c - k)                [ on rationals ]
  --  dist (#1 f) (#1 g) ≥ 2^(c ∸ k)               [ on natural ]
  _]-[_ : ∀ {m n} → ⅁ m → ⅁ n → Set
  _]-[_ {m} {n} f g = dist (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) ≥ 2^((m + n) ∸ k)

  ]-[-sym : ∀ {m n} {f : ⅁ m} {g : ⅁ n} → f ]-[ g → g ]-[ f
  ]-[-sym {m} {n} {f} {g} f]-[g rewrite dist-sym (⟨2^ n ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ g)) | ℕ°.+-comm m n = f]-[g

  postulate
      helper : ∀ x y z t → x + ((y + z) ∸ t) ≡ y + ((x + z) ∸ t)

  ]-[-cong-left-≈↺ : ∀ {m n o} {f : ⅁ m} {g : ⅁ n} {h : ⅁ o} → f ≈⅁ g → g ]-[ h → f ]-[ h
  ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} f≈g g]-[h
      with 2^*-mono m g]-[h
  ... | q rewrite sym (dist-2^* m (⟨2^ o ⟩* (count↺ g)) (⟨2^ n ⟩* (count↺ h)))
                | 2^-comm m o (count↺ g)
                | sym f≈g
                | 2^-comm o n (count↺ f)
                | 2^-comm m n (count↺ h)
                | dist-2^* n (⟨2^ o ⟩* (count↺ f)) (⟨2^ m ⟩* (count↺ h))
                | 2^-+ m (n + o ∸ k) 1
                | helper m n o k
                | sym (2^-+ n (m + o ∸ k) 1)
                = 2^*-mono′ n q

  prgDist : PrgDist
  prgDist = mk _]-[_ (λ {m n f g} x → ]-[-sym {m} {n} {f} {g} x) (λ {m n o f g h} x y → ]-[-cong-left-≈↺ {m} {n} {o} {f} {g} {h} x y)


Avoid using congruence to prove flatmap correct

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Correctness of differentiation with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Change.Correctness where

-- The denotational properties of the `derive` transformation
-- for Calculus Nehemiah. In particular, the main theorem
-- about it producing the correct incremental behavior.

open import Nehemiah.Syntax.Type
open import Nehemiah.Syntax.Term
open import Nehemiah.Denotation.Value
open import Nehemiah.Denotation.Evaluation
open import Nehemiah.Change.Type
open import Nehemiah.Change.Term
open import Nehemiah.Change.Value
open import Nehemiah.Change.Evaluation
open import Nehemiah.Change.Validity
open import Nehemiah.Change.Derive
open import Nehemiah.Change.Implementation

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Data.Integer
open import Theorem.Groups-Nehemiah
open import Postulate.Extensionality

import Parametric.Change.Correctness
  Const ⟦_⟧Base ⟦_⟧Const ΔBase
  apply-base diff-base nil-base
  ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧
  meaning-⊕-base meaning-⊝-base meaning-onil-base
  deriveConst implementation-structure as Correctness

open import Algebra.Structures

private
  open import Level using () renaming (zero to lzero)
  open FunctionChanges {c = lzero} {d = lzero} ℤ Bag using (FunctionChange; changeAlgebra)

  flatmap-funarg-equal : ∀ (f : ℤ → Bag) (Δf : Δ f) Δf′ (Δf≈Δf′ : Δf ≈₍ int ⇒ bag ₎ Δf′) →
    (f ⊞ Δf) ≡ (f ⟦⊕₍ int ⇒ bag ₎⟧ Δf′)
  flatmap-funarg-equal f Δf Δf′ Δf≈Δf′ = ext lemma
    where
    lemma : ∀ v → f v ++ FunctionChange.apply Δf v (+ 0) ≡ f v ++ Δf′ v (+ 0)
    lemma v rewrite Δf≈Δf′ v (+ 0) (+ 0) refl = refl

derive-const-correct : Correctness.Structure
derive-const-correct (intlit-const n) = refl
derive-const-correct add-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl
  rewrite mn·pq=mp·nq {w} {Δw} {w₁} {Δw₁}
  | associative-int (w + w₁) (Δw + Δw₁) (- (w + w₁))
  = n+[m-n]=m {w + w₁} {Δw + Δw₁}
derive-const-correct minus-const w Δw .Δw refl
  rewrite sym (-m·-n=-mn {w} {Δw})
  | associative-int (- w) (- Δw) (- (- w)) = n+[m-n]=m { - w} { - Δw}
derive-const-correct empty-const = refl
derive-const-correct insert-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl = refl
derive-const-correct union-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl
  rewrite ab·cd=ac·bd {w} {Δw} {w₁} {Δw₁}
  | associative-bag (w ++ w₁) (Δw ++ Δw₁) (negateBag (w ++ w₁))
  = a++[b\\a]=b {w ++ w₁} {Δw ++ Δw₁}
derive-const-correct negate-const w Δw .Δw refl
  rewrite sym (-a·-b=-ab {w} {Δw})
  | associative-bag (negateBag w) (negateBag Δw) (negateBag (negateBag w))
  = a++[b\\a]=b {negateBag w} {negateBag Δw}
derive-const-correct flatmap-const w Δw Δw′ Δw≈Δw′ w₁ Δw₁ .Δw₁ refl
  rewrite flatmap-funarg-equal w Δw Δw′ Δw≈Δw′ = refl
derive-const-correct sum-const w Δw .Δw refl
  rewrite homo-sum {w} {Δw}
  | associative-int (sumBag w) (sumBag Δw) (- sumBag w)
  = n+[m-n]=m {sumBag w} {sumBag Δw}

open Correctness.Structure derive-const-correct public

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Correctness of differentiation with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Change.Correctness where

-- The denotational properties of the `derive` transformation
-- for Calculus Nehemiah. In particular, the main theorem
-- about it producing the correct incremental behavior.

open import Nehemiah.Syntax.Type
open import Nehemiah.Syntax.Term
open import Nehemiah.Denotation.Value
open import Nehemiah.Denotation.Evaluation
open import Nehemiah.Change.Type
open import Nehemiah.Change.Term
open import Nehemiah.Change.Value
open import Nehemiah.Change.Evaluation
open import Nehemiah.Change.Validity
open import Nehemiah.Change.Derive
open import Nehemiah.Change.Implementation

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Data.Integer
open import Theorem.Groups-Nehemiah
open import Postulate.Extensionality

import Parametric.Change.Correctness
  Const ⟦_⟧Base ⟦_⟧Const ΔBase
  apply-base diff-base nil-base
  ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧
  meaning-⊕-base meaning-⊝-base meaning-onil-base
  deriveConst implementation-structure as Correctness

open import Algebra.Structures

derive-const-correct : Correctness.Structure
derive-const-correct (intlit-const n) = refl
derive-const-correct add-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl
  rewrite mn·pq=mp·nq {w} {Δw} {w₁} {Δw₁}
  | associative-int (w + w₁) (Δw + Δw₁) (- (w + w₁))
  = n+[m-n]=m {w + w₁} {Δw + Δw₁}
derive-const-correct minus-const w Δw .Δw refl
  rewrite sym (-m·-n=-mn {w} {Δw})
  | associative-int (- w) (- Δw) (- (- w)) = n+[m-n]=m { - w} { - Δw}
derive-const-correct empty-const = refl
derive-const-correct insert-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl = refl
derive-const-correct union-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl
  rewrite ab·cd=ac·bd {w} {Δw} {w₁} {Δw₁}
  | associative-bag (w ++ w₁) (Δw ++ Δw₁) (negateBag (w ++ w₁))
  = a++[b\\a]=b {w ++ w₁} {Δw ++ Δw₁}
derive-const-correct negate-const w Δw .Δw refl
  rewrite sym (-a·-b=-ab {w} {Δw})
  | associative-bag (negateBag w) (negateBag Δw) (negateBag (negateBag w))
  = a++[b\\a]=b {negateBag w} {negateBag Δw}
derive-const-correct flatmap-const w Δw Δw′ Δw≈Δw′ w₁ Δw₁ .Δw₁ refl =
  cong (λ □ → flatmapBag □ (w₁ ++ Δw₁) ++ negateBag (flatmapBag w w₁))
  (ext (λ n → cong (_++_ (w n)) (Δw≈Δw′ n (+ 0) (+ 0) refl)))
derive-const-correct sum-const w Δw .Δw refl
  rewrite homo-sum {w} {Δw}
  | associative-int (sumBag w) (sumBag Δw) (- sumBag w)
  = n+[m-n]=m {sumBag w} {sumBag Δw}

open Correctness.Structure derive-const-correct public


Adding stub for expanding lambda getting checked against hole

open import Nat
open import Prelude
open import contexts

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

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

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

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

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

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

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

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

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

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

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

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

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

  -- not a hole

  data _not-hole : dhexp → Set where
    CNotHole : c not-hole

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ2 τ1 Δ2} →
                Δ1 ## Δ2 →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d τ' Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) → -- todo: i added this
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x  e d Δ } →
              (x # Γ) → -- todo: i added this
              {!!} →
              Γ ⊢ ·λ x e ⇐ ⦇⦈ ~> ·λ x [ {!!}  ] d :: {!!} ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) →
          (x , d) ∈ σ →
          Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                Δ , Γ ⊢ σ :s: Γ' →
                (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈⟨ u , σ ⟩ ↦  ⦇ d' ⦈⟨ u , σ ⟩
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)

open import Nat
open import Prelude
open import contexts

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

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

  -- expressions
  data hexp : Set where
    c       : hexp
    _·:_    : hexp → htyp → hexp
    X       : Nat → hexp
    ·λ      : Nat → hexp → hexp
    ·λ_[_]_ : Nat → htyp → hexp → hexp
    ⦇⦈[_]   : Nat → hexp
    ⦇_⦈[_]  : hexp → Nat → hexp
    _∘_     : hexp → hexp → hexp

  mutual
    subst : Set -- todo: no idea if this is right; mutual thing is weird
    subst = dhexp ctx

    -- expressions without ascriptions but with casts
    data dhexp : Set where
      c        : dhexp
      X        : Nat → dhexp
      ·λ_[_]_  : Nat → htyp → dhexp → dhexp
      ⦇⦈⟨_⟩    : (Nat × subst) → dhexp
      ⦇_⦈⟨_⟩   : dhexp → (Nat × subst) → dhexp
      _∘_      : dhexp → dhexp → dhexp
      <_>_     : htyp → dhexp → dhexp

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

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : htyp) → Set where
    ICBaseArr1 : {τ1 τ2 : htyp} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : htyp} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : htyp} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : htyp} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4

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

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

  hctx : Set
  hctx = (htyp ctx × htyp) ctx

  id : tctx → subst
  id ctx x with ctx x
  id ctx x | Some τ = Some (X x)
  id ctx x | None = None

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

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

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

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

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

  -- not a hole

  data _not-hole : dhexp → Set where
    CNotHole : c not-hole

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) → -- todo: i added this
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp1   : ∀{Γ e1 e2 d2 d1 Δ1 τ2 τ1 Δ2} →
                Δ1 ## Δ2 →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e1 ⇐ (τ2 ==> ⦇⦈) ~> d1 :: τ1 ⊣ Δ1 →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> d2 :: τ2 ⊣ Δ2 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< τ2 ==> ⦇⦈ > d1) ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 τ2 τ d1 d2 Δ1 Δ2 τ2' e2} →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              (τ2 == τ2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ (< τ2 > d2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 τ d1 Δ1 e2 τ2 d2 Δ2 } →
              Δ1 ## Δ2 →
              Γ ⊢ e1 ⇒ (τ2 ==> τ) ~> d1 ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> d1 ∘ d2 ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈⟨ u , id Γ ⟩ ⊣  ■ (u ::[ Γ ] ⦇⦈)
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ d ⦈⟨ u , id Γ ⟩ ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 (τ == τ' → ⊥) →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> (< τ > d) ⊣ Δ
      ESAsc2 : ∀{Γ e τ d τ' Δ } →
               Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
               Γ ⊢ (e ·: τ) ⇒ τ ~> d ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : hexp) (τ : htyp) (d : dhexp) (τ' : htyp) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ1 τ2 e d τ2' Δ } →
              (x # Γ) → -- todo: i added this
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : Nat) → (e == ⦇⦈[ u ] → ⊥)) →
                  ((e' : hexp) (u : Nat) → (e == ⦇ e' ⦈[ u ] → ⊥)) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , id Γ ⟩ :: τ ⊣ ■ (u ::[ Γ ] τ)
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ τ ~> ⦇ d ⦈⟨ u , id Γ ⟩ :: τ ⊣ (Δ ,, u ::[ Γ ] τ)

  mutual
    -- substitition type assignment
    _,_⊢_:s:_ : hctx → tctx → subst → tctx → Set
    Δ , Γ ⊢ σ :s: Γ' =
        (x : Nat) (d : dhexp) →
          (x , d) ∈ σ →
          Σ[ τ ∈ htyp ] (Γ' x == Some τ × Δ , Γ ⊢ d :: τ)

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : dhexp) (τ : htyp) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ2 τ} →
             Δ , Γ ⊢ d1 :: τ1 →
             τ1 ▸arr (τ2 ==> τ) →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                Δ , Γ ⊢ σ :s: Γ' →
                (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 (Δ ,, u ::[ Γ' ] τ) , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  postulate -- todo: write this later
    [_]_ : subst → dhexp → dhexp

  -- value
  data _val : (d : dhexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val

  mutual
    -- indeterminate
    data _indet : (d : dhexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇ d ⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → d1 indet → d2 final → (d1 ∘ d2) indet
      ICast : ∀{d τ} → d indet → (< τ > d) indet

    -- final
    data _final : (d : dhexp) → Set where
      FVal : ∀{d} → d val → d final
      FIndet : ∀{d} → d indet → d final

------------- these two judgements are still being figured out; form
------------- changing, etc. double check everything here once it settles
------------- before doing anything with it
  -- error
  data _err[_] : (d : dhexp) → (Δ : hctx) → Set where
    -- ERNEHole
    -- ERCastError
    -- ERLam
    -- ERAp1
    -- ERAp2
    -- ERCast

  -- small step semantics
  data _↦_ : (d d' : dhexp)  → Set where
    STHole : ∀{ d d' u σ } →
             d ↦ d' →
             ⦇ d ⦈⟨ u , σ ⟩ ↦  ⦇ d' ⦈⟨ u , σ ⟩
    -- STCast
    STAp1 : ∀{ d1 d2 d1' } →
            d1 ↦ d1' →
            (d1 ∘ d2) ↦ (d1' ∘ d2)
    STAp2 : ∀{ d1 d2 d2' } →
            d1 final →
            d2 ↦ d2' →
            (d1 ∘ d2) ↦ (d1 ∘ d2')
    -- STApβ : ∀{ d1 d2 τ x } →
    --         d2 final →
    --         ((·λ x [ τ ] d1) ∘ d2) ↦ ([ ⟦ x , {!!} ⟧ ] d2)