more bounty from added premise #14

more bounty from added premise #14

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 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
  -- 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 er stp = {!!}

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 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
  -- 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 x bv) (d' , Step FHOuter x₂ FHOuter) = {!x₂!} -- cyrus
  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 x ind) stp = {!!}
  lem2 (ICastHoleGround x ind x₁) stp = {!!}

  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 er stp = {!!}


Desc model: add the map operator

Desc model: add the map operator


Use ⟦⊕₍_₎⟧ and ⟦⊝₍_₎⟧ in Popl14.Change.Evaluation.

Old-commit-hash: a05b08ff42508e49817f899523f4849e9334e057

module Popl14.Change.Evaluation where

open import Popl14.Syntax.Type
open import Popl14.Syntax.Term
open import Popl14.Change.Type
open import Popl14.Change.Term
open import Popl14.Change.Value
open import Popl14.Denotation.Value
open import Popl14.Denotation.Evaluation

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation

open import Postulate.Extensionality

-- unique names with unambiguous types
-- to help type inference figure things out
private
  module Disambiguation where
    infixr 9 _⋆_
    _⋆_ : Type → Context → Context
    _⋆_ = _•_

-- Relating `diff` with `diff-term`, `apply` with `apply-term`
meaning-⊕ : ∀ {τ Γ}
  {t : Term Γ τ} {Δt : Term Γ (ΔType τ)} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕ Δt ⟧ ρ

