More fiddling

More fiddling

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 using (ℕ; zero; suc; decTotalOrder)

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 _ = ⊤

open import Data.Nat.Base using (_<_)

-- XXX: This is a lie for now, but all papers agree we'll want this in the end.
_[_]τmono_from_to : (n : ℕ) → ∀ τ → (dv : Val (Δt τ)) →
  ∀ v1 v2 n' →
  n' < n →
  n [ τ ]τ dv from v1 to v2 →
  n' [ τ ]τ dv from v1 to v2
_[_]τmono_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 σ) →
   suc 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 (suc n) ≡ Done v1 → apply f2 a2 (suc 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ρρ

open import Relation.Binary hiding (_⇒_)
foo : ∀ {Γ σ τ v1 v2 dv} n (t : Term (σ • Γ) τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 a2 : Val σ) →
  (eqv1 : eval t (a1 • ρ1) (suc (suc n)) ≡ Done v1) →
  (eqv2 : eval t (a2 • ρ2) (suc (suc n)) ≡ Done v2) →
  (eqvv : eval (derive t) (da • a1 • dρ) (suc (suc n)) ≡ Done dv) →
  suc (suc n) [ τ ]τ' eval (derive t) (da • a1 • dρ) (suc (suc n)) from
      eval t (a1 • ρ1) (suc (suc n)) to eval t (a2 • ρ2) (suc (suc n)) →
  suc n [ τ ]τ dv from v1 to v2
foo n t dρ ρ1 ρ2 da a1 a2 eqv1 eqv2 eqvv dvv with eval t (a1 • ρ1) (suc (suc n)) | eval t (a2 • ρ2) (suc (suc n)) | eval (derive t) (da • a1 • dρ) (suc (suc n))
foo n t dρ ρ1 ρ2 da a1 a2 refl refl refl dvv | Done v1 | (Done v2) | (Done dv) = _[_]τmono_from_to (suc (suc n)) _ dv v1 v2 (suc n) (DecTotalOrder.reflexive Data.Nat.decTotalOrder refl) dvv
foo n t dρ ρ1 ρ2 da a1 a2 refl refl () dvv | Done v₁ | (Done v) | TimeOut
foo n t dρ ρ1 ρ2 da a1 a2 refl () eqvv dvv | Done v | TimeOut | s
foo n t dρ ρ1 ρ2 da a1 a2 () eqv2 eqvv dvv | TimeOut | r | s
-- q r s eqv1 eqv2 eqvv

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 eqv1 eqv2 = {!!}
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 with
  eval (derive t) (da • a1 • dρ) (suc (suc n)) | inspect (eval (derive t) (da • a1 • dρ)) (suc (suc n))
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 | Done dv | [ eqvv ] = dv , refl , foo n t  dρ ρ1 ρ2 da a1 a2 eqv1 eqv2 eqvv (fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ))
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 | TimeOut | eq = {!!}
-- {!eval (derive t)!} , {!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 →

-- 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ρρ!}


Convert ΔConst to new derivation interface.

Old-commit-hash: 7b59661ce496b2c2659e20c6f9c4f528ddbd6102

module Atlas.Change.Derive where

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

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

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

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

ΔConst empty ∅ = empty!

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

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

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

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

module Atlas.Change.Derive where

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

ΔConst : ∀ {Γ Σ τ} → (c : Const Σ τ) →
  Term Γ (internalizeContext (ΔContext′ Σ) (ΔType τ))

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

ΔConst xor = abs₄ (λ x Δx y Δy → xor! Δx Δy)

ΔConst empty = empty!

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
ΔConst update = abs₆ (λ k Δk v Δv m Δm →
  insert (apply Δk k) (apply Δv v) (delete k v Δm))

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

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

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


Cosmetic changes.

Cosmetic changes.

Ignore-this: b3263208f4a36371cda767221bbdfa8a

darcs-hash:20110930164503-3bd4e-20fed55b995059fa3f2ec5feb994ad7cc26b1339.gz

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data.
data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- From data to postulates

-- The predicate: Using the induction principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- The predicate: Using pattern matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

------------------------------------------------------------------------------
-- From postulates to data

-- The predicate.
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

-- Are the FOTC natural numbers defined by data and postulate the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data

data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 h zN      = P0
indN P P0 h (sN Nn) = h Nn (indN P P0 h Nn)

-- The FOTC natural numbers using postulates (we choose 'M' by 'Model')
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  indM : (P : D → Set) →
         P zero →
         (∀ {n} → M n → P n → P (succ n)) →
         ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- From data to postulates

-- The predicate: Using the induction principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = indN M zM (λ _ Mn → sM Mn)

-- The predicate: Using pattern matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

------------------------------------------------------------------------------
-- From postulate to data

-- The predicate.
nat-P2D : ∀ {n} → M n → N n
nat-P2D = indM N zN (λ _ Nn → sN Nn)


ReceiptFreeness: various changes

ReceiptFreeness: various changes

-- {-# OPTIONS --without-K #-}

open import Function
open import Type
open import Data.Maybe.NP
open import Data.Fin.NP as Fin hiding (_+_; _==_)
open import Data.Product renaming (zip to zip-×)
open import Data.One
open import Data.Two
open import Data.Vec
open import Data.List as L

open import Data.Nat.NP renaming (_==_ to _==ℕ_)

{-
open import Explore.Core
open import Explore.Explorable
open import Explore.Product
open Operators
-}
open import Relation.Binary.PropositionalEquality
--open import Control.Strategy renaming (run to runStrategy)

module Game.ReceiptFreeness
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : (checked? : 𝟚) → ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (#q : ℕ) (max#q : Fin #q)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CipherText 1₂)
  (forget : CipherText 1₂ → CipherText 0₂)
  (check  : CipherText 0₂ → Maybe (CipherText 1₂))
  (Dec    : let Message = 𝟚 in
            SecKey → CipherText 1₂ → Message)

where

Checked? = 𝟚
checked unchecked : Checked?
unchecked = 0₂
checked = 1₂

data Strategy (Q : ★) (R : Q → ★) (A : ★) : ★ where
  ask  : (q? : Q) (cont : R q? → Strategy Q R A) → Strategy Q R A
  done : A → Strategy Q R A

module _ {Q : ★} {R : Q → ★} (Oracle : (q : Q) → R q) where
  private
    M = Strategy Q R
  run : ∀ {A} → M A → A
  run (ask q? cont) = run (cont (Oracle q?))
  run (done x)      = x

State : (S A : ★) → ★
State S A = S → A × S

module _ {S Q : ★} {R : Q → ★} (Oracle : (q : Q) → State S (R q)) where
  private
    M = Strategy Q R
  runS : ∀ {A} → M A → State S A
  runS (ask q? cont) s = case Oracle q? s of λ { (x , s') → runS (cont x) s' }
  runS (done x)      s = x , s

  evalS : ∀ {A} → M A → S → A
  evalS x s = proj₁ (runS x s)

  execS : ∀ {A} → M A → S → S
  execS x s = proj₂ (runS x s)

Candidate : ★
Candidate = 𝟚 -- as in the paper: "for simplicity"

alice bob : Candidate
alice = 0₂
bob   = 1₂

-- candidate order
-- also known as LHS or Message
-- represented by who is the first candidate
CO : ★
CO = 𝟚

alice-then-bob bob-then-alice : CO
alice-then-bob = alice
bob-then-alice = bob

data CO-spec : CO → Candidate → Candidate → ★ where
  alice-then-bob-spec : CO-spec alice-then-bob alice bob
  bob-then-alice-spec : CO-spec bob-then-alice bob alice

MarkedReceipt : ★
MarkedReceipt = 𝟚

marked-on-first-cell marked-on-second-cell : MarkedReceipt
marked-on-first-cell  = 0₂
marked-on-second-cell = 1₂

data MarkedReceipt-spec : CO → MarkedReceipt → Candidate → ★ where
  m1 : MarkedReceipt-spec alice-then-bob marked-on-first-cell  alice
  m2 : MarkedReceipt-spec alice-then-bob marked-on-second-cell bob
  m3 : MarkedReceipt-spec bob-then-alice marked-on-first-cell  bob
  m4 : MarkedReceipt-spec bob-then-alice marked-on-second-cell alice

data MarkedReceipt? : ★ where
  not-marked : MarkedReceipt?
  marked     : MarkedReceipt → MarkedReceipt?

-- Receipt or also called RHS
-- Made of a potential mark, a serial number, and an encrypted candidate order
Receipt : (checked? : 𝟚) → ★
Receipt checked? = MarkedReceipt? × SerialNumber × CipherText checked?

forgetReceipt : Receipt checked → Receipt unchecked
forgetReceipt (m? , sn , enc-co) = m? , sn , forget enc-co

checkReceipt : Receipt unchecked → Maybe (Receipt checked)
checkReceipt (m? , sn , ck-enc-co) = map? (λ x → m? , sn , x) (check ck-enc-co)

markedReceipt? : ∀ {checked?} → Receipt checked? → MarkedReceipt?
markedReceipt? = proj₁

-- Marked when there is a 1
marked? : MarkedReceipt? → 𝟚
marked? not-marked = 0₂
marked? (marked _) = 1₂

marked-on-first-cell? : MarkedReceipt? → 𝟚
marked-on-first-cell? not-marked = 0₂
marked-on-first-cell? (marked x) = x == 0₂

marked-on-second-cell? : MarkedReceipt? → 𝟚
marked-on-second-cell? not-marked = 0₂
marked-on-second-cell? (marked x) = x == 1₂

Ballot : (checked? : 𝟚) → ★
Ballot checked? = CO × Receipt checked?

-- co or also called LHS
co : ∀ {checked?} → Ballot checked? → CO
co = proj₁

-- receipt or also called RHS
receipt : ∀ {checked?} → Ballot checked? → Receipt checked?
receipt = proj₂

-- randomness for genBallot
Rgb : ★
Rgb = CO × SerialNumber × Rₑ

genBallot : PubKey → Rgb → Ballot checked
genBallot pk (r-co , sn , rₑ) = r-co , not-marked , sn , Enc pk r-co rₑ

forgetBallot : Ballot checked → Ballot unchecked
forgetBallot (co , m? , sn , enc-co) = co , m? , sn , forget enc-co

mark : CO → Candidate → MarkedReceipt
mark co c = co xor c

mark-ok : ∀ co c → MarkedReceipt-spec co (mark co c) c
mark-ok 1₂ 1₂ = m3
mark-ok 1₂ 0₂ = m4
mark-ok 0₂ 1₂ = m2
mark-ok 0₂ 0₂ = m1

fillBallot : ∀ {checked?} → Candidate → Ballot checked? → Ballot checked?
fillBallot c (co , _ , sn , enc-co) = co , marked (mark co c) , sn , enc-co

-- TODO Ballot-spec c (fillBallot b)

BB : ★
BB = List (Receipt checked)

Tally : ★
Tally = ℕ × ℕ

alice-score : Tally → ℕ
alice-score = proj₁

bob-score : Tally → ℕ
bob-score = proj₂

1:alice-0:bob 0:alice-1:bob : Tally
1:alice-0:bob = 1 , 0
0:alice-1:bob = 0 , 1

data TallyMarkedReceipt-spec : CO → MarkedReceipt → Tally → ★ where
  c1 : TallyMarkedReceipt-spec alice-then-bob marked-on-first-cell  1:alice-0:bob
  c2 : TallyMarkedReceipt-spec alice-then-bob marked-on-second-cell 0:alice-1:bob
  c3 : TallyMarkedReceipt-spec bob-then-alice marked-on-first-cell  0:alice-1:bob
  c4 : TallyMarkedReceipt-spec bob-then-alice marked-on-second-cell 1:alice-0:bob

marked-for-alice? : CO → MarkedReceipt → 𝟚
marked-for-alice? co m = co == m

marked-for-bob? : CO → MarkedReceipt → 𝟚
marked-for-bob? co m = not (marked-for-alice? co m)

tallyMarkedReceipt : CO → MarkedReceipt → Tally
tallyMarkedReceipt co m = 𝟚▹ℕ for-alice , 𝟚▹ℕ (not for-alice)
  where for-alice = marked-for-alice? co m

tallyMarkedReceipt-ok : ∀ co m → TallyMarkedReceipt-spec co m (tallyMarkedReceipt co m)
tallyMarkedReceipt-ok 1₂ 1₂ = c4
tallyMarkedReceipt-ok 1₂ 0₂ = c3
tallyMarkedReceipt-ok 0₂ 1₂ = c2
tallyMarkedReceipt-ok 0₂ 0₂ = c1

tallyMarkedReceipt? : CO → MarkedReceipt? → Tally
tallyMarkedReceipt? co not-marked    = 0 , 0
tallyMarkedReceipt? co (marked mark) = tallyMarkedReceipt co mark

tallyCheckedReceipt : SecKey → Receipt checked → Tally
tallyCheckedReceipt sk (marked? , _ , enc-co) = tallyMarkedReceipt? (Dec sk enc-co) marked?

-- Not taking advantage of any homomorphic encryption
tally : SecKey → BB → Tally
tally sk bb = L.foldr (zip-× _+_ _+_) (0 , 0) (L.map (tallyCheckedReceipt sk) bb)

data Accept? : ★ where
  accept reject : Accept?

-- In the paper RBB is the returning the Tally and we
-- return the BB, here RTally is returning the Tally
data Q : ★ where
  REB RBB RTally : Q
  RCO            : Receipt checked → Q
  Vote           : Receipt unchecked → Q

Resp : Q → ★
Resp REB = Ballot unchecked
Resp (RCO x) = CO
Resp (Vote x) = Accept?
Resp RBB = BB
Resp RTally = Tally

Phase : ★ → ★
Phase = Strategy Q Resp

-- How to read types as protocols:
-- A × B   sends A, then behave as B
-- A → B   receives A, then behave as B

RFChallenge : ★ → ★
RFChallenge Next = (𝟚 → Receipt checked) → Next

Adversary : ★
Adversary = Rₐ → PubKey → Phase -- Phase[I]
                           (RFChallenge
                             (Phase -- Phase[II]
                               𝟚)) -- Adversary guess of whether the vote is for alice

-- TODO adversary validity
-- Valid-Adversary : Adversary → ★

module Oracle (sk : SecKey) (pk : PubKey) (rgb : Rgb) (bb : BB) where
    resp : (q : Q) → Resp q
    resp REB = forgetBallot (genBallot pk rgb)
    resp RBB = bb
    resp RTally = tally sk bb
    resp (RCO (_ , _ , receipt)) = Dec sk receipt
    -- do we check if the sn is already here?
    resp (Vote (m? , sn , receipt)) = case check receipt of λ { (just x) → accept ; nothing → reject }

    newBB : Q → BB
    newBB (Vote (m? , sn , receipt)) = case check receipt of λ { (just x) → (m? , sn , x) ∷ bb ; nothing → bb }
    newBB _ = bb

PhaseNumber = 𝟚
module EXP (b : 𝟚) (A : Adversary) (pk : PubKey) (sk : SecKey)
           (rₐ : Rₐ) (rgb : Candidate → Rgb)
           (v : PhaseNumber → Vec Rgb #q) where
  BBsetup : BB
  BBsetup = []

  Aphase[I] : Phase _
  Aphase[I] = A rₐ pk

  S = BB × Fin #q

  -- When the adversary runs out of allowed queries (namely
  -- when i becomes zero), then all successive queries will
  -- be deterministic. The only case asking for randomness
  -- is ballot creation.
  OracleS : (phase# : 𝟚) (q : Q) → State S (Resp q)
  OracleS phase# q (bb , i) = O.resp q , O.newBB q , Fin.pred i
    where module O = Oracle sk pk (lookup i (v phase#)) bb

  phase[I] = runS (OracleS 0₂) Aphase[I] (BBsetup , max#q)

  AdversaryRFChallenge : RFChallenge _
  AdversaryRFChallenge = proj₁ phase[I]

  BBphase[I] : BB
  BBphase[I] = proj₁ (proj₂ phase[I])

  ballots : Candidate → Ballot checked
  ballots c = fillBallot c (genBallot pk (rgb c))

  ballot-for-alice = ballots alice
  ballot-for-bob   = ballots bob

  randomly-swapped-ballots : Candidate → Ballot checked
  randomly-swapped-ballots = ballots ∘ _xor_ b

  randomly-swapped-receipts : Candidate → Receipt checked
  randomly-swapped-receipts = receipt ∘ randomly-swapped-ballots

  BBrfc : BB
  BBrfc = randomly-swapped-receipts 0₂ ∷ randomly-swapped-receipts 1₂ ∷ BBphase[I]

  Aphase[II] : Phase _
  Aphase[II] = AdversaryRFChallenge randomly-swapped-receipts

  phase[II] = runS (OracleS 1₂) Aphase[II] (BBrfc , max#q)

  -- adversary guess
  b′ = proj₁ phase[II]

_² : ★ → ★
A ² = A × A

R : ★
R = Rₖ × Rₐ × 𝟚 × (Vec Rgb (1{-for the challenge-} + #q))²

game : Adversary → R → 𝟚
game A (rₖ , rₐ , b , (rgb₀ ∷ rgbs₀) , (rgb₁ ∷ rgbs₁)) =
  case KeyGen rₖ of λ
  { (pk , sk) →
    b == EXP.b′ b A pk sk rₐ [0: rgb₀ 1: rgb₁ ] [0: rgbs₀ 1: rgbs₁ ]
  }

-- Winning condition
Win : Adversary → R → ★
Win A r = game A r ≡ 1₂

{- Not all adversaries of the Adversary type are valid.

   First, we do not forbid the challenge in the 2nd step of the Oracle.
   Second, no complexity analysis is done.
-}

module Cheating1 where
    cheatingA : Adversary
    cheatingA rₐ pk = done (λ m → ask (RCO (m 1₂)) (λ co → done (co == (marked-on-second-cell? (markedReceipt? (m 1₂))))))

    module _
     (DecEnc : ∀ rₖ rₑ m → let (pk , sk) = KeyGen rₖ in
                           Dec sk (Enc pk m rₑ) ≡ m) where

        cheatingA-wins : ∀ r → game cheatingA r ≡ 1₂
        cheatingA-wins (rₖ , _ , 0₂ , ((co₀ , _ , rₑ₀) ∷ _) , ((co₁ , _ , rₑ₁) ∷ _))
          rewrite DecEnc rₖ rₑ₁ co₁ with co₁
        ... | 0₂ = refl
        ... | 1₂ = refl
        cheatingA-wins (rₖ , _ , 1₂ , ((co₀ , _ , rₑ₀) ∷ _) , ((_ , _ , rₑ₁) ∷ _))
          rewrite DecEnc rₖ rₑ₀ co₀ with co₀
        ... | 0₂ = refl
        ... | 1₂ = refl

module Cheating2 where
    cheatingA : Adversary
    cheatingA rₐ pk = done λ m → ask (Vote (forgetReceipt (m 1₂)))
                                     (λ { accept → ask RTally (λ { (x , y) →
                                     done (x ==ℕ 2) }) ; reject → done 1₂ })

    module _
     (DecEnc : ∀ rₖ rₑ m → let (pk , sk) = KeyGen rₖ in
                           Dec sk (Enc pk m rₑ) ≡ m)
     (check-forget : ∀ x → check (forget x) ≡ just x)
                       where

        cheatingA-wins : ∀ r → game cheatingA r ≡ 1₂
        cheatingA-wins (rₖ , _ , 0₂ , ((co₀ , _ , rₑ₀) ∷ _) , ((co₁ , _ , rₑ₁) ∷ _))
           rewrite check-forget (Enc (proj₁ (KeyGen rₖ)) co₁ rₑ₁)
                 | DecEnc rₖ rₑ₀ co₀
                 | DecEnc rₖ rₑ₁ co₁ with co₀ | co₁
        ... | 0₂ | 0₂ = refl
        ... | 0₂ | 1₂ = refl
        ... | 1₂ | 0₂ = refl
        ... | 1₂ | 1₂ = refl
        cheatingA-wins (rₖ , _ , 1₂ , ((co₀ , _ , rₑ₀) ∷ _) , ((co₁ , _ , rₑ₁) ∷ _)) -- = {!!}
           rewrite check-forget (Enc (proj₁ (KeyGen rₖ)) co₀ rₑ₀)
                 | DecEnc rₖ rₑ₀ co₀
                 | DecEnc rₖ rₑ₁ co₁ with co₀ | co₁
        ... | 0₂ | 0₂ = refl
        ... | 0₂ | 1₂ = refl
        ... | 1₂ | 0₂ = refl
        ... | 1₂ | 1₂ = refl
-- -}
-- -}
-- -}
-- -}

-- {-# OPTIONS --without-K #-}

open import Function
open import Type
open import Data.Maybe
open import Data.Fin.NP as Fin hiding (_+_; _==_)
open import Data.Product renaming (zip to zip-×)
open import Data.One
open import Data.Two
open import Data.Vec
open import Data.List as L

open import Data.Nat.NP renaming (_==_ to _==ℕ_)

{-
open import Explore.Core
open import Explore.Explorable
open import Explore.Product
open Operators
-}
open import Relation.Binary.PropositionalEquality
--open import Control.Strategy renaming (run to runStrategy)

module Game.ReceiptFreeness
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : ★)
  (CheckedCipherText : ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (#q : ℕ) (max#q : Fin #q)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CheckedCipherText)
  (forget : CheckedCipherText → CipherText)
  (check  : CipherText → Maybe CheckedCipherText)
  (Dec    : let Message = 𝟚 in
            SecKey → CheckedCipherText → Message)

where

data Strategy (Q : ★) (R : Q → ★) (A : ★) : ★ where
  ask  : (q? : Q) (cont : R q? → Strategy Q R A) → Strategy Q R A
  done : A → Strategy Q R A

module _ {Q : ★} {R : Q → ★} (Oracle : (q : Q) → R q) where
  private
    M = Strategy Q R
  run : ∀ {A} → M A → A
  run (ask q? cont) = run (cont (Oracle q?))
  run (done x)      = x

State : (S A : ★) → ★
State S A = S → A × S

module _ {S Q : ★} {R : Q → ★} (Oracle : (q : Q) → State S (R q)) where
  private
    M = Strategy Q R
  runS : ∀ {A} → M A → State S A
  runS (ask q? cont) s = case Oracle q? s of λ { (x , s') → runS (cont x) s' }
  runS (done x)      s = x , s

  evalS : ∀ {A} → M A → S → A
  evalS x s = proj₁ (runS x s)

  execS : ∀ {A} → M A → S → S
  execS x s = proj₂ (runS x s)

Candidate : ★
Candidate = 𝟚 -- as in the paper: "for simplicity"

alice bob : Candidate
alice = 0₂
bob   = 1₂

-- candidate order
-- also known as LHS or Message
-- represented by who is the first candidate
CO : ★
CO = 𝟚

alice-then-bob bob-then-alice : CO
alice-then-bob = 0₂
bob-then-alice = 1₂

data CO-spec : CO → Candidate → Candidate → ★ where
  alice-then-bob-spec : CO-spec alice-then-bob alice bob
  bob-then-alice-spec : CO-spec bob-then-alice bob alice

MarkedRHS : ★
MarkedRHS = 𝟚

marked-on-first-cell marked-on-second-cell : MarkedRHS
marked-on-first-cell  = 0₂
marked-on-second-cell = 1₂

data MarkedRHS-spec : MarkedRHS → ★ where
  marked-on-first-cell-spec  : MarkedRHS-spec marked-on-first-cell
  marked-on-second-cell-spec : MarkedRHS-spec marked-on-second-cell

-- CipherText is the encrypted candidate order
Receipt : ★
Receipt = SerialNumber × CipherText

CheckedReceipt : ★
CheckedReceipt = SerialNumber × CheckedCipherText

forgetReceipt : CheckedReceipt → Receipt
forgetReceipt (sn , encCO) = sn , forget encCO

data MarkedRHS? : ★ where
  not-marked : MarkedRHS?
  marked     : MarkedRHS → MarkedRHS?

RHS : ★
RHS = Receipt × MarkedRHS?

CheckedRHS : ★
CheckedRHS = CheckedReceipt × MarkedRHS?

receipt : RHS → Receipt
receipt = proj₁

markedRHS? : RHS → MarkedRHS?
markedRHS? = proj₂

-- Marked when there is a 1
marked? : MarkedRHS? → 𝟚
marked? not-marked = 0₂
marked? (marked _) = 1₂

marked-on-first-cell? : MarkedRHS? → 𝟚
marked-on-first-cell? not-marked = 0₂
marked-on-first-cell? (marked x) = x == 0₂

marked-on-second-cell? : MarkedRHS? → 𝟚
marked-on-second-cell? not-marked = 0₂
marked-on-second-cell? (marked x) = x == 1₂

Ballot : ★
Ballot = CO × RHS

-- unused
CheckedBallot : ★
CheckedBallot = CO × CheckedRHS

-- randomness for genBallot
Rgb : ★
Rgb = CO × SerialNumber × Rₑ

genBallot : PubKey → Rgb → Ballot
genBallot pk (rCO , sn , rₑ) = rCO , (sn , forget (Enc pk rCO rₑ)) , not-marked

lhs : Ballot → CO
lhs = proj₁

rhs : Ballot → RHS
rhs = proj₂

BB : ★
BB = List CheckedRHS

Tally : ★
Tally = ℕ × ℕ

alice-score : Tally → ℕ
alice-score = proj₁

bob-score : Tally → ℕ
bob-score = proj₂

data Accept? : ★ where
  accept reject : Accept?

-- In the paper RBB is the returning the Tally and we
-- return the BB, here RTally is returning the Tally
data Q : ★ where
  REB RBB RTally : Q
  RCO            : CheckedRHS → Q
  Vote           : RHS → Q

Resp : Q → ★
Resp REB = Ballot
Resp (RCO x) = CO
Resp (Vote x) = Accept?
Resp RBB = BB
Resp RTally = Tally

Phase : ★ → ★
Phase = Strategy Q Resp

-- How to read types as protocols:
-- A × B   sends A, then behave as B
-- A → B   receives A, then behave as B

RFChallenge : ★ → ★
RFChallenge Next = (𝟚 → CheckedReceipt) → Next

Adversary : ★
Adversary = Rₐ → PubKey → Phase -- Phase[I]
                           (RFChallenge
                             (Phase -- Phase[II]
                               𝟚)) -- Adversary guess of whether the vote is for alice

-- TODO adversary validity

1:alice-0:bob 0:alice-1:bob : Tally
1:alice-0:bob = 1 , 0
0:alice-1:bob = 0 , 1

data TallyMarkedRHS-spec : CO → MarkedRHS → Tally → ★ where
  c1 : TallyMarkedRHS-spec alice-then-bob marked-on-first-cell  1:alice-0:bob
  c2 : TallyMarkedRHS-spec alice-then-bob marked-on-second-cell 0:alice-1:bob
  c3 : TallyMarkedRHS-spec bob-then-alice marked-on-first-cell  0:alice-1:bob
  c4 : TallyMarkedRHS-spec bob-then-alice marked-on-second-cell 1:alice-0:bob

tallyMarkedRHS : CO → MarkedRHS → Tally
tallyMarkedRHS co m = 𝟚▹ℕ for-alice , 𝟚▹ℕ (not for-alice)
  where for-alice = co == m

tallyMarkedRHS-ok : ∀ co m → TallyMarkedRHS-spec co m (tallyMarkedRHS co m)
tallyMarkedRHS-ok 1₂ 1₂ = c4
tallyMarkedRHS-ok 1₂ 0₂ = c3
tallyMarkedRHS-ok 0₂ 1₂ = c2
tallyMarkedRHS-ok 0₂ 0₂ = c1

tallyCheckedRHS : SecKey → CheckedRHS → Tally
tallyCheckedRHS sk (_ , not-marked) = 0 , 0
tallyCheckedRHS sk ((_ , encCO) , marked mark) = tallyMarkedRHS (Dec sk encCO) mark

-- Not taking advantage of any homomorphic encryption
tally : SecKey → BB → Tally
tally sk bb = L.foldr (zip-× _+_ _+_) (0 , 0) (L.map (tallyCheckedRHS sk) bb)

module _ (sk : SecKey) (pk : PubKey) (rgb : Rgb) (bb : BB) where
    Oracle : (q : Q) → Resp q
    Oracle REB = genBallot pk rgb
    Oracle RBB = bb
    Oracle RTally = tally sk bb
    Oracle (RCO ((_ , receipt) , _)) = Dec sk receipt
    -- do we check if the sn is already here?
    Oracle (Vote ((sn , receipt) , m?)) = case check receipt of λ { (just x) → accept ; nothing → reject }

    OracleBB : Q → BB
    OracleBB REB = bb
    OracleBB RBB = bb
    OracleBB RTally = bb
    OracleBB (RCO _) = bb
    OracleBB (Vote ((sn , receipt) , m?)) = case check receipt of λ { (just x) → ((sn , x) , m?) ∷ bb ; nothing → bb }

module EXP (b : 𝟚) (A : Adversary) (pk : PubKey) (sk : SecKey)
           (rₐ : Rₐ) (crₑ : 𝟚 → Rₑ) (csn : 𝟚 → SerialNumber)
           (v : 𝟚 → Vec Rgb #q) where
  BBsetup : BB
  BBsetup = []

  Aphase[I] : Phase _
  Aphase[I] = A rₐ pk

  S = BB × Fin #q

  OracleS : (phase# : 𝟚) (q : Q) → State S (Resp q)
  OracleS phase# q (bb , i) = Oracle sk pk rgb bb q , OracleBB sk pk rgb bb q , Fin.pred i
    where rgb = lookup i (v phase#)

  phase[I] = runS (OracleS 0₂) Aphase[I] (BBsetup , max#q)

  ARFChallenge : RFChallenge _
  ARFChallenge = proj₁ phase[I]

  BBphase[I] : BB
  BBphase[I] = proj₁ (proj₂ phase[I])

  Aphase[II] : Phase _
  Aphase[II] = ARFChallenge (λ i → csn i , Enc pk (i == b) (crₑ i))

  phase[II] = runS (OracleS 1₂) Aphase[II] (BBphase[I] , max#q)

  -- adversary guess
  b′ = proj₁ phase[II]

_² : ★ → ★
A ² = A × A

R : ★
R = Rₖ × Rₐ × 𝟚 × (Rₑ × SerialNumber × Vec Rgb #q)²

game : Adversary → R → 𝟚
game A (rₖ , rₐ , b , (rₑ₀ , sn₀ , rgbs₀) , (rₑ₁ , sn₁ , rgbs₁)) =
  case KeyGen rₖ of λ
  { (pk , sk) →
    b == EXP.b′ b A pk sk rₐ [0: rₑ₀ 1: rₑ₁ ] [0: sn₀ 1: sn₁ ] [0: rgbs₀ 1: rgbs₁ ]
  }

-- Winning condition
Win : Adversary → R → ★
Win A r = game A r ≡ 1₂

{- Not all adversaries of the Adversary type are valid.

   First, we do not forbid the challenge in the 2nd step of the Oracle.
   Second, no complexity analysis is done.
-}

module Cheating1 where
    cheatingA : Adversary
    cheatingA rₐ pk = done (λ m → ask (RCO (m 1₂ , marked 1₂)) done)

    module _
     (DecEnc : ∀ rₖ rₑ m → let (pk , sk) = KeyGen rₖ in
                           Dec sk (Enc pk m rₑ) ≡ m) where

        cheatingA-wins : ∀ r → game cheatingA r ≡ 1₂
        cheatingA-wins (rₖ , _ , b , (rₑ₀ , _) , (rₑ₁ , _))
          rewrite DecEnc rₖ rₑ₀ b | DecEnc rₖ rₑ₁ b = ✓→≡ (==-refl {b})

module Cheating2 where
    cheatingA : Adversary
    cheatingA rₐ pk = done λ m → ask (Vote (forgetReceipt (m 1₂) , marked 1₂))
                                     (λ { accept → ask RTally (λ { (x , y) →
                                     done (x ==ℕ 1) }) ; reject → done 1₂ })

    module _
     (DecEnc : ∀ rₖ rₑ m → let (pk , sk) = KeyGen rₖ in
                           Dec sk (Enc pk m rₑ) ≡ m)
     (check-forget : ∀ x → check (forget x) ≡ just x)
                       where

        cheatingA-wins : ∀ r → game cheatingA r ≡ 1₂
        cheatingA-wins (rₖ , rₐ , b , (rₑ₀ , proj₂) , rₑ₁ , proj₃)
           rewrite check-forget (Enc (proj₁ (KeyGen rₖ)) b rₑ₁)
                 | DecEnc rₖ rₑ₁ b with b
        ... | 0₂ = {!!}
        ... | 1₂ = {!!}
                 {-
        cheatingA-wins (rₖ , rₐ , 1₂ , (rₑ₀ , proj₂) , rₑ₁ , proj₃)
           rewrite check-forget (Enc (proj₁ (KeyGen rₖ)) 1₂ rₑ₁)
                 | DecEnc rₖ rₑ₁ 1₂ = refl
        cheatingA-wins (rₖ , rₐ , 0₂ , (rₑ₀ , proj₂) , rₑ₁ , proj₃)
           rewrite check-forget (Enc (proj₁ (KeyGen rₖ)) 0₂ rₑ₁)
                 | DecEnc rₖ rₑ₁ 0₂ = refl
-- -}
-- -}
-- -}
-- -}


Organize imports.

Organize imports.

Old-commit-hash: 3a650cd7e771b0a7c77cdd494a648adcc4b57fa5

module Denotational.Equivalence where

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Nullary using (¬_)

open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality

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

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total

open import Changes
open import ChangeContexts

-- TERMS

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext-t :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext-t (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext-t ≈) = ext-t (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open import Relation.Binary.EqReasoning (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()

module Denotational.Equivalence where

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Nullary using (¬_)

open import Relation.Binary.PropositionalEquality as P
open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

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

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total

open import Changes
open import ChangeContexts

-- TERMS

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext-t :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext-t (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext-t ≈) = ext-t (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open EqR (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()


Removed non FOL schemata.

Removed non FOL schemata.

Ignore-this: c3dec63812f856a7e0919b463a09088

darcs-hash:20120429184726-3bd4e-4d1aaa5d3be0a981adafeb32fdfa611f65d1b48e.gz

------------------------------------------------------------------------------
-- Examples of translation of logical schemata
------------------------------------------------------------------------------

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

module FOL.SchemataATP where

open import FOL.Base

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

postulate _≡_ : D → D → Set

module NonSchemas where

  postulate
    A B C    : Set
    A¹       : D → Set
    A² B²    : D → D → Set
    A³ B³ C³ : D → D → D → Set

  postulate id : A → A
  {-# ATP prove id #-}

  postulate id¹ : ∀ {x} → A¹ x → A¹ x
  {-# ATP prove id¹ #-}

  postulate id² : ∀ {x y} → A² x y → A² x y
  {-# ATP prove id² #-}

  postulate ∨-comm : A ∨ B → B ∨ A
  {-# ATP prove ∨-comm #-}

  postulate ∨-comm² : ∀ {x y} → A² x y ∨ B² x y → B² x y ∨ A² x y
  {-# ATP prove ∨-comm² #-}

  postulate ∧∨-dist : A ∧ (B ∨ C) ↔ A ∧ B ∨ A ∧ C
  {-# ATP prove ∧∨-dist #-}

  postulate
    ∧∨-dist³ : ∀ {x y z} →
               (A³ x y z ∧ (B³ x y z ∨ C³ x y z )) ↔
               (A³ x y z ∧ B³ x y z ∨ A³ x y z ∧ C³ x y z)
  {-# ATP prove ∧∨-dist³ #-}

module Schemas where

  postulate id : {A : Set} → A → A
  {-# ATP prove id #-}

  postulate id¹ : {A¹ : D → Set} → ∀ {x} → A¹ x → A¹ x
  {-# ATP prove id¹ #-}

  postulate id² : {A² : D → D → Set} → ∀ {x y} → A² x y → A² x y
  {-# ATP prove id² #-}

  postulate ∨-comm : {A B : Set} → A ∨ B → A ∨ B
  {-# ATP prove ∨-comm #-}

  postulate
    ∨-comm² : {A² B² : D → D → Set} → ∀ {x y} →
              A² x y ∨ B² x y → B² x y ∨ A² x y
  {-# ATP prove ∨-comm² #-}

  postulate ∧∨-dist : {A B C : Set} → A ∧ (B ∨ C) ↔ A ∧ B ∨ A ∧ C
  {-# ATP prove ∧∨-dist #-}

  postulate
    ∧∨-dist³ : {A³ B³ C³ : D → D → D → Set} → ∀ {x y z} →
               (A³ x y z ∧ (B³ x y z ∨ C³ x y z)) ↔
               (A³ x y z ∧ B³ x y z ∨ A³ x y z ∧ C³ x y z)
  {-# ATP prove ∧∨-dist³ #-}

module SchemaInstances where

  -- A schema
  -- Current translation: ∀ p q x. app(p,x) → app(q,x).
  postulate schema : (A B : D → Set) → ∀ {x} → A x → B x

  -- Using the current translation, the ATPs can prove an instance of
  -- the schema.
  postulate
    d         : D
    A B       : D → Set
    instanceC : A d → B d
  {-# ATP prove instanceC schema #-}

------------------------------------------------------------------------------
-- Examples of translation of logical schemata
------------------------------------------------------------------------------

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

module FOL.SchemataATP where

open import FOL.Base

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

postulate _≡_ : D → D → Set

module NonSchemas where

  postulate
    A B C    : Set
    A¹       : D → Set
    A² B²    : D → D → Set
    A³ B³ C³ : D → D → D → Set
    f¹       : D → D
    f²       : D → D → D
    f³       : D → D → D → D

  postulate f¹-refl : ∀ x → f¹ x ≡ f¹ x
  {-# ATP prove f¹-refl #-}

  postulate f²-refl : ∀ x y → f² x y ≡ f² x y
  {-# ATP prove f²-refl #-}

  postulate f³-refl : ∀ x y z  → f³ x y z ≡ f³ x y z
  {-# ATP prove f³-refl #-}

  postulate id : A → A
  {-# ATP prove id #-}

  postulate id¹ : ∀ {x} → A¹ x → A¹ x
  {-# ATP prove id¹ #-}

  postulate id² : ∀ {x y} → A² x y → A² x y
  {-# ATP prove id² #-}

  postulate ∨-comm : A ∨ B → B ∨ A
  {-# ATP prove ∨-comm #-}

  postulate ∨-comm² : ∀ {x y} → A² x y ∨ B² x y → B² x y ∨ A² x y
  {-# ATP prove ∨-comm² #-}

  postulate ∧∨-dist : A ∧ (B ∨ C) ↔ A ∧ B ∨ A ∧ C
  {-# ATP prove ∧∨-dist #-}

  postulate
    ∧∨-dist³ : ∀ {x y z} →
               (A³ x y z ∧ (B³ x y z ∨ C³ x y z )) ↔
               (A³ x y z ∧ B³ x y z ∨ A³ x y z ∧ C³ x y z)
  {-# ATP prove ∧∨-dist³ #-}

module Schemas where

  postulate f¹-refl : (f¹ : D → D) → ∀ x → f¹ x ≡ f¹ x
  {-# ATP prove f¹-refl #-}

  postulate f²-refl : (f² : D → D → D) → ∀ x y → f² x y ≡ f² x y
  {-# ATP prove f²-refl #-}

  postulate f³-refl : (f³ : D → D → D → D) → ∀ x y z → f³ x y z ≡ f³ x y z
  {-# ATP prove f³-refl #-}

  postulate id : {A : Set} → A → A
  {-# ATP prove id #-}

  postulate id¹ : {A¹ : D → Set} → ∀ {x} → A¹ x → A¹ x
  {-# ATP prove id¹ #-}

  postulate id² : {A² : D → D → Set} → ∀ {x y} → A² x y → A² x y
  {-# ATP prove id² #-}

  postulate ∨-comm : {A B : Set} → A ∨ B → A ∨ B
  {-# ATP prove ∨-comm #-}

  postulate
    ∨-comm² : {A² B² : D → D → Set} → ∀ {x y} →
              A² x y ∨ B² x y → B² x y ∨ A² x y
  {-# ATP prove ∨-comm² #-}

  postulate ∧∨-dist : {A B C : Set} → A ∧ (B ∨ C) ↔ A ∧ B ∨ A ∧ C
  {-# ATP prove ∧∨-dist #-}

  postulate
    ∧∨-dist³ : {A³ B³ C³ : D → D → D → Set} → ∀ {x y z} →
               (A³ x y z ∧ (B³ x y z ∨ C³ x y z)) ↔
               (A³ x y z ∧ B³ x y z ∨ A³ x y z ∧ C³ x y z)
  {-# ATP prove ∧∨-dist³ #-}

module SchemaInstances where

  -- A schema
  -- Current translation: ∀ p q x. app(p,x) → app(q,x).
  postulate schema : (A B : D → Set) → ∀ {x} → A x → B x

  -- Using the current translation, the ATPs can prove an instance of
  -- the schema.
  postulate
    d         : D
    A B       : D → Set
    instanceC : A d → B d
  {-# ATP prove instanceC schema #-}


FunUniverse.Fin: add finCat

FunUniverse.Fin: add finCat

{-# OPTIONS --without-K #-}
module FunUniverse.Fin where

open import Type
open import Function
open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

open import FunUniverse.Data
open import FunUniverse.Core
open import FunUniverse.Category
open import FunUniverse.Rewiring.Linear

_→ᶠ_ : ℕ → ℕ → ★
_→ᶠ_ i o = Fin i → Fin o

finFunU : FunUniverse ℕ
finFunU = Fin-U , _→ᶠ_

module FinFunUniverse = FunUniverse finFunU

finCat : Category _→ᶠ_
finCat = id , _∘′_

{-
finLin : LinRewiring finFunU
finLin = mk finCat {!!} {!!} {!!} {!!} {!!} {!!} {!!} {!!} {!!} {!!} {!!}
-}

{-# OPTIONS --without-K #-}
module FunUniverse.Fin where

open import Type
open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)

open import FunUniverse.Data
open import FunUniverse.Core

_→ᶠ_ : ℕ → ℕ → ★
_→ᶠ_ i o = Fin i → Fin o

finFunU : FunUniverse ℕ
finFunU = Fin-U , _→ᶠ_

module FinFunUniverse = FunUniverse finFunU


agda: comment fix

agda: comment fix

Old-commit-hash: d5ff611d7aaf67a4b7821fedb255e43d07c53504

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

-- The formalization is split across the following files.
-- TODO: document them more.

-- Note that we use two postulates currently:

-- 1. function extensionality (in
--    `Denotational.ExtensionalityPostulate`), known to be consistent
--    with intensional type theory.
--
-- 2. Temporarily, we use `diff-apply` as a postulate, which is only
--    true in a slightly weaker form, `diff-apply-proof` - we are
--    adapting the proofs to use the latter.

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

open import Denotational.Notation
open import Denotational.Values
open import Denotational.ExtensionalityPostulate
open import Denotational.EqualityLemmas
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence
open import Denotational.ValidChanges

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- This finishes the correctness proof of the above work.
open import total

-- EXAMPLES

open import Examples.Examples1

-- NATURAL semantics

open import Syntactic.Closures
open import Denotational.Closures

open import Natural.Lookup
open import Natural.Evaluation

open import Natural.Soundness

-- Other calculi

open import partial
open import lambda

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

-- The formalization is split across the following files.

-- Note that we use two postulates currently:

-- 1. function extensionality (in
--    `Denotational.ExtensionalityPostulate`), known to be consistent
--    with intensional type theory.
--
-- 2. Temporarily, we use `diff-apply` as a postulate, which is only
--    true in a slightly weaker form, `diff-apply-proof` - we are
--    adapting the proofs to use the latter.

-- TODO: document them more.

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

open import Denotational.Notation
open import Denotational.Values
open import Denotational.ExtensionalityPostulate
open import Denotational.EqualityLemmas
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence
open import Denotational.ValidChanges

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- This finishes the correctness proof of the above work.
open import total

-- EXAMPLES

open import Examples.Examples1

-- NATURAL semantics

open import Syntactic.Closures
open import Denotational.Closures

open import Natural.Lookup
open import Natural.Evaluation

open import Natural.Soundness

-- Other calculi

open import partial
open import lambda


README import prg

README import prg

module README where

open import prg

open import composition-sem-sec-reduction

open import one-time-semantic-security

open import Data.Bits

open import data-universe
open import fun-universe
open import agda-fun-universe
open import bits-fun-universe
open import fin-fun-universe
open import const-fun-universe
open import cost-fun-universe

-- Fix & restore the product of universes and ops

open import program-distance

open import flipbased
open import flipbased-implem
open import flipbased-tree

open import bit-guessing-game

open import circuit

module README where

open import composition-sem-sec-reduction

open import one-time-semantic-security

open import Data.Bits

open import data-universe
open import fun-universe
open import agda-fun-universe
open import bits-fun-universe
open import fin-fun-universe
open import const-fun-universe
open import cost-fun-universe

-- Fix & restore the product of universes and ops

open import program-distance

open import flipbased
open import flipbased-implem
open import flipbased-tree

open import bit-guessing-game

open import circuit


Manually reorder imports in README.agda

Manually reorder imports in README.agda

Debatable, but I don't like that the imports are de facto randomized
anyway. README.agda shouldn't be generated.

Old-commit-hash: d718d74f6eb82413aef66792cd10b570ec84c25a

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * multiple calculi

import Syntax.Constant.Popl14
import Syntax.Context.Plotkin
import Syntax.Context.Popl14
import Syntax.Context
import Syntax.DeltaContext
import Syntax.Derive.Canon-Popl14
import Syntax.Derive.Optimized-Popl14
import Syntax.FreeVars.Popl14
{- Language definition of Calc. Atlas -}
import Syntax.Language.Atlas
import Syntax.Language.Calculus
import Syntax.Language.Popl14
{- Terms of a calculus described in Plotkin style
  - types are parametric in base types
  - terms are parametric in constants
  This style of language description is employed in:
  G. D. Plotkin. "LCF considered as a programming language."
  Theoretical Computer Science 5(3) pp. 223--255, 1997.
  http://dx.doi.org/10.1016/0304-3975(77)90044-5 -}
import Syntax.Term.Plotkin
import Syntax.Term.Popl14
import Syntax.Type.Atlas
import Syntax.Type.Plotkin
import Syntax.Type.Popl14
import Syntax.Vars

import Denotation.Change.Popl14
{- Correctness theorem for canonical derivation of Calc. Popl14 -}
import Denotation.Derive.Canon-Popl14
{- Correctness theorem for optimized derivation of Calc. Popl14 -}
import Denotation.Derive.Optimized-Popl14
import Denotation.Environment.Popl14
import Denotation.Environment
import Denotation.Evaluation.Popl14
import Denotation.FreeVars.Popl14
{- The idea of implementing a denotational specification for Calc. Popl14 -}
import Denotation.Implementation.Popl14
import Denotation.Notation
{- Denotation-as-specification for canonical derivation of Calc. Popl14 -}
import Denotation.Specification.Canon-Popl14
import Denotation.Specification.Optimized-Popl14
import Denotation.Value.Popl14
import experimental.DecidableEq
import experimental.FoldableBag
import experimental.FoldableBagParametric
import experimental.NormalizationByEvaluation
import experimental.OrdBag
import experimental.Sorting
import Postulate.Bag-Popl14
import Postulate.Extensionality
import Property.Uniqueness
import Structure.Bag.Popl14
import Structure.Tuples

import Theorem.CongApp
import Theorem.EqualityUnique
import Theorem.Groups-Popl14
import Theorem.IrrelevanceUnique-Popl14
import Theorem.ProductUnique
import Theorem.ValidityUnique-Popl14
import UNDEFINED

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * multiple calculi

import Denotation.Change.Popl14
{- Correctness theorem for canonical derivation of Calc. Popl14 -}
import Denotation.Derive.Canon-Popl14
{- Correctness theorem for optimized derivation of Calc. Popl14 -}
import Denotation.Derive.Optimized-Popl14
import Denotation.Environment.Popl14
import Denotation.Environment
import Denotation.Evaluation.Popl14
import Denotation.FreeVars.Popl14
{- The idea of implementing a denotational specification for Calc. Popl14 -}
import Denotation.Implementation.Popl14
import Denotation.Notation
{- Denotation-as-specification for canonical derivation of Calc. Popl14 -}
import Denotation.Specification.Canon-Popl14
import Denotation.Specification.Optimized-Popl14
import Denotation.Value.Popl14
import experimental.DecidableEq
import experimental.FoldableBag
import experimental.FoldableBagParametric
import experimental.NormalizationByEvaluation
import experimental.OrdBag
import experimental.Sorting
import Postulate.Bag-Popl14
import Postulate.Extensionality
import Property.Uniqueness
import Structure.Bag.Popl14
import Structure.Tuples
import Syntax.Constant.Popl14
import Syntax.Context.Plotkin
import Syntax.Context.Popl14
import Syntax.Context
import Syntax.DeltaContext
import Syntax.Derive.Canon-Popl14
import Syntax.Derive.Optimized-Popl14
import Syntax.FreeVars.Popl14
{- Language definition of Calc. Atlas -}
import Syntax.Language.Atlas
import Syntax.Language.Calculus
import Syntax.Language.Popl14
{- Terms of a calculus described in Plotkin style
  - types are parametric in base types
  - terms are parametric in constants
  This style of language description is employed in:
  G. D. Plotkin. "LCF considered as a programming language."
  Theoretical Computer Science 5(3) pp. 223--255, 1997.
  http://dx.doi.org/10.1016/0304-3975(77)90044-5 -}
import Syntax.Term.Plotkin
import Syntax.Term.Popl14
import Syntax.Type.Atlas
import Syntax.Type.Plotkin
import Syntax.Type.Popl14
import Syntax.Vars
import Theorem.CongApp
import Theorem.EqualityUnique
import Theorem.Groups-Popl14
import Theorem.IrrelevanceUnique-Popl14
import Theorem.ProductUnique
import Theorem.ValidityUnique-Popl14
import UNDEFINED


Prepare for using ≈-Reasoning to prove derive-term-correct (see #25).

Old-commit-hash: b0ca315e1dcaa44e39fdfa67bb29e1da512641a6

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

open import Relation.Binary.PropositionalEquality

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

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence
open import Denotational.ValidChanges

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → (t : Term Γ₁ τ) →
  Δ {{Γ′}} t ≈ derive-term {{Γ′}} t
derive-term-correct {Γ₁} {{Γ′}} (abs {τ} t) =
  begin
     Δ (abs t)
  ≈⟨  Δ-abs t  ⟩
     abs (abs (Δ {τ • Γ₁} t))
  ≈⟨  ≈-abs (≈-abs (derive-term-correct {τ • Γ₁} t))  ⟩
     abs (abs (derive-term {τ • Γ₁} t))
  ≡⟨⟩
     derive-term (abs t)
  ∎ where
      open ≈-Reasoning
      Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term-correct {Γ₁} {{Γ′}} (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨  Δ-app t₁ t₂  ⟩
     app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
  ≈⟨  ≈-app (≈-app (derive-term-correct {{Γ′}} t₁) ≈-refl) (derive-term-correct {{Γ′}} t₂)  ⟩
     app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
  ≡⟨⟩
    derive-term {{Γ′}} (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct {Γ₁} {{Γ′}} (var x) = ext-t (λ ρ →
  begin
    ⟦ Δ {{Γ′}} (var x) ⟧ ρ
  ≡⟨⟩
    diff
      (⟦ x ⟧ (update (⟦ Γ′ ⟧ ρ)))
      (⟦ x ⟧ (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨  derive-var-correct {Γ₁} (⟦ Γ′ ⟧ ρ) x  ⟩
    ⟦ derive-var x ⟧Var (⟦ Γ′ ⟧ ρ)
  ≡⟨ sym (lift-sound Γ′ (derive-var x) ρ) ⟩
    ⟦ lift Γ′ (derive-var x) ⟧Var ρ
  ∎) where open ≡-Reasoning
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct {{Γ′}} (if t₁ t₂ t₃) =
  begin
    Δ (if t₁ t₂ t₃)
  ≈⟨ {!!} ⟩
    if (derive-term t₁ and lift-term {{Γ′}} t₁)
       (diff-term
         (apply-term (derive-term t₃)
         (lift-term {{Γ′}} t₃)) (lift-term {{Γ′}} t₂))
       (if (derive-term t₁ and (lift-term {{Γ′}} (! t₁)))
           (diff-term
             (apply-term (derive-term t₂)
             (lift-term {{Γ′}} t₂)) (lift-term {{Γ′}} t₃))
           (if (lift-term {{Γ′}} t₁)
             (derive-term t₂)
             (derive-term t₃)))
  ≡⟨⟩
    derive-term {{Γ′}} (if t₁ t₂ t₃)
  ∎ where open ≈-Reasoning

derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

open import Relation.Binary.PropositionalEquality

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

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Equivalence
open import Denotational.ValidChanges

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → (t : Term Γ₁ τ) →
  Δ {{Γ′}} t ≈ derive-term {{Γ′}} t
derive-term-correct {Γ₁} {{Γ′}} (abs {τ} t) =
  begin
     Δ (abs t)
  ≈⟨  Δ-abs t  ⟩
     abs (abs (Δ {τ • Γ₁} t))
  ≈⟨  ≈-abs (≈-abs (derive-term-correct {τ • Γ₁} t))  ⟩
     abs (abs (derive-term {τ • Γ₁} t))
  ≡⟨⟩
     derive-term (abs t)
  ∎ where
      open ≈-Reasoning
      Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term-correct {Γ₁} {{Γ′}} (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨  Δ-app t₁ t₂  ⟩
     app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
  ≈⟨  ≈-app (≈-app (derive-term-correct {{Γ′}} t₁) ≈-refl) (derive-term-correct {{Γ′}} t₂)  ⟩
     app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
  ≡⟨⟩
    derive-term {{Γ′}} (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct {Γ₁} {{Γ′}} (var x) = ext-t (λ ρ →
  begin
    ⟦ Δ {{Γ′}} (var x) ⟧ ρ
  ≡⟨⟩
    diff
      (⟦ x ⟧ (update (⟦ Γ′ ⟧ ρ)))
      (⟦ x ⟧ (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨  derive-var-correct {Γ₁} (⟦ Γ′ ⟧ ρ) x  ⟩
    ⟦ derive-var x ⟧Var (⟦ Γ′ ⟧ ρ)
  ≡⟨ sym (lift-sound Γ′ (derive-var x) ρ) ⟩
    ⟦ lift Γ′ (derive-var x) ⟧Var ρ
  ∎) where open ≡-Reasoning
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct {{Γ′}} (if t₁ t₂ t₃) = ext-t (λ ρ →
  begin
    ⟦ Δ (if t₁ t₂ t₃) ⟧Term ρ
  ≡⟨⟩
     diff
       (⟦ if t₁ t₂ t₃ ⟧Term (update (⟦ Γ′ ⟧ ρ)))
       (⟦ if t₁ t₂ t₃ ⟧Term (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨ {!!} ⟩
    ⟦ derive-term (if t₁ t₂ t₃) ⟧ ρ
  ∎) where open ≡-Reasoning

derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)


agda/...: inline substTerm-based lemmas

agda/...: inline substTerm-based lemmas

Before using substTerm, these lemmas were useful to help type
inference, but now this is not needed.

Old-commit-hash: adffd6a90ebb103bdbc9718a03bb579ffbf5ac85

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import IlcModel
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

-- LIFTING terms into Δ-Contexts

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

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ {.(Δ-Context Γ)} {.(Δ-Type τ)} Γ′ (Δ {Γ} {τ} t) = {!!}
lift-term′ {._} {_} _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | bool = lift-term-ignore′ Γ′ t₂
... | false | false | bool = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

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

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

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

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

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

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext (λ ρ → ≡-refl)
derive-term-correct false = ext (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import IlcModel
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

-- LIFTING terms into Δ-Contexts

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

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ {.(Δ-Context Γ)} {.(Δ-Type τ)} Γ′ (Δ {Γ} {τ} t) = {!!}
lift-term′ {._} {_} _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | bool = lift-term-ignore′ Γ′ t₂
... | false | false | bool = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

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

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

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

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

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

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  context-cast-2 Γ₁ Γ₃
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (context-cast Γ₁ Γ₃ (derive-term t))))

  where
    open import Relation.Binary.PropositionalEquality using (subst)

    context-cast :
      ∀ Γ₁ Γ₂ {τ} →
        Term (Δ-Context (Γ₁ ⋎ Γ₂)) τ → Term (Δ-Context Γ₁ ⋎ Δ-Context Γ₂) τ
    context-cast Γ₁ Γ₂ {τ} =
      substTerm (Δ-Context-⋎ Γ₁ Γ₂)

    context-cast-2 :
      ∀ Γ₁ Γ₂ {τ τ₂} →
        Term (Δ-Context Γ₁ ⋎ (Δ-Type τ₂ • τ₂ • Δ-Context Γ₂)) τ →
        Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₂))) τ
    context-cast-2 Γ₁ Γ₂ {τ} {τ₂} =
      substTerm
      (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₂)

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext (λ ρ → ≡-refl)
derive-term-correct false = ext (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}