Validity of derivatives using proof-embedded Δ-terms

Old-commit-hash: 21985b6314506084e5b5171cd083140a95f42d05

{-
The goal of this file is to make the domain of Δ types smaller
so as to be nearer to full abstraction and hopefully close
enough for the purpose of having explicit nil changes.
-}

module TaggedDeltaTypes where

open import Data.NatBag renaming
  (map to mapBag ; empty to emptyBag ; update to updateBag)
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- open import Data.NatBag.Properties
postulate b\\b=∅ : ∀ {{b : Bag}} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {{b : Bag}} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {{b : Bag}} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

------------------------
-- Syntax of programs --
------------------------

data Type : Set where
  nats : Type
  bags : Type
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

data Var : Context → Type → Set where
  this : ∀ {τ Γ} → Var (τ • Γ) τ
  that : ∀ {τ τ′ Γ} → (x : Var Γ τ) → Var (τ′ • Γ) τ

data Term : Context -> Type -> Set where

  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  bag : ∀ {Γ} → (b : Bag) → Term Γ bags

  var : ∀ {τ Γ} → (x : Var Γ τ) → Term Γ τ
  abs : ∀ {τ₁ τ₂ Γ} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ} → (s : Term Γ (τ₁ ⇒ τ₂)) (t : Term Γ τ₁)
                   → Term Γ τ₂

  add : ∀ {Γ} → (s : Term Γ nats) → (t : Term Γ nats) → Term Γ nats
  map : ∀ {Γ} → (f : Term Γ (nats ⇒ nats)) → (b : Term Γ bags) → Term Γ bags

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ {∅} = ∅≼∅
Γ≼Γ {τ • Γ} = keep τ • Γ≼Γ {Γ}

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x
weaken subctx (bag b) = bag b
weaken subctx (add t₁ t₂) = add (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (map f b) = map (weaken subctx f) (weaken subctx b)

---------------------------
-- Semantics of programs --
---------------------------

record Meaning (Syntax : Set) {ℓ : Level.Level} : Set (Level.suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ nats ⟧Type = ℕ
⟦ bags ⟧Type = Bag
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

⟦_⟧Var : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ this ⟧Var (v • ρ) = v
⟦ that x ⟧Var (v • ρ) = ⟦ x ⟧Var ρ

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

identity-weakening : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
identity-weakening {∅} {∅} = refl
identity-weakening {τ • Γ} {v • ρ} =
  cong₂ _•_ {x = v} refl (identity-weakening {Γ} {ρ})

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n
⟦ bag b ⟧Term ρ = b
⟦ add m n ⟧Term ρ = ⟦ m ⟧Term ρ + ⟦ n ⟧Term ρ
⟦ map f b ⟧Term ρ = mapBag (⟦ f ⟧Term ρ) (⟦ b ⟧Term ρ)

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

_⟨$⟩_ : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
_⟨$⟩_ = cong₂ (λ x y → x y)

-- infix 0 $ in Haskell
infixl 0 _⟨$⟩_

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = weaken-sound t₁ ρ ⟨$⟩ weaken-sound t₂ ρ
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (bag b) ρ = refl
weaken-sound (add m n) ρ = cong₂ _+_ (weaken-sound m ρ) (weaken-sound n ρ)
weaken-sound (map f b) ρ =
  cong₂ mapBag (weaken-sound f ρ) (weaken-sound b ρ)

----------------------------------------------------------
-- Syntax and semantics of changes (they are entangled) --
----------------------------------------------------------

data Δ-Type : Set where
  Δ : (τ : Type) → Δ-Type

data Δ-Context : Set where
  Δ : (Γ : Context) → Δ-Context

Env : Context → Set
Env Γ = ⟦ Γ ⟧Context

data Δ-Term : Δ-Context → Δ-Type → Set

-- Syntax of Δ-Types
-- ...   is mutually recursive with semantics of Δ-Terms
-- (because it embeds validity proofs),
-- which is mutually recursive with validity and Δ-environments,
-- which is mutually recursive with ⊕,
-- which is mutually recursive with ⊝ and R[v,v⊝v],
-- which is mutually recursive with v⊕[u⊝v]=v, et cetera.
⟦_⟧Δτ : Δ-Type → Set
Δ-Env : Context → Set
⟦_⟧Δ : ∀ {τ : Type} {Γ : Context}
    → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
_⊕_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → ⟦ τ ⟧
_⊝_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ
valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → Set
R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧
update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧

infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

data Δ-Term where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → Δ-Term (Δ Γ) (Δ nats)
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → Δ-Term (Δ Γ) (Δ bags)
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → Δ-Term (Δ Γ) (Δ τ)
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (t : Δ-Term (Δ (τ₁ • Γ)) (Δ τ₂)) →
         Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂))
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {τ₁ τ₂ Γ} → (ds : Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂)))
                    → ( t :   Term    Γ      τ₁)
                    → (dt : Δ-Term (Δ Γ) (Δ  τ₁))
                    → (R[t,dt] : {ρ : Δ-Env Γ} → -- 'Tis but a proof.
                          valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ)) →
         Δ-Term (Δ Γ) (Δ τ₂)
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ} → (ds : Δ-Term (Δ Γ) (Δ nats))
               → (dt : Δ-Term (Δ Γ) (Δ nats)) →
         Δ-Term (Δ Γ) (Δ nats)
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (df : Δ-Term (Δ Γ) (Δ (nats ⇒ nats)))
                → ( b :   Term    Γ     bags)
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)
  Δmap₁ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)

-- ⟦_⟧Δτ : Δ-Type → Set
⟦ Δ nats ⟧Δτ = ℕ × ℕ
⟦ Δ bags ⟧Δτ = Bag
⟦ Δ (τ₁ ⇒ τ₂) ⟧Δτ =
  (v : ⟦ τ₁ ⟧) → (dv : ⟦ Δ τ₁ ⟧Δτ) → valid v dv → ⟦ Δ τ₂ ⟧Δτ

meaning-Δτ : Meaning Δ-Type
meaning-Δτ = meaning ⟦_⟧Δτ

_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]

_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v

-- valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {τ₁ ⇒ τ₂} f df =
  ∀ (v : ⟦ τ₁ ⟧) (dv : ⟦ Δ τ₁ ⟧Δτ) (R[v,dv] : valid v dv)
  → valid (f v) (df v dv R[v,dv])
  × (f ⊕ df) (v ⊕ dv) ≡ f v ⊕ df v dv R[v,dv]

eq1 : ∀ {τ₁ τ₂ : Type} {f : ⟦ τ₁ ⇒ τ₂ ⟧} {df} {x : ⟦ τ₁ ⟧} {dx} →
      valid f df → (R[x,dx] : valid x dx) →
      (f ⊕ df) (x ⊕ dx) ≡ f x ⊕ df x dx R[x,dx]

eq1 R[f,df] R[x,dx] = proj₂ (R[f,df] _ _ R[x,dx])

v⊕[u⊝v]=u {nats}   {u} {v} = refl
v⊕[u⊝v]=u {bags}   {u} {v} = b++[d\\b]=d {v} {u}
v⊕[u⊝v]=u {τ₁ ⇒ τ₂} {u} {v} = extensionality (λ w →
  begin
    (v ⊕ (u ⊝ v)) w
  ≡⟨ refl ⟩ -- for clarity
    v w ⊕ (u (w ⊕ (w ⊝ w)) ⊝ v w)
  ≡⟨ cong (λ hole → v w ⊕ (u hole ⊝ v w)) v⊕[u⊝v]=u ⟩
    v w ⊕ (u w ⊝ v w)
  ≡⟨ v⊕[u⊝v]=u ⟩
    u w
  ∎) where open ≡-Reasoning

R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {τ₁ ⇒ τ₂} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v] -- NOT a self recursion: implicit arguments are different.
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {u = u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {u = u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

record Quadruple
  (A : Set) (B : A → Set) (C : (a : A) → B a → Set)
  (D : (a : A) → (b : B a) → (c : C a b) → Set): Set where
  constructor cons
  field
    car   : A
    cadr  : B car
    caddr : C car cadr
    cdddr : D car cadr caddr

open Quadruple public

-- The type of environments ensures their consistency.
-- Δ-Env : Context → Set
Δ-Env ∅ = EmptySet
Δ-Env (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ v → ⟦ Δ τ ⟧Δτ)
  (λ v dv → valid v dv)
  (λ v dv R[v,dv] → Δ-Env Γ)

-- ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
ignore {∅} ρ = ∅
ignore {τ • Γ} (cons v dv R[v,dv] ρ) = v • ignore ρ

-- update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
update {∅} ρ = ∅
update {τ • Γ} (cons v dv R[v,dv] ρ) = (v ⊕ dv) • update ρ

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] ρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] ρ) = ⟦ x ⟧ΔVar ρ

-- ⟦_⟧ΔVar is not put into the Meaning type class
-- because its argument is identical to that of ⟦_⟧Var.

-- ⟦_⟧Δ : ∀ {τ Γ} → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ Δnat old new ⟧Δ ρ = (old , new)
⟦ Δbag db ⟧Δ ρ = db
⟦ Δvar x ⟧Δ ρ = ⟦ x ⟧ΔVar ρ
⟦ Δabs t ⟧Δ ρ = λ v dv R[v,dv] → ⟦ t ⟧Δ (cons v dv R[v,dv] ρ)
⟦ Δapp ds t dt R[dt,t] ⟧Δ ρ =
  ⟦ ds ⟧Δ ρ (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ) R[dt,t]
⟦ Δadd ds dt ⟧Δ ρ =
  let
    (old-s , new-s) = ⟦ ds ⟧Δ ρ
    (old-t , new-t) = ⟦ dt ⟧Δ ρ
  in
    (old-s + old-t , new-s + new-t)
⟦ Δmap₀ f df b db ⟧Δ ρ =
  let
    v  = ⟦ b ⟧ (ignore ρ)
    h  = ⟦ f ⟧ (ignore ρ)
    dv = ⟦ db ⟧Δ ρ
    dh = ⟦ df ⟧Δ ρ
  in
    mapBag (h ⊕ dh) (v ⊕ dv) \\ mapBag h v
⟦ Δmap₁ f db ⟧Δ ρ = mapBag (⟦ f ⟧ (ignore ρ)) (⟦ db ⟧Δ ρ)

meaning-ΔTerm : ∀ {τ Γ} → Meaning (Δ-Term (Δ Γ) (Δ τ))
meaning-ΔTerm = meaning ⟦_⟧Δ