meaning-⊝ : ∀ {τ Γ}
  {s : Term Γ τ} {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
  ⟦ s ⟧ ρ ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝ t ⟧ ρ

meaning-⊕ {base base-int} = refl
meaning-⊕ {base base-bag} = refl
meaning-⊕ {σ ⇒ τ} {Γ} {t} {Δt} {ρ} = ext (λ v →
  let
    Γ′ = σ ⋆ (σ ⇒ τ) ⋆ ΔType (σ ⇒ τ) ⋆ Γ
    ρ′ : ⟦ Γ′ ⟧
    ρ′ = v • (⟦ t ⟧ ρ) • (⟦ Δt ⟧ ρ) • ρ
    x  : Term Γ′ σ
    x  = var this
    f  : Term Γ′ (σ ⇒ τ)
    f  = var (that this)
    Δf : Term Γ′ (ΔType (σ ⇒ τ))
    Δf = var (that (that this))
    y  = app f x
    Δy = app (app Δf x) (x ⊝ x)
  in
    begin
      ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (v ⟦⊝₍ σ ₎⟧ v)
    ≡⟨ cong (λ hole → ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v hole)
         (meaning-⊝ {s = x} {x} {ρ′}) ⟩
      ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (⟦ x ⊝ x ⟧ ρ′)
    ≡⟨ meaning-⊕ {t = y} {Δt = Δy} {ρ′} ⟩
      ⟦ y ⊕ Δy ⟧ ρ′
    ∎)
  where
    open ≡-Reasoning
    open Disambiguation

meaning-⊝ {int} = refl
meaning-⊝ {bag} = refl
meaning-⊝ {σ ⇒ τ} {Γ} {s} {t} {ρ} =
  ext (λ v → ext (λ Δv →
  let
    Γ′ = ΔType σ ⋆ σ ⋆ (σ ⇒ τ) ⋆ (σ ⇒ τ) ⋆ Γ
    ρ′ : ⟦ Γ′ ⟧Context
    ρ′ = Δv • v • ⟦ t ⟧Term ρ • ⟦ s ⟧Term ρ • ρ
    Δx : Term Γ′ (ΔType σ)
    Δx = var this
    x  : Term Γ′ σ
    x  = var (that this)
    f  : Term Γ′ (σ ⇒ τ)
    f  = var (that (that this))
    g  : Term Γ′ (σ ⇒ τ)
    g  = var (that (that (that this)))
    y  = app f x
    y′ = app g (x ⊕ Δx)
  in
    begin
      ⟦ s ⟧ ρ (v ⟦⊕₍ σ ₎⟧ Δv) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
    ≡⟨ cong (λ hole → ⟦ s ⟧ ρ hole ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v)
         (meaning-⊕ {t = x} {Δt = Δx} {ρ′}) ⟩
      ⟦ s ⟧ ρ (⟦ x ⊕ Δx ⟧ ρ′) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
    ≡⟨ meaning-⊝ {s = y′} {y} {ρ′} ⟩
      ⟦ y′ ⊝ y ⟧ ρ′
    ∎))
  where
    open ≡-Reasoning
    open Disambiguation

module Popl14.Change.Evaluation where

open import Popl14.Syntax.Type
open import Popl14.Syntax.Term
open import Popl14.Change.Type
open import Popl14.Change.Term
open import Popl14.Change.Value
open import Popl14.Denotation.Value
open import Popl14.Denotation.Evaluation

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation

open import Postulate.Extensionality

-- unique names with unambiguous types
-- to help type inference figure things out
private
  module Disambiguation where
    infixr 9 _⋆_
    _⋆_ : Type → Context → Context
    _⋆_ = _•_

-- Relating `diff` with `diff-term`, `apply` with `apply-term`
meaning-⊕ : ∀ {τ Γ}
  {t : Term Γ τ} {Δt : Term Γ (ΔType τ)} {ρ : ⟦ Γ ⟧} →
  let
    _+_ = _⟦⊕⟧_ {τ}
  in
    ⟦ t ⟧ ρ + ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕ Δt ⟧ ρ

meaning-⊝ : ∀ {τ Γ}
  {s : Term Γ τ} {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
  let
    _-_ = _⟦⊝⟧_ {τ}
  in
    ⟦ s ⟧ ρ - ⟦ t ⟧ ρ ≡ ⟦ s ⊝ t ⟧ ρ

meaning-⊕ {base base-int} = refl
meaning-⊕ {base base-bag} = refl
meaning-⊕ {σ ⇒ τ} {Γ} {t} {Δt} {ρ} = ext (λ v →
  let
    Γ′ = σ ⋆ (σ ⇒ τ) ⋆ ΔType (σ ⇒ τ) ⋆ Γ
    ρ′ : ⟦ Γ′ ⟧
    ρ′ = v • (⟦ t ⟧ ρ) • (⟦ Δt ⟧ ρ) • ρ
    _-₀_ = _⟦⊝⟧_ {σ}
    _+₁_ = _⟦⊕⟧_ {τ}
    x  : Term Γ′ σ
    x  = var this
    f  : Term Γ′ (σ ⇒ τ)
    f  = var (that this)
    Δf : Term Γ′ (ΔType (σ ⇒ τ))
    Δf = var (that (that this))
    y  = app f x
    Δy = app (app Δf x) (x ⊝ x)
  in
    begin
      ⟦ t ⟧ ρ v +₁ ⟦ Δt ⟧ ρ v (v -₀ v)
    ≡⟨ cong (λ hole → ⟦ t ⟧ ρ v +₁ ⟦ Δt ⟧ ρ v hole)
         (meaning-⊝ {s = x} {x} {ρ′}) ⟩
      ⟦ t ⟧ ρ v +₁ ⟦ Δt ⟧ ρ v (⟦ x ⊝ x ⟧ ρ′)
    ≡⟨ meaning-⊕ {t = y} {Δt = Δy} {ρ′} ⟩
      ⟦ y ⊕ Δy ⟧ ρ′
    ∎)
  where
    open ≡-Reasoning
    open Disambiguation

meaning-⊝ {int} = refl
meaning-⊝ {bag} = refl
meaning-⊝ {σ ⇒ τ} {Γ} {s} {t} {ρ} =
  ext (λ v → ext (λ Δv →
  let
    Γ′ = ΔType σ ⋆ σ ⋆ (σ ⇒ τ) ⋆ (σ ⇒ τ) ⋆ Γ
    ρ′ : ⟦ Γ′ ⟧Context
    ρ′ = Δv • v • ⟦ t ⟧Term ρ • ⟦ s ⟧Term ρ • ρ
    Δx : Term Γ′ (ΔType σ)
    Δx = var this
    x  : Term Γ′ σ
    x  = var (that this)
    f  : Term Γ′ (σ ⇒ τ)
    f  = var (that (that this))
    g  : Term Γ′ (σ ⇒ τ)
    g  = var (that (that (that this)))
    y  = app f x
    y′ = app g (x ⊕ Δx)
    _+₀_ = _⟦⊕⟧_ {σ}
    _-₁_ = _⟦⊝⟧_ {τ}
  in
    begin
      ⟦ s ⟧ ρ (v +₀ Δv) -₁ ⟦ t ⟧ ρ v
    ≡⟨ cong (λ hole → ⟦ s ⟧ ρ hole -₁ ⟦ t ⟧ ρ v)
         (meaning-⊕ {t = x} {Δt = Δx} {ρ′}) ⟩
      ⟦ s ⟧ ρ (⟦ x ⊕ Δx ⟧ ρ′) -₁ ⟦ t ⟧ ρ v
    ≡⟨ meaning-⊝ {s = y′} {y} {ρ′} ⟩
      ⟦ y′ ⊝ y ⟧ ρ′
    ∎))
  where
    open ≡-Reasoning
    open Disambiguation


Define derivatives for change algebra families.

Old-commit-hash: 7734b87b24dad9b86ce93e2c34acb376d1aab35a


removing redundant rules after removing marks; guess at eval context rules

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

  -- todo: this probably belongs in contexts, but need to abstract it.
  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 u?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of u?
                 Γ ⊢ 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? should this
  -- be judgemental rather than functional?

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

  -- 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 τ1 τ2 Δ2} →
                -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
                Γ ⊢ 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 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ 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 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ 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 # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ 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) (xd∈σ : (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 Γ' τ} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  -- substitution;; todo: maybe get a premise that it's final; analagous to "value substitution"
  [_/_]_ : dhexp → Nat → dhexp → dhexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X y
  [ d / y ] (·λ x [ x₁ ] d') = ·λ x [ x₁ ] ( [ d / y ] d') -- TODO: i *think* barendrecht's saves us here, or at least i want it to. may need to reformulat this as a relation --> set
  [ d / y ] ⦇⦈⟨ u , σ ⟩ = ⦇⦈⟨ u , σ ⟩
  [ d / y ] ⦇ d' ⦈⟨ u , σ  ⟩ =  ⦇ [ d / y ] d' ⦈⟨ u , σ ⟩
  [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (< τ > d') = < τ > ([ d / y ] d')

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

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

  -- error
  data _⊢_err : (Δ : hctx) (d : dhexp) → Set where
    ECastError : ∀{ Δ d τ1 τ2 } → -- lol hax: d final?
                 Δ , ∅ ⊢ d :: τ2 →
                 τ1 ~̸ τ2 →
                 Δ ⊢ (< τ1 > d) err
    EAp1 : ∀{ Δ d1 d2} →
           Δ ⊢ d1 err →
           Δ ⊢ (d1 ∘ d2) err
    EAp2 : ∀{ Δ d1 d2} →
           d1 final →
           Δ ⊢ d2 err →
           Δ ⊢ (d1 ∘ d2) err
    ENEHole : ∀{ Δ d u σ } →
           Δ ⊢ d err →
           Δ ⊢ (⦇ d ⦈⟨ (u , σ)⟩) err
    ECastProp : ∀{ Δ d τ} →
                Δ ⊢ d err →
                Δ ⊢ (< τ > d) err

  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    _∘₁_ : dhexp → ectx → ectx
    _∘₂_ : ectx → dhexp → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst ) → ectx
    <_>_   : htyp → ectx → ectx

 --ε is an evaluation context
  data _evalctx : (ε : ectx) → Set where
    ECDot : ⊙ evalctx
    ECAp1 : ∀{d ε} →
            d final →
            ε evalctx →
            (d ∘₁ ε) evalctx
    ECAp2 : ∀{d ε} →
            ε evalctx →
            (ε ∘₂ d) evalctx
    ECNEHole : ∀{ε u σ} →
               ε evalctx →
               ⦇ ε ⦈⟨ u , σ  ⟩ evalctx
    ECCast : ∀{ ε τ } →
             ε evalctx →
             (< τ > ε ) evalctx

  -- d is the result of filling the hole in ε with d'
  data _==_⟦_⟧ : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FHFinal : ∀{d} → d final → d == ⊙ ⟦ d ⟧
    FHAp1 : ∀{d1 d2 d2' ε} →
           d1 final →
           d2 == ε ⟦ d2' ⟧ →
           (d1 ∘ d2) == (d1 ∘₁ ε) ⟦ d2' ⟧
    FHAp2 : ∀{d1 d1' d2 ε} →
           d1 == ε ⟦ d1' ⟧ →
           (d1 ∘ d2) == (ε ∘₂ d2) ⟦ d1' ⟧
    FHEHole : ∀{u σ} → ⦇⦈⟨ (u , σ ) ⟩ == ⊙ ⟦ ⦇⦈⟨ (u , σ ) ⟩ ⟧
    FHNEHole : ∀{ d d' ε u σ} →
              d == ε ⟦ d' ⟧ →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⦇ ε ⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧
    FHNEHoleFinal : ∀{ d u σ} →
              d final →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⊙ ⟦ ⦇ d ⦈⟨ (u , σ ) ⟩ ⟧
    FHCast : ∀{ d d' ε τ } →
            d == ε ⟦ d' ⟧ →
            (< τ > d) == < τ > ε ⟦ d' ⟧
    FHCastFinal : ∀{d τ} →
                 d final →
                 (< τ > d) == ⊙ ⟦ < τ > d ⟧

  -- instruction transition judgement
  data _⊢_→>_ : (Δ : hctx) (d d' : dhexp) → Set where
    ITLam : ∀{ Δ x τ d1 d2 } →
            d2 final →
            Δ ⊢ ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) -- this is very unlikely to work long term
    ITCast : ∀{d Δ τ1 τ2 } →
             d final →
             Δ , ∅ ⊢ d :: τ2 →
             τ1 ~ τ2 → -- maybe?
             Δ ⊢ < τ1 > d →> d

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε ⟦ d0 ⟧ →
           Δ ⊢ d0 →> d0' →
           d' == ε ⟦ d0' ⟧ →
           Δ ⊢ d ↦ d'

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

  -- todo: this probably belongs in contexts, but need to abstract it.
  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 u?
      SNEHole : {Γ : tctx} {e : hexp} {τ : htyp} {u : Nat} → -- todo: uniqueness of u?
                 Γ ⊢ 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? should this
  -- be judgemental rather than functional?

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

  -- 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 τ1 τ2 Δ2} →
                -- Δ1 ## Δ2 → -- todo: bneed to think about disjointness and context rep
                Γ ⊢ 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 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ 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 → -- todo: bneed to think about disjointness and context rep
              Γ ⊢ 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 # Γ) →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ1 ==> τ2 ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EALamHole : ∀{Γ x e τ d Δ } →
              (x # Γ) →
              (Γ ,, (x , ⦇⦈)) ⊢ e ⇐ ⦇⦈ ~> d :: τ ⊣ Δ  →
              Γ ⊢ ·λ 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) (xd∈σ : (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 Γ' τ} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇ d ⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ τ'} →
             Δ , Γ ⊢ d :: τ' →
             τ ~ τ' →
             Δ , Γ ⊢ < τ > d :: τ

  -- substitution;; todo: maybe get a premise that it's final; analagous to "value substitution"
  [_/_]_ : dhexp → Nat → dhexp → dhexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X y
  [ d / y ] (·λ x [ x₁ ] d') = ·λ x [ x₁ ] ( [ d / y ] d') -- TODO: i *think* barendrecht's saves us here, or at least i want it to. may need to reformulat this as a relation --> set
  [ d / y ] ⦇⦈⟨ u , σ ⟩ = ⦇⦈⟨ u , σ ⟩
  [ d / y ] ⦇ d' ⦈⟨ u , σ  ⟩ =  ⦇ [ d / y ] d' ⦈⟨ u , σ ⟩
  [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (< τ > d') = < τ > ([ d / y ] d')

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

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

  -- error
  data _⊢_err : (Δ : hctx) (d : dhexp) → Set where
    ECastError : ∀{ Δ d τ1 τ2 } → -- lol hax: d final?
                 Δ , ∅ ⊢ d :: τ2 →
                 τ1 ~̸ τ2 →
                 Δ ⊢ (< τ1 > d) err
    EAp1 : ∀{ Δ d1 d2} →
           Δ ⊢ d1 err →
           Δ ⊢ (d1 ∘ d2) err
    EAp2 : ∀{ Δ d1 d2} →
           d1 final →
           Δ ⊢ d2 err →
           Δ ⊢ (d1 ∘ d2) err
    ENEHole : ∀{ Δ d u σ } →
           Δ ⊢ d err →
           Δ ⊢ (⦇ d ⦈⟨ (u , σ)⟩) err
    ECastProp : ∀{ Δ d τ} →
                Δ ⊢ d err →
                Δ ⊢ (< τ > d) err

  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    _∘₁_ : dhexp → ectx → ectx
    _∘₂_ : ectx → dhexp → ectx
    ⦇_⦈⟨_⟩ : ectx → (Nat × subst ) → ectx
    <_>_   : htyp → ectx → ectx

 --ε is an evaluation context
  data _evalctx : (ε : ectx) → Set where
    ECDot : ⊙ evalctx
    ECAp1 : ∀{d ε} →
            d final →
            ε evalctx →
            (d ∘₁ ε) evalctx
    ECAp2 : ∀{d ε} →
            ε evalctx →
            (ε ∘₂ d) evalctx
    ECNEHole : ∀{ε u σ} →
               ε evalctx →
               ⦇ ε ⦈⟨ u , σ  ⟩ evalctx
    ECCast : ∀{ ε τ } →
             ε evalctx →
             (< τ > ε ) evalctx

  -- d is the result of filling the hole in ε with d'
  data _==_⟦_⟧ : (d : dhexp) (ε : ectx) (d' : dhexp) → Set where
    FHFinal : ∀{d} → d final → d == ⊙ ⟦ d ⟧
    FHAp1 : ∀{d1 d2 d2' ε} →
           d1 final →
           d2 == ε ⟦ d2' ⟧ →
           (d1 ∘ d2) == (d1 ∘₁ ε) ⟦ d2' ⟧
    FHAp2 : ∀{d1 d1' d2 ε} →
           d1 == ε ⟦ d1' ⟧ →
           (d1 ∘ d2) == (ε ∘₂ d2) ⟦ d1' ⟧
    FHEHole : ∀{u σ} → ⦇⦈⟨ (u , σ ) ⟩ == ⊙ ⟦ ⦇⦈⟨ (u , σ ) ⟩ ⟧
    FHNEHoleEvaled : ∀{ d u σ} →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⊙ ⟦ ⦇ d ⦈⟨ (u , σ ) ⟩ ⟧
    FHNEHoleInside : ∀{ d d' ε u σ} →
              d == ε ⟦ d' ⟧ →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⦇ ε ⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧
    FHNEHoleFinal : ∀{ d u σ} →
              d final →
              ⦇ d ⦈⟨ (u , σ ) ⟩ ==  ⊙ ⟦ ⦇ d ⦈⟨ (u , σ ) ⟩ ⟧
    FHCast : ∀{ d d' ε τ } →
            d == ε ⟦ d' ⟧ →
            (< τ > d) == < τ > ε ⟦ d' ⟧
    FHCastFinal : ∀{d τ} →
                 d final →
                 (< τ > d) == ⊙ ⟦ < τ > d ⟧

  -- instruction transition judgement
  data _⊢_→>_ : (Δ : hctx) (d d' : dhexp) → Set where
    ITLam : ∀{ Δ x τ d1 d2 } →
            d2 final →
            Δ ⊢ ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1) -- this is very unlikely to work long term
    ITCast : ∀{d Δ τ1 τ2 } →
             d final →
             Δ , ∅ ⊢ d :: τ2 →
             τ1 ~ τ2 → -- maybe?
             Δ ⊢ < τ1 > d →> d
    ITEHole : ∀{ Δ u σ} →
              Δ ⊢ ⦇⦈⟨ u , σ  ⟩ →> ⦇⦈⟨ u , σ  ⟩
    ITNEHole : ∀{ Δ u σ d } →
               d final →
               Δ ⊢ ⦇ d ⦈⟨ u , σ  ⟩ →> ⦇ d ⦈⟨ u , σ  ⟩

  data _⊢_↦_ : (Δ : hctx) (d d' : dhexp) → Set where
    Step : ∀{ d d0 d' d0' Δ ε} →
           d == ε ⟦ d0 ⟧ →
           Δ ⊢ d0 →> d0' →
           d' == ε ⟦ d0' ⟧ →
           Δ ⊢ d ↦ d'


Make P.C.Type conform to plugin pattern.

Old-commit-hash: 8dc76b168a0b8d9f859a69834d52d91e2f34b235

import Parametric.Syntax.Type as Type

module Parametric.Change.Type
  (Base : Type.Structure)
  where

open Type.Structure Base

Structure : Set
Structure = Base → Base

module Structure (ΔBase : Structure) where
  ΔType : Type → Type
  ΔType (base ι) = base (ΔBase ι)
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  open import Base.Change.Context ΔType public

module Parametric.Change.Type
  (Base : Set)
  where

import Parametric.Syntax.Type as Type
open Type.Structure Base

Structure : Set
Structure = Base → Base

module Structure (ΔBase : Structure) where
  ΔType : Type → Type
  ΔType (base ι) = base (ΔBase ι)
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  open import Base.Change.Context ΔType public


Cleanup

Cleanup

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes (Fig. 3).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

-- Extension point 1: A term for ⊝ on base types.
DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

-- Extension point 2: A term for ⊕ on base types.
ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (apply-base : ApplyStructure)
    (diff-base  : DiffStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  -- We provide: terms for ⊕ and ⊝ on arbitrary types.
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)
  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       absV 3 (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y))

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       absV 4 (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x)

  apply : ∀ τ {Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply _ = app₂ apply-term

  diff : ∀ τ {Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff _ = app₂ diff-term

  infixl 6 apply diff

  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = apply τ

  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes (Fig. 3).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

-- Extension point 1: A term for ⊝ on base types.
DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

-- Extension point 2: A term for ⊕ on base types.
ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (apply-base : ApplyStructure)
    (diff-base  : DiffStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  -- We provide: terms for ⊕ and ⊝ on arbitrary types.
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)
  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    (let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       absV 3 (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    (let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       absV 4 (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x))

  apply : ∀ τ {Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply _ = app₂ apply-term

  diff : ∀ τ {Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff _ = app₂ diff-term

  infixl 6 apply diff

  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = apply τ

  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ


game: more

game: more

module game where

open import Level using (Lift) renaming (_⊔_ to _L⊔_)
open import Function.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Product
open import Data.Maybe.NP
open import Data.List
open import Data.List.Any
open import Data.Bool
open import Relation.Binary.PropositionalEquality
open Membership-≡

{-
-- Game
data ⅁ ...
-}

{-
- cost
- non-det
- queries
- partial (like decryption with a mac)
-}

open import Data.Bits
open import flipbased

Bits⟨_⟩→_ : ∀ {a} → ℕ → Set a → Set a
Bits⟨ n ⟩→ A = Bits n → A

data Strategy (☐_ : Set → Set) (R : Set) : ∀ k → Set₁ where
  say : R → Strategy ☐_ R 0
  ask : ∀ {k} {A : Set} → ☐ A → (A → Strategy ☐_ R k) → Strategy ☐_ R k
  rnd : ∀ {n k} {A : Set} → ↺ n A → (A → Strategy ☐_ R k) → Strategy ☐_ R (n + k)

run : ∀ {k R} → Strategy id R k → ↺ k R
run (say r)    = ⟪ r ⟫
run (ask a f)  = run (f a)
run (rnd nd f) = nd >>= (λ xs → run (f xs))

postulate
      Proba : Set
      Pr[_≡1] : ∀ {k} (EXP : ↺ k Bit) → Proba
      _≡1/2^_ : Proba → ℕ → Set
      Pr[toss≡1] : Pr[ toss ≡1] ≡1/2^ 1
      Pr[random≡_] : ∀ {n} (x : Bits n) → Pr[ ⟪ _==_ x · random ⟫ ≡1] ≡1/2^ n
      negligible-proba : Proba
      negligible-advantage-proba : Proba → Proba → Set

_is-negligible : Proba → Set
p is-negligible = negligible-advantage-proba p negligible-proba

negligible-advantage : ∀ {k} (EXP : Bit → ↺ k Bit) → Set
negligible-advantage EXP = negligible-advantage-proba Pr[ EXP 0b ≡1] Pr[ EXP 1b ≡1]

postulate
  negligible-advantage-xor : ∀ {k} (EXP₁ EXP₂ : ↺ k Bit) → EXP₁ ≡ ⟪ _xor_ 1b · EXP₂ ⟫ → negligible-advantage-proba Pr[ EXP₁ ≡1] Pr[ EXP₂ ≡1]

  -- whatch out
  negligible-advantage-trans : ∀ {p₁ p₂ p₃} → negligible-advantage-proba p₁ p₂ → negligible-advantage-proba p₂ p₃ → negligible-advantage-proba p₁ p₃

pattern looks-random = 0b
pattern not-random   = 1b

EXP : ∀ {a b} {A : Set a} {B : Set b} → Bit → (A → B) → (A × A → B)
EXP 0b f (x₀ , x₁) = f x₀
EXP 1b f (x₀ , x₁) = f x₁

module CryptoGames where

  module CipherGames (|K| |M| |C| : ℕ) where
    K = Bits |K|
    M = Bits |M|
    C = Bits |C|

    record SemSecAdv k : Set where
      constructor mk
      field
        {k₀ k₁}   : ℕ
        k≡k₀+k₁  : k ≡ k₀ + k₁
        gen-m₀m₁  : ↺ k₀ (M × M)
        stat-test : C → ↺ k₁ Bit

    mk′ : ∀ {k₀ k₁} → ↺ k₀ (M × M) → (C → ↺ k₁ Bit) → SemSecAdv (k₀ + k₁)
    mk′ = mk refl

    module DeterministicSemanticSecurity where
      runDetSemSec : ∀ {k} (enc : M → C) → SemSecAdv k → Bit → ↺ k Bit
      runDetSemSec enc (mk refl gen-m₀m₁ f) b = gen-m₀m₁ >>= λ m₀m₁ → f (EXP b enc m₀m₁)

      DetSemSecWinner : ∀ (enc : M → C) b {k} (Adv : SemSecAdv k) → ↺ k Set
      DetSemSecWinner enc b Adv = ↺T (runDetSemSec enc Adv b)

      DetSemSec : ∀ k (enc : M → C) → Set
      DetSemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runDetSemSec enc Adv)

      luckySemSec : SemSecAdv 1
      luckySemSec = mk′ ⟪ 0ⁿ , 0ⁿ ⟫ᴰ (λ _ → toss)

      -- see OTPDetSemSec

    module DeterministicCPASecurity where
      DetCPAAdv : ∀ k → Set₁
      DetCPAAdv k = ∀ {☐_} (enc : M × M → ☐ C) → Strategy ☐_ Bit k

      data DetCPAWinner (enc : M × M → C) b (ms : List (M × M)) : ∀ {k} (q : ℕ) → Strategy id Bit k → Set₁ where
        win : ∀ {q} → DetCPAWinner enc b ms q (say b)
        ask : ∀ {k q m₀m₁ f} → m₀m₁ ∉ ms → DetCPAWinner enc b (m₀m₁ ∷ ms) q (f (enc m₀m₁)) →
              DetCPAWinner enc b ms {k} (suc q) (ask (enc m₀m₁) f)
        rnd : ∀ {A : Set} {n k q bs} {r : ↺ n A} {f : A → _}
              → DetCPAWinner enc b ms {k} q (f bs) → DetCPAWinner enc b ms q (rnd r f)

      runDetCPA : ∀ {k} (enc : M → C) (Adv : DetCPAAdv k) → Bit → ↺ k Bit
      runDetCPA enc Adv b = run (Adv (EXP b enc))

      -- no use of CPAWinner
      DetCPASec : ∀ k (enc : M → C) → Set₁
      DetCPASec k enc = ∀ (Adv : DetCPAAdv k) → negligible-advantage (runDetCPA enc Adv)

    CPAAdv : ∀ k → Set₁
    CPAAdv k = ∀ {☐_} (enc : M × M → ☐ (↺ |K| C)) → Strategy ☐_ Bit k

    sem2CPAAdv : ∀ {k} → SemSecAdv k → CPAAdv (|K| + k)
    sem2CPAAdv (mk {k₀} {k₁} refl gen-m₀m₁ f) {☐_} enc =
      subst (Strategy ☐_ Bit) helper
        (rnd gen-m₀m₁ (λ m₀m₁ →
          ask (enc m₀m₁) (λ c →
            rnd c (λ c' → rnd (f c') say))))
      where open import Data.Nat.Properties
            open SemiringSolver
            helper : k₀ + (|K| + (k₁ + 0)) ≡ |K| + (k₀ + k₁)
            helper = solve 3 (λ k₀ |K| k₁ → k₀ :+ (|K| :+ (k₁ :+ con 0)) := |K| :+ (k₀ :+ k₁))
                             refl k₀ |K| k₁

    data CPAWinner (enc : M × M → ↺ |K| C) b : ∀ {k} q → Strategy id Bit k → Set₁ where
      win : ∀ {q} → CPAWinner enc b q (say b)
      ask : ∀ {k q m₀m₁ f} → CPAWinner enc b {k} q (f (enc m₀m₁)) →
            CPAWinner enc b (suc q) (ask (enc m₀m₁) f)
      rnd : ∀ {A : Set} {n k q bs} {r : ↺ n A} {f : A → _}
            → CPAWinner enc b {k} q (f bs) → CPAWinner enc b q (rnd r f)

    det : ∀ {k a b} {A : Set a} {B : Set b} → (A → B) → A → ↺ k B
    det f x = ⟪ f x ⟫

    runCPA : ∀ {k} (enc : M → ↺ |K| C) (Adv : CPAAdv k) → Bit → ↺ k Bit
    runCPA enc Adv b = run (Adv (EXP b enc))

    -- no use of CPAWinner
    CPASec : ∀ k (enc : M → ↺ |K| C) → Set₁
    CPASec k enc = ∀ (Adv : CPAAdv k) → negligible-advantage (runCPA enc Adv)

    SemSecWinner : ∀ (enc : M × M → ↺ |K| C) b k → SemSecAdv k → Set₁
    SemSecWinner enc b k Adv = CPAWinner enc b 1 (sem2CPAAdv Adv enc)

    runSemSec : ∀ {k} (enc : M → ↺ |K| C) → SemSecAdv k → Bit → ↺ (|K| + k) Bit
    runSemSec enc Adv = runCPA enc (sem2CPAAdv Adv)

    -- no use of SemSecWinner
    SemSec : ∀ k (enc : M → ↺ |K| C) → Set
    SemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runSemSec enc Adv)

    weakenWinner : ∀ {enc b k q₀ q₁} {s : Strategy id Bit k} → CPAWinner enc b q₀ s → CPAWinner enc b (q₀ + q₁) s
    weakenWinner win     = win
    weakenWinner (ask w) = ask (weakenWinner w)
    weakenWinner (rnd {n = n} {k} {bs = bs} w) = rnd {n = n} {k} {bs = bs} (weakenWinner w)

    CPA2Sem-correct : ∀ {enc b k q} {semAdv : SemSecAdv k}
                      → SemSecWinner enc b k semAdv → CPAWinner enc b (suc q) (sem2CPAAdv semAdv enc)
    CPA2Sem-correct = weakenWinner

  record Forgery {a} {A : Set a} (P : A → Set) (queries : List A) : Set a where
    field
      forgery         : A
      fresh-forgery   : forgery ∉ queries
      correct-forgery : P forgery
  open Forgery public

  module MACGames (|M| |Tag| : ℕ) where
    M = Bits |M|
    Tag = Bits |Tag|

    -- One might also want that the adversary sends the trials to the challenger.
    -- The challenger might then either end the game or maybe return the info to
    -- the adversary.
    MACAdv : Set₁
    MACAdv = ∀ {☐_} (mac : M → ☐ Tag) → Strategy ☐_ (M × Tag) 0

    -- or
    -- MACAdv = ∀ {☐_ Done} (mac : M → ☐ Tag) (submit : M × Tag → ☐ Done) → Strategy ☐_ Done

    -- or
    -- MACAdv = ∀ {☐_ Done} (mac : M → ☐ Tag)
    --                       (try : M × Tag → ☐ Bool)
    --                       (submit : M × Tag → ☐ Done) → Strategy ☐_ Done

    module MACGames' (mac : M → Tag) where
      CorrectMAC : M × Tag → Set
      CorrectMAC (m , t) = mac m ≡ t

      correctMAC? : M × Tag → Bool
      correctMAC? (m , t) = mac m == t

      data MACWinner (mts : List (M × Tag)) : (q : ℕ) → Strategy id (M × Tag) 0 → Set₁ where
        win : ∀ {q} (f : Forgery CorrectMAC mts) → MACWinner mts q (say (forgery f))
        ask : ∀ {m f q} → MACWinner ((m , mac m) ∷ mts) q (f (mac m))
                        → MACWinner mts (suc q) (ask (mac m) f)

      SecMAC : Set₁
      SecMAC = ∀ (A : MACAdv) → Pr[ ⟪ correctMAC? · run (A mac) ⟫ ≡1] ≡1/2^ |Tag| -- check that bound

  module CiphertextIntegrity (M C : Set) where
    CIAdv : Set₁
    CIAdv = ∀ {☐_} (enc : M → ☐ C) → Strategy ☐_ C 0

    module CiphertextIntegrity' (enc : M → C) (dec : C →? M) where
      CorrectCiphertext : C → Set
      CorrectCiphertext c = IsJust (dec c)

      data CIWinner (cs : List C) : (q : ℕ) → Strategy id C 0 → Set₁ where
        win : ∀ {q} (f : Forgery CorrectCiphertext cs) → CIWinner cs q (say (forgery f))
        ask : ∀ {m f q} → CIWinner (enc m ∷ cs) q (f (enc m))
                        → CIWinner cs (suc q) (ask (enc m) f)

  module AuthenticatedEncryption (|K| |M| |C| : ℕ) where
    open CipherGames |K| |M| |C|
    open CiphertextIntegrity M C

    data AERes : Set where
      distinguish   : Bit → AERes
      found-forgery : C → AERes

    AEAdv : Set₁
    AEAdv = ∀ {☐_} (enc : M × M → ☐ C) → Strategy ☐_ AERes 0

    CCAAdv : Set₁
    CCAAdv = ∀ {☐_} (enc : M × M → ☐ C) (dec : C → ☐ (Maybe M)) → Strategy ☐_ Bit 0

    module AE' (enc : M × M → C) (dec : C →? M) where
      open CiphertextIntegrity' (λ m → enc (m , m)) dec

      data AEWinner (cs : List C) b : (q : ℕ) → Strategy id AERes 0 → Set₁ where
        win-distinguish : ∀ {q} → AEWinner cs b q (say (distinguish b))
        win-forgery : ∀ {q} (f : Forgery CorrectCiphertext cs)
                       → AEWinner cs b q (say (found-forgery (forgery f)))
        ask : ∀ {m₀m₁ f q} → AEWinner cs b q (f (enc m₀m₁)) →
              AEWinner cs b (suc q) (ask (enc m₀m₁) f)

      data CCAWinner b : (q : ℕ) → Strategy id Bit 0 → Set₁ where
        win : ∀ {q} → CCAWinner b q (say b)
        ask-enc : ∀ {m₀m₁ f q} → CCAWinner b q (f (enc m₀m₁)) →
                    CCAWinner b (suc q) (ask (enc m₀m₁) f)
        ask-dec : ∀ {c f q} → CCAWinner b q (f (dec c)) →
                    CCAWinner b (suc q) (ask (dec c) f)

  -- CBC with rand IV is not CCA secure

      -- AE ⇒ CCA Secure

  module OTPDetSemSec {n} (key : Bits n) where
    open CipherGames n n n
    open DeterministicSemanticSecurity

    postulate
      OTPDetSemSec : ∀ {k} → DetSemSec k (OTP key)
{-
    OTPDetSemSec (mk refl gen-m₀m₁ stat-test) = {!!}
    -- DetSemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runDetSemSec enc Adv)
    -- runDetSemSec enc (mk refl gen-m₀m₁ f) b = gen-m₀m₁ >>= λ m₀m₁ → f (EXP b enc m₀m₁)

Pr[ runDetSemSec enc Adv b ≡ b ]
-}

  Enc : ∀ |K| |M| |C| → Set
  Enc |K| |M| |C| = Bits |K| → Bits |M| → Bits |C|

  module DerivedBlockCiphers
    {|K| |M| |C|} {E : Enc |K| |M| |C|}
    (E-sec : ∀ {k} key → CipherGames.DeterministicSemanticSecurity.DetSemSec |K| |M| |C| k (E key)) where

    open module CipherGames' {|M| |C|} = CipherGames |K| |M| |C|
    open DeterministicSemanticSecurity

    E₀ : Enc |K| |M| |C|
    E₀ k m = 1ⁿ ⊕ E k m

    postulate
      lem' : ∀ {k} (Adv : SemSecAdv k) b (f : Bits k → Bits |C|) → runDetSemSec {k} (_⊕_ 1ⁿ ∘ f) Adv b ≡ ⟪ _xor_ 1b · runDetSemSec f Adv b ⟫
    -- lem' Adv b f = {!!}

      lem'' : ∀ {k} (Adv : SemSecAdv k) b (f : Bits k → Bits |C|) → ⟪ _xor_ 1b · runDetSemSec {k} (_⊕_ 1ⁿ ∘ f) Adv b ⟫ ≡ runDetSemSec f Adv b
    -- lem'' Adv b f = {!!}

    -- postulate
    E₀-sec : ∀ key → DetSemSec |M| (E₀ key)
    E₀-sec key Adv = negligible-advantage-trans (negligible-advantage-xor (runDetSemSec (E₀ key) Adv 0b) (runDetSemSec (E key) Adv 0b) (lem' Adv 0b (E key))) (negligible-advantage-trans (E-sec key Adv) (negligible-advantage-xor (runDetSemSec (E key) Adv 1b) (runDetSemSec (E₀ key) Adv 1b) (sym (lem'' Adv 1b (E key)))))

    E₁ : Enc |K| |M| (1 + |C|)
    E₁ k m = 0∷ E k m

    -- E₁-adv : ∀ {k} key → SemSecAdv k (E key) → SemSecAdv k (E₁ key)
    -- E₁-adv key Adv = {!E-sec!}

    postulate
      E₁-sec : ∀ {k} key → DetSemSec k (E₁ key)
    -- E₁-sec key Adv = {!E-sec key ?!}

    -- runDetSemSec enc adv b ≈ runDetSemSec enc' adv b

module game where

open import Function.NP
open import Data.Nat.NP
open import Data.Product
open import Data.Bool -- hiding (_≟_)

{-
-- Game
data ⅁ ...
-}

data Strategy (☐_ : Set → Set) (R : Set) : Set₁ where
  say : R → Strategy ☐_ R
  ask : {A : Set} → ☐ A → (A → Strategy ☐_ R) → Strategy ☐_ R

run : ∀ {R} → Strategy id R → R
run (say r)   = r
run (ask a f) = run (f a)

open import Data.Bits

pattern looks-random = 0b
pattern not-random   = 1b

module CryptoGames where

  module CipherGames (|M| |C| : ℕ) where
    M : Set
    M = Bits |M|
    C : Set
    C = Bits |C|

    SemSecAdv : Set
    SemSecAdv = C → Bit

    CPAAdv : Set₁
    CPAAdv = ∀ {☐_} (enc : M → ☐ C) → Strategy ☐_ Bit

    data CPAWinner (enc : M → C) b : Strategy id Bit → Set₁ where
      win : CPAWinner enc b (say b)
      ask : ∀ {m f} → CPAWinner enc b (f (enc m)) → CPAWinner enc b (ask (enc m) f)

    CPA2Sem : SemSecAdv → CPAAdv
    CPA2Sem semAdv enc = ask (enc 0…) (λ c → say (semAdv c))

    CPA2Sem-correct : SemSecWinner semAdv → CPAWinner enc b (CPA2Sem semAdv)
    CPA2Sem-correct

  module MACGames (M T : Set) where
    MacAdv : Set₁
    MacAdv = ∀ {☐_} (mac : M → ☐ T) → Strategy ☐_ (M × T)

    data MACWinner (mac : M → T) : Strategy id (M × T) → Set₁ where
      win : ∀ {m} → MACWinner mac (say (m , mac m))
      ask : ∀ {m f} → MACWinner mac (f (mac m)) → MACWinner mac (ask (mac m) f)


Group change structures need no abelian group

The previous proof was unnecessarily restrictive for no clear reason.
OTOH, aggregation can take advantage of abelian groups.

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c}
    {Carrier : Set c}
    (Change : Carrier → Set c)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c}
    (Carrier : Set c) : Set (suc c) where
  field
    Change : Carrier → Set c
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} {A : Set a} (P : A → Set p): Set (suc p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

-- XXX not clear this is ever used
instance
  change-algebra-family-inst = change-algebra₍_₎

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

RawChange : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  Set (a ⊔ b)
RawChange f = ∀ a (da : Δ a) → Δ (f a)

IsDerivative : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  (df : RawChange f) →
  Set (a ⊔ b)
IsDerivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of IsDerivative for change algebra families.
RawChange₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) → Set (p ⊔ q)
RawChange₍ x , y ₎ f = ∀ px (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)

IsDerivative₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : RawChange₍_,_₎ x y f) →
  Set (p ⊔ q)
IsDerivative₍_,_₎ {P = P} {{CP}} {{CQ}} x y f df = IsDerivative {{change-algebra₍ _ ₎}} {{change-algebra₍ _ ₎}} f df where
  CPx = change-algebra₍_₎ {{CP}} x
  CQy = change-algebra₍_₎ {{CQ}} y

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isGroup : IsGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsGroup isGroup
      hiding
        ( refl
        ; sym
        )
      renaming
        ( ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    _⊝_ : A → A → A
    v ⊝ u = (u ⁻¹) ⊕ v

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨⟩
               v ⊕ ((v ⁻¹) ⊕ u)
            ≡⟨  sym (assoc _ _ _) ⟩
               (v ⊕ (v ⁻¹)) ⊕ u
            ≡⟨ proj₂ inverse v ⟨⊕⟩ refl ⟩
               ε ⊕ u
            ≡⟨ proj₁ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

module AbelianGroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} (A : Set a) (B : Set b) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b) where
      field
        -- Definition 2.6a
        apply : RawChange f

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g (a ⊞ da ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }

    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)

    funNil : (f : A → B) → FunctionChange f
    funNil = λ f → funDiff f f
    private
      -- Realizer for funNil
      funNil-realizer : (f : A → B) → RawChange f
      funNil-realizer f = λ a da → f (a ⊞ da) ⊟ f a
      -- Note that it cannot use nil (f a), that would not be a correct function change!
      funNil-correct : ∀ f a da → funNil-realizer f a da ≡ apply (funNil f) a da
      funNil-correct f a da = refl

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      instance
        changeAlgebraFun : ChangeAlgebra (A → B)

      changeAlgebraFun = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ (nil a)) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper. However, the derivative of f is just
    -- the apply component of `nil f`, not the full `nil f`, which also includes
    -- a proof. This is not an issue in the paper, which is formulated in a
    -- proof-irrelevant metalanguage.
    nil-is-derivative : ∀ (f : A → B) →
      IsDerivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

    -- Show that any derivative is a valid function change.

    -- In the paper, this is never actually stated. We just prove that nil
    -- changes are derivatives; the paper keeps talking about "the derivative",
    -- suggesting derivatives are unique. If derivatives were unique, we could
    -- say that the nil change is *the* derivative, hence the derivative is the
    -- nil change (hence also a change).
    --
    -- In fact, derivatives are only unique up to change equivalence and
    -- extensional equality; this is proven in Base.Change.Equivalence.derivative-unique.
    --
    Derivative-is-valid : ∀ {f : A → B} df (IsDerivative-f-df : IsDerivative f df) a da →
      f (a ⊞ da) ⊞ (df (a ⊞ da) (nil (a ⊞ da))) ≡ f a ⊞ df a da
    Derivative-is-valid {f} df IsDerivative-f-df a da rewrite IsDerivative-f-df (a ⊞ da) (nil (a ⊞ da)) | update-nil (a ⊞ da) = sym (IsDerivative-f-df a da)

    DerivativeAsChange : ∀ {f : A → B} {df} (IsDerivative-f-df : IsDerivative f df) → Δ f
    DerivativeAsChange {df = df} IsDerivative-f-df = record { apply = df ; correct = Derivative-is-valid df IsDerivative-f-df }
    -- In Equivalence.agda, derivative-is-nil-alternative then proves that a derivative is also a nil change.

-- Reexport a few members with A and B marked as implicit parameters. This
-- matters especially for changeAlgebra, since otherwise it can't be used for
-- instance search.
module _
    {a} {b} {A : Set a} {B : Set b} {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    open FunctionChanges A B {{CA}} {{CB}} public
      using
        ( changeAlgebraFun
        ; apply
        ; correct
        ; incrementalization
        ; DerivativeAsChange
        ; FunctionChange
        ; nil-is-derivative
        )

module BinaryFunctionChanges
    {a} {b} {c} (A : Set a) (B : Set b) (C : Set c) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} {{CC : ChangeAlgebra C}} where
    incrementalization-binary : ∀ (f : A → B → C) df a da b db →
      (f ⊞ df) (a ⊞ da) (b ⊞ db) ≡ f a b ⊞ apply (apply df a da) b db
    incrementalization-binary f df x dx y dy
      rewrite cong (λ □ → □ (y ⊞ dy)) (incrementalization f df x dx)
      = incrementalization (f x) (apply df x dx) y dy

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ Δ pxs  → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ Δ pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff px′ px) (update-diff-all pxs′ pxs)

    instance
      changeAlgebraListChanges : ChangeAlgebraFamily (All P)

    changeAlgebraListChanges = record
      { change-algebra = λ xs → record
        { Change = All′ Δ
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c}
    {Carrier : Set c}
    (Change : Carrier → Set c)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c}
    (Carrier : Set c) : Set (suc c) where
  field
    Change : Carrier → Set c
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} {A : Set a} (P : A → Set p): Set (suc p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

-- XXX not clear this is ever used
instance
  change-algebra-family-inst = change-algebra₍_₎

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

RawChange : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  Set (a ⊔ b)
RawChange f = ∀ a (da : Δ a) → Δ (f a)

IsDerivative : ∀ {a b} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra A}} →
  {{CB : ChangeAlgebra B}} →
  (f : A → B) →
  (df : RawChange f) →
  Set (a ⊔ b)
IsDerivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of IsDerivative for change algebra families.
RawChange₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) → Set (p ⊔ q)
RawChange₍ x , y ₎ f = ∀ px (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)

IsDerivative₍_,_₎ : ∀ {a b p q} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily P}} →
  {{CQ : ChangeAlgebraFamily Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : RawChange₍_,_₎ x y f) →
  Set (p ⊔ q)
IsDerivative₍_,_₎ {P = P} {{CP}} {{CQ}} x y f df = IsDerivative {{change-algebra₍ _ ₎}} {{change-algebra₍ _ ₎}} f df where
  CPx = change-algebra₍_₎ {{CP}} x
  CQy = change-algebra₍_₎ {{CQ}} y

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebraGroup : ChangeAlgebra A
    changeAlgebraGroup = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} (A : Set a) (B : Set b) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b) where
      field
        -- Definition 2.6a
        apply : RawChange f

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g (a ⊞ da ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }

    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)

    funNil : (f : A → B) → FunctionChange f
    funNil = λ f → funDiff f f
    private
      -- Realizer for funNil
      funNil-realizer : (f : A → B) → RawChange f
      funNil-realizer f = λ a da → f (a ⊞ da) ⊟ f a
      -- Note that it cannot use nil (f a), that would not be a correct function change!
      funNil-correct : ∀ f a da → funNil-realizer f a da ≡ apply (funNil f) a da
      funNil-correct f a da = refl

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      instance
        changeAlgebraFun : ChangeAlgebra (A → B)

      changeAlgebraFun = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ (nil a)) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper. However, the derivative of f is just
    -- the apply component of `nil f`, not the full `nil f`, which also includes
    -- a proof. This is not an issue in the paper, which is formulated in a
    -- proof-irrelevant metalanguage.
    nil-is-derivative : ∀ (f : A → B) →
      IsDerivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

    -- Show that any derivative is a valid function change.

    -- In the paper, this is never actually stated. We just prove that nil
    -- changes are derivatives; the paper keeps talking about "the derivative",
    -- suggesting derivatives are unique. If derivatives were unique, we could
    -- say that the nil change is *the* derivative, hence the derivative is the
    -- nil change (hence also a change).
    --
    -- In fact, derivatives are only unique up to change equivalence and
    -- extensional equality; this is proven in Base.Change.Equivalence.derivative-unique.
    --
    Derivative-is-valid : ∀ {f : A → B} df (IsDerivative-f-df : IsDerivative f df) a da →
      f (a ⊞ da) ⊞ (df (a ⊞ da) (nil (a ⊞ da))) ≡ f a ⊞ df a da
    Derivative-is-valid {f} df IsDerivative-f-df a da rewrite IsDerivative-f-df (a ⊞ da) (nil (a ⊞ da)) | update-nil (a ⊞ da) = sym (IsDerivative-f-df a da)

    DerivativeAsChange : ∀ {f : A → B} {df} (IsDerivative-f-df : IsDerivative f df) → Δ f
    DerivativeAsChange {df = df} IsDerivative-f-df = record { apply = df ; correct = Derivative-is-valid df IsDerivative-f-df }
    -- In Equivalence.agda, derivative-is-nil-alternative then proves that a derivative is also a nil change.

