Comment on validity definition

Comment on validity definition

module Thesis.BigStep where

open import Thesis.Syntax hiding (suc)
open import Thesis.Lang hiding (⟦_⟧Context; ⟦_⟧Var; suc)

open import Relation.Binary.PropositionalEquality

-- open import Base.Syntax.Context Type public
-- open import Base.Syntax.Vars Type public

-- data Const : (τ : Type) → Set where
--   lit : ℤ → Const int
--   -- succ : Const (int ⇒ int)

-- data Term (Γ : Context) :
--   (τ : Type) → Set where
--   -- constants aka. primitives
--   const : ∀ {τ} →
--     (c : Const τ) →
--     Term Γ τ
--   var : ∀ {τ} →
--     (x : Var Γ τ) →
--     Term Γ τ
--   app : ∀ {σ τ}
--     (s : Term Γ (σ ⇒ τ)) →
--     (t : Term Γ σ) →
--     Term Γ τ
--   -- we use de Bruijn indices, so we don't need binding occurrences.
--   abs : ∀ {σ τ}
--     (t : Term (σ • Γ) τ) →
--     Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public
open import Data.Nat.Base using (ℕ; zero; suc)

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℤ) → Val int
  -- prim : ∀ {σ τ} → (f : Val σ → Val τ) → Val (σ ⇒ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⇒ τ ⟧Type) → Val (σ ⇒ τ)
  pairV : ∀ {σ τ} → Val σ → Val τ → Val (pair σ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⟧Type → Val τ) → Val (σ ⇒ τ)

-- TODO: add defunctionalized interpretations for primitives. Yes, annoying but mechanical.

-- Doesn't work
-- data Val2 : ℕ → Type → Set where
--   prim : ∀ {σ τ n} → (f : Val2 n σ → Val2 n τ) → Val2 (ℕ.suc n) (σ ⇒ τ)

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ intV n ⟧Val = n
-- ⟦ prim f ⟧Val = λ v → ⟦ f v ⟧Val
⟦ pairV a b ⟧Val = (⟦ a ⟧Val , ⟦ b ⟧Val)
-- ⟦ true ⟧Val = true
-- ⟦ false ⟧Val = false

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)
evalConst c n = {!!}

-- evalConst plus n = Done (prim (λ a → prim (λ b → intV (a + b))))
-- evalConst minus n = Done (prim (λ a → prim (λ b → intV (a - b))))
-- evalConst cons n = Done (prim (λ a → prim (λ b → {!pairV !})))
-- evalConst fst n = {!!}
-- evalConst snd n = {!!}
-- evalConst linj n = {!!}
-- evalConst rinj n = {!!}
-- evalConst match n = {!!}
-- evalConst zero = intV (+ 0)
-- evalConst succ = {!!}

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n
-- apply (prim f) a n = Done (f ⟦ a ⟧Val)

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut
-- eval t0 ρ (suc n) with t0
-- ... | const c = evalConst c n
-- ... | var x = Done (⟦ x ⟧Var ρ)
-- ... | abs t = Done (closure t ρ)
-- ... | app s t with eval s ρ n | eval t ρ n
-- ... | Done f | Done a = apply f a n
-- ... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool!
eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
  eval t ρ n ≡ Done v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
  ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
  apply f a n ≡ Done v →
  ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

eval-sound ρ v zero t ()
eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
  let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}

-- Next, we can try defining change structures and validity.

dapply : ∀ {σ τ} → Val (Δt (σ ⇒ τ)) → Val σ → Val (Δt σ) → Res (Δt τ)
dapply df a1 da zero = TimeOut
dapply df a1 da (suc zero) = TimeOut
dapply df a1 da (suc (suc n)) with apply df a1 n
... | Done dfa = apply dfa da (suc n)
... | TimeOut = TimeOut

-- apply (closure (abs (derive t)) dρ) a1 (suc (suc n))
-- eval (derive (abs t)) dρ (suc n) ≡
-- dapply-sound-0
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) n

dapply' : ∀ {σ τ} → ErrVal (Δt (σ ⇒ τ)) → ErrVal σ → ErrVal (Δt σ) → Res (Δt τ)
dapply' (Done df) (Done v) (Done dv) n = dapply df v dv n
dapply' _ _ _ _ = TimeOut

-- Which step-indexes should we use in dapply's specification and
-- implementation? That's highly non-obvious. To come up with them, I had to
-- step through the evaluation of eval (app (app ds t) dt), and verify that I
-- never invoke eval or apply on the same inputs at different step-indexes.
--
-- However, I expect I wouldn't be able to get a working proof if I got the
-- indexes wrong.
dapply-sound : ∀ {Γ σ τ} n ρ (ds : Term Γ (Δt (σ ⇒ τ))) t dt →
    eval (app (app ds t) dt) ρ (suc (suc n))
  ≡
    dapply' (eval ds ρ n) (eval t ρ n) (eval dt ρ (suc n)) (suc (suc n))
dapply-sound zero ρ ds t dt = refl
dapply-sound (suc n) ρ ds t dt with
  eval ds ρ (suc n) | eval t ρ (suc n) | eval dt ρ (suc (suc n))
dapply-sound (suc n) ρ ds t dt | Done df | Done v | Done dv with apply df v (suc n)
... | Done dfv = refl
... | TimeOut  = refl
dapply-sound (suc n) ρ ds t dt | Done df | Done v | TimeOut with apply df v (suc n)
... | Done dfv = refl
... | TimeOut = refl
dapply-sound (suc n) ρ ds t dt | Done df | TimeOut | dv = refl
dapply-sound (suc n) ρ ds t dt | TimeOut | v | dv = refl

open import Data.Empty
open import Data.Unit

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
deriveConst = {!!}

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (ΔΓ Γ) (Δt τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

-- open import Thesis.Derive
Chτ : Type → Set
Chτ τ = Val (Δt τ)

deval : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → Res (Δt τ)
deval t ρ dρ = eval (derive t) dρ

dapply-equiv : ∀ {Γ σ τ} n
  (t : Term (σ • Γ) τ)
  (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 : Val σ) →
  dapply (closure (abs (derive t)) dρ) a1 da (suc (suc (suc n))) ≡
  eval (derive t) (da • a1 • dρ) (suc (suc n))
dapply-equiv n t dρ ρ1 da a1 = refl

-- Target statement:

_[_]τ_from_to_ : (n : ℕ) → ∀ τ → Val (Δt τ) → Val τ → Val τ → Set
_[_]τ'_from_to_ : (n : ℕ) → ∀ τ → ErrVal (Δt τ) → ErrVal τ → ErrVal τ → Set
n [ τ ]τ' Done dv from Done v1 to Done v2 = n [ τ ]τ dv from v1 to v2
n [ τ ]τ' TimeOut from Done v1 to Done v2 = ⊥
n [ τ ]τ' dv from _ to _ = ⊤

_[_]τ'_fromToTimeOut : ∀ n τ edv → n [ τ ]τ' edv from TimeOut to TimeOut ≡ ⊤
n [ τ ]τ' Done v fromToTimeOut = refl
n [ τ ]τ' TimeOut fromToTimeOut = refl
-- n [ τ ]τ' dv from Done v1 to TimeOut = ⊤
-- n [ τ ]τ' dv from TimeOut to Done v2 = ⊤
-- n [ τ ]τ' dv from TimeOut to TimeOut = ⊤

-- In the static-caching paper, the specification we use is similar to this one:
-- n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
--    Σ[ dv ∈ Val (Δt τ) ]
--        dapply df a1 da n ≡ Done dv
--      × n [ τ ]τ dv from v1 to v2
-- I defined _[_]τ'_from_to_ to be able to write an equivalent (hopefully) specification more quickly.

zero [ τ ]τ dv from v1 to v2 = ⊤
-- suc n [ σ ⇒ τ ]τ df from f1 to f2 =
--   ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    n [ τ ]τ' dapply df a1 da n from apply f1 a1 n to apply f2 a2 n

suc n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
   n [ σ ]τ da from a1 to a2 →

-- This definition violates all tips from Pitts tutorial (Step-Indexed
-- Biorthogonality: a Tutorial Example). Compare with Definition 4.1,
-- equation (10), and remark 4.4.
--
-- For extra complication, the setting is rather different, so a direct
-- comparison doesn't quite work.
   ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
   Σ[ dv ∈ Val (Δt τ) ]
       dapply df a1 da (suc (suc n)) ≡ Done dv
     × n [ τ ]τ dv from v1 to v2

suc n [ int ]τ intV dn from intV n1 to intV n2 = n1 + dn ≡ n2
suc n [ pair σ τ ]τ pairV da db from pairV a1 b1 to pairV a2 b2 =
  suc n [ σ ]τ da from a1 to a2 × suc n [ τ ]τ db from b1 to b2
suc n [ sum σ τ ]τ () from v1 to v2

data _[_]Γ_from_to_ : ∀ ℕ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : ∀ {n} → n [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {n τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : n [ τ ]τ dv from v1 to v2) →
    (dρρ : n [ Γ ]Γ dρ from ρ1 to ρ2) →
    n [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

fromtoDeriveVar : ∀ {Γ} τ n → (x : Var Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ (⟦ deriveVar x ⟧Var dρ) from ⟦ x ⟧Var ρ1 to ⟦ x ⟧Var ρ2
fromtoDeriveVar τ n this (dv • .(v1 • _)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = dvv
fromtoDeriveVar τ n (that x) (dv • (.v1 • dρ)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = fromtoDeriveVar τ n x dρ ρ1 ρ2 dρρ

fromtoDerive : ∀ {Γ} τ n → (t : Term Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ' (deval t ρ1 dρ n) from eval t ρ1 n to eval t ρ2 n
fromtoDerive τ zero t dρ ρ1 ρ2 dρρ rewrite zero [ τ ]τ' (deval t ρ1 dρ (suc zero)) fromToTimeOut = tt
fromtoDerive τ (suc n) (const c) dρ ρ1 ρ2 dρρ = {!!}
fromtoDerive τ (suc n) (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar τ (suc n) x dρ ρ1 ρ2 dρρ
fromtoDerive τ (suc n) (app s t) dρ ρ1 ρ2 dρρ = {!!}
-- fromtoDerive (σ ⇒ τ) (suc n) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   rewrite dapply-equiv n t dρ ρ1 da a1 =
--   fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ)

fromtoDerive (σ ⇒ τ) (suc zero) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 () eqv2
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 = {!fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) ?!}

-- fromtoDerive (σ ⇒ τ) (suc (suc zero)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa = {!!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   with eval (abs (derive t)) (a1 • dρ) n | inspect (eval (abs (derive t)) (a1 • dρ)) n
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | Done v | [ eq ] = {!fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) _!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | TimeOut | _ = {!!}
-- --   fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• ?)
-- -- fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}
--   -- fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}

module Thesis.BigStep where

open import Thesis.Syntax hiding (suc)
open import Thesis.Lang hiding (⟦_⟧Context; ⟦_⟧Var; suc)

open import Relation.Binary.PropositionalEquality

-- open import Base.Syntax.Context Type public
-- open import Base.Syntax.Vars Type public

-- data Const : (τ : Type) → Set where
--   lit : ℤ → Const int
--   -- succ : Const (int ⇒ int)

-- data Term (Γ : Context) :
--   (τ : Type) → Set where
--   -- constants aka. primitives
--   const : ∀ {τ} →
--     (c : Const τ) →
--     Term Γ τ
--   var : ∀ {τ} →
--     (x : Var Γ τ) →
--     Term Γ τ
--   app : ∀ {σ τ}
--     (s : Term Γ (σ ⇒ τ)) →
--     (t : Term Γ σ) →
--     Term Γ τ
--   -- we use de Bruijn indices, so we don't need binding occurrences.
--   abs : ∀ {σ τ}
--     (t : Term (σ • Γ) τ) →
--     Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public
open import Data.Nat.Base using (ℕ; zero; suc)

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℤ) → Val int
  -- prim : ∀ {σ τ} → (f : Val σ → Val τ) → Val (σ ⇒ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⇒ τ ⟧Type) → Val (σ ⇒ τ)
  pairV : ∀ {σ τ} → Val σ → Val τ → Val (pair σ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⟧Type → Val τ) → Val (σ ⇒ τ)

-- TODO: add defunctionalized interpretations for primitives. Yes, annoying but mechanical.

-- Doesn't work
-- data Val2 : ℕ → Type → Set where
--   prim : ∀ {σ τ n} → (f : Val2 n σ → Val2 n τ) → Val2 (ℕ.suc n) (σ ⇒ τ)

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ intV n ⟧Val = n
-- ⟦ prim f ⟧Val = λ v → ⟦ f v ⟧Val
⟦ pairV a b ⟧Val = (⟦ a ⟧Val , ⟦ b ⟧Val)
-- ⟦ true ⟧Val = true
-- ⟦ false ⟧Val = false

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)
evalConst c n = {!!}

-- evalConst plus n = Done (prim (λ a → prim (λ b → intV (a + b))))
-- evalConst minus n = Done (prim (λ a → prim (λ b → intV (a - b))))
-- evalConst cons n = Done (prim (λ a → prim (λ b → {!pairV !})))
-- evalConst fst n = {!!}
-- evalConst snd n = {!!}
-- evalConst linj n = {!!}
-- evalConst rinj n = {!!}
-- evalConst match n = {!!}
-- evalConst zero = intV (+ 0)
-- evalConst succ = {!!}

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n
-- apply (prim f) a n = Done (f ⟦ a ⟧Val)

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut
-- eval t0 ρ (suc n) with t0
-- ... | const c = evalConst c n
-- ... | var x = Done (⟦ x ⟧Var ρ)
-- ... | abs t = Done (closure t ρ)
-- ... | app s t with eval s ρ n | eval t ρ n
-- ... | Done f | Done a = apply f a n
-- ... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool!
eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
  eval t ρ n ≡ Done v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
  ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
  apply f a n ≡ Done v →
  ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

eval-sound ρ v zero t ()
eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
  let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}

-- Next, we can try defining change structures and validity.

dapply : ∀ {σ τ} → Val (Δt (σ ⇒ τ)) → Val σ → Val (Δt σ) → Res (Δt τ)
dapply df a1 da zero = TimeOut
dapply df a1 da (suc zero) = TimeOut
dapply df a1 da (suc (suc n)) with apply df a1 n
... | Done dfa = apply dfa da (suc n)
... | TimeOut = TimeOut

-- apply (closure (abs (derive t)) dρ) a1 (suc (suc n))
-- eval (derive (abs t)) dρ (suc n) ≡
-- dapply-sound-0
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) n

dapply' : ∀ {σ τ} → ErrVal (Δt (σ ⇒ τ)) → ErrVal σ → ErrVal (Δt σ) → Res (Δt τ)
dapply' (Done df) (Done v) (Done dv) n = dapply df v dv n
dapply' _ _ _ _ = TimeOut

-- Which step-indexes should we use in dapply's specification and
-- implementation? That's highly non-obvious. To come up with them, I had to
-- step through the evaluation of eval (app (app ds t) dt), and verify that I
-- never invoke eval or apply on the same inputs at different step-indexes.
--
-- However, I expect I wouldn't be able to get a working proof if I got the
-- indexes wrong.
dapply-sound : ∀ {Γ σ τ} n ρ (ds : Term Γ (Δt (σ ⇒ τ))) t dt →
    eval (app (app ds t) dt) ρ (suc (suc n))
  ≡
    dapply' (eval ds ρ n) (eval t ρ n) (eval dt ρ (suc n)) (suc (suc n))
dapply-sound zero ρ ds t dt = refl
dapply-sound (suc n) ρ ds t dt with
  eval ds ρ (suc n) | eval t ρ (suc n) | eval dt ρ (suc (suc n))
dapply-sound (suc n) ρ ds t dt | Done df | Done v | Done dv with apply df v (suc n)
... | Done dfv = refl
... | TimeOut  = refl
dapply-sound (suc n) ρ ds t dt | Done df | Done v | TimeOut with apply df v (suc n)
... | Done dfv = refl
... | TimeOut = refl
dapply-sound (suc n) ρ ds t dt | Done df | TimeOut | dv = refl
dapply-sound (suc n) ρ ds t dt | TimeOut | v | dv = refl

open import Data.Empty
open import Data.Unit

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
deriveConst = {!!}

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (ΔΓ Γ) (Δt τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

-- open import Thesis.Derive
Chτ : Type → Set
Chτ τ = Val (Δt τ)

deval : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → Res (Δt τ)
deval t ρ dρ = eval (derive t) dρ

dapply-equiv : ∀ {Γ σ τ} n
  (t : Term (σ • Γ) τ)
  (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 : Val σ) →
  dapply (closure (abs (derive t)) dρ) a1 da (suc (suc (suc n))) ≡
  eval (derive t) (da • a1 • dρ) (suc (suc n))
dapply-equiv n t dρ ρ1 da a1 = refl

-- Target statement:

_[_]τ_from_to_ : (n : ℕ) → ∀ τ → Val (Δt τ) → Val τ → Val τ → Set
_[_]τ'_from_to_ : (n : ℕ) → ∀ τ → ErrVal (Δt τ) → ErrVal τ → ErrVal τ → Set
n [ τ ]τ' Done dv from Done v1 to Done v2 = n [ τ ]τ dv from v1 to v2
n [ τ ]τ' TimeOut from Done v1 to Done v2 = ⊥
n [ τ ]τ' dv from _ to _ = ⊤

_[_]τ'_fromToTimeOut : ∀ n τ edv → n [ τ ]τ' edv from TimeOut to TimeOut ≡ ⊤
n [ τ ]τ' Done v fromToTimeOut = refl
n [ τ ]τ' TimeOut fromToTimeOut = refl
-- n [ τ ]τ' dv from Done v1 to TimeOut = ⊤
-- n [ τ ]τ' dv from TimeOut to Done v2 = ⊤
-- n [ τ ]τ' dv from TimeOut to TimeOut = ⊤

-- In the static-caching paper, the specification we use is similar to this one:
-- n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
--    Σ[ dv ∈ Val (Δt τ) ]
--        dapply df a1 da n ≡ Done dv
--      × n [ τ ]τ dv from v1 to v2
-- I defined _[_]τ'_from_to_ to be able to write an equivalent (hopefully) specification more quickly.

zero [ τ ]τ dv from v1 to v2 = ⊤
-- suc n [ σ ⇒ τ ]τ df from f1 to f2 =
--   ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    n [ τ ]τ' dapply df a1 da n from apply f1 a1 n to apply f2 a2 n

suc n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
   n [ σ ]τ da from a1 to a2 →
   ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
   Σ[ dv ∈ Val (Δt τ) ]
       dapply df a1 da (suc (suc n)) ≡ Done dv
     × n [ τ ]τ dv from v1 to v2

suc n [ int ]τ intV dn from intV n1 to intV n2 = n1 + dn ≡ n2
suc n [ pair σ τ ]τ pairV da db from pairV a1 b1 to pairV a2 b2 =
  suc n [ σ ]τ da from a1 to a2 × suc n [ τ ]τ db from b1 to b2
suc n [ sum σ τ ]τ () from v1 to v2

data _[_]Γ_from_to_ : ∀ ℕ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : ∀ {n} → n [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {n τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : n [ τ ]τ dv from v1 to v2) →
    (dρρ : n [ Γ ]Γ dρ from ρ1 to ρ2) →
    n [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

fromtoDeriveVar : ∀ {Γ} τ n → (x : Var Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ (⟦ deriveVar x ⟧Var dρ) from ⟦ x ⟧Var ρ1 to ⟦ x ⟧Var ρ2
fromtoDeriveVar τ n this (dv • .(v1 • _)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = dvv
fromtoDeriveVar τ n (that x) (dv • (.v1 • dρ)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = fromtoDeriveVar τ n x dρ ρ1 ρ2 dρρ

fromtoDerive : ∀ {Γ} τ n → (t : Term Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ' (deval t ρ1 dρ n) from eval t ρ1 n to eval t ρ2 n
fromtoDerive τ zero t dρ ρ1 ρ2 dρρ rewrite zero [ τ ]τ' (deval t ρ1 dρ (suc zero)) fromToTimeOut = tt
fromtoDerive τ (suc n) (const c) dρ ρ1 ρ2 dρρ = {!!}
fromtoDerive τ (suc n) (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar τ (suc n) x dρ ρ1 ρ2 dρρ
fromtoDerive τ (suc n) (app s t) dρ ρ1 ρ2 dρρ = {!!}
-- fromtoDerive (σ ⇒ τ) (suc n) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   rewrite dapply-equiv n t dρ ρ1 da a1 =
--   fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ)

fromtoDerive (σ ⇒ τ) (suc zero) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 () eqv2
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 = {!fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) ?!}

-- fromtoDerive (σ ⇒ τ) (suc (suc zero)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa = {!!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   with eval (abs (derive t)) (a1 • dρ) n | inspect (eval (abs (derive t)) (a1 • dρ)) n
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | Done v | [ eq ] = {!fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) _!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | TimeOut | _ = {!!}
-- --   fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• ?)
-- -- fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}
--   -- fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}


Implement change composition directly for unit

Would like to avoid the generic implementation.

module Thesis.Changes where

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

record IsChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  infixl 6 _⊕_ _⊝_
  field
    _⊕_ : A → ChA → A
    fromto→⊕ : ∀ dv v1 v2 →
      ch dv from v1 to v2 →
      v1 ⊕ dv ≡ v2
    _⊝_ : A → A → ChA
    ⊝-fromto : ∀ (a b : A) → ch (b ⊝ a) from a to b

  update-diff : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  update-diff b a = fromto→⊕ (b ⊝ a) a b (⊝-fromto a b)
  nil : A → ChA
  nil a = a ⊝ a
  nil-fromto : (a : A) → ch (nil a) from a to a
  nil-fromto a = ⊝-fromto a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  valid : ∀ (a : A) (da : ChA) → Set
  valid a da = ch da from a to (a ⊕ da)
  Δ : (a : A) → Set
  Δ a = Σ[ da ∈ ChA ] valid a da
  Δ₂ : (a1 : A) (a2 : A) → Set
  Δ₂ a1 a2 = Σ[ da ∈ ChA ] ch da from a1 to a2

  _⊕'_ : (a1 : A) -> {a2 : A} -> (da : Δ₂ a1 a2) -> A
  a1 ⊕' (da , daa) = a1 ⊕ da

record IsCompChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  field
    isChangeStructure : IsChangeStructure A ChA ch_from_to_
    _⊚[_]_ : ChA → A → ChA → ChA
    ⊚-fromto : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
      ch da1 from a1 to a2 → ch da2 from a2 to a3 → ch da1 ⊚[ a1 ] da2 from a1 to a3

  open IsChangeStructure isChangeStructure public
  ⊚-correct : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
    ch da1 from a1 to a2 → ch da2 from a2 to a3 →
    a1 ⊕ (da1 ⊚[ a1 ] da2) ≡ a3
  ⊚-correct a1 a2 a3 da1 da2 daa1 daa2 = fromto→⊕ _ _ _ (⊚-fromto _ _ _ da1 da2 daa1 daa2)

IsChangeStructure→IsCompChangeStructure : ∀ {A ChA ch_from_to_} → IsChangeStructure A ChA ch_from_to_ → IsCompChangeStructure A ChA ch_from_to_
IsChangeStructure→IsCompChangeStructure {A} {ChA} {ch_from_to_} isCS = record
  { isChangeStructure = isCS
  ; _⊚[_]_ = λ da1 a da2 → a ⊕ da1 ⊕ da2 ⊝ a
  ; ⊚-fromto = body
  }
  where
    _⊕_ = IsChangeStructure._⊕_ isCS
    _⊝_ = IsChangeStructure._⊝_ isCS
    fromto→⊕ = IsChangeStructure.fromto→⊕ isCS
    ⊝-fromto = IsChangeStructure.⊝-fromto isCS
    infixl 6 _⊕_ _⊝_
    body : ∀ (a1 a2 a3 : A) da1 da2 →
      ch da1 from a1 to a2 →
      ch da2 from a2 to a3 → ch a1 ⊕ da1 ⊕ da2 ⊝ a1 from a1 to a3
    body a1 a2 a3 da1 da2 daa1 daa2 rewrite fromto→⊕ _ _ _ daa1 | fromto→⊕ _ _ _ daa2 =
      ⊝-fromto a1 a3

record ChangeStructure (A : Set) : Set₁ where
  field
    Ch : Set
    ch_from_to_ : (dv : Ch) → (v1 v2 : A) → Set
    isCompChangeStructure : IsCompChangeStructure A Ch ch_from_to_
  open IsCompChangeStructure isCompChangeStructure public

open ChangeStructure {{...}} public hiding (Ch)
Ch : ∀ (A : Set) → {{CA : ChangeStructure A}} → Set
Ch A {{CA}} = ChangeStructure.Ch CA

{-# DISPLAY IsChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY ChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY ChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY IsChangeStructure.nil x = nil #-}
{-# DISPLAY ChangeStructure.nil x = nil #-}
{-# DISPLAY IsCompChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure.ch_from_to_ x = ch_from_to_ #-}

module _ {A B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  -- In this module, given change structures CA and CB for A and B, we define
  -- change structures for A → B, A × B and A ⊎ B.

  open import Postulate.Extensionality

  -- Functions
  instance
    funCS : ChangeStructure (A → B)

  infixl 6 _f⊕_ _f⊝_
  private
    fCh = A → Ch A → Ch B

    fCh_from_to_ : (df : fCh) → (f1 f2 : A → B) → Set
    fCh_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2

    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)

    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

    f⊝-fromto : ∀ (f1 f2 : A → B) → fCh (f2 f⊝ f1) from f1 to f2
    f⊝-fromto f1 f2 da a1 a2 daa
      rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))

    _f⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f⊚[_]_ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)

    _f2⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f2⊚[_]_ df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))

    f⊚-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f⊚[ f1 ] df2 from f1 to f3
    f⊚-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a1) (f3 a2)
        (df1 a1 (nil a1))
        (df2 a1 da)
        (dff1 (nil a1) a1 a1 (nil-fromto a1))
        (dff2 da a1 a2 daa)

    f⊚2-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f2⊚[ f1 ] df2 from f1 to f3
    f⊚2-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa rewrite fromto→⊕ da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a2) (f3 a2)
        (df1 a1 da)
        (df2 a2 (nil a2))
        (dff1 da a1 a2 daa)
        (dff2 (nil a2) a2 a2 (nil-fromto a2))

  funCS = record
    { Ch = fCh
    ; ch_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _f⊕_
        ; fromto→⊕ = λ df f1 f2 dff →
          ext (λ v →
            fromto→⊕ (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
        ; _⊝_ = _f⊝_
        ; ⊝-fromto = f⊝-fromto
        }
      ; _⊚[_]_ = _f⊚[_]_
      ; ⊚-fromto = f⊚-fromto
      }
    }

  -- Products
  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pch_from_to_ : pCh → A × B → A × B → Set
    pch (da , db) from (a1 , b1) to (a2 , b2) = ch da from a1 to a2 × ch db from b1 to b2
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    pfromto→⊕ : ∀ dp p1 p2 →
      pch dp from p1 to p2 → p1 p⊕ dp ≡ p2
    pfromto→⊕ (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
      cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
    p⊝-fromto : ∀ (p1 p2 : A × B) → pch p2 p⊝ p1 from p1 to p2
    p⊝-fromto (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
    p⊚-fromto : ∀ p1 p2 p3 dp1 dp2 →
      pch dp1 from p1 to p2 → (pch dp2 from p2 to p3) → pch dp1 p⊚[ p1 ] dp2 from p1 to p3
    p⊚-fromto (a1 , b1) (a2 , b2) (a3 , b3) (da1 , db1) (da2 , db2)
      (daa1 , dbb1) (daa2 , dbb2) =
        ⊚-fromto a1 a2 a3 da1 da2 daa1 daa2 , ⊚-fromto b1 b2 b3 db1 db2 dbb1 dbb2

  instance
    pairCS : ChangeStructure (A × B)
  pairCS = record
    { Ch = pCh
    ; ch_from_to_ = pch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _p⊕_
        ; fromto→⊕ = pfromto→⊕
        ; _⊝_ = _p⊝_
        ; ⊝-fromto = p⊝-fromto
        }
      ; _⊚[_]_ = _p⊚[_]_
      ; ⊚-fromto = p⊚-fromto
      }
    }

  -- Sums
  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    _s⊕2_ : A ⊎ B → SumChange2 → A ⊎ B
    _s⊕2_ (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    _s⊕2_ (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    _s⊕2_ (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    _s⊕2_ (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    _s⊕2_ s (rp s₁) = s₁

    _s⊕_ : A ⊎ B → SumChange → A ⊎ B
    s s⊕ ds = s s⊕2 (convert ds)

    _s⊝2_ : A ⊎ B → A ⊎ B → SumChange2
    _s⊝2_ (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    _s⊝2_ (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    _s⊝2_ s2 s1 = rp s2

    _s⊝_ : A ⊎ B → A ⊎ B → SumChange
    s2 s⊝ s1 = convert₁ (s2 s⊝2 s1)

  data sch_from_to_ : SumChange → A ⊎ B → A ⊎ B → Set where
    -- sft = Sum From To
    sft₁ : ∀ {da a1 a2} (daa : ch da from a1 to a2) → sch (convert₁ (ch₁ da)) from (inj₁ a1) to (inj₁ a2)
    sft₂ : ∀ {db b1 b2} (dbb : ch db from b1 to b2) → sch (convert₁ (ch₂ db)) from (inj₂ b1) to (inj₂ b2)
    sftrp₁ : ∀ a1 b2 → sch (convert₁ (rp (inj₂ b2))) from (inj₁ a1) to (inj₂ b2)
    sftrp₂ : ∀ b1 a2 → sch (convert₁ (rp (inj₁ a2))) from (inj₂ b1) to (inj₁ a2)

  sfromto→⊕2 : (ds : SumChange2) (s1 s2 : A ⊎ B) →
    sch convert₁ ds from s1 to s2 → s1 s⊕2 ds ≡ s2
  sfromto→⊕2 (ch₁ da) (inj₁ a1) (inj₁ a2) (sft₁ daa) = cong inj₁ (fromto→⊕ _ _ _ daa)
  sfromto→⊕2 (ch₂ db) (inj₂ b1) (inj₂ b2) (sft₂ dbb) = cong inj₂ (fromto→⊕ _ _ _ dbb)
  sfromto→⊕2 (rp .(inj₂ y)) (inj₁ x) (inj₂ y) (sftrp₁ .x .y) = refl
  sfromto→⊕2 (rp .(inj₁ x)) (inj₂ y) (inj₁ x) (sftrp₂ .y .x) = refl

  sfromto→⊕ : (ds : SumChange) (s1 s2 : A ⊎ B) →
    sch ds from s1 to s2 → s1 s⊕ ds ≡ s2
  sfromto→⊕ ds s1 s2 dss =
    sfromto→⊕2 (convert ds) s1 s2
      (subst (sch_from s1 to s2) (sym (inv1 ds))
        dss)
  s⊝-fromto : (s1 s2 : A ⊎ B) → sch s2 s⊝ s1 from s1 to s2
  s⊝-fromto (inj₁ a1) (inj₁ a2) = sft₁ (⊝-fromto a1 a2)
  s⊝-fromto (inj₁ a1) (inj₂ b2) = sftrp₁ a1 b2
  s⊝-fromto (inj₂ b1) (inj₁ a2) = sftrp₂ b1 a2
  s⊝-fromto (inj₂ b1) (inj₂ b2) = sft₂ (⊝-fromto b1 b2)
  instance
    sumCS : ChangeStructure (A ⊎ B)
  sumCS = record
    { Ch = SumChange
    ; ch_from_to_ = sch_from_to_
    ; isCompChangeStructure = IsChangeStructure→IsCompChangeStructure (record
      { _⊕_ = _s⊕_
      ; fromto→⊕ = sfromto→⊕
      ; _⊝_ = _s⊝_
      ; ⊝-fromto = s⊝-fromto
      })
    }

instance
  unitCS : ChangeStructure ⊤

  unitCS = record
    { Ch = ⊤
    ; ch_from_to_ = λ dv v1 v2 → ⊤
    ; isCompChangeStructure = record
      { isChangeStructure = record
      { _⊕_ = λ _ _ → tt
      ; fromto→⊕ = λ { _ _ tt _ → refl }
      ; _⊝_ = λ _ _ → tt
      ; ⊝-fromto = λ a b → tt
      }
      ; _⊚[_]_ = λ da1 a da2 → tt
      ; ⊚-fromto = λ a1 a2 a3 da1 da2 daa1 daa2 → tt
      }
    }

module Thesis.Changes where

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

record IsChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  infixl 6 _⊕_ _⊝_
  field
    _⊕_ : A → ChA → A
    fromto→⊕ : ∀ dv v1 v2 →
      ch dv from v1 to v2 →
      v1 ⊕ dv ≡ v2
    _⊝_ : A → A → ChA
    ⊝-fromto : ∀ (a b : A) → ch (b ⊝ a) from a to b

  update-diff : (b a : A) → a ⊕ (b ⊝ a) ≡ b
  update-diff b a = fromto→⊕ (b ⊝ a) a b (⊝-fromto a b)
  nil : A → ChA
  nil a = a ⊝ a
  nil-fromto : (a : A) → ch (nil a) from a to a
  nil-fromto a = ⊝-fromto a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  valid : ∀ (a : A) (da : ChA) → Set
  valid a da = ch da from a to (a ⊕ da)
  Δ : (a : A) → Set
  Δ a = Σ[ da ∈ ChA ] valid a da
  Δ₂ : (a1 : A) (a2 : A) → Set
  Δ₂ a1 a2 = Σ[ da ∈ ChA ] ch da from a1 to a2

  _⊕'_ : (a1 : A) -> {a2 : A} -> (da : Δ₂ a1 a2) -> A
  a1 ⊕' (da , daa) = a1 ⊕ da

record IsCompChangeStructure (A : Set) (ChA : Set) (ch_from_to_ : (dv : ChA) → (v1 v2 : A) → Set) : Set₁ where
  field
    isChangeStructure : IsChangeStructure A ChA ch_from_to_
    _⊚[_]_ : ChA → A → ChA → ChA
    ⊚-fromto : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
      ch da1 from a1 to a2 → ch da2 from a2 to a3 → ch da1 ⊚[ a1 ] da2 from a1 to a3

  open IsChangeStructure isChangeStructure public
  ⊚-correct : ∀ (a1 a2 a3 : A) (da1 da2 : ChA) →
    ch da1 from a1 to a2 → ch da2 from a2 to a3 →
    a1 ⊕ (da1 ⊚[ a1 ] da2) ≡ a3
  ⊚-correct a1 a2 a3 da1 da2 daa1 daa2 = fromto→⊕ _ _ _ (⊚-fromto _ _ _ da1 da2 daa1 daa2)

IsChangeStructure→IsCompChangeStructure : ∀ {A ChA ch_from_to_} → IsChangeStructure A ChA ch_from_to_ → IsCompChangeStructure A ChA ch_from_to_
IsChangeStructure→IsCompChangeStructure {A} {ChA} {ch_from_to_} isCS = record
  { isChangeStructure = isCS
  ; _⊚[_]_ = λ da1 a da2 → a ⊕ da1 ⊕ da2 ⊝ a
  ; ⊚-fromto = body
  }
  where
    _⊕_ = IsChangeStructure._⊕_ isCS
    _⊝_ = IsChangeStructure._⊝_ isCS
    fromto→⊕ = IsChangeStructure.fromto→⊕ isCS
    ⊝-fromto = IsChangeStructure.⊝-fromto isCS
    infixl 6 _⊕_ _⊝_
    body : ∀ (a1 a2 a3 : A) da1 da2 →
      ch da1 from a1 to a2 →
      ch da2 from a2 to a3 → ch a1 ⊕ da1 ⊕ da2 ⊝ a1 from a1 to a3
    body a1 a2 a3 da1 da2 daa1 daa2 rewrite fromto→⊕ _ _ _ daa1 | fromto→⊕ _ _ _ daa2 =
      ⊝-fromto a1 a3

record ChangeStructure (A : Set) : Set₁ where
  field
    Ch : Set
    ch_from_to_ : (dv : Ch) → (v1 v2 : A) → Set
    isCompChangeStructure : IsCompChangeStructure A Ch ch_from_to_
  open IsCompChangeStructure isCompChangeStructure public

open ChangeStructure {{...}} public hiding (Ch)
Ch : ∀ (A : Set) → {{CA : ChangeStructure A}} → Set
Ch A {{CA}} = ChangeStructure.Ch CA

{-# DISPLAY IsChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY ChangeStructure._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY ChangeStructure._⊝_ x = _⊝_ #-}
{-# DISPLAY IsChangeStructure.nil x = nil #-}
{-# DISPLAY ChangeStructure.nil x = nil #-}
{-# DISPLAY IsCompChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure._⊚[_]_ x = _⊚[_]_ #-}
{-# DISPLAY ChangeStructure.ch_from_to_ x = ch_from_to_ #-}

module _ {A B : Set} {{CA : ChangeStructure A}} {{CB : ChangeStructure B}} where

  -- In this module, given change structures CA and CB for A and B, we define
  -- change structures for A → B, A × B and A ⊎ B.

  open import Postulate.Extensionality

  -- Functions
  instance
    funCS : ChangeStructure (A → B)

  infixl 6 _f⊕_ _f⊝_
  private
    fCh = A → Ch A → Ch B

    fCh_from_to_ : (df : fCh) → (f1 f2 : A → B) → Set
    fCh_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2

    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)

    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

    f⊝-fromto : ∀ (f1 f2 : A → B) → fCh (f2 f⊝ f1) from f1 to f2
    f⊝-fromto f1 f2 da a1 a2 daa
      rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))

    _f⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f⊚[_]_ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)

    _f2⊚[_]_ : fCh → (A → B) → fCh → fCh
    _f2⊚[_]_ df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))

    f⊚-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f⊚[ f1 ] df2 from f1 to f3
    f⊚-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a1) (f3 a2)
        (df1 a1 (nil a1))
        (df2 a1 da)
        (dff1 (nil a1) a1 a1 (nil-fromto a1))
        (dff2 da a1 a2 daa)

    f⊚2-fromto : ∀ (f1 f2 f3 : A → B) (df1 df2 : fCh) → fCh df1 from f1 to f2 → fCh df2 from f2 to f3 →
      fCh df1 f2⊚[ f1 ] df2 from f1 to f3
    f⊚2-fromto f1 f2 f3 df1 df2 dff1 dff2 da a1 a2 daa rewrite fromto→⊕ da a1 a2 daa =
      ⊚-fromto (f1 a1) (f2 a2) (f3 a2)
        (df1 a1 da)
        (df2 a2 (nil a2))
        (dff1 da a1 a2 daa)
        (dff2 (nil a2) a2 a2 (nil-fromto a2))

  funCS = record
    { Ch = fCh
    ; ch_from_to_ =
      λ df f1 f2 → ∀ da (a1 a2 : A) (daa : ch da from a1 to a2) →
        ch df a1 da from f1 a1 to f2 a2
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _f⊕_
        ; fromto→⊕ = λ df f1 f2 dff →
          ext (λ v →
            fromto→⊕ (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
        ; _⊝_ = _f⊝_
        ; ⊝-fromto = f⊝-fromto
        }
      ; _⊚[_]_ = _f⊚[_]_
      ; ⊚-fromto = f⊚-fromto
      }
    }

  -- Products
  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pch_from_to_ : pCh → A × B → A × B → Set
    pch (da , db) from (a1 , b1) to (a2 , b2) = ch da from a1 to a2 × ch db from b1 to b2
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    pfromto→⊕ : ∀ dp p1 p2 →
      pch dp from p1 to p2 → p1 p⊕ dp ≡ p2
    pfromto→⊕ (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
      cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
    p⊝-fromto : ∀ (p1 p2 : A × B) → pch p2 p⊝ p1 from p1 to p2
    p⊝-fromto (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
    p⊚-fromto : ∀ p1 p2 p3 dp1 dp2 →
      pch dp1 from p1 to p2 → (pch dp2 from p2 to p3) → pch dp1 p⊚[ p1 ] dp2 from p1 to p3
    p⊚-fromto (a1 , b1) (a2 , b2) (a3 , b3) (da1 , db1) (da2 , db2)
      (daa1 , dbb1) (daa2 , dbb2) =
        ⊚-fromto a1 a2 a3 da1 da2 daa1 daa2 , ⊚-fromto b1 b2 b3 db1 db2 dbb1 dbb2

  instance
    pairCS : ChangeStructure (A × B)
  pairCS = record
    { Ch = pCh
    ; ch_from_to_ = pch_from_to_
    ; isCompChangeStructure = record
      { isChangeStructure = record
        { _⊕_ = _p⊕_
        ; fromto→⊕ = pfromto→⊕
        ; _⊝_ = _p⊝_
        ; ⊝-fromto = p⊝-fromto
        }
      ; _⊚[_]_ = _p⊚[_]_
      ; ⊚-fromto = p⊚-fromto
      }
    }

  -- Sums
  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    _s⊕2_ : A ⊎ B → SumChange2 → A ⊎ B
    _s⊕2_ (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    _s⊕2_ (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    _s⊕2_ (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    _s⊕2_ (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    _s⊕2_ s (rp s₁) = s₁

    _s⊕_ : A ⊎ B → SumChange → A ⊎ B
    s s⊕ ds = s s⊕2 (convert ds)

    _s⊝2_ : A ⊎ B → A ⊎ B → SumChange2
    _s⊝2_ (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    _s⊝2_ (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    _s⊝2_ s2 s1 = rp s2

    _s⊝_ : A ⊎ B → A ⊎ B → SumChange
    s2 s⊝ s1 = convert₁ (s2 s⊝2 s1)

  data sch_from_to_ : SumChange → A ⊎ B → A ⊎ B → Set where
    -- sft = Sum From To
    sft₁ : ∀ {da a1 a2} (daa : ch da from a1 to a2) → sch (convert₁ (ch₁ da)) from (inj₁ a1) to (inj₁ a2)
    sft₂ : ∀ {db b1 b2} (dbb : ch db from b1 to b2) → sch (convert₁ (ch₂ db)) from (inj₂ b1) to (inj₂ b2)
    sftrp₁ : ∀ a1 b2 → sch (convert₁ (rp (inj₂ b2))) from (inj₁ a1) to (inj₂ b2)
    sftrp₂ : ∀ b1 a2 → sch (convert₁ (rp (inj₁ a2))) from (inj₂ b1) to (inj₁ a2)

  sfromto→⊕2 : (ds : SumChange2) (s1 s2 : A ⊎ B) →
    sch convert₁ ds from s1 to s2 → s1 s⊕2 ds ≡ s2
  sfromto→⊕2 (ch₁ da) (inj₁ a1) (inj₁ a2) (sft₁ daa) = cong inj₁ (fromto→⊕ _ _ _ daa)
  sfromto→⊕2 (ch₂ db) (inj₂ b1) (inj₂ b2) (sft₂ dbb) = cong inj₂ (fromto→⊕ _ _ _ dbb)
  sfromto→⊕2 (rp .(inj₂ y)) (inj₁ x) (inj₂ y) (sftrp₁ .x .y) = refl
  sfromto→⊕2 (rp .(inj₁ x)) (inj₂ y) (inj₁ x) (sftrp₂ .y .x) = refl

  sfromto→⊕ : (ds : SumChange) (s1 s2 : A ⊎ B) →
    sch ds from s1 to s2 → s1 s⊕ ds ≡ s2
  sfromto→⊕ ds s1 s2 dss =
    sfromto→⊕2 (convert ds) s1 s2
      (subst (sch_from s1 to s2) (sym (inv1 ds))
        dss)
  s⊝-fromto : (s1 s2 : A ⊎ B) → sch s2 s⊝ s1 from s1 to s2
  s⊝-fromto (inj₁ a1) (inj₁ a2) = sft₁ (⊝-fromto a1 a2)
  s⊝-fromto (inj₁ a1) (inj₂ b2) = sftrp₁ a1 b2
  s⊝-fromto (inj₂ b1) (inj₁ a2) = sftrp₂ b1 a2
  s⊝-fromto (inj₂ b1) (inj₂ b2) = sft₂ (⊝-fromto b1 b2)
  instance
    sumCS : ChangeStructure (A ⊎ B)
  sumCS = record
    { Ch = SumChange
    ; ch_from_to_ = sch_from_to_
    ; isCompChangeStructure = IsChangeStructure→IsCompChangeStructure (record
      { _⊕_ = _s⊕_
      ; fromto→⊕ = sfromto→⊕
      ; _⊝_ = _s⊝_
      ; ⊝-fromto = s⊝-fromto
      })
    }

instance
  unitCS : ChangeStructure ⊤

  unitCS = record
    { Ch = ⊤
    ; ch_from_to_ = λ dv v1 v2 → ⊤
    ; isCompChangeStructure = IsChangeStructure→IsCompChangeStructure (record
      { _⊕_ = λ _ _ → tt
      ; fromto→⊕ = λ { _ _ tt _ → refl }
      ; _⊝_ = λ _ _ → tt
      ; ⊝-fromto = λ a b → tt
      })
    }


Update derivation.agda

Update derivation.agda

typo

Old-commit-hash: 719b7f355a6ddb5cacf3f0d3a90f563748f921a0

module derivation where

open import lambda

-- KO: Is it correct that this file is supposed to contain the syntactic
-- variants of the operations in Syntactic.Changes.agda?
-- If so, why does it have a different (and rather strange) Δ-Type definition?
-- Why are the base cases (bool) all missing? The inductive cases look
-- boring since they don't actually do anything (which explains why compose and apply are the same)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂
Δ-Type bool = {!!}

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )
apply {bool} = {!!}

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app (compose {τ₂}) (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )
compose {bool} = {!!}

nil : ∀ {τ Γ} → Term Γ (Δ-Type τ)
nil {τ₁ ⇒ τ₂} =
    abs (nil {τ₂})
 -- λx. nil
nil {bool} = {!!}

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Δ-Context Γ

-- CHANGE VARIABLES

-- changes 'x' to 'dx'

rename : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
rename this = that this
rename (that x) = that (that (rename x))

-- Weakening of a term needed during derivation - change x to x in a context which also includes dx.
-- The actual specification is more complicated, study the type signature.
adaptVar : ∀ {τ} Γ₁ Γ₂ → Var (Γ₁ ⋎ Γ₂) τ → Var (Γ₁ ⋎ Δ-Context Γ₂) τ
adaptVar ∅ (τ₂ • Γ₂) this = this
adaptVar ∅ (τ₂ • Γ₂) (that x) = that (that (adaptVar ∅ Γ₂ x))
adaptVar (τ₁ • Γ₁) Γ₂ this = this
adaptVar (τ₁ • Γ₁) Γ₂ (that x) = that (adaptVar Γ₁ Γ₂ x)

adapt : ∀ {τ} Γ₁ Γ₂ → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) τ
adapt {τ₁ ⇒ τ₂} Γ₁ Γ₂ (abs t) = abs (adapt (τ₁ • Γ₁) Γ₂ t)
adapt Γ₁ Γ₂ (app t₁ t₂) = app (adapt Γ₁ Γ₂ t₁) (adapt Γ₁ Γ₂ t₂)
adapt Γ₁ Γ₂ (var t) = var (adaptVar Γ₁ Γ₂ t)
adapt Γ₁ Γ₂ true = true
adapt Γ₁ Γ₂ false = false
adapt Γ₁ Γ₂ (cond tc t₁ t₂) = cond (adapt Γ₁ Γ₂ tc) (adapt Γ₁ Γ₂ t₁) (adapt Γ₁ Γ₂ t₂)

-- changes 'x' to 'nil' (if internally bound) or 'dx' (if externally bound)

Δ-var : ∀ {Γ₁ Γ₂ τ} → Var (Γ₁ ⋎ Γ₂) τ → Term (Δ-Context Γ₂) (Δ-Type τ)
Δ-var {∅} x = var (rename x)
Δ-var {τ • Γ} this = nil {τ}
Δ-var {τ • Γ} (that x) = Δ-var {Γ} x

-- Note: this should be the derivative with respect to the first variable.
nabla : ∀ {Γ τ₁ τ₂} → (t₀ : Term Γ (τ₁ ⇒ τ₂)) → Term Γ (τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂)
nabla = {!!}

-- CHANGE TERMS
Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)

-- To recheck: which is the order in which to apply the changes? When I did my live proof to Klaus, I came up with this order:
-- (Δ-term t₁) (t₂ ⊕ (Δ-term t₂)) ∘ (∇ t₁) t₂ (Δ-term t₂)
-- corresponding to:
Δ-term {Γ₁} {Γ₂} {τ} (app t₁ t₂) = app (app (compose {τ}) (app (Δ-term {Γ₁} t₁) (app (app apply (Δ-term {Γ₁} {Γ₂} t₂)) (adapt Γ₁ Γ₂ t₂))))
  (app (adapt Γ₁ Γ₂ (app (nabla {Γ₁ ⋎ Γ₂} t₁) t₂)) (Δ-term {Γ₁} {Γ₂} t₂))

Δ-term {Γ} (var x) = weaken {∅} {Γ} (Δ-var {Γ} x)
Δ-term {Γ} true = {!!}
Δ-term {Γ} false = {!!}
Δ-term {Γ} (cond t₁ t₂ t₃) = {!!}

module derivation where

open import lambda

-- KO: Is it correct that this file is supposed to contain the syntactic
-- variants of the operations in Changes.agda?
-- If so, why does it have a different (and rather strange) Δ-Type definition?
-- Why are the base cases (bool) all missing? The inductive cases look
-- boring since they don't actually do anything (which explains why compose and apply are the same)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂
Δ-Type bool = {!!}

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )
apply {bool} = {!!}

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app (compose {τ₂}) (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )
compose {bool} = {!!}

nil : ∀ {τ Γ} → Term Γ (Δ-Type τ)
nil {τ₁ ⇒ τ₂} =
    abs (nil {τ₂})
 -- λx. nil
nil {bool} = {!!}

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Δ-Context Γ

-- CHANGE VARIABLES

-- changes 'x' to 'dx'

rename : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
rename this = that this
rename (that x) = that (that (rename x))

-- Weakening of a term needed during derivation - change x to x in a context which also includes dx.
-- The actual specification is more complicated, study the type signature.
adaptVar : ∀ {τ} Γ₁ Γ₂ → Var (Γ₁ ⋎ Γ₂) τ → Var (Γ₁ ⋎ Δ-Context Γ₂) τ
adaptVar ∅ (τ₂ • Γ₂) this = this
adaptVar ∅ (τ₂ • Γ₂) (that x) = that (that (adaptVar ∅ Γ₂ x))
adaptVar (τ₁ • Γ₁) Γ₂ this = this
adaptVar (τ₁ • Γ₁) Γ₂ (that x) = that (adaptVar Γ₁ Γ₂ x)

adapt : ∀ {τ} Γ₁ Γ₂ → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) τ
adapt {τ₁ ⇒ τ₂} Γ₁ Γ₂ (abs t) = abs (adapt (τ₁ • Γ₁) Γ₂ t)
adapt Γ₁ Γ₂ (app t₁ t₂) = app (adapt Γ₁ Γ₂ t₁) (adapt Γ₁ Γ₂ t₂)
adapt Γ₁ Γ₂ (var t) = var (adaptVar Γ₁ Γ₂ t)
adapt Γ₁ Γ₂ true = true
adapt Γ₁ Γ₂ false = false
adapt Γ₁ Γ₂ (cond tc t₁ t₂) = cond (adapt Γ₁ Γ₂ tc) (adapt Γ₁ Γ₂ t₁) (adapt Γ₁ Γ₂ t₂)

-- changes 'x' to 'nil' (if internally bound) or 'dx' (if externally bound)

Δ-var : ∀ {Γ₁ Γ₂ τ} → Var (Γ₁ ⋎ Γ₂) τ → Term (Δ-Context Γ₂) (Δ-Type τ)
Δ-var {∅} x = var (rename x)
Δ-var {τ • Γ} this = nil {τ}
Δ-var {τ • Γ} (that x) = Δ-var {Γ} x

-- Note: this should be the derivative with respect to the first variable.
nabla : ∀ {Γ τ₁ τ₂} → (t₀ : Term Γ (τ₁ ⇒ τ₂)) → Term Γ (τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂)
nabla = {!!}

-- CHANGE TERMS
Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)

-- To recheck: which is the order in which to apply the changes? When I did my live proof to Klaus, I came up with this order:
-- (Δ-term t₁) (t₂ ⊕ (Δ-term t₂)) ∘ (∇ t₁) t₂ (Δ-term t₂)
-- corresponding to:
Δ-term {Γ₁} {Γ₂} {τ} (app t₁ t₂) = app (app (compose {τ}) (app (Δ-term {Γ₁} t₁) (app (app apply (Δ-term {Γ₁} {Γ₂} t₂)) (adapt Γ₁ Γ₂ t₂))))
  (app (adapt Γ₁ Γ₂ (app (nabla {Γ₁ ⋎ Γ₂} t₁) t₂)) (Δ-term {Γ₁} {Γ₂} t₂))

Δ-term {Γ} (var x) = weaken {∅} {Γ} (Δ-var {Γ} x)
Δ-term {Γ} true = {!!}
Δ-term {Γ} false = {!!}
Δ-term {Γ} (cond t₁ t₂ t₃) = {!!}


documenting Equality module

documenting Equality module

-- This is an implementation of the equality type for Sets. Agda's
-- standard equality is more powerful. The main idea here is to
-- illustrate the equality type.
module Equality where

-- The equality of two elements of type A. The type a ≡ b is a family
-- of types which captures the statement of equality in A. Not all of
-- the types are inhabited as in general not all elements are equal
-- here. The only type that are inhabited are a ≡ a by the element
-- that we call definition. This is called refl (for reflection in
-- agda).
data _≡_  {A : Set} : (a b : A) → Set where
  definition : {x : A} → x ≡ x

-- ≡ is a symmetric relation.
sym : {A : Set} {a b : A} → a ≡ b → b ≡ a
sym definition = definition

-- ≡ is a transitive relation.
trans : {A : Set} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans pAB definition = pAB
-- trans definition pBC = pBC  -- alternate proof of transitivity.

-- Congruence. If we apply f to equals the result are also equal.
cong : {A B : Set} {a₀ a₁ : A} → (f : A → B) → a₀ ≡ a₁ → f a₀ ≡ f a₁
cong f definition = definition

-- Pretty way of doing equational reasoning.  If we want to prove a₀ ≡
-- b through an intermediate set of equations use this. The general
-- form will look like.
--
-- begin a  ≈ a₀ by p₀
--          ≈ a₁ by p₁
--          ...
--          ≈ b  by p
-- ∎

begin : {A : Set} (a : A) →  a ≡ a
_≈_by_ : {A : Set} {a b : A} → a ≡ b → (c : A) → b ≡ c → a ≡ c
_∎ : {A : Set} (a : A) → A

begin a = definition
aEb ≈ c by bEc = trans aEb bEc
x ∎ = x

infixl 1 _≈_by_
infixl 1 _≡_

module Equality where

data _≡_  {A : Set} : (a b : A) → Set where
  definition : {x : A} → x ≡ x

sym : {A : Set} {a b : A} → a ≡ b → b ≡ a
sym definition = definition

trans : {A : Set} {a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans pAB definition = pAB
-- trans definition pBC = pBC

cong : {A B : Set} {a₀ a₁ : A} → (f : A → B) → a₀ ≡ a₁ → f a₀ ≡ f a₁
cong f definition = definition

begin : {A : Set} (a : A) →  a ≡ a
begin a = definition

_≈_by_ : {A : Set} {a b : A} → a ≡ b → (c : A) → b ≡ c → a ≡ c
aEb ≈ c by bEc = trans aEb bEc

_∎ : {A : Set} (a : A) → A
x ∎ = x

infixl 1 _≈_by_
infixl 1 _≡_


Revert "Show we can define e⊕ using base values in changes"

That was a demonstration, but the old definition is the one I prefer.
This reverts commit 47190645cc58ddea24ef59e6877fda0473ae4818.

module Thesis.LangChanges where

open import Thesis.Changes
open import Thesis.IntChanges
open import Thesis.Lang
open import Relation.Binary.PropositionalEquality

Chτ : (τ : Type) → Set
Chτ τ = ⟦ Δt τ ⟧Type

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context

[_]τ_from_to_ : ∀ (τ : Type) → (dv : Chτ τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

isCompChangeStructureτ : ∀ τ → IsCompChangeStructure ⟦ τ ⟧Type ⟦ Δt τ ⟧Type [ τ ]τ_from_to_

changeStructureτ : ∀ τ → ChangeStructure ⟦ τ ⟧Type
changeStructureτ τ = record { isCompChangeStructure = isCompChangeStructureτ τ }

instance
  ichangeStructureτ : ∀ {τ} → ChangeStructure ⟦ τ ⟧Type
  ichangeStructureτ {τ} = changeStructureτ τ

[ σ ⇒ τ ]τ df from f1 to f2 =
  ∀ (da : Chτ σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ]τ da from a1 to a2 → [ τ ]τ df a1 da from f1 a1 to f2 a2
[ int ]τ dv from v1 to v2 = v1 + dv ≡ v2
[ pair σ τ ]τ (da , db) from (a1 , b1) to (a2 , b2) = [ σ ]τ da from a1 to a2 × [ τ ]τ db from b1 to b2
[ sum σ τ ]τ dv from v1 to v2 = sch_from_to_ dv v1 v2

isCompChangeStructureτ (σ ⇒ τ) = ChangeStructure.isCompChangeStructure (funCS {{changeStructureτ σ}} {{changeStructureτ τ}})
isCompChangeStructureτ int = ChangeStructure.isCompChangeStructure intCS
isCompChangeStructureτ (pair σ τ) = ChangeStructure.isCompChangeStructure (pairCS {{changeStructureτ σ}} {{changeStructureτ τ}})
isCompChangeStructureτ (sum σ τ) = ChangeStructure.isCompChangeStructure ((sumCS {{changeStructureτ σ}} {{changeStructureτ τ}}))

open import Data.Unit
-- We can define an alternative semantics for contexts, that defines environments as nested products:
⟦_⟧Context-prod : Context → Set
⟦ ∅ ⟧Context-prod = ⊤
⟦ τ • Γ ⟧Context-prod = ⟦ τ ⟧Type × ⟦ Γ ⟧Context-prod

-- And define a change structure for such environments, reusing the change
-- structure constructor for pairs. However, this change structure does not
-- duplicate base values in the environment. We probably *could* define a
-- different change structure for pairs that gives the right result.
changeStructureΓ-old : ∀ Γ → ChangeStructure ⟦ Γ ⟧Context-prod
changeStructureΓ-old ∅ = unitCS
changeStructureΓ-old (τ • Γ) = pairCS {{changeStructureτ τ}}  {{changeStructureΓ-old Γ}}

data [_]Γ_from_to_ : ∀ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

module _ where
  _e⊕_ : ∀ {Γ} → ⟦ Γ ⟧Context → ChΓ Γ → ⟦ Γ ⟧Context
  _e⊕_ ∅ ∅ = ∅
  _e⊕_ (v • ρ) (dv • _ • dρ) = v ⊕ dv • ρ e⊕ dρ
  _e⊝_ : ∀ {Γ} → ⟦ Γ ⟧Context → ⟦ Γ ⟧Context → ChΓ Γ
  _e⊝_ ∅ ∅ = ∅
  _e⊝_ (v₂ • ρ₂) (v₁ • ρ₁) = v₂ ⊝ v₁ • v₁ • ρ₂ e⊝ ρ₁

  isEnvCompCS : ∀ Γ → IsCompChangeStructure ⟦ Γ ⟧Context (ChΓ Γ) [ Γ ]Γ_from_to_

  efromto→⊕ : ∀ {Γ} (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) →
      [ Γ ]Γ dρ from ρ1 to ρ2 → (ρ1 e⊕ dρ) ≡ ρ2
  efromto→⊕ .∅ .∅ .∅ v∅ = refl
  efromto→⊕ .(_ • _ • _) .(_ • _) .(_ • _) (dvv v• dρρ) =
    cong₂ _•_ (fromto→⊕ _ _ _ dvv) (efromto→⊕ _ _ _ dρρ)

  e⊝-fromto : ∀ {Γ} → (ρ1 ρ2 : ⟦ Γ ⟧Context) → [ Γ ]Γ ρ2 e⊝ ρ1 from ρ1 to ρ2
  e⊝-fromto ∅ ∅ = v∅
  e⊝-fromto (v1 • ρ1) (v2 • ρ2) = ⊝-fromto v1 v2 v• e⊝-fromto ρ1 ρ2

  _e⊚[_]_ : ∀ {Γ} → ChΓ Γ → ⟦ Γ ⟧Context → ChΓ Γ → ChΓ Γ
  _e⊚[_]_ {∅} ∅ ∅ ∅ = ∅
  _e⊚[_]_ {τ • Γ} (dv1 • _ • dρ1) (v1 • ρ1) (dv2 • _ • dρ2) = (dv1 ⊚[ v1 ] dv2) • v1 • (dρ1 e⊚[ ρ1 ] dρ2)

  e⊚-fromto : ∀ Γ → (ρ1 ρ2 ρ3 : ⟦ Γ ⟧Context) (dρ1 dρ2 : ChΓ Γ) →
    [ Γ ]Γ dρ1 from ρ1 to ρ2 →
    [ Γ ]Γ dρ2 from ρ2 to ρ3 → [ Γ ]Γ (dρ1 e⊚[ ρ1 ] dρ2) from ρ1 to ρ3
  e⊚-fromto ∅ ∅ ∅ ∅ ∅ ∅ v∅ v∅ = v∅
  e⊚-fromto (τ • Γ) (v1 • ρ1) (v2 • ρ2) (v3 • ρ3)
    (dv1 • (.v1 • dρ1)) (dv2 • (.v2 • dρ2))
    (dvv1 v• dρρ1) (dvv2 v• dρρ2) =
        ⊚-fromto v1 v2 v3 dv1 dv2 dvv1 dvv2
      v•
        e⊚-fromto Γ ρ1 ρ2 ρ3 dρ1 dρ2 dρρ1 dρρ2

  isEnvCompCS Γ = record
    { isChangeStructure = record
      { _⊕_ = _e⊕_
      ; fromto→⊕ = efromto→⊕
      ; _⊝_ = _e⊝_
      ; ⊝-fromto = e⊝-fromto
      }
    ; _⊚[_]_ = _e⊚[_]_
    ; ⊚-fromto = e⊚-fromto Γ
    }

changeStructureΓ : ∀ Γ → ChangeStructure ⟦ Γ ⟧Context
changeStructureΓ Γ = record { isCompChangeStructure = isEnvCompCS Γ }

instance
  ichangeStructureΓ : ∀ {Γ} → ChangeStructure ⟦ Γ ⟧Context
  ichangeStructureΓ {Γ} = changeStructureΓ Γ

changeStructureΓτ : ∀ Γ τ → ChangeStructure (⟦ Γ ⟧Context → ⟦ τ ⟧Type)
changeStructureΓτ Γ τ = funCS

instance
  ichangeStructureΓτ : ∀ {Γ τ} → ChangeStructure (⟦ Γ ⟧Context → ⟦ τ ⟧Type)
  ichangeStructureΓτ {Γ} {τ} = changeStructureΓτ Γ τ

module Thesis.LangChanges where

open import Thesis.Changes
open import Thesis.IntChanges
open import Thesis.Lang
open import Relation.Binary.PropositionalEquality

Chτ : (τ : Type) → Set
Chτ τ = ⟦ Δt τ ⟧Type

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context

[_]τ_from_to_ : ∀ (τ : Type) → (dv : Chτ τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

isCompChangeStructureτ : ∀ τ → IsCompChangeStructure ⟦ τ ⟧Type ⟦ Δt τ ⟧Type [ τ ]τ_from_to_

changeStructureτ : ∀ τ → ChangeStructure ⟦ τ ⟧Type
changeStructureτ τ = record { isCompChangeStructure = isCompChangeStructureτ τ }

instance
  ichangeStructureτ : ∀ {τ} → ChangeStructure ⟦ τ ⟧Type
  ichangeStructureτ {τ} = changeStructureτ τ

[ σ ⇒ τ ]τ df from f1 to f2 =
  ∀ (da : Chτ σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ]τ da from a1 to a2 → [ τ ]τ df a1 da from f1 a1 to f2 a2
[ int ]τ dv from v1 to v2 = v1 + dv ≡ v2
[ pair σ τ ]τ (da , db) from (a1 , b1) to (a2 , b2) = [ σ ]τ da from a1 to a2 × [ τ ]τ db from b1 to b2
[ sum σ τ ]τ dv from v1 to v2 = sch_from_to_ dv v1 v2

isCompChangeStructureτ (σ ⇒ τ) = ChangeStructure.isCompChangeStructure (funCS {{changeStructureτ σ}} {{changeStructureτ τ}})
isCompChangeStructureτ int = ChangeStructure.isCompChangeStructure intCS
isCompChangeStructureτ (pair σ τ) = ChangeStructure.isCompChangeStructure (pairCS {{changeStructureτ σ}} {{changeStructureτ τ}})
isCompChangeStructureτ (sum σ τ) = ChangeStructure.isCompChangeStructure ((sumCS {{changeStructureτ σ}} {{changeStructureτ τ}}))

open import Data.Unit
-- We can define an alternative semantics for contexts, that defines environments as nested products:
⟦_⟧Context-prod : Context → Set
⟦ ∅ ⟧Context-prod = ⊤
⟦ τ • Γ ⟧Context-prod = ⟦ τ ⟧Type × ⟦ Γ ⟧Context-prod

-- And define a change structure for such environments, reusing the change
-- structure constructor for pairs. However, this change structure does not
-- duplicate base values in the environment. We probably *could* define a
-- different change structure for pairs that gives the right result.
changeStructureΓ-old : ∀ Γ → ChangeStructure ⟦ Γ ⟧Context-prod
changeStructureΓ-old ∅ = unitCS
changeStructureΓ-old (τ • Γ) = pairCS {{changeStructureτ τ}}  {{changeStructureΓ-old Γ}}

data [_]Γ_from_to_ : ∀ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

module _ where
  _e⊕_ : ∀ {Γ} → ⟦ Γ ⟧Context → ChΓ Γ → ⟦ Γ ⟧Context
  _e⊕_ ∅ ∅ = ∅
  _e⊕_ (_ • ρ) (dv • v • dρ) = v ⊕ dv • ρ e⊕ dρ
  _e⊝_ : ∀ {Γ} → ⟦ Γ ⟧Context → ⟦ Γ ⟧Context → ChΓ Γ
  _e⊝_ ∅ ∅ = ∅
  _e⊝_ (v₂ • ρ₂) (v₁ • ρ₁) = v₂ ⊝ v₁ • v₁ • ρ₂ e⊝ ρ₁

  isEnvCompCS : ∀ Γ → IsCompChangeStructure ⟦ Γ ⟧Context (ChΓ Γ) [ Γ ]Γ_from_to_

  efromto→⊕ : ∀ {Γ} (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) →
      [ Γ ]Γ dρ from ρ1 to ρ2 → (ρ1 e⊕ dρ) ≡ ρ2
  efromto→⊕ .∅ .∅ .∅ v∅ = refl
  efromto→⊕ .(_ • _ • _) .(_ • _) .(_ • _) (dvv v• dρρ) =
    cong₂ _•_ (fromto→⊕ _ _ _ dvv) (efromto→⊕ _ _ _ dρρ)

  e⊝-fromto : ∀ {Γ} → (ρ1 ρ2 : ⟦ Γ ⟧Context) → [ Γ ]Γ ρ2 e⊝ ρ1 from ρ1 to ρ2
  e⊝-fromto ∅ ∅ = v∅
  e⊝-fromto (v1 • ρ1) (v2 • ρ2) = ⊝-fromto v1 v2 v• e⊝-fromto ρ1 ρ2

  _e⊚[_]_ : ∀ {Γ} → ChΓ Γ → ⟦ Γ ⟧Context → ChΓ Γ → ChΓ Γ
  _e⊚[_]_ {∅} ∅ ∅ ∅ = ∅
  _e⊚[_]_ {τ • Γ} (dv1 • _ • dρ1) (v1 • ρ1) (dv2 • _ • dρ2) = (dv1 ⊚[ v1 ] dv2) • v1 • (dρ1 e⊚[ ρ1 ] dρ2)

  e⊚-fromto : ∀ Γ → (ρ1 ρ2 ρ3 : ⟦ Γ ⟧Context) (dρ1 dρ2 : ChΓ Γ) →
    [ Γ ]Γ dρ1 from ρ1 to ρ2 →
    [ Γ ]Γ dρ2 from ρ2 to ρ3 → [ Γ ]Γ (dρ1 e⊚[ ρ1 ] dρ2) from ρ1 to ρ3
  e⊚-fromto ∅ ∅ ∅ ∅ ∅ ∅ v∅ v∅ = v∅
  e⊚-fromto (τ • Γ) (v1 • ρ1) (v2 • ρ2) (v3 • ρ3)
    (dv1 • (.v1 • dρ1)) (dv2 • (.v2 • dρ2))
    (dvv1 v• dρρ1) (dvv2 v• dρρ2) =
        ⊚-fromto v1 v2 v3 dv1 dv2 dvv1 dvv2
      v•
        e⊚-fromto Γ ρ1 ρ2 ρ3 dρ1 dρ2 dρρ1 dρρ2

  isEnvCompCS Γ = record
    { isChangeStructure = record
      { _⊕_ = _e⊕_
      ; fromto→⊕ = efromto→⊕
      ; _⊝_ = _e⊝_
      ; ⊝-fromto = e⊝-fromto
      }
    ; _⊚[_]_ = _e⊚[_]_
    ; ⊚-fromto = e⊚-fromto Γ
    }

changeStructureΓ : ∀ Γ → ChangeStructure ⟦ Γ ⟧Context
changeStructureΓ Γ = record { isCompChangeStructure = isEnvCompCS Γ }

instance
  ichangeStructureΓ : ∀ {Γ} → ChangeStructure ⟦ Γ ⟧Context
  ichangeStructureΓ {Γ} = changeStructureΓ Γ

changeStructureΓτ : ∀ Γ τ → ChangeStructure (⟦ Γ ⟧Context → ⟦ τ ⟧Type)
changeStructureΓτ Γ τ = funCS

instance
  ichangeStructureΓτ : ∀ {Γ τ} → ChangeStructure (⟦ Γ ⟧Context → ⟦ τ ⟧Type)
  ichangeStructureΓτ {Γ} {τ} = changeStructureΓτ Γ τ


Start to formalize changes (WIP).

Start to formalize changes (WIP).

This is intended to be the approach Paolo describes in the last
subsection of alternative-defs-proofs.md.

Old-commit-hash: 68ae9d3ef37f16aa12f3cc6d85367de6aeb73ca7

module incremental where

-- SIMPLE TYPES

-- Syntax

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

infixr 5 _⇒_

-- Semantics

Dom⟦_⟧ : Type -> Set
Dom⟦ τ₁ ⇒ τ₂ ⟧ = Dom⟦ τ₁ ⟧ → Dom⟦ τ₂ ⟧

-- TYPING CONTEXTS

-- Syntax

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

infixr 9 _•_

-- Semantics

data Empty : Set where
  ∅ : Empty

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

Env⟦_⟧ : Context → Set
Env⟦ ∅ ⟧ = Empty
Env⟦ τ • Γ ⟧ = Bind Dom⟦ τ ⟧ Env⟦ Γ ⟧

-- VARIABLES

-- Syntax

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

-- Semantics

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

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

-- Semantics

eval⟦_⟧ : ∀ {Γ τ} → Term Γ τ → Env⟦ Γ ⟧ → Dom⟦ τ ⟧
eval⟦ abs t ⟧ ρ = λ v → eval⟦ t ⟧ (v • ρ)
eval⟦ app t₁ t₂ ⟧ ρ = (eval⟦ t₁ ⟧ ρ) (eval⟦ t₂ ⟧ ρ)
eval⟦ var x ⟧ ρ = lookup⟦ x ⟧ ρ

-- WEAKENING

-- Extend a context to a super context

infixr 10 _⋎_

_⋎_ : (Γ₁ Γ₁ : Context) → Context
∅ ⋎ Γ₂ = Γ₂
(τ • Γ₁) ⋎ Γ₂ = τ • Γ₁ ⋎ Γ₂

-- Lift a variable to a super context

lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
lift {∅} {∅} x = x
lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
lift {τ • Γ₁} {Γ₂} this = this
lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- Weaken a term to a super context

weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app compose (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = τ • Δ-Type τ • Γ

-- CHANGING TERMS WHEN THE ENVIRONMENT CHANGES

Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)
Δ-term {Γ} (app t₁ t₂) = {!!}
Δ-term {Γ} (var x) = {!!}


Desc model: generic proof that map id = id.