--------------------------------------------------------
-- Program transformation and correctness (entangled) --
--------------------------------------------------------

Δ-equiv : ∀ {τ : Type} → (du : ⟦ Δ τ ⟧Δτ) (dv : ⟦ Δ τ ⟧Δτ) → Set
Δ-equiv {τ} du dv =
  ∀ {v : ⟦ τ ⟧} (R[v,du] : valid v du) (R[v,dv] : valid v dv) →
    v ⊕ du ≡ v ⊕ dv

derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)

validity : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  valid (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

correctness : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  Δ-equiv (⟦ derive t ⟧ ρ) (⟦ t ⟧ (update ρ) ⊝ ⟦ t ⟧ (ignore ρ))

corollary : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧ ρ ≡ ⟦ t ⟧ (update ρ)

corollary {τ} {Γ} {t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    v′ = ⟦ t ⟧ (update ρ)
  in
    begin
      v ⊕ ⟦ derive t ⟧ ρ
    ≡⟨ correctness {τ} {Γ} {t} {ρ} {v} validity R[v,u⊝v] ⟩
      v ⊕ (v′ ⊝ v)
    ≡⟨ v⊕[u⊝v]=u ⟩
      v′
    ∎ where open ≡-Reasoning

-- derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)
derive (nat n) = Δnat n n
derive (bag b) = Δbag b
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t) validity
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

validity-var : ∀ {τ Γ} → (x : Var Γ τ) →
  ∀ {ρ : Δ-Env Γ} → valid (⟦ x ⟧ (ignore ρ)) (⟦ x ⟧ΔVar ρ)

validity-var this {cons v dv R[v,dv] ρ} = R[v,dv]
validity-var (that x) {cons v dv R[v,dv] ρ} = validity-var x

validity {nats} {Γ} {nat n} = refl
validity {bags} {Γ} {bag b} = tt
validity {τ} {Γ} {var x} = validity-var x
validity {nats} {Γ} {add s t} = cong₂ _+_ R[s,ds] R[t,dt]
  where R[s,ds] = validity {nats} {Γ} {s}
        R[t,dt] = validity {nats} {Γ} {t}
validity {bags} {Γ} {map f b} = tt

validity {τ₁ ⇒ τ₂} {Γ} {abs t} {ρ} = λ v dv R[v,dv] →
  let
    v′ = v ⊕ dv
    dv′ = v′ ⊝ v′
    ρ₁ = cons v dv R[v,dv] ρ
    ρ₂ = cons v′ dv′ R[v,u⊝v] ρ
  in
    validity {t = t} {ρ₁}
    ,
    (begin
      ⟦ t ⟧ (ignore ρ₂) ⊕ ⟦ derive t ⟧ ρ₂
    ≡⟨ corollary {t = t} {ρ₂} ⟩
      ⟦ t ⟧ (update ρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update ρ)) v⊕[u⊝v]=u ⟩
      ⟦ t ⟧ (update ρ₁)
    ≡⟨ sym (corollary {t = t} {ρ₁}) ⟩
      ⟦ t ⟧ (ignore ρ₁) ⊕ ⟦ derive t ⟧ ρ₁
    ∎) where open ≡-Reasoning

validity {τ} {Γ} {app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧ ρ
  in
    proj₁ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))

correctness = {!!}

{-
The goal of this file is to make the domain of Δ types smaller
so as to be nearer to full abstraction and hopefully close
enough for the purpose of having explicit nil changes.
-}

module TaggedDeltaTypes where

open import Data.NatBag renaming
  (map to mapBag ; empty to emptyBag ; update to updateBag)
open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- open import Data.NatBag.Properties
postulate b\\b=∅ : ∀ {{b : Bag}} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {{b : Bag}} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {{b : Bag}} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

------------------------
-- Syntax of programs --
------------------------

data Type : Set where
  nats : Type
  bags : Type
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

data Context : Set where
  ∅ : Context
  _•_ : (τ : Type) (Γ : Context) → Context

infixr 9 _•_

data Var : Context → Type → Set where
  this : ∀ {τ Γ} → Var (τ • Γ) τ
  that : ∀ {τ τ′ Γ} → (x : Var Γ τ) → Var (τ′ • Γ) τ

data Term : Context -> Type -> Set where

  nat : ∀ {Γ} → (n : ℕ) → Term Γ nats
  bag : ∀ {Γ} → (b : Bag) → Term Γ bags

  var : ∀ {τ Γ} → (x : Var Γ τ) → Term Γ τ
  abs : ∀ {τ₁ τ₂ Γ} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ} → (s : Term Γ (τ₁ ⇒ τ₂)) (t : Term Γ τ₁)
                   → Term Γ τ₂

  add : ∀ {Γ} → (s : Term Γ nats) → (t : Term Γ nats) → Term Γ nats
  map : ∀ {Γ} → (f : Term Γ (nats ⇒ nats)) → (b : Term Γ bags) → Term Γ bags

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ {∅} = ∅≼∅
Γ≼Γ {τ • Γ} = keep τ • Γ≼Γ {Γ}

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x
weaken subctx (bag b) = bag b
weaken subctx (add t₁ t₂) = add (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (map f b) = map (weaken subctx f) (weaken subctx b)

---------------------------
-- Semantics of programs --
---------------------------

record Meaning (Syntax : Set) {ℓ : Level.Level} : Set (Level.suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

⟦_⟧Type : Type -> Set
⟦ nats ⟧Type = ℕ
⟦ bags ⟧Type = Bag
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

data Bind A B : Set where
  _•_ : (v : A) (ρ : B) → Bind A B

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

⟦_⟧Var : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ this ⟧Var (v • ρ) = v
⟦ that x ⟧Var (v • ρ) = ⟦ x ⟧Var ρ

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

identity-weakening : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
identity-weakening {∅} {∅} = refl
identity-weakening {τ • Γ} {v • ρ} =
  cong₂ _•_ {x = v} refl (identity-weakening {Γ} {ρ})

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ nat n ⟧Term ρ = n
⟦ bag b ⟧Term ρ = b
⟦ add m n ⟧Term ρ = ⟦ m ⟧Term ρ + ⟦ n ⟧Term ρ
⟦ map f b ⟧Term ρ = mapBag (⟦ f ⟧Term ρ) (⟦ b ⟧Term ρ)

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

_⟨$⟩_ : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
_⟨$⟩_ = cong₂ (λ x y → x y)

-- infix 0 $ in Haskell
infixl 0 _⟨$⟩_

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = weaken-sound t₁ ρ ⟨$⟩ weaken-sound t₂ ρ
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (bag b) ρ = refl
weaken-sound (add m n) ρ = cong₂ _+_ (weaken-sound m ρ) (weaken-sound n ρ)
weaken-sound (map f b) ρ =
  cong₂ mapBag (weaken-sound f ρ) (weaken-sound b ρ)

----------------------------------------------------------
-- Syntax and semantics of changes (they are entangled) --
----------------------------------------------------------

data Δ-Type : Set where
  Δ : (τ : Type) → Δ-Type

data Δ-Context : Set where
  Δ : (Γ : Context) → Δ-Context

Env : Context → Set
Env Γ = ⟦ Γ ⟧Context

data Δ-Term : Δ-Context → Δ-Type → Set

-- Syntax of Δ-Types
-- ...   is mutually recursive with semantics of Δ-Terms,
-- (because it embeds validity proofs)
-- which is mutually recursive with validity and Δ-environments,
-- which is mutually recursive with ⊕,
-- which is mutually recursive with ⊝ and R[v,v⊝v],
-- which is mutually recursive with v⊕[u⊝v]=v, et cetera.
⟦_⟧Δτ : Δ-Type → Set
Δ-Env : Context → Set
⟦_⟧Δ : ∀ {τ : Type} {Γ : Context}
    → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
_⊕_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → ⟦ τ ⟧
_⊝_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ
valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ τ ⟧Δτ → Set
R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧
update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → ⟦ Γ ⟧

infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

data Δ-Term where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → Δ-Term (Δ Γ) (Δ nats)
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → Δ-Term (Δ Γ) (Δ bags)
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → Δ-Term (Δ Γ) (Δ τ)
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (t : Δ-Term (Δ (τ₁ • Γ)) (Δ τ₂)) →
         Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂))
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {τ₁ τ₂ Γ} →(ds : Δ-Term (Δ Γ) (Δ (τ₁ ⇒ τ₂)))
                    → ( t :   Term    Γ      τ₁)
                    → (dt : Δ-Term (Δ Γ) (Δ  τ₁))
                    → (R[t,dt] : {ρ : Δ-Env Γ} → -- 'Tis but a proof.
                                 valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ)) →
         Δ-Term (Δ Γ) (Δ τ₂)
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ} → (ds : Δ-Term (Δ Γ) (Δ nats))
               → (dt : Δ-Term (Δ Γ) (Δ nats)) →
         Δ-Term (Δ Γ) (Δ nats)
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (df : Δ-Term (Δ Γ) (Δ (nats ⇒ nats)))
                → ( b :   Term    Γ     bags)
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)
  Δmap₁ : ∀ {Γ} → ( f :   Term    Γ     (nats ⇒ nats))
                → (db : Δ-Term (Δ Γ) (Δ bags))
          → Δ-Term (Δ Γ) (Δ bags)

-- ⟦_⟧Δτ : Δ-Type → Set
⟦ Δ nats ⟧Δτ = ℕ × ℕ
⟦ Δ bags ⟧Δτ = Bag
⟦ Δ (τ₁ ⇒ τ₂) ⟧Δτ =
  (v : ⟦ τ₁ ⟧) → (dv : ⟦ Δ τ₁ ⟧Δτ) → valid v dv → ⟦ Δ τ₂ ⟧Δτ

meaning-Δτ : Meaning Δ-Type
meaning-Δτ = meaning ⟦_⟧Δτ

_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]

_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v

-- valid : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {τ₁ ⇒ τ₂} f df =
  ∀ (v : ⟦ τ₁ ⟧) (dv : ⟦ Δ τ₁ ⟧Δτ) (R[v,dv] : valid v dv)
  → valid (f v) (df v dv R[v,dv])
  × (f ⊕ df) (v ⊕ dv) ≡ f v ⊕ df v dv R[v,dv]

eq1 : ∀ {τ₁ τ₂ : Type} {f : ⟦ τ₁ ⇒ τ₂ ⟧} {df} {x : ⟦ τ₁ ⟧} {dx} →
      valid f df → (R[x,dx] : valid x dx) →
      (f ⊕ df) (x ⊕ dx) ≡ f x ⊕ df x dx R[x,dx]

eq1 R[f,df] R[x,dx] = proj₂ (R[f,df] _ _ R[x,dx])

v⊕[u⊝v]=u {nats}   {u} {v} = refl
v⊕[u⊝v]=u {bags}   {u} {v} = b++[d\\b]=d {v} {u}
v⊕[u⊝v]=u {τ₁ ⇒ τ₂} {u} {v} = extensionality (λ w →
  begin
    (v ⊕ (u ⊝ v)) w
  ≡⟨ refl ⟩ -- for clarity
    v w ⊕ (u (w ⊕ (w ⊝ w)) ⊝ v w)
  ≡⟨ cong (λ hole → v w ⊕ (u hole ⊝ v w)) v⊕[u⊝v]=u ⟩
    v w ⊕ (u w ⊝ v w)
  ≡⟨ v⊕[u⊝v]=u ⟩
    u w
  ∎) where open ≡-Reasoning

R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {τ₁ ⇒ τ₂} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v] -- NOT a self recursion: implicit arguments are different.
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {_} {u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {_} {u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

record Quadruple
  (A : Set) (B : A → Set) (C : (a : A) → B a → Set)
  (D : (a : A) → (b : B a) → (c : C a b) → Set): Set where
  constructor cons
  field
    car    : A
    cadr   : B car
    caddr  : C car cadr
    cadddr : D car cadr caddr

open Quadruple public

-- The type of environments ensures their consistency.
-- Δ-Env : Context → Set
Δ-Env ∅ = EmptySet
Δ-Env (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ v → ⟦ Δ τ ⟧Δτ)
  (λ v dv → valid v dv)
  (λ v dv R[v,dv] → Δ-Env Γ)

-- ignore : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
ignore {∅} ρ = ∅
ignore {τ • Γ} (cons v dv R[v,dv] ρ) = v • ignore ρ

-- update : ∀ {Γ : Context} → (ρ : Δ-Env Γ) → Env Γ
update {∅} ρ = ∅
update {τ • Γ} (cons v dv R[v,dv] ρ) = (v ⊕ dv) • update ρ

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] ρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] ρ) = ⟦ x ⟧ΔVar ρ

-- ⟦_⟧ΔVar is not put into the Meaning type class
-- because its argument is identical to that of ⟦_⟧Var.

-- ⟦_⟧Δ : ∀ {τ Γ} → Δ-Term (Δ Γ) (Δ τ) → Δ-Env Γ → ⟦ Δ τ ⟧Δτ
⟦ Δnat old new ⟧Δ ρ = (old , new)
⟦ Δbag db ⟧Δ ρ = db
⟦ Δvar x ⟧Δ ρ = ⟦ x ⟧ΔVar ρ
⟦ Δabs t ⟧Δ ρ = λ v dv R[v,dv] → ⟦ t ⟧Δ (cons v dv R[v,dv] ρ)
⟦ Δapp ds t dt R[dt,t] ⟧Δ ρ =
  ⟦ ds ⟧Δ ρ (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ) R[dt,t]
⟦ Δadd ds dt ⟧Δ ρ =
  let
    (old-s , new-s) = ⟦ ds ⟧Δ ρ
    (old-t , new-t) = ⟦ dt ⟧Δ ρ
  in
    (old-s + old-t , new-s + new-t)
⟦ Δmap₀ f df b db ⟧Δ ρ =
  let
    v  = ⟦ b ⟧ (ignore ρ)
    h  = ⟦ f ⟧ (ignore ρ)
    dv = ⟦ db ⟧Δ ρ
    dh = ⟦ df ⟧Δ ρ
  in
    mapBag (h ⊕ dh) (v ⊕ dv) \\ mapBag h v
⟦ Δmap₁ f db ⟧Δ ρ = mapBag (⟦ f ⟧ (ignore ρ)) (⟦ db ⟧Δ ρ)

meaning-ΔTerm : ∀ {τ Γ} → Meaning (Δ-Term (Δ Γ) (Δ τ))
meaning-ΔTerm = meaning ⟦_⟧Δ

--------------------------------------------------------
-- Program transformation and correctness (entangled) --
--------------------------------------------------------

Δ-equiv : ∀ {τ : Type} → (du : ⟦ Δ τ ⟧Δτ) (dv : ⟦ Δ τ ⟧Δτ) → Set
Δ-equiv {τ} du dv =
  ∀ {v : ⟦ τ ⟧} (R[v,du] : valid v du) (R[v,dv] : valid v dv) →
    v ⊕ du ≡ v ⊕ dv

derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)

validity : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  valid (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

correctness : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  Δ-equiv (⟦ derive t ⟧ ρ) (⟦ t ⟧ (update ρ) ⊝ ⟦ t ⟧ (ignore ρ))

corollary : ∀ {τ Γ} {t : Term Γ τ} {ρ : Δ-Env Γ} →
  ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧ ρ ≡ ⟦ t ⟧ (update ρ)

corollary {τ} {Γ} {t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    v′ = ⟦ t ⟧ (update ρ)
  in
    begin
      v ⊕ ⟦ derive t ⟧ ρ
    ≡⟨ correctness {τ} {Γ} {t} {ρ} {v} validity R[v,u⊝v] ⟩
      v ⊕ (v′ ⊝ v)
    ≡⟨ v⊕[u⊝v]=u ⟩
      v′
    ∎ where open ≡-Reasoning

-- derive : ∀ {τ Γ} → Term Γ τ → Δ-Term (Δ Γ) (Δ τ)
derive (nat n) = Δnat n n
derive (bag b) = Δbag b
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t) validity
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

validity-var : ∀ {τ Γ} → (x : Var Γ τ) →
  ∀ {ρ : Δ-Env Γ} → valid (⟦ x ⟧ (ignore ρ)) (⟦ x ⟧ΔVar ρ)

validity-var this {cons v dv R[v,dv] ρ} = R[v,dv]
validity-var (that x) {cons v dv R[v,dv] ρ} = validity-var x

validity {nats} {Γ} {nat n} = refl
validity {bags} {Γ} {bag b} = tt
validity {τ} {Γ} {var x} = validity-var x
validity {nats} {Γ} {add s t} = cong₂ _+_ R[s,ds] R[t,dt]
  where R[s,ds] = validity {nats} {Γ} {s}
        R[t,dt] = validity {nats} {Γ} {t}
validity {bags} {Γ} {map f b} = tt

validity {τ₁ ⇒ τ₂} {Γ} {abs t} {ρ} = λ v dv R[v,dv] →
  let
    v′ = v ⊕ dv
    dv′ = v′ ⊝ v′
    ρ₁ = cons v  dv R[v,dv] ρ
    ρ₂ = cons v′ dv′ R[v,u⊝v] ρ
  in
    validity {_} {_} {t} {ρ₁}
    ,
    (begin
      ⟦ t ⟧ (ignore ρ₂) ⊕ ⟦ derive t ⟧ ρ₂
    ≡⟨ corollary {_} {_} {t} {ρ₂} ⟩
      ⟦ t ⟧ (update ρ₂)
    ≡⟨ {!!} ⟩
      ⟦ t ⟧ (ignore ρ₁) ⊕ ⟦ derive t ⟧ ρ₁
    ∎) where open ≡-Reasoning

validity {τ} {Γ} {app s t} = {!!}

correctness = {!!}


Banana :D

Banana :D

module Banana where

data Banana : Set where
    raw : Banana
    ripe : Banana
    rotten : Banana

a : Banana
a = {!!}

b : Banana
b = {!!}

module Banana where

data Banana : Set where
    peeled : Banana
    unpeeled : Banana

data Nat : Set where
  Z : Nat
  S : Nat -> Nat

a : Banana
a = {!!}

b : Banana
b = {!!}


Typos.

Typos.

Ignore-this: b93037029d2add29e31efadb8744c5b3

darcs-hash:20120204164223-3bd4e-e7bbfb7655b2839a5c2aa5890b9eb16cc3354155.gz

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_
infix  7  _≣_

------------------------------------------------------------------------------
-- PA universe
open import Common.Universe public renaming ( D to ℕ )

-- Logical constants
open import Common.LogicalConstants public

-- Non-logical constants
postulate
  zero : ℕ
  succ : ℕ → ℕ
  _+_  : ℕ → ℕ → ℕ
  _*_  : ℕ → ℕ → ℕ

-- The PA equality.
-- N.B. The symbol _≡_ should not be used because it is hard-coded by
-- the program agda2atp as the ATPs equality.
postulate _≣_ : ℕ → ℕ → Set

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- N.B. We make the recursion in the first argument for _+_ and _*_.

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + m
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wf P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≣ n → m ≣ o → n ≣ o
  S₂ : ∀ {m n} → m ≣ n → succ m ≣ succ n
  S₃ : ∀ {n} → ¬ (zero ≣ succ n)
  S₄ : ∀ {m n} → succ m ≣ succ n → m ≣ n
  S₅ : ∀ n → zero + n ≣ n
  S₆ : ∀ m n → succ m + n ≣ succ (m + n)
  S₇ : ∀ n → zero * n ≣ zero
  S₈ : ∀ m n → succ m * n ≣ n + m * n
{-# ATP axiom S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- The axiom S₉ is a higher-order one, therefore we do not translate
-- it as an ATP axiom.
postulate S₉ : (P : ℕ → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infix  7  _≣_
infixl 9  _+_

------------------------------------------------------------------------------
-- PA universe
open import Common.Universe public renaming ( D to ℕ )

-- Logical constants
open import Common.LogicalConstants public

-- Non-logical constants
postulate
  zero : ℕ
  succ : ℕ → ℕ
  _+_  : ℕ → ℕ → ℕ
  _*_  : ℕ → ℕ → ℕ

-- The PA equality.
-- N.B. The symbol _≡_ should not be used because it is hard-coded by
-- the program agda2atp as the ATPs equality.
postulate _≣_ : ℕ → ℕ → Set

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- N.B. We make the recursion in the first argument for _+_ and _*_.

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + m
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wf P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≣ n → m ≣ o → n ≣ o
  S₂ : ∀ {m n} → m ≣ n → succ m ≣ succ n
  S₃ : ∀ {n} → ¬ (zero ≣ succ n)
  S₄ : ∀ {m n} → succ m ≣ succ n → m ≣ n
  S₅ : ∀ n → zero + n ≣ n
  S₆ : ∀ m n → succ m + n ≣ succ (m + n)
  S₇ : ∀ n → zero   * n ≣ zero
  S₈ : ∀ m n → succ m * n ≣ n + m * n
{-# ATP axiom S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- The axiom S₉ is a higher-order one, therefore we do not translate
-- it as an ATP axiom.
postulate S₉ : (P : ℕ → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n


Add ≙-cong₂

Add ≙-cong₂

Useful for next steps.

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

open import Base.Change.Equivalence.Base public
open import Base.Change.Equivalence.EqReasoning public

module _ {a} {A : Set a} {{ca : ChangeAlgebra A}} {x : A} where
  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ (dx : Δ x) → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ (dx : Δ x) → x ⊞ dx ≡ x → dx ≙ (nil x)
  ⊞-unit-is-nil dx x⊞dx≡x = doe $
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

  -- Let's show that nil x is d.o.e. to x ⊟ x
  nil-x-is-x⊟x : nil x ≙ x ⊟ x
  nil-x-is-x⊟x = ≙-sym (⊞-unit-is-nil (x ⊟ x) (update-diff x x))

  -- TODO: we want to show that all functions of interest respect
  -- delta-observational equivalence, so that two d.o.e. changes can be
  -- substituted for each other freely.
  --
  -- * That should be be true for
  --   functions using changes parametrically.
  --
  -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
  --   this is proved below on both contexts at once by
  --   equiv-fun-changes-respect, and its corollaries fun-change-respects and
  --   equiv-fun-changes-funs.
  --
  -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
  --   it by definition, and ⊟ doesn't take change arguments - we will only
  --   need a proof for compose, when we define it.
  --
  -- Stating the general result, though, seems hard, we should
  -- rather have lemmas proving that certain classes of functions respect this
  -- equivalence.

  -- This results pairs with update-diff.
  diff-update : ∀ {dx : Δ x} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

  -- \begin{lemma}[Equivalence cancellation]
  --   |v2 `ominus` v1 `doe` dv| holds if and only if |v2 = v1 `oplus`
  --   dv|, for any |v1, v2 `elem` V| and |dv `elem` Dt ^ v1|.
  -- \end{lemma}

  equiv-cancel-1 : ∀ x' dx → (x' ⊟ x) ≙ dx → x' ≡ x ⊞ dx
  equiv-cancel-1 x' dx (doe x'⊟x≙dx) = trans (sym (update-diff x' x)) x'⊟x≙dx
  equiv-cancel-2 : ∀ x' dx → x' ≡ x ⊞ dx → x' ⊟ x ≙ dx
  equiv-cancel-2 _ dx refl = diff-update

module _ {a} {b} {A : Set a} {B : Set b}
  {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} where

  ≙-cong₂ : ∀ {c} {C : Set c} {x y}
       (f : A → B → C) {dx1 dx2 dy1 dy2} → dx1 ≙ dx2 → dy1 ≙ dy2 → f (x ⊞ dx1) (y ⊞ dy1) ≡ f (x ⊞ dx2) (y ⊞ dy2)
  ≙-cong₂ f dx1≙dx2 dy1≙dy2 = cong₂ f (proof dx1≙dx2) (proof dy1≙dy2)

  equiv-fun-changes-respect : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂ : Δ f} →
    df₁ ≙₍ f ₎ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  equiv-fun-changes-respect {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = doe lemma
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
      -- Informally: use incrementalization on both sides and then apply
      -- congruence.
      lemma =
        begin
          f x ⊞ apply df₁ x dx₁
        ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
          (f ⊞ df₁) (x ⊞ dx₁)
        ≡⟨ ≙-cong (f ⊞ df₁) dx₁≙dx₂ ⟩
          (f ⊞ df₁) (x ⊞ dx₂)
        ≡⟨ ≙-cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
          (f ⊞ df₂) (x ⊞ dx₂)
        ≡⟨ incrementalization f df₂ x dx₂ ⟩
          f x ⊞ apply df₂ x dx₂
        ∎

  fun-change-respects : ∀ {x : A} {dx₁ dx₂} {f : A → B} (df : Δ f) →
    dx₁ ≙ dx₂ → apply df x dx₁ ≙ apply df x dx₂
  fun-change-respects df dx₁≙dx₂ = equiv-fun-changes-respect (≙-refl {dx = df}) dx₁≙dx₂

  -- D.o.e. function changes behave like the same function (up to d.o.e.).
  equiv-fun-changes-funs : ∀ {x : A} {dx} {f : A → B} {df₁ df₂} →
    df₁ ≙₍ f ₎ df₂ → apply df₁ x dx ≙ apply df₂ x dx
  equiv-fun-changes-funs {dx = dx} df₁≙df₂ = equiv-fun-changes-respect df₁≙df₂ (≙-refl {dx = dx})

  derivative-doe-characterization : ∀ {a : A} {da : Δ a}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    df a da ≙ f (a ⊞ da) ⊟ f a
  derivative-doe-characterization {a} {da} {f} {df} is-derivative = doe lemma
    where
      open ≡-Reasoning
      lemma : f a ⊞ df a da ≡ f a ⊞ (f (a ⊞ da) ⊟ f a)
      lemma =
        begin
          (f a ⊞ df a da)
        ≡⟨ is-derivative a da ⟩
          (f (a ⊞ da))
        ≡⟨ sym (update-diff (f (a ⊞ da)) (f a)) ⟩
          (f a ⊞ (f (a ⊞ da) ⊟ f a))
        ∎

  derivative-respects-doe : ∀ {x : A} {dx₁ dx₂ : Δ x}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    dx₁ ≙ dx₂ → df x dx₁ ≙ df x dx₂
  derivative-respects-doe {x} {dx₁} {dx₂} {f} {df} is-derivative dx₁≙dx₂ =
    begin
      df x dx₁
    ≙⟨ derivative-doe-characterization is-derivative ⟩
      f (x ⊞ dx₁) ⊟ f x
    ≡⟨ cong (λ v → f v  ⊟ f x) (proof dx₁≙dx₂) ⟩
      f (x ⊞ dx₂) ⊟ f x
    ≙⟨ ≙-sym (derivative-doe-characterization is-derivative) ⟩
      df x dx₂
    ∎
    where
      open ≙-Reasoning

  -- This is also a corollary of fun-changes-respect
  derivative-respects-doe-alt : ∀ {x : A} {dx₁ dx₂ : Δ x}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    dx₁ ≙ dx₂ → df x dx₁ ≙ df x dx₂
  derivative-respects-doe-alt {x} {dx₁} {dx₂} {f} {df} is-derivative dx₁≙dx₂ =
    fun-change-respects (DerivativeAsChange is-derivative) dx₁≙dx₂

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = doe lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ x dx = proof $ df-x-dx≙dg-x-dx x dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- You could think that the function should relate equivalent changes, but
  -- that's a stronger hypothesis, which doesn't give you extra guarantees. But
  -- here's the statement and proof, for completeness:

  delta-ext₂ : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x (dx₁ dx₂ : Δ x) → dx₁ ≙₍ x ₎ dx₂ → apply df x dx₁ ≙ apply dg x dx₂) → df ≙ dg
  delta-ext₂ {f} {df} {dg} df-x-dx≙dg-x-dx = delta-ext (λ x dx → df-x-dx≙dg-x-dx x dx dx ≙-refl)

  -- We know that IsDerivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> IsDerivative f (apply df).
  -- Now, we try to prove that if IsDerivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    IsDerivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    IsDerivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  derivative-is-nil-alternative : ∀ {f : A → B} df →
    (IsDerivative-f-df : IsDerivative f df) → DerivativeAsChange IsDerivative-f-df ≙ nil f
  derivative-is-nil-alternative df IsDerivative-f-df = derivative-is-nil (DerivativeAsChange IsDerivative-f-df) IsDerivative-f-df

  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)
    ∎
    where
      open ≡-Reasoning

  -- If we have two derivatives, they're both nil, hence they're equivalent.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → IsDerivative f (apply df) → IsDerivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ ≙-sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning

  equiv-derivative-is-derivative : ∀ {f : A → B} df₁ df₂ → IsDerivative f (apply df₁) → df₁ ≙₍ f ₎ df₂ → IsDerivative f (apply df₂)
  equiv-derivative-is-derivative {f} df₁ df₂ IsDerivative-f-df₁ df₁≙df₂ a da =
    begin
      f a ⊞ apply df₂ a da
    ≡⟨ sym (incrementalization f df₂ a da) ⟩
      (f ⊞ df₂) (a ⊞ da)
    ≡⟨ cong (λ □ → □ (a ⊞ da)) lemma ⟩
      f (a ⊞ da)
    ∎
    where
      open ≡-Reasoning
      lemma : f ⊞ df₂ ≡ f
      lemma =
        begin
          f ⊞ df₂
        ≡⟨ proof (≙-sym df₁≙df₂) ⟩
          f ⊞ df₁
        ≡⟨ derivative-is-⊞-unit df₁ IsDerivative-f-df₁ ⟩
          f
        ∎

  -- This is Lemma 2.5 in the paper. Note that the statement in the paper uses
  -- (incorrectly) normal equality instead of delta-observational equivalence.
  deriv-zero :
    ∀ (f : A → B) df → IsDerivative f df →
    ∀ v → df v (nil v) ≙ nil (f v)
  deriv-zero f df proof v = doe lemma
    where
      open ≡-Reasoning
      lemma : f v ⊞ df v (nil v) ≡ f v ⊞ nil (f v)
      lemma =
        begin
          f v ⊞ df v (nil v)
        ≡⟨ proof v (nil v) ⟩
          f (v ⊞ (nil v))
        ≡⟨ cong f (update-nil v) ⟩
          f v
        ≡⟨ sym (update-nil (f v)) ⟩
          f v ⊞ nil (f v)
        ∎

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

open import Base.Change.Equivalence.Base public
open import Base.Change.Equivalence.EqReasoning public

module _ {a} {A : Set a} {{ca : ChangeAlgebra A}} {x : A} where
  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ (dx : Δ x) → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ (dx : Δ x) → x ⊞ dx ≡ x → dx ≙ (nil x)
  ⊞-unit-is-nil dx x⊞dx≡x = doe $
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

  -- Let's show that nil x is d.o.e. to x ⊟ x
  nil-x-is-x⊟x : nil x ≙ x ⊟ x
  nil-x-is-x⊟x = ≙-sym (⊞-unit-is-nil (x ⊟ x) (update-diff x x))

  -- TODO: we want to show that all functions of interest respect
  -- delta-observational equivalence, so that two d.o.e. changes can be
  -- substituted for each other freely.
  --
  -- * That should be be true for
  --   functions using changes parametrically.
  --
  -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
  --   this is proved below on both contexts at once by
  --   equiv-fun-changes-respect, and its corollaries fun-change-respects and
  --   equiv-fun-changes-funs.
  --
  -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
  --   it by definition, and ⊟ doesn't take change arguments - we will only
  --   need a proof for compose, when we define it.
  --
  -- Stating the general result, though, seems hard, we should
  -- rather have lemmas proving that certain classes of functions respect this
  -- equivalence.

  -- This results pairs with update-diff.
  diff-update : ∀ {dx : Δ x} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

  -- \begin{lemma}[Equivalence cancellation]
  --   |v2 `ominus` v1 `doe` dv| holds if and only if |v2 = v1 `oplus`
  --   dv|, for any |v1, v2 `elem` V| and |dv `elem` Dt ^ v1|.
  -- \end{lemma}

  equiv-cancel-1 : ∀ x' dx → (x' ⊟ x) ≙ dx → x' ≡ x ⊞ dx
  equiv-cancel-1 x' dx (doe x'⊟x≙dx) = trans (sym (update-diff x' x)) x'⊟x≙dx
  equiv-cancel-2 : ∀ x' dx → x' ≡ x ⊞ dx → x' ⊟ x ≙ dx
  equiv-cancel-2 _ dx refl = diff-update

module _ {a} {b} {A : Set a} {B : Set b}
  {{CA : ChangeAlgebra A}} {{CB : ChangeAlgebra B}} where

  equiv-fun-changes-respect : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂ : Δ f} →
    df₁ ≙₍ f ₎ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  equiv-fun-changes-respect {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = doe lemma
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
      -- Informally: use incrementalization on both sides and then apply
      -- congruence.
      lemma =
        begin
          f x ⊞ apply df₁ x dx₁
        ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
          (f ⊞ df₁) (x ⊞ dx₁)
        ≡⟨ ≙-cong (f ⊞ df₁) dx₁≙dx₂ ⟩
          (f ⊞ df₁) (x ⊞ dx₂)
        ≡⟨ ≙-cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
          (f ⊞ df₂) (x ⊞ dx₂)
        ≡⟨ incrementalization f df₂ x dx₂ ⟩
          f x ⊞ apply df₂ x dx₂
        ∎

  fun-change-respects : ∀ {x : A} {dx₁ dx₂} {f : A → B} (df : Δ f) →
    dx₁ ≙ dx₂ → apply df x dx₁ ≙ apply df x dx₂
  fun-change-respects df dx₁≙dx₂ = equiv-fun-changes-respect (≙-refl {dx = df}) dx₁≙dx₂

  -- D.o.e. function changes behave like the same function (up to d.o.e.).
  equiv-fun-changes-funs : ∀ {x : A} {dx} {f : A → B} {df₁ df₂} →
    df₁ ≙₍ f ₎ df₂ → apply df₁ x dx ≙ apply df₂ x dx
  equiv-fun-changes-funs {dx = dx} df₁≙df₂ = equiv-fun-changes-respect df₁≙df₂ (≙-refl {dx = dx})

  derivative-doe-characterization : ∀ {a : A} {da : Δ a}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    df a da ≙ f (a ⊞ da) ⊟ f a
  derivative-doe-characterization {a} {da} {f} {df} is-derivative = doe lemma
    where
      open ≡-Reasoning
      lemma : f a ⊞ df a da ≡ f a ⊞ (f (a ⊞ da) ⊟ f a)
      lemma =
        begin
          (f a ⊞ df a da)
        ≡⟨ is-derivative a da ⟩
          (f (a ⊞ da))
        ≡⟨ sym (update-diff (f (a ⊞ da)) (f a)) ⟩
          (f a ⊞ (f (a ⊞ da) ⊟ f a))
        ∎

  derivative-respects-doe : ∀ {x : A} {dx₁ dx₂ : Δ x}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    dx₁ ≙ dx₂ → df x dx₁ ≙ df x dx₂
  derivative-respects-doe {x} {dx₁} {dx₂} {f} {df} is-derivative dx₁≙dx₂ =
    begin
      df x dx₁
    ≙⟨ derivative-doe-characterization is-derivative ⟩
      f (x ⊞ dx₁) ⊟ f x
    ≡⟨ cong (λ v → f v  ⊟ f x) (proof dx₁≙dx₂) ⟩
      f (x ⊞ dx₂) ⊟ f x
    ≙⟨ ≙-sym (derivative-doe-characterization is-derivative) ⟩
      df x dx₂
    ∎
    where
      open ≙-Reasoning

  -- This is also a corollary of fun-changes-respect
  derivative-respects-doe-alt : ∀ {x : A} {dx₁ dx₂ : Δ x}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    dx₁ ≙ dx₂ → df x dx₁ ≙ df x dx₂
  derivative-respects-doe-alt {x} {dx₁} {dx₂} {f} {df} is-derivative dx₁≙dx₂ =
    fun-change-respects (DerivativeAsChange is-derivative) dx₁≙dx₂

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = doe lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ x dx = proof $ df-x-dx≙dg-x-dx x dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- You could think that the function should relate equivalent changes, but
  -- that's a stronger hypothesis, which doesn't give you extra guarantees. But
  -- here's the statement and proof, for completeness:

  delta-ext₂ : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x (dx₁ dx₂ : Δ x) → dx₁ ≙₍ x ₎ dx₂ → apply df x dx₁ ≙ apply dg x dx₂) → df ≙ dg
  delta-ext₂ {f} {df} {dg} df-x-dx≙dg-x-dx = delta-ext (λ x dx → df-x-dx≙dg-x-dx x dx dx ≙-refl)

  -- We know that IsDerivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> IsDerivative f (apply df).
  -- Now, we try to prove that if IsDerivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    IsDerivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    IsDerivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  derivative-is-nil-alternative : ∀ {f : A → B} df →
    (IsDerivative-f-df : IsDerivative f df) → DerivativeAsChange IsDerivative-f-df ≙ nil f
  derivative-is-nil-alternative df IsDerivative-f-df = derivative-is-nil (DerivativeAsChange IsDerivative-f-df) IsDerivative-f-df

  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)
    ∎
    where
      open ≡-Reasoning

  -- If we have two derivatives, they're both nil, hence they're equivalent.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → IsDerivative f (apply df) → IsDerivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ ≙-sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning

  equiv-derivative-is-derivative : ∀ {f : A → B} df₁ df₂ → IsDerivative f (apply df₁) → df₁ ≙₍ f ₎ df₂ → IsDerivative f (apply df₂)
  equiv-derivative-is-derivative {f} df₁ df₂ IsDerivative-f-df₁ df₁≙df₂ a da =
    begin
      f a ⊞ apply df₂ a da
    ≡⟨ sym (incrementalization f df₂ a da) ⟩
      (f ⊞ df₂) (a ⊞ da)
    ≡⟨ cong (λ □ → □ (a ⊞ da)) lemma ⟩
      f (a ⊞ da)
    ∎
    where
      open ≡-Reasoning
      lemma : f ⊞ df₂ ≡ f
      lemma =
        begin
          f ⊞ df₂
        ≡⟨ proof (≙-sym df₁≙df₂) ⟩
          f ⊞ df₁
        ≡⟨ derivative-is-⊞-unit df₁ IsDerivative-f-df₁ ⟩
          f
        ∎

  -- This is Lemma 2.5 in the paper. Note that the statement in the paper uses
  -- (incorrectly) normal equality instead of delta-observational equivalence.
  deriv-zero :
    ∀ (f : A → B) df → IsDerivative f df →
    ∀ v → df v (nil v) ≙ nil (f v)
  deriv-zero f df proof v = doe lemma
    where
      open ≡-Reasoning
      lemma : f v ⊞ df v (nil v) ≡ f v ⊞ nil (f v)
      lemma =
        begin
          f v ⊞ df v (nil v)
        ≡⟨ proof v (nil v) ⟩
          f (v ⊞ (nil v))
        ≡⟨ cong f (update-nil v) ⟩
          f v
        ≡⟨ sym (update-nil (f v)) ⟩
          f v ⊞ nil (f v)
        ∎


Adding witness, statement and valid witnesses to SigmaProtocol

open import Type                 using (Type)
open import Data.Bool.Base       using (Bool) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; _≢_)

module ZK.SigmaProtocol
          (Commitment : Type) -- Prover commitments
          (Challenge  : Type) -- Verifier challenges
          (Response   : Type) -- Prover responses/proofs to challenges
          (Witness    : Type) -- Prover's witness
          (Statement  : Type) -- Set of possible statements of the zk-proof
          (_∈_ : Witness → Statement → Type) -- Valid witness for a given statement
       where

-- The prover is made of two steps.
-- * First, send the commitment.
-- * Second, receive a challenge and send back the response.
--
-- Therefor one represents a prover as a pair (a record) made
-- of a commitment (get-A) and a function (get-f) from challenges
-- to responses.
--
-- Note that one might wish the function get-f to be partial.
--
-- This covers any kind of prover, either honest or dishonest
-- Notice as well that such should depend on some randomness.
-- So such a prover as type: SomeRandomness → Prover
record Prover-Interaction : Type where
  constructor _,_
  field
    get-A : Commitment
    get-f : Challenge → Response

Prover : Type
Prover = (w : Witness)(Y : Statement) → Prover-Interaction

-- A transcript of the interaction between the prover and the
-- verifier.
--
-- Note that in the case of an interactive zero-knowledge
-- proof the transcript alone does not prove anything. It can usually
-- be simulated if one knows the challenge before the commitment.
--
-- The only way to be convinced by an interactive prover is to be/trust the verifier,
-- namely to receive the commitment first and send a randomly picked challenge
-- thereafter. So the proof is not transferable.
--
-- The other way is by making the zero-knowledge proof non-interactive, which forces the
-- challenge to be a cryptographic hash of the commitment and the statement.
-- See the StrongFiatShamir module and the corresponding paper for more details.
record Transcript : Type where
  constructor mk
  field
    get-A : Commitment
    get-c : Challenge
    get-f : Response

-- The actual behavior of an interactive verifier is as follows:
-- * Given a statement
-- * Receive a commitment from the prover
-- * Send a randomly chosen challenge to the prover
-- * Receive a response to that challenge
-- Since the first two points are common to all Σ-protocols we describe
-- the verifier behavior as a computable test on the transcript.
Verifier : Type
Verifier = (Y : Statement)(t : Transcript) → Bool

-- To run the interaction, one only needs the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover-Interaction → Challenge → Transcript
run (A , f) c = mk A c (f c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

-- Correctness (also called completeness in some papers): a Σ-protocol is said
-- to be correct if for any challenge, the (honest) verifier accepts what
-- the (honest) prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ {w Y} c → w ∈ Y → ✓ (verifier Y (run (prover w Y) c))

-- A simulator takes a challenge and a response and returns a commitment.
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (Y : Statement) (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ Y c s → let A = simulator Y c s in
              ✓(verifier Y (mk A c s))

{-
  A Σ-protocol, more specifically a verifier which is equipped with
  a correct simulator is said to be Special Honest Verifier Zero Knowledge.
  This property is one of the condition to apply the Strong Fiat Shamir
  transformation.

  The Special part of Special-Honest-Verifier-Zero-Knowledge is covered by the
  simulator being correct.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if the challenge c and response s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the (honest) prover and the (honest) verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator         : Simulator
    correct-simulator : Correct-simulator verifier simulator

-- A pair of "Transcript"s such that the commitment is shared
-- and the challenges are different.
record Transcript² (verifier : Verifier) (Y : Statement) : Type where
  constructor mk
  field
    -- The commitment is shared
    get-A         : Commitment

    -- The challenges...
    get-c₀ get-c₁ : Challenge

    -- ...are different
    c₀≢c₁         : get-c₀ ≢ get-c₁

    -- The responses/proofs are arbitrary
    get-f₀ get-f₁ : Response

  -- The two transcripts
  t₀ : Transcript
  t₀ = mk get-A get-c₀ get-f₀
  t₁ : Transcript
  t₁ = mk get-A get-c₁ get-f₁

  field
    -- The transcripts verify
    verify₀ : ✓ (verifier Y t₀)
    verify₁ : ✓ (verifier Y t₁)

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = ∀ Y → Transcript² verifier Y → Witness

Extract-Valid-Witness : (verifier : Verifier) → Extractor verifier → Type
Extract-Valid-Witness verifier extractor = ∀ Y t² → extractor Y t² ∈ Y

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct extractor is said to have the Special Soundness property.
-- This property is one of the condition to apply the Strong Fiat Shamir
-- transformation.
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
    extractor             : Extractor verifier
    extract-valid-witness : Extract-Valid-Witness verifier extractor

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public

open import Type                 using (Type)
open import Data.Bool.Base       using (Bool) renaming (T to ✓)
open import Relation.Binary.Core using (_≡_; _≢_)

module ZK.SigmaProtocol
          (Commitment : Type) -- Prover commitments
          (Challenge  : Type) -- Verifier challenges
          (Response   : Type) -- Prover responses/proofs to challenges
       where

-- The prover is made of two steps.
-- * First, send the commitment.
-- * Second, receive a challenge and send back the response.
--
-- Therefor one represents a prover as a pair (a record) made
-- of a commitment (get-A) and a function (get-f) from challenges
-- to responses.
--
-- Note that one might wish the function get-f to be partial.
--
-- Notice as well that such should depend on some randomness.
-- So such a prover as type: SomeRandomness → Prover
record Prover : Type where
  constructor _,_
  field
    get-A : Commitment
    get-f : Challenge → Response

-- A transcript of the interaction between the prover and the
-- verifier.
--
-- Note that in the case of an interactive zero-knowledge
-- proof the transcript alone does not prove anything. It can usually
-- be simulated if one knows the challenge before the commitment.
--
-- The only to be convinced by an interactive prover is to be/trust the verifier,
-- namely to receive the commitment first and send a randomly picked challenge
-- thereafter.
--
-- The other way is the non-interactive zero-knowledge proof which forces the
-- challenge to be a cryptographic hash of the commitment and the statement.
-- See the StrongFiatShamir module and the corresponding paper for more details.
record Transcript : Type where
  constructor mk
  field
    get-A : Commitment
    get-c : Challenge
    get-f : Response

-- The actual behavior of an interactive verifier is as follows:
-- * Receive a commitment from the prover
-- * Send a randomly chosen challenge to the prover
-- * Receive a response to that challenge
-- Since the first two points are common to all Σ-protocols we describe
-- the verifier behavior as a computable test on the transcript.
Verifier : Type
Verifier = Transcript → Bool

-- To run the interaction, one only need the prover and a randomly
-- chosen challenge. The returned transcript is then checked by the
-- verifier afterwards.
run : Prover → Challenge → Transcript
run (A , f) c = mk A c (f c)

-- A Σ-protocol is made of the code for honest prover
-- and honest verifier.
record Σ-Protocol : Type where
  constructor _,_
  field
    prover   : Prover
    verifier : Verifier

-- Correctness: a Σ-protocol is said to be correct if for any challenge,
-- the (honest) verifier accepts what the (honest) prover returns.
Correct : Σ-Protocol → Type
Correct (prover , verifier) = ∀ c → ✓ (verifier (run prover c))

-- A simulator takes a challenge and a response and returns a commitment.
--
-- As defined next, a correct simulator picks the commitment such that
-- the transcript is accepted by the verifier.
--
-- Notice that generally, to make a valid looking transcript one should
-- randomly pick the challenge and the response.
Simulator : Type
Simulator = (c : Challenge) (s : Response) → Commitment

-- A correct simulator always convinces the honest verifier.
Correct-simulator : Verifier → Simulator → Type
Correct-simulator verifier simulator
  = ∀ c s → let A = simulator c s in
            ✓(verifier (mk A c s))

{-
  A Σ-protocol, more specifically a verifier which is equipped with
  a correct simulator is said to be Special Honest Verifier Zero Knowledge.
  This property is one of the condition to apply the Strong Fiat Shamir
  transformation.

  The Special part of Special-Honest-Verifier-Zero-Knowledge is coverd by the
  simulator being correct.

  The Honest part is not covered yet, the definition is informally adapted from
  the paper "How not to prove yourself":

  Furthermore, if c and s where chosen uniformly at random from their respective
  domains then the triple (A, c, s) is distributed identically to that of an execution
  between the prover and the verifier (run prover c).

  where A = simulator c s
-}
record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : Type where
  open Σ-Protocol Σ-proto
  field
    simulator         : Simulator
    correct-simulator : Correct-simulator verifier simulator

-- Two provers being equivalent, namely pointwise equal.
record EqProver (p₀ p₁ : Prover) : Type where
  constructor _,_
  module P₀ = Prover p₀
  module P₁ = Prover p₁
  field
    eq-A : P₀.get-A ≡ P₁.get-A
    eq-f : ∀ c → P₀.get-f c ≡ P₁.get-f c

-- A pair of "Transcript"s such that the commitment is shared
-- and the challenges are different.
record Transcript² (verifier : Verifier) : Type where
  constructor mk
  field
    -- The commitment is shared
    get-A         : Commitment

    -- The challenges...
    get-c₀ get-c₁ : Challenge

    -- ...are different
    c₀≢c₁         : get-c₀ ≢ get-c₁

    -- The responses/proofs are arbitrary
    get-f₀ get-f₁ : Response

  -- The two transcripts
  t₀ : Transcript
  t₀ = mk get-A get-c₀ get-f₀
  t₁ : Transcript
  t₁ = mk get-A get-c₁ get-f₁

  field
    -- The transcripts verify
    verify₀ : ✓ (verifier t₀)
    verify₁ : ✓ (verifier t₁)

-- Remark: What if the underlying witnesses are different? Nothing is enforced here.
-- At least in the case of the Schnorr protocol it does not matter and yield a unique
-- witness.
Extractor : Verifier → Type
Extractor verifier = Transcript² verifier → Prover

Extractor-Exact : (prover : Prover) (verifier : Verifier) → Extractor verifier → Type
Extractor-Exact prover verifier extractor = ∀ t² → EqProver (extractor t²) prover

-- A Σ-protocol, more specifically a verifier which is equipped with
-- a correct extractor is said to have the Special Soundness property.
-- This property is one of the condition to apply the Strong Fiat Shamir
-- transformation.
record Special-Soundness Σ-proto : Type where
  open Σ-Protocol Σ-proto
  field
    extractor       : Extractor verifier
    extractor-exact : Extractor-Exact prover verifier extractor

  {- In the module StrongFiatShamir the extractor is as follows:

    Extract    : (t : Σ-Transcript² verifier) → W
    Extract-ok : (t : Σ-Transcript² verifier) → L (Extract t) Y

    This version does not include the language of statements (Λ : Type),
    the statements (Y : Δ), the witnesses (W : Type), nor the witnesses
    relation (L : W → Λ → Type).
    Therefor the extraction is described as extracting a honest prover
    from the pair of transcripts.
  -}

record Special-Σ-Protocol : Type where
  field
    Σ-protocol : Σ-Protocol
    correct : Correct Σ-protocol
    shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-protocol
    ssound  : Special-Soundness Σ-protocol
  open Σ-Protocol Σ-protocol public
  open Special-Honest-Verifier-Zero-Knowledge shvzk public
  open Special-Soundness ssound public


Fixed typo.

Fixed typo.

------------------------------------------------------------------------------
-- The first-order theory of combinators (FOTC) base
------------------------------------------------------------------------------

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

{-
FOTC                                  The logical framework (Agda)

* Logical constants                   * Curry-Howard isomorphism
* Equality                            * Identity type
* Term language and conversion rules  * Postulates
* Inductively defined predicates      * Inductive families
* Co-inductively defined predicates   * Greatest fixed-points
-}

-- References:
--
-- • Peter Aczel. The strength of Martin-Löf's intuitionistic type
--   theory with one universe. In Miettinen and Väänanen,
--   editors. Proc. of the Symposium on Mathematical Logic (Oulu,
--   1974), Report No. 2, Department of Philosopy, University of
--   Helsinki, Helsinki, 1977, pages 1–32.

module FOTC.Base where

-- We add 3 to the fixities of the standard library.
infixl 9 _·_  -- The symbol is '\cdot'.
infix  8 if_then_else_

------------------------------------------------------------------------------
-- First-order logic with equality.
open import Common.FOL.FOL-Eq public

-- Common definitions.
open import Common.DefinitionsATP public

------------------------------------------------------------------------------
-- The term language of FOTC

--   t ::= x   | t · t |
--      | true | false | if
--      | 0    | succ  | pred | iszero
--      | loop

postulate
  _·_                    : D → D → D  -- FOTC application.
  true false if          : D          -- FOTC partial Booleans.
  zero succ pred iszero  : D          -- FOTC partial natural numbers.
  loop                   : D          -- FOTC looping programs.

------------------------------------------------------------------------------
-- Definitions

-- We define some function symbols for convenience in writing and
-- looking for an optimization for the ATPs.

-- 2012-03-20. The definitions are inside an abstract block because
-- the conversion rules (see below) are based on them, so want to
-- avoid their expansion.

abstract
  if_then_else_ : D → D → D → D
  if b then d₁ else d₂ = if · b · d₁ · d₂
  -- {-# ATP definition if_then_else_ #-}

  succ₁ : D → D
  succ₁ n = succ · n
  -- {-# ATP definition succ₁ #-}

  pred₁ : D → D
  pred₁ n = pred · n
  -- {-# ATP definition pred₁ #-}

  iszero₁ : D → D
  iszero₁ n = iszero · n
  -- {-# ATP definition iszero₁ #-}

------------------------------------------------------------------------------
-- Conversion rules

-- The conversion relation _conv_ satifies (Aczel 1977, p. 8)
--
-- x conv y <=> FOTC ⊢ x ≡ y,
--
-- therefore, we introduce the conversion rules as non-logical axioms.

-- N.B. Looking for an optimization for the ATPs, we write the
-- conversion rules on the defined function symbols instead of on the
-- term constants.

-- Conversion rules for Booleans.
-- if-true  : ∀ d₁ {d₂} → if · true  · d₁ · d₂ ≡ d₁
-- if-false : ∀ {d₁} d₂ → if · false · d₁ · d₂ ≡ d₂
postulate
  if-true  : ∀ d₁ {d₂} → if true  then d₁ else d₂ ≡ d₁
  if-false : ∀ {d₁} d₂ → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom if-true if-false #-}

-- Conversion rules for pred.
-- N.B. We don't need this equation.
-- pred-0 :       pred · zero     ≡ zero
-- pred-S : ∀ n → pred · (succ · n) ≡ n
postulate
  pred-S : ∀ n → pred₁ (succ₁ n) ≡ n
{-# ATP axiom pred-S #-}

-- Conversion rules for iszero.
-- iszero-0 :       iszero · zero       ≡ true
-- iszero-S : ∀ n → iszero · (succ · n) ≡ false
postulate
  iszero-0 :       iszero₁ zero      ≡ true
  iszero-S : ∀ n → iszero₁ (succ₁ n) ≡ false
{-# ATP axiom iszero-0 iszero-S #-}

-- Conversion rule for loop.
--
-- The equation loop-eq adds anything to the logic (because
-- reflexivity is already an axiom of equality), therefore we won't
-- add this equation as a first-order logic axiom.
postulate loop-eq : loop ≡ loop

------------------------------------------------------------------------------
-- Discrimination rules

--  0≢S : ∀ {n} → zero ≢ succ · n
postulate
  true≢false : true ≢ false
  0≢S        : ∀ {n} → zero ≢ succ₁ n
{-# ATP axiom true≢false 0≢S #-}

------------------------------------------------------------------------------
-- FOTC combinators for lists, colists, streams, etc.

module BList where

  -- We add 3 to the fixities of the standard library.
  infixr 8 _∷_

  -- List constants.
  postulate
    [] cons head tail null : D  -- FOTC lists.

  -- Definitions
  abstract
    _∷_  : D → D → D
    x ∷ xs = cons · x · xs
    -- {-# ATP definition _∷_ #-}

    head₁ : D → D
    head₁ xs = head · xs
    -- {-# ATP definition head₁ #-}

    tail₁ : D → D
    tail₁ xs = tail · xs
    -- {-# ATP definition tail₁ #-}

    null₁ : D → D
    null₁ xs = null · xs
    -- {-# ATP definition null₁ #-}

  -- Conversion rules for null.
  -- null-[] :          null · []              ≡ true
  -- null-∷  : ∀ x xs → null · (cons · x · xs) ≡ false
  postulate
    null-[] :          null₁ []       ≡ true
    null-∷  : ∀ x xs → null₁ (x ∷ xs) ≡ false

  -- Conversion rule for head.
  -- head-∷ : ∀ x xs → head · (cons · x · xs) ≡ x
  postulate head-∷ : ∀ x xs → head₁ (x ∷ xs) ≡ x
  {-# ATP axiom head-∷ #-}

  -- Conversion rule for tail.
  -- tail-∷ : ∀ x xs → tail · (cons · x · xs) ≡ xs
  postulate tail-∷ : ∀ x xs → tail₁ (x ∷ xs) ≡ xs
  {-# ATP axiom tail-∷ #-}

  -- Discrimination rules
  -- postulate []≢cons : ∀ {x xs} → [] ≢ cons · x · xs
  postulate []≢cons : ∀ {x xs} → [] ≢ x ∷ xs

------------------------------------------------------------------------------
-- The first-order theory of combinators (FOTC) base
------------------------------------------------------------------------------

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

{-
FOTC                                  The logical framework (Agda)

* Logical constants                   * Curry-Howard isomorphism
* Equality                            * Identity type
* Term language and conversion rules  * Postulates
* Inductively defined predicates      * Inductive families
* Co-inductively defined predicates   * Greatest fixed-points
-}

-- References:
--
-- • Peter Aczel. The strength of Martin-Löf's intuitionistic type
--   theory with one universe. In Miettinen and Väänanen,
--   editors. Proc. of the Symposium on Mathematical Logic (Oulu,
--   1974), Report No. 2, Department of Philosopy, University of
--   Helsinki, Helsinki, 1977, pages 1–32.

module FOTC.Base where

-- We add 3 to the fixities of the standard library.
infixl 9 _·_  -- The symbol is '\cdot'.
infix  8 if_then_else_

------------------------------------------------------------------------------
-- First-order logic with equality.
open import Common.FOL.FOL-Eq public

-- Common definitions.
open import Common.DefinitionsATP public

------------------------------------------------------------------------------
-- The term language of FOTC

--   t ::= x   | t · t |
--      | true | false | if
--      | 0    | succ  | pred | iszero
--      | loop

postulate
  _·_                    : D → D → D  -- FOTC application.
  true false if          : D          -- FOTC partial Booleans.
  zero succ pred iszero  : D          -- FOTC partial natural numbers.
  loop                   : D          -- FOTC looping programs.

------------------------------------------------------------------------------
-- Definitions

-- We define some function symbols for convenience in writing and
-- looking for an optimization for the ATPs.

-- 2012-03-20. The definitions are inside an abstract block because
-- the conversion rules (see below) are based on them, so want to
-- avoid their expansion.

abstract
  if_then_else_ : D → D → D → D
  if b then d₁ else d₂ = if · b · d₁ · d₂
  -- {-# ATP definition if_then_else_ #-}

  succ₁ : D → D
  succ₁ n = succ · n
  -- {-# ATP definition succ₁ #-}

  pred₁ : D → D
  pred₁ n = pred · n
  -- {-# ATP definition pred₁ #-}

  iszero₁ : D → D
  iszero₁ n = iszero · n
  -- {-# ATP definition iszero₁ #-}

------------------------------------------------------------------------------
-- Conversion rules

-- The conversion relation _conv_ satifies (Aczel 1977, p. 8)
--
-- x conv y <=> FOTC ⊢ x ≡ y,
--
-- therefore, we introduce the conversion rules as non-logical axioms.

-- N.B. Looking for an optimization for the ATPs, we write the
-- conversion rules on the defined function symbols instead of on the
-- term constants.

-- Conversion rules for Booleans.
-- if-true  : ∀ d₁ {d₂} → if · true  · d₁ · d₂ ≡ d₁
-- if-false : ∀ {d₁} d₂ → if · false · d₁ · d₂ ≡ d₂
postulate
  if-true  : ∀ d₁ {d₂} → if true  then d₁ else d₂ ≡ d₁
  if-false : ∀ {d₁} d₂ → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom if-true if-false #-}

-- Conversion rules for pred.
-- N.B. We don't need this equation.
-- pred-0 :       pred · zero     ≡ zero
-- pred-S : ∀ n → pred · (succ · n) ≡ n
postulate
  pred-S : ∀ n → pred₁ (succ₁ n) ≡ n
{-# ATP axiom pred-S #-}

-- Conversion rules for iszero.
-- iszero-0 :       iszero · zero       ≡ true
-- iszero-S : ∀ n → iszero · (succ · n) ≡ false
postulate
  iszero-0 :       iszero₁ zero      ≡ true
  iszero-S : ∀ n → iszero₁ (succ₁ n) ≡ false
{-# ATP axiom iszero-0 iszero-S #-}

-- Conversion rule for loop.
--
-- The equation loop-eq adds anything to the logic (because
-- reflexivity is already an axiom of equality), therefore we won't
-- add this equation as a first-order logic axiom.
postulate loop-eq : loop ≡ loop

------------------------------------------------------------------------------
-- Discrimination rules

--  0≢S : ∀ {n} → zero ≢ succ · n
postulate
  true≢false : true ≢ false
  0≢S        : ∀ {n} → zero ≢ succ₁ n
{-# ATP axiom true≢false 0≢S #-}

------------------------------------------------------------------------------
-- FOTC combinators for lists, colists, streams, etc.

module BList where

  -- We add 3 to the fixities of the standard library.
  infixr 8 _∷_

  -- List constants.
  postulate
    [] cons head tail null : D  -- FOTC lists.

  -- Definitions
  abstract
    _∷_  : D → D → D
    x ∷ xs = cons · x · xs
    -- {-# ATP definition _∷_ #-}

    head₁ : D → D
    head₁ xs = head · xs
    -- {-# ATP definition head₁ #-}

    tail₁ : D → D
    tail₁ xs = tail · xs
    -- {-# ATP definition tail₁ #-}

    null₁ : D → D
    null₁ xs = null · xs
    -- {-# ATP definition null₁ #-}

  -- Conversion rules for null.
  -- null-[] :          null · nil             ≡ true
  -- null-∷  : ∀ x xs → null · (cons · x · xs) ≡ false
  postulate
    null-[] :          null₁ []       ≡ true
    null-∷  : ∀ x xs → null₁ (x ∷ xs) ≡ false

  -- Conversion rule for head.
  -- head-∷ : ∀ x xs → head · (cons · x · xs) ≡ x
  postulate head-∷ : ∀ x xs → head₁ (x ∷ xs) ≡ x
  {-# ATP axiom head-∷ #-}

  -- Conversion rule for tail.
  -- tail-∷ : ∀ x xs → tail · (cons · x · xs) ≡ xs
  postulate tail-∷ : ∀ x xs → tail₁ (x ∷ xs) ≡ xs
  {-# ATP axiom tail-∷ #-}

  -- Discrimination rules
  -- postulate []≢cons : ∀ {x xs} → [] ≢ cons · x · xs
  postulate []≢cons : ∀ {x xs} → [] ≢ x ∷ xs


easy subst cases

easy subst cases

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import structural

module lemmas-subst-ta where
  lem-subst-σ : ∀{Δ x Γ τ1 σ Γ' d } →
                  Δ , Γ ,, (x , τ1) ⊢ σ :s: Γ' →
                  Δ , Γ ⊢ d :: τ1 →
                  Δ , Γ ⊢ Subst d x σ :s: Γ'
  lem-subst-σ s wt = STASubst s wt

  -- todo: i'm worried this may actually be false without knowing that x ≠
  -- y, but that's kind of what we usually mean on paper anyway
  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   x ≠ y →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} x≠y xy = tr (λ qq → Δ , qq ⊢ σ :s: Γ') (funext swap) xy
    where
      swap : (z : Nat) → (Γ ,, (x , τ1) ,, (y , τ2)) z == (Γ ,, (y , τ2) ,, (x , τ1)) z
      swap = {!!}

  mutual
    data envfresh : Nat → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y -- todo: maybe?
                           → envfresh x (Subst d y σ)

    data fresh : Nat → dhexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇ d ⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  -- this is false
  --
  -- apart-fresh : ∀{ x Γ Δ d τ} →
  --               x # Γ →
  --               Δ , Γ ⊢ d :: τ →
  --               fresh x d
  -- apart-fresh aprt TAConst = FConst
  -- apart-fresh {x = x} aprt (TAVar {x = y} x₂) with natEQ x y
  -- apart-fresh aprt (TAVar x₃) | Inl refl = abort (somenotnone (! x₃ · aprt))
  -- apart-fresh aprt (TAVar x₃) | Inr x₂ = FVar x₂
  -- apart-fresh {x = x} aprt (TALam {x = y} x₂ wt) with natEQ x y
  -- apart-fresh aprt (TALam x₃ wt) | Inl refl = {!!}
  -- apart-fresh aprt (TALam x₃ wt) | Inr x₂ = FLam x₂
  -- apart-fresh aprt (TAAp wt wt₁) = FAp (apart-fresh aprt wt) (apart-fresh aprt wt₁)
  -- apart-fresh aprt (TAEHole x₁ x₂) = FHole {!!}
  -- apart-fresh aprt (TANEHole x₁ wt x₂) = FNEHole {!!} (apart-fresh aprt wt)
  -- apart-fresh aprt (TACast wt x₁) = FCast (apart-fresh aprt wt)
  -- apart-fresh aprt (TAFailedCast wt x₁ x₂ x₃) = FFailedCast (apart-fresh aprt wt)

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     x # Γ → -- todo should this be envfresh x σ
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ = {!!}
    -- weaken-subst-Γ {x = x} {Γ = Γ} {τ = τ1} apt (STAId x₁) = STAId (λ y τ2 x₂ → x∈∪l Γ (■ (x , τ1)) _ _ (x₁ y τ2 x₂))
    -- weaken-subst-Γ {x = x} {Γ = Γ} {τ = τ1} apt (STASubst {y = y} {τ = τ2} s x₁) with natEQ x y
    -- weaken-subst-Γ {x = x} {Γ = Γ} {τ = τ1} apt (STASubst {τ = τ2} s x₂) | Inl refl = STASubst {!!} (weaken-ta apt x₂)
    -- weaken-subst-Γ apt (STASubst s x₂) | Inr x₁ = STASubst {!!} (weaken-ta apt x₂)
    -- = STASubst {!!} (weaken-ta apt x₁)

      -- STASubst (weaken-subst-Γ {x = y} {Γ = Γ ,, (x , τ1)} {τ = τ2} {!!} {!!}) (weaken-ta apt x₁)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →
                -- x # Γ ?
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta {x} {Γ} {_} {_} {τ} {τ'} (FVar x₂) (TAVar x₃) = TAVar (x∈∪l Γ (■ (x , τ')) _ _ x₃)
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-parts Γ _ _ x₄ (apart-singleton (flip x₁))) (weaken-ta {Γ = {!■ (y , ? )!} ∪ Γ} x₃ wt)
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = TAAp (weaken-ta frsh wt) (weaken-ta frsh₁ wt₁)
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = TAEHole x₂ (weaken-subst-Γ {!!} x₃)
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = TANEHole x₂ (weaken-ta frsh wt) (weaken-subst-Γ {!!} x₃)
    weaken-ta (FCast frsh) (TACast wt x₁) = TACast (weaken-ta frsh wt) x₁
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = TAFailedCast (weaken-ta frsh wt) x₁ x₂ x₃

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

  -- with lem-union-none {Γ = Γ} x₂ | lem-subst apt wt1 {!!}
  -- ... | l , r | ih = TALam r {!ih!}

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import structural

module lemmas-subst-ta where
  lem-subst-σ : ∀{Δ x Γ τ1 σ Γ' d } →
                  Δ , Γ ,, (x , τ1) ⊢ σ :s: Γ' →
                  Δ , Γ ⊢ d :: τ1 →
                  Δ , Γ ⊢ Subst d x σ :s: Γ'
  lem-subst-σ s wt = STASubst s wt

  exchange-subst-Γ : ∀{Δ Γ x y τ1 τ2 σ Γ'} →
                   Δ , (Γ ,, (x , τ1) ,, (y , τ2)) ⊢ σ :s: Γ' →
                   Δ , (Γ ,, (y , τ2) ,, (x , τ1)) ⊢ σ :s: Γ'
  exchange-subst-Γ {Δ} {Γ} {x} {y} {τ1} {τ2} {σ} {Γ'} xy = tr (λ qq → Δ , qq ⊢ σ :s: Γ') {!!} xy -- todo: i'm worried this may actually be false without knowing that x ≠ y

  mutual
    data envfresh : Nat → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y -- todo: maybe?
                           → envfresh x (Subst d y σ)

    data fresh : Nat → dhexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇ d ⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)

  -- this is false
  --
  -- apart-fresh : ∀{ x Γ Δ d τ} →
  --               x # Γ →
  --               Δ , Γ ⊢ d :: τ →
  --               fresh x d
  -- apart-fresh aprt TAConst = FConst
  -- apart-fresh {x = x} aprt (TAVar {x = y} x₂) with natEQ x y
  -- apart-fresh aprt (TAVar x₃) | Inl refl = abort (somenotnone (! x₃ · aprt))
  -- apart-fresh aprt (TAVar x₃) | Inr x₂ = FVar x₂
  -- apart-fresh {x = x} aprt (TALam {x = y} x₂ wt) with natEQ x y
  -- apart-fresh aprt (TALam x₃ wt) | Inl refl = {!!}
  -- apart-fresh aprt (TALam x₃ wt) | Inr x₂ = FLam x₂
  -- apart-fresh aprt (TAAp wt wt₁) = FAp (apart-fresh aprt wt) (apart-fresh aprt wt₁)
  -- apart-fresh aprt (TAEHole x₁ x₂) = FHole {!!}
  -- apart-fresh aprt (TANEHole x₁ wt x₂) = FNEHole {!!} (apart-fresh aprt wt)
  -- apart-fresh aprt (TACast wt x₁) = FCast (apart-fresh aprt wt)
  -- apart-fresh aprt (TAFailedCast wt x₁ x₂ x₃) = FFailedCast (apart-fresh aprt wt)

  mutual
    weaken-subst-Γ : ∀{ x Γ Δ σ Γ' τ} →
                     x # Γ →
                     Δ , Γ ⊢ σ :s: Γ' →
                     Δ , (Γ ,, (x , τ)) ⊢ σ :s: Γ'
    weaken-subst-Γ = {!!}
    -- weaken-subst-Γ {x = x} {Γ = Γ} {τ = τ1} apt (STAId x₁) = STAId (λ y τ2 x₂ → x∈∪l Γ (■ (x , τ1)) _ _ (x₁ y τ2 x₂))
    -- weaken-subst-Γ {x = x} {Γ = Γ} {τ = τ1} apt (STASubst {y = y} {τ = τ2} s x₁) with natEQ x y
    -- weaken-subst-Γ {x = x} {Γ = Γ} {τ = τ1} apt (STASubst {τ = τ2} s x₂) | Inl refl = STASubst {!!} (weaken-ta apt x₂)
    -- weaken-subst-Γ apt (STASubst s x₂) | Inr x₁ = STASubst {!!} (weaken-ta apt x₂)
    -- = STASubst {!!} (weaken-ta apt x₁)

      -- STASubst (weaken-subst-Γ {x = y} {Γ = Γ ,, (x , τ1)} {τ = τ2} {!!} {!!}) (weaken-ta apt x₁)

    weaken-ta : ∀{x Γ Δ d τ τ'} →
                fresh x d →
                -- x # Γ ?
                Δ , Γ ⊢ d :: τ →
                Δ , Γ ,, (x , τ') ⊢ d :: τ
    weaken-ta _ TAConst = TAConst
    weaken-ta (FVar x₂) (TAVar x₃) = {!!}
    weaken-ta {x = x} frsh (TALam {x = y} x₂ wt) with natEQ x y
    weaken-ta (FLam x₁ x₂) (TALam x₃ wt) | Inl refl = abort (x₁ refl)
    weaken-ta {Γ = Γ} {τ' = τ'} (FLam x₁ x₃) (TALam {x = y} x₄ wt) | Inr x₂ = TALam (apart-parts Γ _ _ x₄ (apart-singleton (flip x₁))) (weaken-ta {Γ = {!■ (y , )!} ∪ Γ} x₃ {!!})
    weaken-ta (FAp frsh frsh₁) (TAAp wt wt₁) = {!!}
    weaken-ta (FHole x₁) (TAEHole x₂ x₃) = {!!}
    weaken-ta (FNEHole x₁ frsh) (TANEHole x₂ wt x₃) = {!!}
    weaken-ta (FCast frsh) (TACast wt x₁) = {!!}
    weaken-ta (FFailedCast frsh) (TAFailedCast wt x₁ x₂ x₃) = {!!}

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

  -- with lem-union-none {Γ = Γ} x₂ | lem-subst apt wt1 {!!}
  -- ... | l , r | ih = TALam r {!ih!}