-- Reexport a few members with A and B marked as implicit parameters. This
-- matters especially for changeAlgebra, since otherwise it can't be used for
-- instance search.
module _
    {a} {b} {A : Set a} {B : Set b} {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}}
  where
    open FunctionChanges A B {{CA}} {{CB}} public
      using
        ( changeAlgebraFun
        ; apply
        ; correct
        ; incrementalization
        ; DerivativeAsChange
        ; FunctionChange
        ; nil-is-derivative
        )

module BinaryFunctionChanges
    {a} {b} {c} (A : Set a) (B : Set b) (C : Set c) {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} {{CC : ChangeAlgebra C}} where
    incrementalization-binary : ∀ (f : A → B → C) df a da b db →
      (f ⊞ df) (a ⊞ da) (b ⊞ db) ≡ f a b ⊞ apply (apply df a da) b db
    incrementalization-binary f df x dx y dy
      rewrite cong (λ □ → □ (y ⊞ dy)) (incrementalization f df x dx)
      = incrementalization (f x) (apply df x dx) y dy

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ Δ pxs  → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ Δ pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff px′ px) (update-diff-all pxs′ pxs)

    instance
      changeAlgebraListChanges : ChangeAlgebraFamily (All P)

    changeAlgebraListChanges = record
      { change-algebra = λ xs → record
        { Change = All′ Δ
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }