Update ZK/Disjunctive

Update ZK/Disjunctive

open import Level.NP
open import Type
open import Function
open import Algebra.FunctionProperties.Eq
open import Data.Zero
open import Data.Two hiding (_≟_)
open import Data.Nat.NP as ℕ hiding (_≟_)
open import Data.Product renaming (proj₁ to fst) hiding (map)
open import Data.Fin.NP as Fin
open import Data.Vec
open import Data.Vec.Properties
import Data.List as L
open L using (List; []; _∷_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP
import ZK.SigmaProtocol
import ZK.ChaumPedersen

module ZK.Disjunctive
    (G ℤq : ★)
    (g    : G)
    (_^_  : G  → ℤq → G)
    (_·_  : G  → G  → G)
    (_/_  : G  → G  → G)
    (_+_  : ℤq → ℤq → ℤq)
    (_-_  : ℤq → ℤq → ℤq)
    (_*_  : ℤq → ℤq → ℤq)
    (_==_ : (x y : G) → 𝟚)
    (_==ℤq_ : (x y : ℤq) → 𝟚)
    (max  : ℕ)
    (Fin▹ℤq : Fin (suc max) → ℤq)
    where

  0q : ℤq
  0q = Fin▹ℤq zero

  record Structure : Set where
    field
      ✓-==ℤq : ∀ {x y} → x ≡ y → ✓ (x ==ℤq y)
      ✓-== : ∀ {x y} → x ≡ y → ✓ (x == y)
      ^-+  : ∀ {b x y} → b ^(x + y) ≡ (b ^ x) · (b ^ y)
      ^-*  : ∀ {b x y} → b ^(x * y) ≡ (b ^ x) ^ y
      ·-/  : ∀ {P Q} → P ≡ (P · Q) / Q
      /-·  : ∀ {P Q} → P ≡ (P / Q) · Q
      -+   : ∀ {x y} → (x - y) + y ≡ x
      +-comm     : Commutative _+_
      +-assoc    : Associative _+_
      0-+-identity : Identity 0q _+_

  _‼_ : ∀ {n} {A : ★} → Vec A n → Fin n → A
  v ‼ i = lookup i v

  tabulate′ : ∀ {A : ★} (n : ℕ) (f : ℕ → A) → Vec A n
  tabulate′ n f = tabulate {n = n} (f ∘ Fin▹ℕ)

  tabulateL : ∀ {A : ★} (n : ℕ) (f : ℕ → A) → List A
  tabulateL n f = toList (tabulate′ n f)

  tubulate :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : Fin n → A)
      (f≡m : A)
    → Vec A n
  tubulate zero    f x = x  ∷ tabulate (f ∘ suc)
  tubulate (suc m) f x = fz ∷ tubulate m (f ∘ suc) x
     where fz = f zero

  tubulate-tabulate[]≔ :
      ∀ {n} {A : ★} (m : Fin n)
        {f≢m : Fin n → A}
        {f≡m : A}
      → tubulate m f≢m f≡m ≡ (tabulate f≢m)[ m ]≔ f≡m
  tubulate-tabulate[]≔ zero    = refl
  tubulate-tabulate[]≔ (suc m) = ap (_∷_ _) (tubulate-tabulate[]≔ m)

  tubulate‼m :
      ∀ {n} {A : ★} (m : Fin n)
        (f≢m : Fin n → A)
        (f≡m : A)
      → tubulate m f≢m f≡m ‼ m ≡ f≡m
  tubulate‼m zero    _ _ = refl
  tubulate‼m (suc m) _ _ = tubulate‼m m _ _

  tubulate‼≢m :
      ∀ {n} {A : ★} (m : Fin n)
        (f≢m : Fin n → A)
        (f≡m : A)
        i (m≢i : m ≢ i) →
        tubulate m f≢m f≡m ‼ i ≡ f≢m i
  tubulate‼≢m m f≢m f≡m i m≢i
    rewrite tubulate-tabulate[]≔ m {f≢m} {f≡m}
          | lookup∘update′ (m≢i ∘ !_) (tabulate f≢m) f≡m
          = lookup∘tabulate f≢m i
  {-
  tubulate‼≢m zero       zero    i≢m = 𝟘-elim (i≢m refl)
  tubulate‼≢m (suc m)    zero    i≢m = refl
  tubulate‼≢m zero {f≢m} (suc i) i≢m = lookup∘tabulate f≢m (suc i)
  tubulate‼≢m (suc m)    (suc i) i≢m = tubulate‼≢m m i (i≢m ∘ ap suc)
  -}

  module _ {A : ★} where
    _⟦_⟧≔_ : ∀ {n} (f : Fin n → A) (i : Fin n) (z : A) → Fin n → A
    (f ⟦ zero  ⟧≔ z) zero    = z
    (f ⟦ zero  ⟧≔ z) (suc j) = f (suc j)
    (f ⟦ suc i ⟧≔ z) zero    = f zero
    (f ⟦ suc i ⟧≔ z) (suc j) = ((f ∘ suc) ⟦ i ⟧≔ z) j

    tabulate-⟦⟧≔ : ∀ {n} (f : Fin n → A) (i : Fin n) (z : A) → tabulate (f ⟦ i ⟧≔ z) ≡ tabulate f [ i ]≔ z
    tabulate-⟦⟧≔ f zero z = refl
    tabulate-⟦⟧≔ f (suc i) z = ap (_∷_ _) (tabulate-⟦⟧≔ (f ∘ suc) i z)

  {-
  module _ {A : ★} where
    [_≔_]_ : ∀ {n} (m : Fin n) (z : A) (xs : Vec A n) → Vec A n
    [ zero  ≔ z ] (x ∷ xs) = z ∷ xs
    [ suc m ≔ z ] (x ∷ xs) = x ∷ [ m ≔ z ] xs

    [≔]-‼-m : ∀ {n} (m : Fin n) (z : A) (xs : Vec A n) → [ m ≔ z ] xs ‼ m ≡ z
    [≔]-‼-m m z xs = {!!}
    [≔]-‼-≢m : ∀ {n} (m : Fin n) (z : A) (xs : Vec A n) j (j≢m : j ≢ m) → [ m ≔ z ] xs ‼ j ≡ xs ‼ j
    -}

  -- split : ∀ {A : ★} {n} (m : Fin n) →

  {-
  module _ {A : ★}
           (B : ℕ → ★)
           (_◅′_ _◅_ : ∀ {n} → A → B n → B (suc n))
           (ε   : B zero) where
    fuldr : ∀ {n} (m : Fin n) (f : Fin n → A) → B n
    fuldr zero    f = f zero ◅′ iterate B _◅_ ε (f ∘ suc)
    fuldr (suc m) f = f zero ◅ fuldr m (f ∘ suc)
  -}

  {-
  xs [ m ]≔ z ≡ take xs ++ z ∷ drop xs

  foldr B _◅_ ε (xs [ m ]≔ z)
  ≡
  (foldr B _◅_ ε (xs [ m ]≔ ε))
  -}

  module _ {A : ★}
           (_+_ : A → A → A)
           (+-comm     : Commutative _+_)
           (+-assoc    : Associative _+_)
           (z z' : A)
           where
     +-exch-top : ∀ {a b c} → a + (b + c) ≡ b + (a + c)
     +-exch-top = ! +-assoc ∙ ap₂ _+_ +-comm refl ∙ +-assoc
     +-exch : ∀ {a b c d e} → a + c ≡ d + e → a + (b + c) ≡ d + (b + e)
     +-exch p = +-exch-top ∙ ap (_+_ _) p ∙ ! +-exch-top
     foldr-exch : ∀ {n} (xs : Vec A n) → z + foldr _ _+_ z' xs ≡ z' + foldr _ _+_ z xs
     foldr-exch [] = +-comm
     foldr-exch (x ∷ xs) = +-exch (foldr-exch xs)
     foldr-[]≔-exch : ∀ {n} (xs : Vec A n) (m : Fin n)
                         → foldr _ _+_ z' (xs [ m ]≔ z)
                         ≡  foldr _ _+_ z  (xs [ m ]≔ z')
     foldr-[]≔-exch (x ∷ xs) zero    = foldr-exch xs
     foldr-[]≔-exch (x ∷ xs) (suc m) = ap (_+_ x) (foldr-[]≔-exch xs m)

     foldr-[]≔-exch′ : ∀ {n ε} (xs : Vec A n) (m : Fin n)
                         → z' + foldr _ _+_ ε (xs [ m ]≔ z)
                         ≡  z  + foldr _ _+_ ε (xs [ m ]≔ z')
     foldr-[]≔-exch′ (x ∷ xs) zero    = +-exch-top
     foldr-[]≔-exch′ (x ∷ xs) (suc m) = +-exch (foldr-[]≔-exch′ xs m)

     -- foldr _ _+_ z ≡ foldr _ _+_ ε + z

  {-
  fuldr-as-tubulate :
    ∀ {A : ★} {n} (m : Fin n) →
    fuldr (Vec A) ? _∷_ [] m xs
  -}
 --   x ◅′ (y ◅ z) ≡ y ◅′

 {-
  module _ {A : ★}
           (B : ℕ → ★)
           (_◅_ : ∀ {n} → A → B n → B (suc n))
           (ε   : B zero)
           where

    foldr-tubulate : ∀ {n} (m : Fin n)
                       {f≢m : Fin n → A}
                       {f≡m : A}
                  → foldr B _◅_ ε (tubulate m f≢m f≡m) ≡ foldr B (λ _ b → f≡m ◅ b) _◅_ ε m f≢m
    foldr-tubulate zero    = ap (_◅_ _) (! iterate-foldr∘tabulate B _◅_ ε _)
    foldr-tubulate (suc m) = ap (_◅_ _) (foldr-tubulate m)

    foldr-tubulate : ∀ {n} (m : Fin n)
                       {f≢m : Fin n → A}
                       {f≡m : A}
                  → foldr B _◅_ ε (tubulate m f≢m f≡m) ≡ fuldr B (λ _ b → f≡m ◅ b) _◅_ ε m f≢m
    foldr-tubulate zero    = ap (_◅_ _) (! iterate-foldr∘tabulate B _◅_ ε _)
    foldr-tubulate (suc m) = ap (_◅_ _) (foldr-tubulate m)
-}
{-
  module _ {A : ★}
           (B : ℕ → ★)
           (_◅_ : ∀ {n} → A → B n → B (suc n))
           (ε   : B zero) where
    tribulate :
        ∀ {n} (m : Fin n)
          (f≢m : Fin n → A) -- (f≢m : (i : Fin n) → i ≢ m → A)
          (f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A)
        → Vec A n
    tribulate zero f x = x ε (foldr B _◅_ ε tl) ∷ tl
         where tl = tabulate (f ∘ suc)
    tribulate (suc m) f x = fz ∷ tribulate m (f ∘ suc) (x ∘ _◅_ fz)
         where fz = f zero

    module _
        (P : A → ★)
        (Q : ∀ {n} → B n → ★)
        (Q[_◅_] : ∀ {n x} {y : B n} → P x → Q y → Q (x ◅ y))
        (Qε : Q ε) where
        tabulate-spec :
          ∀ {n} {f : Fin n → A}
            (Pf : ∀ i → P (f i))
          → Q (foldr B _◅_ ε (tabulate f))
        tabulate-spec {zero}  Pf = Qε
        tabulate-spec {suc n} Pf = Q[ Pf zero ◅ tabulate-spec (Pf ∘ suc) ]

        tribulate-spec :
          ∀ {n} (m : Fin n)
            {f≢m : Fin n → A}
            {f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A}
            (P≢m : ∀ i → i ≢ m → P (f≢m i))
            (P≡m : ∀ {pr po} → Q pr → Q po → P (f≡m pr po))
          → ∀ i → P (tribulate m f≢m f≡m ‼ i)
        tribulate-spec zero       P≢m P≡m zero
          = P≡m Qε (tabulate-spec (λ i → P≢m (suc i) (λ())))
        tribulate-spec (suc m)    P≢m P≡m zero
          = P≢m zero (λ())
        tribulate-spec zero {f≢m} P≢m P≡m (suc i)
          rewrite lookup∘tabulate (f≢m ∘ suc) i
          = P≢m (suc i) (λ())
        tribulate-spec (suc m) P≢m P≡m (suc i)
          = tribulate-spec m (λ j j≢m → P≢m (suc j) (j≢m ∘ Fin.suc-injective))
                             (λ Qpr Qpo → P≡m Q[ P≢m zero (λ()) ◅ Qpr ] Qpo) i

        tribulate≢m :
          ∀ {n} (m : Fin n)
            {f≢m : Fin n → A}
            {f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A}
            i (i≢m : i ≢ m) →
            tribulate m f≢m f≡m ‼ i ≡ f≢m i
        tribulate≢m = {!!}

    tribulate-naive :
      ∀ {n} (m : Fin n)
        (f≢m : ℕ → A)
        (f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A)
      → Vec A (Fin▹ℕ m ℕ.+ suc (n ℕ-ℕ suc m))
    tribulate-naive {n = n} m f≢m f≡m
       = prefix ++ f≡m fprefix fpostfix ∷ postfix
       where
         prefix   = tabulate′ (Fin▹ℕ m)      f≢m
         postfix  = tabulate′ (n ℕ-ℕ suc m) (f≢m ∘ ℕ._+_ (Fin▹ℕ (suc m)))
         fprefix  = foldr B _◅_ ε prefix
         fpostfix = foldr B _◅_ ε postfix

    tribulate-correct :
      ∀ {n} (m : Fin n)
        (f≢m : ℕ → A)
        (f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A)
      → toList (tribulate m (f≢m ∘ Fin▹ℕ) f≡m)
       ≡ toList (tribulate-naive m f≢m f≡m)
    tribulate-correct zero    f≢m f≡m = refl
    tribulate-correct (suc m) f≢m f≡m =
      ap (_∷_ (f≢m 0)) (tribulate-correct m (f≢m ∘ suc) (f≡m ∘ _◅_ (f≢m 0)))

  test-tribulate1 :
    tribulate (Vec ℕ) _∷_ [] (# 4) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ [])
  test-tribulate1 = refl

  test-tribulate2 :
    tribulate _ L._++_ L.[]
              (# 4) (L.[_] ∘ Fin▹ℕ)
              (λ xs ys → xs L.++ 42 ∷ ys)
      ≡
    (0 ∷ []) ∷ (1 ∷ []) ∷ (2 ∷ []) ∷ (3 ∷ []) ∷ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ []) ∷ (5 ∷ []) ∷ []
  test-tribulate2 = refl

  test-tribulate3 :
    tribulate (Vec ℕ) _∷_ [] (# 3) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 42 ∷ [])
  test-tribulate3 = refl

  test-tribulate4 :
    tribulate (const ℕ) ℕ._+_ 0 (# 3) Fin▹ℕ (λ x y → (x ℕ.∸ 1) ℕ.+ 10 ℕ.* y) ≡ (0 ∷ 1 ∷ 2 ∷ 42 ∷ 4 ∷ [])
  test-tribulate4 = refl

     {-
  tribulate :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : Fin n → A)
      (f≡m : Vec A (Fin▹ℕ m) → Vec A (n ℕ-ℕ suc m) → A)
    → Vec A n
  tribulate zero f x = x [] tl ∷ tl
     where tl = tabulate (f ∘ suc)
  tribulate (suc m) f x = fz ∷ tribulate m (f ∘ suc) (x ∘ _∷_ fz)
     where fz = f zero

  test-tribulate1 :
    tribulate (# 4) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ [])
  test-tribulate1 = refl

  test-tribulate2 :
    tribulate (# 4) (L.[_] ∘ Fin▹ℕ)
              (λ xs ys → L.concat (toList (xs ++ L.[ 42 ] ∷ ys)))
      ≡
    (0 ∷ []) ∷ (1 ∷ []) ∷ (2 ∷ []) ∷ (3 ∷ []) ∷ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ []) ∷ (5 ∷ []) ∷ []
  test-tribulate2 = refl

  test-tribulate3 :
    tribulate (# 3) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 42 ∷ [])
  test-tribulate3 = refl

  tribulate-naive :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : ℕ → A)
      (f≡m : List A → List A → A)
    → List A
  tribulate-naive {n = n} m f≢m f≡m
     = prefix L.++ f≡m prefix postfix ∷ postfix
     where
       prefix  = tabulateL (Fin▹ℕ m)      f≢m
       postfix = tabulateL (n ℕ-ℕ suc m) (f≢m ∘ ℕ._+_ (Fin▹ℕ (suc m)))

  tribulate-correct :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : ℕ → A)
      (f≡m : List A → List A → A)
    → toList (tribulate m (f≢m ∘ Fin▹ℕ) (λ xs ys → f≡m (toList xs) (toList ys)))
     ≡ tribulate-naive m f≢m f≡m
  tribulate-correct zero    f≢m f≡m = refl
  tribulate-correct (suc m) f≢m f≡m =
    ap (_∷_ (f≢m 0)) (tribulate-correct m (f≢m ∘ suc) (f≡m ∘ _∷_ (f≢m 0)))
    -}
-}
  and : ∀ {n} → Vec 𝟚 n → 𝟚
  and = foldr _ _∧_ 1₂

  ✓-and : ∀ {n} {v : Vec 𝟚 n} (✓p : ∀ i → ✓(v ‼ i)) → ✓(and v)
  ✓-and {v = []}     ✓p = _
  ✓-and {v = x ∷ xs} ✓p = ✓∧ (✓p zero) (✓-and (✓p ∘ suc))

  module _ {A B C D : ★} {n}
           (f : Fin n → A → B → C → D)
           (va : Vec A n) (vb : Vec B n) (vc : Vec C n) where
    mapi3 : Vec D n
    mapi3 = replicate f ⊛ allFin _ ⊛ va ⊛ vb ⊛ vc

  open import Category.Applicative.Indexed -- .Morphism
  module _ {A B C D : ★} {n}
           {f : Fin n → A → B → C → D}
           {va : Vec A n} {vb : Vec B n} {vc : Vec C n}
           i where
    -- Surely this could be done better...
    open Morphism (lookup-morphism {₀} {n} i)
    mapi3‼ : mapi3 f va vb vc ‼ i ≡ f i (va ‼ i) (vb ‼ i) (vc ‼ i)
    mapi3‼ = op-⊛ (replicate f ⊛ allFin _ ⊛ va ⊛ vb) vc
           ∙ ap (λ g → g (vc ‼ i))
                (op-⊛ (replicate f ⊛ allFin _ ⊛ va) vb)
           ∙ ap (λ g → g (vb ‼ i) (vc ‼ i)) (op-⊛ (replicate f ⊛ allFin _) va)
           ∙ ap (λ g → g (va ‼ i) (vb ‼ i) (vc ‼ i)) (op-⊛ (replicate f) (allFin _))
           ∙ ap (λ g → g (allFin _ ‼ i) (va ‼ i) (vb ‼ i) (vc ‼ i)) (op-pure f)
           ∙ ap (λ x → f x (va ‼ i) (vb ‼ i) (vc ‼ i)) (lookup∘tabulate id i)

  module _ {A B C : ★} {n}
           (p : Fin n → A → B → C → 𝟚)
           (va : Vec A n) (vb : Vec B n) (vc : Vec C n) where
    all3 : 𝟚
    all3 = and (mapi3 p va vb vc)

  module _ {A B C : ★} where
    ✓-all3 : ∀ {n}
           {p  : Fin n → A → B → C → 𝟚}
           {va : Vec A n} {vb : Vec B n} {vc : Vec C n}
           (✓p : ∀ i → ✓(p i (va ‼ i) (vb ‼ i) (vc ‼ i)))
           → ✓(all3 p va vb vc)
    ✓-all3 {p = p} {va} {vb} {vc} ✓p = ✓-and {v = mapi3 p va vb vc} (λ i → tr ✓ (! mapi3‼ i) (✓p i))

  sumℤq : ∀ {n} → Vec ℤq n → ℤq
  sumℤq = foldr _ _+_ 0q

  sumℤq-fun : ∀ {n} (f : Fin n → ℤq) → ℤq
  sumℤq-fun = iterate _ _+_ 0q

  module CP = ZK.ChaumPedersen {G} {ℤq} g _^_ _·_ _/_ _+_ _*_ _==_
  open CP.ElGamal-encryption using (PubKey; CipherText; EncRnd; enc)

  VecCommitments = Vec CP.Commitment (suc max)
  VecChallenges  = Vec CP.Challenge  (suc max)
  VecResponses   = Vec CP.Response   (suc max)

  module Interactive (y : PubKey) where
    Response   = VecChallenges × VecResponses

    open ZK.SigmaProtocol VecCommitments ℤq Response public

    private
      M = λ i → g ^ Fin▹ℤq i

    module _ (ct : CipherText) where
      verifier1 = λ i A c s → CP.verifier y (M i) ct (CP.mk A c s)

      -- H-commitments is the actual challenge for this Σ-protocol
      verifier : Verifier
      verifier (mk commitments H-commitments (challenges , responses))
          = all3 verifier1 commitments challenges responses
          ∧ sumℤq challenges ==ℤq H-commitments

    module Prover-and-correctness
             (i : Fin (suc max))
             (rnd-challenge  : Fin (suc max) → CP.Challenge) -- the iᵗʰ slot is not used
             (rnd-response   : Fin (suc max) → CP.Response)  -- the iᵗʰ slot is not used
             (r : EncRnd) (w : ℤq)
             where

      ct = enc y r (M i)

      commitment-i = CP.prover-commitment y r w

      simulated-commitment-j : (j : Fin (suc max)) → CP.Commitment
      simulated-commitment-j j
        = CP.simulate-commitment y (M j) ct (rnd-challenge j) (rnd-response j)

      commitments = tubulate i simulated-commitment-j commitment-i

      sum≢i = sumℤq-fun (rnd-challenge ⟦ i ⟧≔ 0q)

      prover-response : ℤq → Response
      prover-response Hcommitments = (challenges , responses)
        module Prover-response where
          challenge-i = Hcommitments - sum≢i

          challenges = tubulate i rnd-challenge challenge-i

          response-i = CP.prover-response y r w (challenges ‼ i)

          responses = tubulate i rnd-response response-i

      prover : Prover
      prover = commitments , prover-response

      module Correctness-proof (structure : Structure) where
        open Structure structure
        CPcs = λ M c s → CP.Correct-simulation.correct-simulation y M ct c s ✓-== /-·
        CPcp = CP.Correctness-proof.correctness ✓-== ^-+ ^-* ·-/ y r w
        correctness : Correct (prover , verifier ct)
        correctness Hcommitments = ✓∧ (✓-all3 {p = verifier1 ct} helper) helper'
          where
            open Prover-response Hcommitments
            open ≡-Reasoning
            c-i-e : challenges ‼ i ≡ challenge-i
            c-i-e = tubulate‼m i _ _
            W-i-e : commitments ‼ i ≡ commitment-i
            W-i-e = tubulate‼m i _ _
            s-i-e : responses ‼ i ≡ response-i
            s-i-e = tubulate‼m i _ _
            s-j-e : ∀ j → i ≢ j → responses ‼ j ≡ rnd-response j
            s-j-e = tubulate‼≢m i _ _
            W-j-e : ∀ j → i ≢ j → commitments ‼ j ≡ simulated-commitment-j j
            W-j-e = tubulate‼≢m i _ _
            c-j-e : ∀ j → i ≢ j → challenges ‼ j ≡ rnd-challenge j
            c-j-e = tubulate‼≢m i _ _
            helper : ∀ j → ✓(verifier1 ct j (commitments ‼ j) (challenges ‼ j) (responses ‼ j))
            helper j with Fin._≟_ i j
            helper .i | yes refl
              rewrite s-i-e | W-i-e | tubulate‼m i rnd-challenge challenge-i
                    = CPcp (M i) challenge-i
            helper  j | no ¬p rewrite s-j-e j ¬p | W-j-e j ¬p | c-j-e j ¬p = CPcs _ _ _
            sum≢i-def : sum≢i ≡ sumℤq (tabulate rnd-challenge [ i ]≔ 0q)
            sum≢i-def = iterate-foldr∘tabulate _ _+_ 0q (rnd-challenge ⟦ i ⟧≔ 0q)
                      ∙ ap sumℤq (tabulate-⟦⟧≔ rnd-challenge i 0q)
            helper' : ✓(sumℤq challenges ==ℤq Hcommitments)
            helper' = ✓-==ℤq (sumℤq challenges
                             ≡⟨ ap sumℤq (tubulate-tabulate[]≔ i) ⟩
                              sumℤq (tabulate rnd-challenge [ i ]≔ challenge-i)
                             ≡⟨ ! fst 0-+-identity ⟩
                              0q + sumℤq (tabulate rnd-challenge [ i ]≔ challenge-i)
                             ≡⟨ foldr-[]≔-exch′ _+_ +-comm +-assoc challenge-i 0q (tabulate rnd-challenge) i ⟩
                              challenge-i + sumℤq (tabulate rnd-challenge [ i ]≔ 0q)
                             ≡⟨  ap (_+_ challenge-i) (! sum≢i-def)  ⟩
                              challenge-i + sum≢i
                             ≡⟨  -+  ⟩
                              Hcommitments
                             ∎)

    -- Like Prover-and-correctness but avoids wasting randomness for r and w
    -- This is maybe not a good idea as this is rather brittle
    module Prover-and-correctness′
             (i : Fin (suc max))
             (rnd-challenge  : Fin (suc max) → CP.Challenge)
             (rnd-response   : Fin (suc max) → CP.Response)
      = Prover-and-correctness i rnd-challenge rnd-response (rnd-challenge i) (rnd-response i)

  module Non-interactive
    (y : PubKey)
    (H : VecCommitments → ℤq)
    where
    module I = Interactive y

    open ZK.SigmaProtocol VecCommitments VecChallenges VecResponses public
      using (Transcript; mk; Verifier)

    module _ (ct : CipherText) where
        verifier : Verifier
        verifier (mk commitments challenges responses)
          = I.verifier ct (I.mk commitments (H commitments) (challenges , responses))

    module Prover-and-correctness
             (i : Fin (suc max))
             (rnd-challenge  : Fin (suc max) → CP.Challenge) -- the iᵗʰ slot is not used
             (rnd-response   : Fin (suc max) → CP.Response)  -- the iᵗʰ slot is not used
             (r : EncRnd) (w : ℤq)
             where
      module IPC = I.Prover-and-correctness i rnd-challenge rnd-response r w
      open IPC using (commitments; ct)
      open IPC.Prover-response (H commitments)
      transcript : Transcript
      transcript = mk commitments challenges responses
      module Correctness-proof (structure : Structure) where
        correctness : ✓ (verifier ct transcript)
        correctness = IPC.Correctness-proof.correctness structure (H commitments)

-- -}
-- -}
-- -}
-- -}

open import Level.NP
open import Type
open import Function
open import Algebra.FunctionProperties.Eq
open import Data.Zero
open import Data.Two hiding (_≟_)
open import Data.Nat.NP as ℕ hiding (_≟_)
open import Data.Product renaming (proj₁ to fst) hiding (map)
open import Data.Fin.NP as Fin
open import Data.Vec
open import Data.Vec.Properties
import Data.List as L
open L using (List; []; _∷_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP
import ZK.Sigma-Protocol
import ZK.Chaum-Pedersen

module ZK.Disjunctive
    (G ℤq : ★)
    (g    : G)
    (_^_  : G  → ℤq → G)
    (_·_  : G  → G  → G)
    (_/_  : G  → G  → G)
    (_+_  : ℤq → ℤq → ℤq)
    (_-_  : ℤq → ℤq → ℤq)
    (_*_  : ℤq → ℤq → ℤq)
    (_==_ : (x y : G) → 𝟚)
    (_==ℤq_ : (x y : ℤq) → 𝟚)
    (max  : ℕ)
    (Fin▹ℤq : Fin (suc max) → ℤq)
    where

  0q : ℤq
  0q = Fin▹ℤq zero

  record Structure : Set where
    field
      ✓-==ℤq : ∀ {x y} → x ≡ y → ✓ (x ==ℤq y)
      ✓-== : ∀ {x y} → x ≡ y → ✓ (x == y)
      ^-+  : ∀ {b x y} → b ^(x + y) ≡ (b ^ x) · (b ^ y)
      ^-*  : ∀ {b x y} → b ^(x * y) ≡ (b ^ x) ^ y
      ·-/  : ∀ {P Q} → P ≡ (P · Q) / Q
      /-·  : ∀ {P Q} → P ≡ (P / Q) · Q
      -+   : ∀ {x y} → (x - y) + y ≡ x
      +-comm     : Commutative _+_
      +-assoc    : Associative _+_
      0-+-identity : Identity 0q _+_

  _‼_ : ∀ {n} {A : ★} → Vec A n → Fin n → A
  v ‼ i = lookup i v

  tabulate′ : ∀ {A : ★} (n : ℕ) (f : ℕ → A) → Vec A n
  tabulate′ n f = tabulate {n = n} (f ∘ Fin▹ℕ)

  tabulateL : ∀ {A : ★} (n : ℕ) (f : ℕ → A) → List A
  tabulateL n f = toList (tabulate′ n f)

  tubulate :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : Fin n → A)
      (f≡m : A)
    → Vec A n
  tubulate zero    f x = x  ∷ tabulate (f ∘ suc)
  tubulate (suc m) f x = fz ∷ tubulate m (f ∘ suc) x
     where fz = f zero

  tubulate-tabulate[]≔ :
      ∀ {n} {A : ★} (m : Fin n)
        {f≢m : Fin n → A}
        {f≡m : A}
      → tubulate m f≢m f≡m ≡ (tabulate f≢m)[ m ]≔ f≡m
  tubulate-tabulate[]≔ zero    = refl
  tubulate-tabulate[]≔ (suc m) = ap (_∷_ _) (tubulate-tabulate[]≔ m)

  tubulate‼m :
      ∀ {n} {A : ★} (m : Fin n)
        (f≢m : Fin n → A)
        (f≡m : A)
      → tubulate m f≢m f≡m ‼ m ≡ f≡m
  tubulate‼m zero    _ _ = refl
  tubulate‼m (suc m) _ _ = tubulate‼m m _ _

  tubulate‼≢m :
      ∀ {n} {A : ★} (m : Fin n)
        (f≢m : Fin n → A)
        (f≡m : A)
        i (m≢i : m ≢ i) →
        tubulate m f≢m f≡m ‼ i ≡ f≢m i
  tubulate‼≢m m f≢m f≡m i m≢i
    rewrite tubulate-tabulate[]≔ m {f≢m} {f≡m}
          | lookup∘update′ (m≢i ∘ !_) (tabulate f≢m) f≡m
          = lookup∘tabulate f≢m i
  {-
  tubulate‼≢m zero       zero    i≢m = 𝟘-elim (i≢m refl)
  tubulate‼≢m (suc m)    zero    i≢m = refl
  tubulate‼≢m zero {f≢m} (suc i) i≢m = lookup∘tabulate f≢m (suc i)
  tubulate‼≢m (suc m)    (suc i) i≢m = tubulate‼≢m m i (i≢m ∘ ap suc)
  -}

  module _ {A : ★} where
    _⟦_⟧≔_ : ∀ {n} (f : Fin n → A) (i : Fin n) (z : A) → Fin n → A
    (f ⟦ zero  ⟧≔ z) zero    = z
    (f ⟦ zero  ⟧≔ z) (suc j) = f (suc j)
    (f ⟦ suc i ⟧≔ z) zero    = f zero
    (f ⟦ suc i ⟧≔ z) (suc j) = ((f ∘ suc) ⟦ i ⟧≔ z) j

    tabulate-⟦⟧≔ : ∀ {n} (f : Fin n → A) (i : Fin n) (z : A) → tabulate (f ⟦ i ⟧≔ z) ≡ tabulate f [ i ]≔ z
    tabulate-⟦⟧≔ f zero z = refl
    tabulate-⟦⟧≔ f (suc i) z = ap (_∷_ _) (tabulate-⟦⟧≔ (f ∘ suc) i z)

  {-
  module _ {A : ★} where
    [_≔_]_ : ∀ {n} (m : Fin n) (z : A) (xs : Vec A n) → Vec A n
    [ zero  ≔ z ] (x ∷ xs) = z ∷ xs
    [ suc m ≔ z ] (x ∷ xs) = x ∷ [ m ≔ z ] xs

    [≔]-‼-m : ∀ {n} (m : Fin n) (z : A) (xs : Vec A n) → [ m ≔ z ] xs ‼ m ≡ z
    [≔]-‼-m m z xs = {!!}
    [≔]-‼-≢m : ∀ {n} (m : Fin n) (z : A) (xs : Vec A n) j (j≢m : j ≢ m) → [ m ≔ z ] xs ‼ j ≡ xs ‼ j
    -}

  -- split : ∀ {A : ★} {n} (m : Fin n) →

  {-
  module _ {A : ★}
           (B : ℕ → ★)
           (_◅′_ _◅_ : ∀ {n} → A → B n → B (suc n))
           (ε   : B zero) where
    fuldr : ∀ {n} (m : Fin n) (f : Fin n → A) → B n
    fuldr zero    f = f zero ◅′ iterate B _◅_ ε (f ∘ suc)
    fuldr (suc m) f = f zero ◅ fuldr m (f ∘ suc)
  -}

  {-
  xs [ m ]≔ z ≡ take xs ++ z ∷ drop xs

  foldr B _◅_ ε (xs [ m ]≔ z)
  ≡
  (foldr B _◅_ ε (xs [ m ]≔ ε))
  -}

  module _ {A : ★}
           (_+_ : A → A → A)
           (+-comm     : Commutative _+_)
           (+-assoc    : Associative _+_)
           (z z' : A)
           where
     +-exch-top : ∀ {a b c} → a + (b + c) ≡ b + (a + c)
     +-exch-top = ! +-assoc ∙ ap₂ _+_ +-comm refl ∙ +-assoc
     +-exch : ∀ {a b c d e} → a + c ≡ d + e → a + (b + c) ≡ d + (b + e)
     +-exch p = +-exch-top ∙ ap (_+_ _) p ∙ ! +-exch-top
     foldr-exch : ∀ {n} (xs : Vec A n) → z + foldr _ _+_ z' xs ≡ z' + foldr _ _+_ z xs
     foldr-exch [] = +-comm
     foldr-exch (x ∷ xs) = +-exch (foldr-exch xs)
     foldr-[]≔-exch : ∀ {n} (xs : Vec A n) (m : Fin n)
                         → foldr _ _+_ z' (xs [ m ]≔ z)
                         ≡  foldr _ _+_ z  (xs [ m ]≔ z')
     foldr-[]≔-exch (x ∷ xs) zero    = foldr-exch xs
     foldr-[]≔-exch (x ∷ xs) (suc m) = ap (_+_ x) (foldr-[]≔-exch xs m)

     foldr-[]≔-exch′ : ∀ {n ε} (xs : Vec A n) (m : Fin n)
                         → z' + foldr _ _+_ ε (xs [ m ]≔ z)
                         ≡  z  + foldr _ _+_ ε (xs [ m ]≔ z')
     foldr-[]≔-exch′ (x ∷ xs) zero    = +-exch-top
     foldr-[]≔-exch′ (x ∷ xs) (suc m) = +-exch (foldr-[]≔-exch′ xs m)

     -- foldr _ _+_ z ≡ foldr _ _+_ ε + z

  {-
  fuldr-as-tubulate :
    ∀ {A : ★} {n} (m : Fin n) →
    fuldr (Vec A) ? _∷_ [] m xs
  -}
 --   x ◅′ (y ◅ z) ≡ y ◅′

 {-
  module _ {A : ★}
           (B : ℕ → ★)
           (_◅_ : ∀ {n} → A → B n → B (suc n))
           (ε   : B zero)
           where

    foldr-tubulate : ∀ {n} (m : Fin n)
                       {f≢m : Fin n → A}
                       {f≡m : A}
                  → foldr B _◅_ ε (tubulate m f≢m f≡m) ≡ foldr B (λ _ b → f≡m ◅ b) _◅_ ε m f≢m
    foldr-tubulate zero    = ap (_◅_ _) (! iterate-foldr∘tabulate B _◅_ ε _)
    foldr-tubulate (suc m) = ap (_◅_ _) (foldr-tubulate m)

    foldr-tubulate : ∀ {n} (m : Fin n)
                       {f≢m : Fin n → A}
                       {f≡m : A}
                  → foldr B _◅_ ε (tubulate m f≢m f≡m) ≡ fuldr B (λ _ b → f≡m ◅ b) _◅_ ε m f≢m
    foldr-tubulate zero    = ap (_◅_ _) (! iterate-foldr∘tabulate B _◅_ ε _)
    foldr-tubulate (suc m) = ap (_◅_ _) (foldr-tubulate m)
-}
{-
  module _ {A : ★}
           (B : ℕ → ★)
           (_◅_ : ∀ {n} → A → B n → B (suc n))
           (ε   : B zero) where
    tribulate :
        ∀ {n} (m : Fin n)
          (f≢m : Fin n → A) -- (f≢m : (i : Fin n) → i ≢ m → A)
          (f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A)
        → Vec A n
    tribulate zero f x = x ε (foldr B _◅_ ε tl) ∷ tl
         where tl = tabulate (f ∘ suc)
    tribulate (suc m) f x = fz ∷ tribulate m (f ∘ suc) (x ∘ _◅_ fz)
         where fz = f zero

    module _
        (P : A → ★)
        (Q : ∀ {n} → B n → ★)
        (Q[_◅_] : ∀ {n x} {y : B n} → P x → Q y → Q (x ◅ y))
        (Qε : Q ε) where
        tabulate-spec :
          ∀ {n} {f : Fin n → A}
            (Pf : ∀ i → P (f i))
          → Q (foldr B _◅_ ε (tabulate f))
        tabulate-spec {zero}  Pf = Qε
        tabulate-spec {suc n} Pf = Q[ Pf zero ◅ tabulate-spec (Pf ∘ suc) ]

        tribulate-spec :
          ∀ {n} (m : Fin n)
            {f≢m : Fin n → A}
            {f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A}
            (P≢m : ∀ i → i ≢ m → P (f≢m i))
            (P≡m : ∀ {pr po} → Q pr → Q po → P (f≡m pr po))
          → ∀ i → P (tribulate m f≢m f≡m ‼ i)
        tribulate-spec zero       P≢m P≡m zero
          = P≡m Qε (tabulate-spec (λ i → P≢m (suc i) (λ())))
        tribulate-spec (suc m)    P≢m P≡m zero
          = P≢m zero (λ())
        tribulate-spec zero {f≢m} P≢m P≡m (suc i)
          rewrite lookup∘tabulate (f≢m ∘ suc) i
          = P≢m (suc i) (λ())
        tribulate-spec (suc m) P≢m P≡m (suc i)
          = tribulate-spec m (λ j j≢m → P≢m (suc j) (j≢m ∘ Fin.suc-injective))
                             (λ Qpr Qpo → P≡m Q[ P≢m zero (λ()) ◅ Qpr ] Qpo) i

        tribulate≢m :
          ∀ {n} (m : Fin n)
            {f≢m : Fin n → A}
            {f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A}
            i (i≢m : i ≢ m) →
            tribulate m f≢m f≡m ‼ i ≡ f≢m i
        tribulate≢m = {!!}

    tribulate-naive :
      ∀ {n} (m : Fin n)
        (f≢m : ℕ → A)
        (f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A)
      → Vec A (Fin▹ℕ m ℕ.+ suc (n ℕ-ℕ suc m))
    tribulate-naive {n = n} m f≢m f≡m
       = prefix ++ f≡m fprefix fpostfix ∷ postfix
       where
         prefix   = tabulate′ (Fin▹ℕ m)      f≢m
         postfix  = tabulate′ (n ℕ-ℕ suc m) (f≢m ∘ ℕ._+_ (Fin▹ℕ (suc m)))
         fprefix  = foldr B _◅_ ε prefix
         fpostfix = foldr B _◅_ ε postfix

    tribulate-correct :
      ∀ {n} (m : Fin n)
        (f≢m : ℕ → A)
        (f≡m : B (Fin▹ℕ m) → B (n ℕ-ℕ suc m) → A)
      → toList (tribulate m (f≢m ∘ Fin▹ℕ) f≡m)
       ≡ toList (tribulate-naive m f≢m f≡m)
    tribulate-correct zero    f≢m f≡m = refl
    tribulate-correct (suc m) f≢m f≡m =
      ap (_∷_ (f≢m 0)) (tribulate-correct m (f≢m ∘ suc) (f≡m ∘ _◅_ (f≢m 0)))

  test-tribulate1 :
    tribulate (Vec ℕ) _∷_ [] (# 4) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ [])
  test-tribulate1 = refl

  test-tribulate2 :
    tribulate _ L._++_ L.[]
              (# 4) (L.[_] ∘ Fin▹ℕ)
              (λ xs ys → xs L.++ 42 ∷ ys)
      ≡
    (0 ∷ []) ∷ (1 ∷ []) ∷ (2 ∷ []) ∷ (3 ∷ []) ∷ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ []) ∷ (5 ∷ []) ∷ []
  test-tribulate2 = refl

  test-tribulate3 :
    tribulate (Vec ℕ) _∷_ [] (# 3) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 42 ∷ [])
  test-tribulate3 = refl

  test-tribulate4 :
    tribulate (const ℕ) ℕ._+_ 0 (# 3) Fin▹ℕ (λ x y → (x ℕ.∸ 1) ℕ.+ 10 ℕ.* y) ≡ (0 ∷ 1 ∷ 2 ∷ 42 ∷ 4 ∷ [])
  test-tribulate4 = refl

     {-
  tribulate :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : Fin n → A)
      (f≡m : Vec A (Fin▹ℕ m) → Vec A (n ℕ-ℕ suc m) → A)
    → Vec A n
  tribulate zero f x = x [] tl ∷ tl
     where tl = tabulate (f ∘ suc)
  tribulate (suc m) f x = fz ∷ tribulate m (f ∘ suc) (x ∘ _∷_ fz)
     where fz = f zero

  test-tribulate1 :
    tribulate (# 4) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ [])
  test-tribulate1 = refl

  test-tribulate2 :
    tribulate (# 4) (L.[_] ∘ Fin▹ℕ)
              (λ xs ys → L.concat (toList (xs ++ L.[ 42 ] ∷ ys)))
      ≡
    (0 ∷ []) ∷ (1 ∷ []) ∷ (2 ∷ []) ∷ (3 ∷ []) ∷ (0 ∷ 1 ∷ 2 ∷ 3 ∷ 42 ∷ 5 ∷ []) ∷ (5 ∷ []) ∷ []
  test-tribulate2 = refl

  test-tribulate3 :
    tribulate (# 3) Fin▹ℕ (λ _ _ → 42) ≡ (0 ∷ 1 ∷ 2 ∷ 42 ∷ [])
  test-tribulate3 = refl

  tribulate-naive :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : ℕ → A)
      (f≡m : List A → List A → A)
    → List A
  tribulate-naive {n = n} m f≢m f≡m
     = prefix L.++ f≡m prefix postfix ∷ postfix
     where
       prefix  = tabulateL (Fin▹ℕ m)      f≢m
       postfix = tabulateL (n ℕ-ℕ suc m) (f≢m ∘ ℕ._+_ (Fin▹ℕ (suc m)))

  tribulate-correct :
    ∀ {A : ★} {n} (m : Fin n)
      (f≢m : ℕ → A)
      (f≡m : List A → List A → A)
    → toList (tribulate m (f≢m ∘ Fin▹ℕ) (λ xs ys → f≡m (toList xs) (toList ys)))
     ≡ tribulate-naive m f≢m f≡m
  tribulate-correct zero    f≢m f≡m = refl
  tribulate-correct (suc m) f≢m f≡m =
    ap (_∷_ (f≢m 0)) (tribulate-correct m (f≢m ∘ suc) (f≡m ∘ _∷_ (f≢m 0)))
    -}
-}
  and : ∀ {n} → Vec 𝟚 n → 𝟚
  and = foldr _ _∧_ 1₂

  ✓-and : ∀ {n} {v : Vec 𝟚 n} (✓p : ∀ i → ✓(v ‼ i)) → ✓(and v)
  ✓-and {v = []}     ✓p = _
  ✓-and {v = x ∷ xs} ✓p = ✓∧ (✓p zero) (✓-and (✓p ∘ suc))

  module _ {A B C D : ★} {n}
           (f : Fin n → A → B → C → D)
           (va : Vec A n) (vb : Vec B n) (vc : Vec C n) where
    mapi3 : Vec D n
    mapi3 = replicate f ⊛ allFin _ ⊛ va ⊛ vb ⊛ vc

  open import Category.Applicative.Indexed -- .Morphism
  module _ {A B C D : ★} {n}
           {f : Fin n → A → B → C → D}
           {va : Vec A n} {vb : Vec B n} {vc : Vec C n}
           i where
    -- Surely this could be done better...
    open Morphism (lookup-morphism {₀} {n} i)
    mapi3‼ : mapi3 f va vb vc ‼ i ≡ f i (va ‼ i) (vb ‼ i) (vc ‼ i)
    mapi3‼ = op-⊛ (replicate f ⊛ allFin _ ⊛ va ⊛ vb) vc
           ∙ ap (λ g → g (vc ‼ i))
                (op-⊛ (replicate f ⊛ allFin _ ⊛ va) vb)
           ∙ ap (λ g → g (vb ‼ i) (vc ‼ i)) (op-⊛ (replicate f ⊛ allFin _) va)
           ∙ ap (λ g → g (va ‼ i) (vb ‼ i) (vc ‼ i)) (op-⊛ (replicate f) (allFin _))
           ∙ ap (λ g → g (allFin _ ‼ i) (va ‼ i) (vb ‼ i) (vc ‼ i)) (op-pure f)
           ∙ ap (λ x → f x (va ‼ i) (vb ‼ i) (vc ‼ i)) (lookup∘tabulate id i)

  module _ {A B C : ★} {n}
           (p : Fin n → A → B → C → 𝟚)
           (va : Vec A n) (vb : Vec B n) (vc : Vec C n) where
    all3 : 𝟚
    all3 = and (mapi3 p va vb vc)

  module _ {A B C : ★} where
    ✓-all3 : ∀ {n}
           {p  : Fin n → A → B → C → 𝟚}
           {va : Vec A n} {vb : Vec B n} {vc : Vec C n}
           (✓p : ∀ i → ✓(p i (va ‼ i) (vb ‼ i) (vc ‼ i)))
           → ✓(all3 p va vb vc)
    ✓-all3 {p = p} {va} {vb} {vc} ✓p = ✓-and {v = mapi3 p va vb vc} (λ i → tr ✓ (! mapi3‼ i) (✓p i))

  sumℤq : ∀ {n} → Vec ℤq n → ℤq
  sumℤq = foldr _ _+_ 0q

  sumℤq-fun : ∀ {n} (f : Fin n → ℤq) → ℤq
  sumℤq-fun = iterate _ _+_ 0q

  module CP = ZK.Chaum-Pedersen G ℤq g _^_ _·_ _/_ _+_ _*_ _==_
  open CP using (PubKey; CipherText; EncRnd; enc)

  VecCommitments = Vec CP.Commitment (suc max)
  VecChallenges  = Vec CP.Challenge  (suc max)
  VecResponses   = Vec CP.Response   (suc max)

  module Interactive (y : PubKey) where
    Response   = VecChallenges × VecResponses

    open ZK.Sigma-Protocol VecCommitments ℤq Response public

    private
      M = λ i → g ^ Fin▹ℤq i

    module _ (ct : CipherText) where
      verifier1 = λ i A c s → CP.verifier y (M i) ct (CP.mk A c s)

      -- H-commitments is the actual challenge for this Σ-protocol
      verifier : Verifier
      verifier (mk commitments H-commitments (challenges , responses))
          = all3 verifier1 commitments challenges responses
          ∧ sumℤq challenges ==ℤq H-commitments

    module Prover-and-correctness
             (i : Fin (suc max))
             (rnd-challenge  : Fin (suc max) → CP.Challenge) -- the iᵗʰ slot is not used
             (rnd-response   : Fin (suc max) → CP.Response)  -- the iᵗʰ slot is not used
             (r : EncRnd) (w : ℤq)
             where

      ct = enc y r (M i)

      commitment-i = CP.prover-commitment y r w

      simulated-commitment-j : (j : Fin (suc max)) → CP.Commitment
      simulated-commitment-j j
        = CP.simulate-commitment y (M j) ct (rnd-challenge j) (rnd-response j)

      commitments = tubulate i simulated-commitment-j commitment-i

      sum≢i = sumℤq-fun (rnd-challenge ⟦ i ⟧≔ 0q)

      prover-response : ℤq → Response
      prover-response Hcommitments = (challenges , responses)
        module Prover-response where
          challenge-i = Hcommitments - sum≢i

          challenges = tubulate i rnd-challenge challenge-i

          response-i = CP.prover-response y r w (challenges ‼ i)

          responses = tubulate i rnd-response response-i

      prover : Prover
      prover = commitments , prover-response

      module Correctness-proof (structure : Structure) where
        open Structure structure
        CPcs = λ M c s → CP.Correct-simulation.correct-simulation y M ct c s ✓-== /-·
        CPcp = CP.Correctness-proof.correctness ✓-== ^-+ ^-* ·-/ y r w
        correctness : Correctness prover (verifier ct)
        correctness Hcommitments = ✓∧ (✓-all3 {p = verifier1 ct} helper) helper'
          where
            open Prover-response Hcommitments
            open ≡-Reasoning
            c-i-e : challenges ‼ i ≡ challenge-i
            c-i-e = tubulate‼m i _ _
            W-i-e : commitments ‼ i ≡ commitment-i
            W-i-e = tubulate‼m i _ _
            s-i-e : responses ‼ i ≡ response-i
            s-i-e = tubulate‼m i _ _
            s-j-e : ∀ j → i ≢ j → responses ‼ j ≡ rnd-response j
            s-j-e = tubulate‼≢m i _ _
            W-j-e : ∀ j → i ≢ j → commitments ‼ j ≡ simulated-commitment-j j
            W-j-e = tubulate‼≢m i _ _
            c-j-e : ∀ j → i ≢ j → challenges ‼ j ≡ rnd-challenge j
            c-j-e = tubulate‼≢m i _ _
            helper : ∀ j → ✓(verifier1 ct j (commitments ‼ j) (challenges ‼ j) (responses ‼ j))
            helper j with Fin._≟_ i j
            helper .i | yes refl
              rewrite s-i-e | W-i-e | tubulate‼m i rnd-challenge challenge-i
                    = CPcp (M i) challenge-i
            helper  j | no ¬p rewrite s-j-e j ¬p | W-j-e j ¬p | c-j-e j ¬p = CPcs _ _ _
            sum≢i-def : sum≢i ≡ sumℤq (tabulate rnd-challenge [ i ]≔ 0q)
            sum≢i-def = iterate-foldr∘tabulate _ _+_ 0q (rnd-challenge ⟦ i ⟧≔ 0q)
                      ∙ ap sumℤq (tabulate-⟦⟧≔ rnd-challenge i 0q)
            helper' : ✓(sumℤq challenges ==ℤq Hcommitments)
            helper' = ✓-==ℤq (sumℤq challenges
                             ≡⟨ ap sumℤq (tubulate-tabulate[]≔ i) ⟩
                              sumℤq (tabulate rnd-challenge [ i ]≔ challenge-i)
                             ≡⟨ ! fst 0-+-identity ⟩
                              0q + sumℤq (tabulate rnd-challenge [ i ]≔ challenge-i)
                             ≡⟨ foldr-[]≔-exch′ _+_ +-comm +-assoc challenge-i 0q (tabulate rnd-challenge) i ⟩
                              challenge-i + sumℤq (tabulate rnd-challenge [ i ]≔ 0q)
                             ≡⟨  ap (_+_ challenge-i) (! sum≢i-def)  ⟩
                              challenge-i + sum≢i
                             ≡⟨  -+  ⟩
                              Hcommitments
                             ∎)

    -- Like Prover-and-correctness but avoids wasting randomness for r and w
    -- This is maybe not a good idea as this is rather brittle
    module Prover-and-correctness′
             (i : Fin (suc max))
             (rnd-challenge  : Fin (suc max) → CP.Challenge)
             (rnd-response   : Fin (suc max) → CP.Response)
      = Prover-and-correctness i rnd-challenge rnd-response (rnd-challenge i) (rnd-response i)

  module Non-interactive
    (y : PubKey)
    (H : VecCommitments → ℤq)
    where
    module I = Interactive y

    open ZK.Sigma-Protocol VecCommitments VecChallenges VecResponses public
      using (Transcript; mk; Verifier)

    module _ (ct : CipherText) where
        verifier : Verifier
        verifier (mk commitments challenges responses)
          = I.verifier ct (I.mk commitments (H commitments) (challenges , responses))

    module Prover-and-correctness
             (i : Fin (suc max))
             (rnd-challenge  : Fin (suc max) → CP.Challenge) -- the iᵗʰ slot is not used
             (rnd-response   : Fin (suc max) → CP.Response)  -- the iᵗʰ slot is not used
             (r : EncRnd) (w : ℤq)
             where
      module IPC = I.Prover-and-correctness i rnd-challenge rnd-response r w
      open IPC using (commitments; ct)
      open IPC.Prover-response (H commitments)
      transcript : Transcript
      transcript = mk commitments challenges responses
      module Correctness-proof (structure : Structure) where
        correctness : ✓ (verifier ct transcript)
        correctness = IPC.Correctness-proof.correctness structure (H commitments)

-- -}
-- -}
-- -}
-- -}


Plug Atlas.Change.Derive into Parametric.C.D.

Old-commit-hash: 2fb657275ba8085c801b6c81ccd68d6b09f16075

module Atlas.Change.Derive where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type
open import Atlas.Change.Term

import Parametric.Change.Derive Const ΔBase as Derive

ΔConst : Derive.Structure

ΔConst true  ∅ = false!
ΔConst false ∅ = false!

ΔConst xor (Δx • x • Δy • y • ∅) = xor! Δx Δy

ΔConst empty ∅ = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
ΔConst (update {κ} {ι}) (Δk • k • Δv • v • Δm • m • ∅) =
  insert (apply {base κ} Δk k) (apply {base ι} Δv v) (delete k v Δm)

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
ΔConst (lookup {κ} {ι}) (Δk • k • Δm • m • ∅) =
  let
    k′ = apply {base κ} Δk k
  in
    (diff (apply {base _} (lookup! k′ Δm) (lookup! k′ m))
          (lookup! k m))

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

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

open Derive.Structure ΔConst public

module Atlas.Change.Derive where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type
open import Atlas.Change.Term

ΔConst : ∀ {Γ Σ τ} →
  Const Σ τ →
  Terms (ΔContext Γ) (ΔContext Σ) →
  Term (ΔContext Γ) (ΔType τ)

ΔConst true  ∅ = false!
ΔConst false ∅ = false!

ΔConst xor (Δx • x • Δy • y • ∅) = xor! Δx Δy

ΔConst empty ∅ = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
ΔConst (update {κ} {ι}) (Δk • k • Δv • v • Δm • m • ∅) =
  insert (apply {base κ} Δk k) (apply {base ι} Δv v) (delete k v Δm)

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
ΔConst (lookup {κ} {ι}) (Δk • k • Δm • m • ∅) =
  let
    k′ = apply {base κ} Δk k
  in
    (diff (apply {base _} (lookup! k′ Δm) (lookup! k′ m))
          (lookup! k m))

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

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


Split Control.Protocol

Split Control.Protocol

module Control.Protocol where

open import Control.Protocol.InOut public
open import Control.Protocol.End   public
open import Control.Protocol.Core  public

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Level.NP
open import Data.Product.NP using (Σ; _×_; _,_) renaming (proj₁ to fst)
open import Data.One using (𝟙)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; ap; coe; coe!)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences

module Control.Protocol where

data InOut : ★ where
  In Out : InOut

dualᴵᴼ : InOut → InOut
dualᴵᴼ In  = Out
dualᴵᴼ Out = In

dualᴵᴼ-involutive : ∀ io → dualᴵᴼ (dualᴵᴼ io) ≡ io
dualᴵᴼ-involutive In = refl
dualᴵᴼ-involutive Out = refl

dualᴵᴼ-equiv : Is-equiv dualᴵᴼ
dualᴵᴼ-equiv = self-inv-is-equiv dualᴵᴼ-involutive

dualᴵᴼ-inj : ∀ {x y} → dualᴵᴼ x ≡ dualᴵᴼ y → x ≡ y
dualᴵᴼ-inj = Is-equiv.injective dualᴵᴼ-equiv

{-
module UniversalProtocols ℓ {U : ★_(ₛ ℓ)}(U⟦_⟧ : U → ★_ ℓ) where
-}
module _ ℓ where
  U = ★_ ℓ
  U⟦_⟧ = id
  data Proto_ : ★_(ₛ ℓ) where
    end : Proto_
    com : (io : InOut){M : U}(P : U⟦ M ⟧ → Proto_) → Proto_
{-
module U★ ℓ = UniversalProtocols ℓ {★_ ℓ} id
open U★
-}

Proto : ★₁
Proto = Proto_ ₀
Proto₀ = Proto
Proto₁ = Proto_ ₁

pattern recv P = com In  P
pattern send P = com Out P

module _ {{_ : FunExt}} where
    com= : ∀ {io₀ io₁}(io= : io₀ ≡ io₁)
             {M₀ M₁}(M= : M₀ ≡ M₁)
             {P₀ : M₀ → Proto}{P₁ : M₁ → Proto}(P= : ∀ m₀ → P₀ m₀ ≡ P₁ (coe M= m₀))
           → com io₀ P₀ ≡ com io₁ P₁
    com= refl refl P= = ap (com _) (λ= P=)

    module _ {io₀ io₁}(io= : io₀ ≡ io₁)
             {M₀ M₁}(M≃ : M₀ ≃ M₁)
             {P₀ : M₀ → Proto}{P₁ : M₁ → Proto}
             (P= : ∀ m₀ → P₀ m₀ ≡ P₁ (–> M≃ m₀))
             {{_ : UA}} where
        com≃ : com io₀ P₀ ≡ com io₁ P₁
        com≃ = com= io= (ua M≃) λ m → P= m ∙ ap P₁ (! coe-β M≃ m)

    module _ io {M N}(P : M × N → Proto)
             where
        com₂ : Proto
        com₂ = com io λ m → com io λ n → P (m , n)

    {- Proving this would be awesome...
    module _ io
             {M₀ M₁ N₀ N₁ : ★}
             (M×N≃ : (M₀ × N₀) ≃ (M₁ × N₁))
             {P₀ : M₀ × N₀ → Proto}{P₁ : M₁ × N₁ → Proto}
             (P= : ∀ m,n₀ → P₀ m,n₀ ≡ P₁ (–> M×N≃ m,n₀))
             {{_ : UA}} where
        com₂≃ : com₂ io P₀ ≡ com₂ io P₁
        com₂≃ = {!com=!}
    -}

    send= = com= {Out} refl
    send≃ = com≃ {Out} refl
    recv= = com= {In} refl
    recv≃ = com≃ {In} refl

    com=′ : ∀ io {M}{P₀ P₁ : M → Proto}(P= : ∀ m → P₀ m ≡ P₁ m) → com io P₀ ≡ com io P₁
    com=′ io = com= refl refl

    send=′ : ∀ {M}{P₀ P₁ : M → Proto}(P= : ∀ m → P₀ m ≡ P₁ m) → send P₀ ≡ send P₁
    send=′ = send= refl

    recv=′ : ∀ {M}{P₀ P₁ : M → Proto}(P= : ∀ m → P₀ m ≡ P₁ m) → recv P₀ ≡ recv P₁
    recv=′ = recv= refl

pattern recvE M P = com In  {M} P
pattern sendE M P = com Out {M} P

recv☐ : {M : ★}(P : ..(_ : M) → Proto) → Proto
recv☐ P = recv (λ { [ m ] → P m })

send☐ : {M : ★}(P : ..(_ : M) → Proto) → Proto
send☐ P = send (λ { [ m ] → P m })

{-
dual : Proto → Proto
dual end      = end
dual (send P) = recv λ m → dual (P m)
dual (recv P) = send λ m → dual (P m)
-}

dual : Proto → Proto
dual end        = end
dual (com io P) = com (dualᴵᴼ io) λ m → dual (P m)

source-of : Proto → Proto
source-of end       = end
source-of (com _ P) = send λ m → source-of (P m)

sink-of : Proto → Proto
sink-of = dual ∘ source-of

data IsSource : Proto → ★₁ where
  end   : IsSource end
  send' : ∀ {M P} (PT : (m : M) → IsSource (P m)) → IsSource (send P)

data IsSink : Proto → ★₁ where
  end   : IsSink end
  recv' : ∀ {M P} (PT : (m : M) → IsSink (P m)) → IsSink (recv P)

data Proto☐ : Proto → ★₁ where
  end : Proto☐ end
  com : ∀ io {M P} (P☐ : ∀ (m : ☐ M) → Proto☐ (P m)) → Proto☐ (com io P)

record End_ ℓ : ★_ ℓ where
  constructor end

End : ∀ {ℓ} → ★_ ℓ
End = End_ _

End-equiv : End ≃ 𝟙
End-equiv = equiv {₀} _ _ (λ _ → refl) (λ _ → refl)

End-uniq : {{_ : UA}} → End ≡ 𝟙
End-uniq = ua End-equiv

⟦_⟧ᴵᴼ : InOut → ∀{ℓ}(M : ★_ ℓ)(P : M → ★_ ℓ) → ★_ ℓ
⟦_⟧ᴵᴼ In  = Π
⟦_⟧ᴵᴼ Out = Σ

⟦_⟧ : ∀ {ℓ} → Proto_ ℓ → ★_ ℓ
⟦ end      ⟧ = End
⟦ com io P ⟧ = ⟦ io ⟧ᴵᴼ _ λ m → ⟦ P m ⟧

⟦_⊥⟧ : Proto → ★
⟦ P ⊥⟧ = ⟦ dual P ⟧

Log : Proto → ★
Log P = ⟦ source-of P ⟧

Sink : Proto → ★
Sink P = ⟦ sink-of P ⟧

sink : ∀ P → Sink P
sink end         = _
sink (com _ P) x = sink (P x)

telecom : ∀ P → ⟦ P ⟧ → ⟦ P ⊥⟧ → Log P
telecom end      _       _       = _
telecom (recv P) p       (m , q) = m , telecom (P m) (p m) q
telecom (send P) (m , p) q       = m , telecom (P m) p (q m)

send′ : ★ → Proto → Proto
send′ M P = send λ (_ : M) → P

recv′ : ★ → Proto → Proto
recv′ M P = recv λ (_ : M) → P

module _ {{_ : FunExt}} where
    dual-involutive : ∀ P → dual (dual P) ≡ P
    dual-involutive end        = refl
    dual-involutive (com io P) = com= (dualᴵᴼ-involutive io) refl λ m → dual-involutive (P m)

    dual-equiv : Is-equiv dual
    dual-equiv = self-inv-is-equiv dual-involutive

    dual-inj : ∀ {P Q} → dual P ≡ dual Q → P ≡ Q
    dual-inj = Is-equiv.injective dual-equiv

    source-of-idempotent : ∀ P → source-of (source-of P) ≡ source-of P
    source-of-idempotent end       = refl
    source-of-idempotent (com _ P) = com= refl refl λ m → source-of-idempotent (P m)

    source-of-dual-oblivious : ∀ P → source-of (dual P) ≡ source-of P
    source-of-dual-oblivious end       = refl
    source-of-dual-oblivious (com _ P) = com= refl refl λ m → source-of-dual-oblivious (P m)

module _ {{_ : FunExt}} where
    sink-contr : ∀ P s → sink P ≡ s
    sink-contr end       s = refl
    sink-contr (com _ P) s = λ= λ m → sink-contr (P m) (s m)

    Sink-is-contr : ∀ P → Is-contr (Sink P)
    Sink-is-contr P = sink P , sink-contr P

    𝟙≃Sink : ∀ P → 𝟙 ≃ Sink P
    𝟙≃Sink P = Is-contr-to-Is-equiv.𝟙≃ (Sink-is-contr P)

    dual-Log : ∀ P → Log (dual P) ≡ Log P
    dual-Log = ap ⟦_⟧ ∘ source-of-dual-oblivious


#14 scraps

#14 scraps

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
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 boxed values, indeterminates, cast
-- 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
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter er) = ve bv (lem er)
    where
    -- todo: also being used below
    lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
    lem (CECong FHOuter ce) = lem ce
    lem (CECong (FHCast x₁) ce) = CECong x₁ ce
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong FHOuter er) = ve bv (lem er)
    where
    --- todo: okay this is now getting reused here and in the case of ie
    --- below, so this is apparently more of an interesting property than
    --- i'd thought
    lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
    lem (CECastFail x₁ x₂ () x₄)
    lem (CECong FHOuter ce) = lem ce
    lem (CECong (FHCast x₁) ce) = CECong x₁ ce
  ve (BVHoleCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVVal x) (CECong FHOuter er) = ve (BVVal x) er
  ve (BVVal ()) (CECong (FHAp1 x₁) er)
  ve (BVVal ()) (CECong (FHAp2 x₁ x₂) er)
  ve (BVVal ()) (CECong (FHNEHole x₁) er)
  ve (BVVal ()) (CECong (FHCast x₁) er)

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast () bv) (d' , Step FHOuter (ITCastID x₁) FHOuter)
  vs (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
  vs (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround x₁ x₂) FHOuter) = x₂ refl
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- todo: there's something going on with these lemmas here that's
    -- repetative and i don't quite understand how to make it more compact

    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err
    ie (INEHole x) (CECong FHOuter err) = fe x (lem err)
      where
      lem : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHNEHole x₁) ce) = CECong x₁ ce
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err)
      with lem err
      where
      lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
      lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
    ... | Inl d1err = ie indet d1err
    ... | Inr d2err = fe x₁ d2err
      where
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
      lem (CECastFail x₁ x₂ () x₄)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = ie indet (lem err x)
      where
      lem : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → ((d' : dhexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇⦈ ⟩)) → d casterr
      lem (CECastFail x₂ x₃ x₄ x₅) f = abort (f _ _ refl)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₂) ce) _ = CECong x₂ ce
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole () ind) (ITCastID x₁)
  lem2 (ICastGroundHole x ind) (ITCastSucceed x₁ ())
  lem2 (ICastGroundHole GHole ind) (ITGround x₁ x₂) = x₂ refl
  lem2 (ICastHoleGround x ind ()) (ITCastID x₂)
  lem2 (ICastHoleGround x ind x₁) (ITCastSucceed x₂ x₃) = x _ _ refl
  lem2 (ICastHoleGround x ind GHole) (ITExpand x₂ x₃) = x₃ refl

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁ y ) = y refl

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround _ y) FHOuter) = y refl
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    is (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    -- cast fail cases
  es (CECastFail x x₁ () x₃) (_ , Step FHOuter (ITCastID x₄) FHOuter)
  es (CECastFail x x₁ x₂ x₃) (_ , Step FHOuter (ITCastSucceed x₄ x₅) FHOuter) = x₃ refl
  es (CECastFail x x₁ GHole x₃) (_ , Step FHOuter (ITExpand x₄ x₅) FHOuter) = x₅ refl
  es (CECastFail x x₁ x₂ x₃) (_ , Step (FHCast x₄) x₅ (FHCast x₆)) = {!!} -- es ? (_ , Step x₄ x₅ x₆)

    -- congruence cases -- es ce
  es (CECong x ce) (_ , Step FHOuter x₂ FHOuter) = {!!}
  es (CECong x ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = {!x!}
  es (CECong x ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  es (CECong x ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = {!!}
  es (CECong x ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!}

  -- es (CECong FHOuter er) (d0' , Step FHOuter x₂ FHOuter) = es er (_ , Step FHOuter x₂ FHOuter)
  -- es (CECong (FHAp1 x) er) (d0' , Step FHOuter x₂ FHOuter) = {!er!}
  -- es (CECong (FHAp2 x x₁) er) (d0' , Step FHOuter x₂ FHOuter) = {!!}
  -- es (CECong (FHNEHole x) er) (d0' , Step FHOuter x₂ FHOuter) = {!!}
  -- es (CECong (FHCast x) er) (d0' , Step FHOuter x₂ FHOuter) = {!!}

  -- es (CECong FHOuter er) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = {!!}
  -- es (CECong (FHAp1 x) er) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = {!!}
  -- es (CECong (FHAp2 x x₁) er) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = fs x (_ , Step x₂ x₃ x₄)

  -- es (CECong FHOuter er) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  -- es (CECong (FHAp1 x) er) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  -- es (CECong (FHAp2 x x₁) er) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = {!!}
  -- --     with lem {!!}
  -- --     where
  -- --     lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
  -- --     lem (CECong FHOuter ce) = lem ce
  -- --     lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
  -- --     lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
  -- -- ... | Inl d1err = {!!}
  -- -- ... | Inr d2err = {!!} -- = es {!!} (_ , Step x₂ x₃ x₅)
  -- es (CECong FHOuter er) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = {!!}
  -- es (CECong (FHNEHole x) er) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = {!!}

  -- es (CECong FHOuter er) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!}
  -- es (CECong (FHCast x) er) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!}

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import 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 boxed values, indeterminates, cast
-- 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
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter er) = ve bv (lem er)
    where
    -- todo: also being used below
    lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
    lem (CECong FHOuter ce) = lem ce
    lem (CECong (FHCast x₁) ce) = CECong x₁ ce
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong FHOuter er) = ve bv (lem er)
    where
    --- todo: okay this is now getting reused here and in the case of ie
    --- below, so this is apparently more of an interesting property than
    --- i'd thought
    lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
    lem (CECastFail x₁ x₂ () x₄)
    lem (CECong FHOuter ce) = lem ce
    lem (CECong (FHCast x₁) ce) = CECong x₁ ce
  ve (BVHoleCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVVal x) (CECong FHOuter er) = ve (BVVal x) er
  ve (BVVal ()) (CECong (FHAp1 x₁) er)
  ve (BVVal ()) (CECong (FHAp2 x₁ x₂) er)
  ve (BVVal ()) (CECong (FHNEHole x₁) er)
  ve (BVVal ()) (CECong (FHCast x₁) er)

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast () bv) (d' , Step FHOuter (ITCastID x₁) FHOuter)
  vs (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
  vs (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround x₁ x₂) FHOuter) = x₂ refl
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- todo: there's something going on with these lemmas here that's
    -- repetative and i don't quite understand how to make it more compact

    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err
    ie (INEHole x) (CECong FHOuter err) = fe x (lem err)
      where
      lem : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHNEHole x₁) ce) = CECong x₁ ce
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err)
      with lem err
      where
      lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
      lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
    ... | Inl d1err = ie indet d1err
    ... | Inr d2err = fe x₁ d2err
      where
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
      lem (CECastFail x₁ x₂ () x₄)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = ie indet (lem err x)
      where
      lem : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → ((d' : dhexp) (τ' : htyp) → d ≠ (d' ⟨ τ' ⇒ ⦇⦈ ⟩)) → d casterr
      lem (CECastFail x₂ x₃ x₄ x₅) f = abort (f _ _ refl)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₂) ce) _ = CECong x₂ ce
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole () ind) (ITCastID x₁)
  lem2 (ICastGroundHole x ind) (ITCastSucceed x₁ ())
  lem2 (ICastGroundHole GHole ind) (ITGround x₁ x₂) = x₂ refl
  lem2 (ICastHoleGround x ind ()) (ITCastID x₂)
  lem2 (ICastHoleGround x ind x₁) (ITCastSucceed x₂ x₃) = x _ _ refl
  lem2 (ICastHoleGround x ind GHole) (ITExpand x₂ x₃) = x₃ refl

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁ y ) = y refl

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround _ y) FHOuter) = y refl
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    is (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es (CECastFail x x₁ () x₃) (_ , Step FHOuter (ITCastID x₄) FHOuter)
  es (CECastFail x x₁ x₂ x₃) (d' , Step FHOuter (ITCastSucceed x₄ x₅) FHOuter) = x₃ refl
  es (CECastFail x x₁ GHole x₃) (_ , Step FHOuter (ITExpand x₄ x₅) FHOuter) = x₅ refl
  es (CECastFail x x₁ x₂ x₃) (_ , Step (FHCast x₄) x₅ (FHCast x₆)) = {!!} -- cyrus

  es (CECong FHOuter er) (d0' , Step FHOuter x₂ FHOuter) = es er (_ , Step FHOuter x₂ FHOuter)
  es (CECong (FHAp1 x) er) (d0' , Step FHOuter x₂ FHOuter) = {!er!}
  es (CECong (FHAp2 x x₁) er) (d0' , Step FHOuter x₂ FHOuter) = {!!}
  es (CECong (FHNEHole x) er) (d0' , Step FHOuter x₂ FHOuter) = {!!}
  es (CECong (FHCast x) er) (d0' , Step FHOuter x₂ FHOuter) = {!!}

  es (CECong FHOuter er) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = {!!}
  es (CECong (FHAp1 x) er) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = {!!}
  es (CECong (FHAp2 x x₁) er) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = fs x (_ , Step x₂ x₃ x₄)

  es (CECong FHOuter er) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  es (CECong (FHAp1 x) er) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  es (CECong (FHAp2 x x₁) er) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = {!!}
  --     with lem {!!}
  --     where
  --     lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
  --     lem (CECong FHOuter ce) = lem ce
  --     lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
  --     lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
  -- ... | Inl d1err = {!!}
  -- ... | Inr d2err = {!!} -- = es {!!} (_ , Step x₂ x₃ x₅)
  es (CECong FHOuter er) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = {!!}
  es (CECong (FHNEHole x) er) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = {!!}

  es (CECong FHOuter er) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!}
  es (CECong (FHCast x) er) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!}


cleaning up preservation pre ae, rel to #52 and #49

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

open import lemmas-consistency
open import type-assignment-unicity
open import binders-disjoint-checks

open import lemmas-subst-ta

module preservation where
  -- if d and d' both result from filling the hole in ε with terms of the
  -- same type, they too have the same type.
  wt-different-fill : ∀{ Δ Γ d ε d1 d2 d' τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d' == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d' :: τ
  wt-different-fill FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  wt-different-fill (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (wt-different-fill eps D1 D3 D4 D5) D2
  wt-different-fill (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (wt-different-fill eps D2 D3 D4 D5)
  wt-different-fill (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (wt-different-fill eps D1 D2 D3 D4) x₁
  wt-different-fill (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (wt-different-fill eps D1 D2 D3 D4) x
  wt-different-fill (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (wt-different-fill x y D3 D4 eps) x₁ x₂ x₃

  -- if a well typed term results from filling the hole in ε, then the term
  -- that filled the hole is also well typed
  wt-filling : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  wt-filling TAConst FHOuter = _ , TAConst
  wt-filling (TAVar x₁) FHOuter = _ , TAVar x₁
  wt-filling (TALam f ta) FHOuter = _ , TALam f ta

  wt-filling (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  wt-filling (TAAp ta ta₁) (FHAp1 eps) = wt-filling ta eps
  wt-filling (TAAp ta ta₁) (FHAp2 eps) = wt-filling ta₁ eps

  wt-filling (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  wt-filling (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  wt-filling (TANEHole x ta x₁) (FHNEHole eps) = wt-filling ta eps
  wt-filling (TACast ta x) FHOuter = _ , TACast ta x
  wt-filling (TACast ta x) (FHCast eps) = wt-filling ta eps
  wt-filling (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  wt-filling (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = wt-filling x y

  -- instruction transitions preserve type
  preserve-trans : ∀{ Δ Γ d τ d' } →
            binders-unique d →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  preserve-trans bd TAConst ()
  preserve-trans bd (TAVar x₁) ()
  preserve-trans bd (TALam _ ta) ()
  preserve-trans (BUAp (BULam bd x₁) bd₁ (BDLam x₂ x₃)) (TAAp (TALam apt ta) ta₁) ITLam = lem-subst apt x₂ bd₁ ta ta₁
  preserve-trans bd (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  preserve-trans bd (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  preserve-trans bd (TAEHole x x₁) ()
  preserve-trans bd (TANEHole x ta x₁) ()
  preserve-trans bd (TACast ta x) (ITCastID) = ta
  preserve-trans bd (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  preserve-trans bd (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  preserve-trans bd (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  preserve-trans bd (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  preserve-trans bd (TAFailedCast x y z q) ()

  -- this is the main preservation theorem, gluing together the above
  preservation : {Δ : hctx} {d d' : ihexp} {τ : htyp} {Γ : tctx} →
             binders-unique d →
             Δ , Γ ⊢ d :: τ →
             d ↦ d' →
             Δ , Γ ⊢ d' :: τ
  preservation bd D (Step x x₁ x₂)
    with wt-filling D x
  ... | (_ , wt) = wt-different-fill x D wt (preserve-trans (lem-bd-ε1 x bd) wt x₁) x₂

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

open import lemmas-consistency
open import type-assignment-unicity
open import binders-disjoint-checks

open import lemmas-subst-ta

module preservation where
  -- if d and d' both result from filling the hole in ε with terms of the
  -- same type, they too have the same type.
  wt-different-fill : ∀{ Δ Γ d ε d1 d2 d' τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d' == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d' :: τ
  wt-different-fill FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  wt-different-fill (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (wt-different-fill eps D1 D3 D4 D5) D2
  wt-different-fill (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (wt-different-fill eps D2 D3 D4 D5)
  wt-different-fill (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (wt-different-fill eps D1 D2 D3 D4) x₁
  wt-different-fill (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (wt-different-fill eps D1 D2 D3 D4) x
  wt-different-fill (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (wt-different-fill x y D3 D4 eps) x₁ x₂ x₃

  -- if a well typed term results from filling the hole in ε, then the term
  -- that filled the hole is also well typed
  wt-filling : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  wt-filling TAConst FHOuter = _ , TAConst
  wt-filling (TAVar x₁) FHOuter = _ , TAVar x₁
  wt-filling (TALam f ta) FHOuter = _ , TALam f ta

  wt-filling (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  wt-filling (TAAp ta ta₁) (FHAp1 eps) = wt-filling ta eps
  wt-filling (TAAp ta ta₁) (FHAp2 eps) = wt-filling ta₁ eps

  wt-filling (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  wt-filling (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  wt-filling (TANEHole x ta x₁) (FHNEHole eps) = wt-filling ta eps
  wt-filling (TACast ta x) FHOuter = _ , TACast ta x
  wt-filling (TACast ta x) (FHCast eps) = wt-filling ta eps
  wt-filling (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  wt-filling (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = wt-filling x y

  -- instruction transitions preserve type
  preserve-trans : ∀{ Δ Γ d τ d' } →
            binders-unique d →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  preserve-trans bd TAConst ()
  preserve-trans bd (TAVar x₁) ()
  preserve-trans bd (TALam _ ta) ()
  preserve-trans (BUAp (BULam bd x₁) bd₁ (BDLam x₂ x₃)) (TAAp (TALam apt ta) ta₁) ITLam = lem-subst apt x₂ bd₁ ta ta₁
  preserve-trans bd (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  preserve-trans bd (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  preserve-trans bd (TAEHole x x₁) ()
  preserve-trans bd (TANEHole x ta x₁) ()
  preserve-trans bd (TACast ta x) (ITCastID) = ta
  preserve-trans bd (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  preserve-trans bd (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  preserve-trans bd (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  preserve-trans bd (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  preserve-trans bd (TAFailedCast x y z q) ()

  -- binder uniqueness is preserved by hole filling
  lem-bd-ε1 : ∀{ d ε d0} → d == ε ⟦ d0 ⟧ → binders-unique d → binders-unique d0
  lem-bd-ε1 FHOuter bd = bd
  lem-bd-ε1 (FHAp1 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHAp2 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd₁
  lem-bd-ε1 (FHNEHole eps) (BUNEHole bd x) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHCast eps) (BUCast bd) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHFailedCast eps) (BUFailedCast bd) = lem-bd-ε1 eps bd

  -- mutual
  --   bu-subst : ∀{d1 d2 x} → binders-unique d1 → binders-unique d2 → unbound-in x d1 → binders-unique ([ d2 / x ] d1)
  --   bu-subst BUHole bu2 ub = BUHole
  --   bu-subst {x = x} (BUVar {x = y}) bu2 UBVar with natEQ y x
  --   bu-subst BUVar bu2 UBVar | Inl refl = bu2
  --   bu-subst BUVar bu2 UBVar | Inr x₂ = BUVar
  --   bu-subst {x = x} (BULam {x = y}  bu1 x₂) bu2 (UBLam2 x₃ ub) with natEQ y x
  --   bu-subst (BULam bu1 x₃) bu2 (UBLam2 x₄ ub) | Inl refl = BULam bu1 ub -- can also abort here; odd
  --   bu-subst (BULam bu1 x₃) bu2 (UBLam2 x₄ ub) | Inr x₂ = BULam (bu-subst bu1 bu2 ub) {!!}
  --   bu-subst (BUEHole x₁) bu2 (UBHole x₂) = BUEHole (BUσSubst bu2 {!!})
  --   bu-subst (BUNEHole bu1 x₁) bu2 (UBNEHole x₂ ub) = BUNEHole (bu-subst bu1 bu2 ub) (BUσSubst bu2 {!!})
  --   bu-subst (BUAp bu1 bu2 x₁) bu3 (UBAp ub ub₁) = BUAp (bu-subst bu1 bu3 ub) (bu-subst bu2 bu3 ub₁) {!!}
  --   bu-subst (BUCast bu1) bu2 (UBCast ub) = BUCast (bu-subst bu1 bu2 ub)
  --   bu-subst (BUFailedCast bu1) bu2 (UBFailedCast ub) = BUFailedCast (bu-subst bu1 bu2 ub)

  -- bu-trans : ∀{d0 d0'} → binders-unique d0 → d0 →> d0' → binders-unique d0'
  -- bu-trans BUHole ()
  -- bu-trans BUVar ()
  -- bu-trans (BULam bu x₁) ()
  -- bu-trans (BUEHole x) ()
  -- bu-trans (BUNEHole bu x) ()
  -- bu-trans (BUAp (BULam bu x₁) bu₁ (BDLam x₂ x₃)) ITLam = bu-subst bu bu₁ x₁
  -- bu-trans (BUAp (BUCast bu) bu₁ (BDCast x)) ITApCast = BUCast (BUAp bu (BUCast bu₁) (lem-bd-into-cast x))
  -- bu-trans (BUCast bu) ITCastID = bu
  -- bu-trans (BUCast (BUCast bu)) (ITCastSucceed x) = bu
  -- bu-trans (BUCast (BUCast bu)) (ITCastFail x x₁ x₂) = BUFailedCast bu
  -- bu-trans (BUCast bu) (ITGround x) = BUCast (BUCast bu)
  -- bu-trans (BUCast bu) (ITExpand x) = BUCast (BUCast bu)
  -- bu-trans (BUFailedCast bu) ()

  -- subst-disjoint : ∀{d1 d2 d3 x} → binders-disjoint d1 d2 → unbound-in x d2 → binders-disjoint d3 d2 →  binders-disjoint ([ d3 / x ] d1) d2
  -- subst-disjoint = {!!}

  -- lem3 : ∀{d1 d2 d3} → d1 →> d3 → binders-disjoint d1 d2 → binders-disjoint d3 d2
  -- lem3 ITLam (BDAp (BDLam disj x₁) disj₁) = subst-disjoint disj x₁ disj₁
  -- lem3 ITCastID (BDCast disj) = disj
  -- lem3 (ITCastSucceed x) (BDCast (BDCast disj)) = disj
  -- lem3 (ITCastFail x x₁ x₂) (BDCast (BDCast disj)) = BDFailedCast disj
  -- lem3 ITApCast (BDAp (BDCast disj) disj₁) = BDCast (BDAp disj (BDCast disj₁))
  -- lem3 (ITGround x) (BDCast disj) = BDCast (BDCast disj)
  -- lem3 (ITExpand x) (BDCast disj) = BDCast (BDCast disj)

  -- decomp1 : ∀{d0 d1 d2 ε} → d1 == ε ⟦ d0 ⟧ → binders-disjoint d1 d2 → binders-disjoint d0 d2
  -- decomp1 = {!!}

  -- lem2 : ∀{d1 d2 d3} → d1 ↦ d3 → binders-disjoint d1 d2 → binders-disjoint d3 d2
  -- lem2 (Step x y z) disj = {!(lem3 y (decomp x disj))!} --
  -- lem2 (Step FHOuter () FHOuter) BDConst
  -- lem2 (Step FHOuter () x₃) BDVar
  -- lem2 (Step FHOuter () x₃) (BDLam disj x₄)
  -- lem2 (Step FHOuter () FHOuter) (BDHole x₃)
  -- lem2 (Step FHOuter () FHOuter) (BDNEHole x₃ disj)
  -- lem2 (Step (FHNEHole x) x₁ (FHNEHole x₂)) (BDNEHole x₃ disj) = BDNEHole x₃ (lem2 (Step x x₁ x₂) disj)
  -- lem2 (Step FHOuter ITLam FHOuter) (BDAp (BDLam disj x₁) disj₁) = subst-disjoint disj x₁ disj₁
  -- lem2 (Step FHOuter ITApCast FHOuter) (BDAp (BDCast disj) disj₁) = BDCast (BDAp disj (BDCast disj₁))

  -- lem2 (Step (FHAp1 x₁) ITLam (FHAp1 x₂)) (BDAp disj disj₁) = BDAp {!!} disj₁

  -- lem2 (Step (FHAp1 x) ITCastID (FHAp1 x₂)) (BDAp disj disj₁) = {!!}
  -- lem2 (Step (FHAp1 x) (ITCastSucceed x₁) (FHAp1 x₂)) (BDAp disj disj₁) = {!!}
  -- lem2 (Step (FHAp1 x) (ITCastFail x₁ x₂ x₃) (FHAp1 x₄)) (BDAp disj disj₁) = {!!}
  -- lem2 (Step (FHAp1 x) ITApCast (FHAp1 x₂)) (BDAp disj disj₁) = {!!}
  -- lem2 (Step (FHAp1 x) (ITGround x₁) (FHAp1 x₂)) (BDAp disj disj₁) = {!!}
  -- lem2 (Step (FHAp1 x) (ITExpand x₁) (FHAp1 x₂)) (BDAp disj disj₁) = {!!}
  -- lem2 (Step (FHAp2 x) x₁ (FHAp2 x₂)) (BDAp disj disj₁) = {!!}
  -- lem2 step (BDCast disj) = {!!}
  -- lem2 step (BDFailedCast disj) = {!!}

  -- lem' : ∀{d d'} → d ↦ d' → binders-unique d → binders-unique d'
  -- lem' (Step FHOuter () FHOuter) BUHole
  -- lem' (Step FHOuter () FHOuter) BUVar
  -- lem' (Step FHOuter () FHOuter) (BULam bd x₄)
  -- lem' (Step FHOuter () FHOuter) (BUEHole x₃)

  -- lem' (Step FHOuter () FHOuter) (BUNEHole bd x₃)
  -- lem' (Step (FHNEHole x) x₁ (FHNEHole x₂)) (BUNEHole bd x₃) = BUNEHole (lem' (Step x x₁ x₂) bd) x₃

  -- lem' (Step FHOuter ITLam FHOuter) (BUAp (BULam bd x₁) bd₁ (BDLam x₃ x₂)) = bu-subst bd bd₁ x₁
  -- lem' (Step FHOuter ITApCast FHOuter) (BUAp (BUCast bd) bd₁ (BDCast x₃)) = BUCast (BUAp bd (BUCast bd₁) {!lem-bd-cast!}) -- easy lemma, i think?
  -- lem' (Step (FHAp1 x) x₁ (FHAp1 x₂)) (BUAp bd bd₁ x₃) = BUAp (lem' (Step x x₁ x₂) bd) bd₁ {!Step x x₁ x₂!}
  -- lem' (Step (FHAp2 x) x₁ (FHAp2 x₂)) (BUAp bd bd₁ x₃) = BUAp bd (lem' (Step x x₁ x₂) bd₁) {!(Step x x₁ x₂)!}

  -- lem' (Step FHOuter ITCastID FHOuter) (BUCast bd) = bd
  -- lem' (Step FHOuter (ITCastSucceed x) FHOuter) (BUCast (BUCast bd)) = bd
  -- lem' (Step FHOuter (ITCastFail x x₁ x₂) FHOuter) (BUCast (BUCast bd)) = BUFailedCast bd
  -- lem' (Step FHOuter (ITGround x) FHOuter) (BUCast bd) = BUCast (BUCast bd)
  -- lem' (Step FHOuter (ITExpand x) FHOuter) (BUCast bd) = BUCast (BUCast bd)
  -- lem' (Step (FHCast x) x₁ (FHCast x₂)) (BUCast bd) = BUCast (lem' (Step x x₁ x₂) bd)

  -- lem' (Step FHOuter () FHOuter) (BUFailedCast bd)
  -- lem' (Step (FHFailedCast x) x₁ (FHFailedCast x₂)) (BUFailedCast bd) = BUFailedCast (lem' (Step x x₁ x₂) bd)

  -- this is the main preservation theorem, gluing together the above
  preservation : {Δ : hctx} {d d' : ihexp} {τ : htyp} {Γ : tctx} →
             binders-unique d →
             Δ , Γ ⊢ d :: τ →
             d ↦ d' →
             Δ , Γ ⊢ d' :: τ -- × binders-unique d'
  preservation bd D (Step x x₁ x₂)
    with wt-filling D x
  ... | (_ , wt) = wt-different-fill x D wt (preserve-trans (lem-bd-ε1 x bd) wt x₁) x₂
                 -- {!bu-trans (lem-bd-ε1 x bd) x₁ !}

-- lem' (Step x x₁ x₂) bd --