Checkpoint: To merge alter/abide to one constructor with Bool tag.
Reason: Otherwise impossible to express "nonempty Δ-context" as
a type.

Old-commit-hash: 67e1406b2769044d22b7ac779f8da7e8eea1b5f2

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

module TaggedDeltaTypes where

open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Bool
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- open import Data.NatBag renaming
--   (map to mapBag ; empty to emptyBag ; update to updateBag)
-- open import Data.NatBag.Properties
postulate Bag : Set
postulate emptyBag : Bag
postulate mapBag : (ℕ → ℕ) → Bag → Bag
postulate _++_ : Bag → Bag → Bag
postulate _\\_ : Bag → Bag → Bag
infixr 5 _++_
infixl 9 _\\_
postulate b\\b=∅ : ∀ {b : Bag} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {b : Bag} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {b : Bag} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

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

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

infixr 5 _⇒_

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

infixr 9 _•_

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

data Term : Context -> Type -> Set where

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

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

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

infix 8 _≼_

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

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

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

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

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

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

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

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

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

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

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

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

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

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

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

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

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

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

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

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

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

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

data Δ-Type : Set where
  nats : Δ-Type
  bags : Δ-Type
  alter_⇒_ : Δ-Type → Δ-Type → Δ-Type
  abide_⇒_ : Δ-Type → Δ-Type → Δ-Type

data Δ-Context : Set where
  ∅ : Δ-Context
  alter_•_ : Δ-Type → Δ-Context → Δ-Context
  abide_•_ : Δ-Type → Δ-Context → Δ-Context

erase : Δ-Type → Type
erase nats = nats
erase bags = bags
erase (alter τ₁ ⇒ τ₂) = erase τ₁ ⇒ erase τ₂
erase (abide τ₁ ⇒ τ₂) = erase τ₁ ⇒ erase τ₂

forget : Δ-Context → Context
forget ∅ = ∅
forget (alter τ • ρ) = erase τ • forget ρ
forget (abide τ • ρ) = erase τ • forget ρ

-- Convert a type/context to a Δ-type/Δ-context without any
-- assumption about arguments

Δ-type : Type → Δ-Type
Δ-type nats = nats
Δ-type bags = bags
Δ-type (τ₁ ⇒ τ₂) = alter Δ-type τ₁ ⇒ Δ-type τ₂

Δ-context : Context → Δ-Context
Δ-context ∅ = ∅
Δ-context (τ • Γ) = alter Δ-type τ • Δ-context Γ

data Δ-Term : Δ-Context → Δ-Type → Set
data ⟦_⟧ΔContext : Δ-Context → Set

⟦_⟧ΔType : Δ-Type → Set
⟦_⟧ΔTerm : ∀ {τ Γ} → Δ-Term Γ τ → ⟦ Γ ⟧ΔContext → ⟦ τ ⟧ΔType
_⊕_ : ∀ {τ} → ⟦ erase τ ⟧ → ⟦ τ ⟧ΔType → ⟦ erase τ ⟧
_⊝_ : ∀ {τ} → ⟦ erase τ ⟧ → ⟦ erase τ ⟧ → ⟦ τ ⟧ΔType
valid : ∀ {τ} → ⟦ erase τ ⟧ → ⟦ τ ⟧ΔType → Set
R[v,u⊝v] : ∀ {τ} {u v : ⟦ erase τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ} {u v : ⟦ erase τ ⟧} → v ⊕ (_⊝_ {τ} u v) ≡ u
ignore : ∀ {Γ} → ⟦ Γ ⟧ΔContext → ⟦ forget Γ ⟧
update : ∀ {Γ} → ⟦ Γ ⟧ΔContext → ⟦ forget Γ ⟧
infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

data Δ-Term where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → Δ-Term Γ nats
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → Δ-Term Γ bags
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var (forget Γ) (erase τ)) → Δ-Term Γ τ
  -- changes to abstractions are binders of x and dx
  -- There are two kinds of those: One who expects the argument
  -- to change, and one who does not.
  Δabs₀ : ∀ {τ₁ τ₂ Γ}
    (t : Δ-Term (abide τ₁ • Γ) τ₂) →
    Δ-Term Γ (abide τ₁ ⇒ τ₂)
  Δabs₁ : ∀ {τ₁ τ₂ Γ}
    (t : Δ-Term (alter τ₁ • Γ) τ₂) →
    Δ-Term Γ (alter τ₁ ⇒ τ₂)
{-
  Δapp₀ : ∀ {τ₁ τ₂ Γ}
    (ds : Δ-Term Γ (abide τ₁ ⇒ τ₂))
    (t : Term (forget Γ) (erase τ₁))
    (dt : Δ-Term Γ τ₁)
    {R[t,dt] : ∀ {ρ : ⟦
-}

{-
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {τ₁ τ₂ Γ vars}
    (ds : Δ-Term Γ (τ₁ ⇒ τ₂) {vars})
    ( t :   Term Γ τ₁)
    (dt : Δ-Term Γ τ₁ {vars})
    (R[t,dt] : {ρ : Δ-Env Γ {-vars-}} →
      valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧ΔTerm ρ)) →
    Δ-Term Γ τ₂ {vars}
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ vars}
    (ds : Δ-Term Γ nats {vars})
    (dt : Δ-Term Γ nats {vars}) →
    Δ-Term Γ nats {vars}
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ vars} →
    ( f :   Term Γ (nats ⇒ nats))
    (df : Δ-Term Γ (nats ⇒ nats) {vars})
    ( b :   Term Γ bags)
    (db : Δ-Term Γ bags {vars}) →
    Δ-Term Γ bags {vars}
  Δmap₁ : ∀ {Γ vars} →
    ( f :   Term Γ (nats ⇒ nats)) (db : Δ-Term Γ bags {vars}) →
    Δ-Term Γ bags {vars}
-}

-- ⟦_⟧ΔType : Δ-Type → Set
⟦ nats ⟧ΔType = ℕ × ℕ
⟦ bags ⟧ΔType = Bag
⟦ alter τ₁ ⇒ τ₂ ⟧ΔType =
  (v : ⟦ erase τ₁ ⟧) → (dv : ⟦ τ₁ ⟧ΔType) →
  valid {τ₁} v dv →
  ⟦ τ₂ ⟧ΔType
⟦ abide τ₁ ⇒ τ₂ ⟧ΔType =
  (v : ⟦ erase τ₁ ⟧) → (dv : ⟦ τ₁ ⟧ΔType) →
  valid {τ₁} v dv → _⊕_ {τ₁} v dv ≡ v →
  ⟦ τ₂ ⟧ΔType

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

-- _⊕_ : ∀ {τ} → ⟦ erase τ ⟧ → ⟦ τ ⟧ΔType → ⟦ erase τ ⟧
_⊕_ = {!!}
{-
_⊕_ {nats}   n dn = proj₂ dn
_⊕_ {bags}   b db = b ++ db
_⊕_ {τ₁ ⇒ τ₂} f df = λ v → f v ⊕ df v (v ⊝ v) R[v,u⊝v]
-}

-- _⊝_ : ∀ {τ} → ⟦ erase τ ⟧ → ⟦ erase τ ⟧ → ⟦ τ ⟧ΔType
_⊝_ = {!!}
{-
_⊝_ {nats}   m n = (n , m)
_⊝_ {bags}   b d = b \\ d
_⊝_ {τ₁ ⇒ τ₂} f g = λ v dv R[v,dv] → f (v ⊕ dv) ⊝ g v
-}

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

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

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

-- The type of environments ensures their consistency and honesty.
-- data ⟦_⟧ΔContext : Δ-Context → Set
data ⟦_⟧ΔContext where
  ∅ : ⟦ ∅ ⟧ΔContext
  quad : ∀ {τ Γ}
    (v : ⟦ erase τ ⟧)
    (dv : ⟦ τ ⟧ΔType)
    (R[v,dv] : valid {τ} v dv)
    (ρ : ⟦ Γ ⟧ΔContext) →
    ⟦ alter τ • Γ ⟧ΔContext
  quint : ∀ {τ Γ}
    (v : ⟦ erase τ ⟧)
    (dv : ⟦ τ ⟧ΔType)
    (R[v,dv] : valid {τ} v dv)
    (v⊕dv=v : _⊕_ {τ} v dv ≡ v)
    (ρ : ⟦ Γ ⟧ΔContext) →
    ⟦ abide τ • Γ ⟧ΔContext

meaning-ΔContext : Meaning Δ-Context
meaning-ΔContext = meaning ⟦_⟧ΔContext

-- ignore : ∀ {Γ} → ⟦ Γ ⟧ΔContext → ⟦ forget Γ ⟧
ignore ∅ = ∅
ignore (quad v dv R[v,dv] ρ) = v • ignore ρ
ignore (quint v dv R[v,dv] v⊕dv=v ρ) = v • ignore ρ

-- update : ∀ {Γ} → ⟦ Γ ⟧ΔContext → ⟦ forget Γ ⟧
update ∅ = ∅
update (quad {τ} v dv R[v,dv] ρ) = (_⊕_ {τ} v dv) • update ρ
update (quint {τ} v dv R[v,dv] v⊕dv=v ρ) = (_⊕_ {τ} v dv) • update ρ

--⟦_⟧ΔVar : ∀ {τ} {Γ} → Var (forget Γ) (erase τ) → ⟦ Γ ⟧ → ⟦ τ ⟧

{-
⟦_⟧ΔVar {alter τ • _} {.τ} this (quad _ dv _ _) = dv
⟦_⟧ΔVar {abide τ • _} {.τ} this (quint _ dv _ _ _) = dv
⟦_⟧ΔVar {alter _ • _} (that x) (quad _ _ _ ρ) = ⟦ x ⟧ΔVar ρ
⟦_⟧ΔVar {abide _ • _} (that x) (quint _ _ _ _ ρ) = ⟦ x ⟧ΔVar ρ
-}

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

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

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

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

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

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

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

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

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

validity {t = nat n} = refl
validity {t = bag b} = tt
validity {t = var x} = validity-var x
validity {t = map f b} = tt
validity {t = add s t} = cong₂ _+_ (validity {t = s}) (validity {t = t})

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

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

correctVar : ∀ {τ Γ} {x : Var Γ τ} {ρ : Δ-Env Γ} →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (update ρ)

correctVar {x = this  } {cons v dv R[v,dv] ρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] ρ} = correctVar {x = y} {ρ}

correctness {t = nat n} = refl
correctness {t = bag b} = b++∅=b
correctness {t = var x} = correctVar {x = x}

correctness {t = add s t} =
  cong₂ _+_ (correctness {t = s}) (correctness {t = t})

correctness {t = map s t} {ρ} =
  trans (b++[d\\b]=d {mapBag f b} {mapBag (f ⊕ df) (b ⊕ db)})
        (cong₂ mapBag (correctness {t = s}) (correctness {t = t}))
  where
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧ ρ
    db = ⟦ derive t ⟧ ρ

correctness {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧ ρ
  in trans
     (sym (proj₂ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))))
     (correctness {t = s} ⟨$⟩ correctness {t = t})

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

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

module TaggedDeltaTypes where

open import Relation.Binary.PropositionalEquality
open import Data.Nat
open import Data.Unit using (⊤ ; tt)
import Data.Integer as ℤ
import Data.Product as Product
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
import Level

-- Postulates: Extensionality and bag properties (#55)
postulate extensionality : Extensionality Level.zero Level.zero
--
-- open import Data.NatBag renaming
--   (map to mapBag ; empty to emptyBag ; update to updateBag)
-- open import Data.NatBag.Properties
postulate Bag : Set
postulate emptyBag : Bag
postulate mapBag : (ℕ → ℕ) → Bag → Bag
postulate _++_ : Bag → Bag → Bag
postulate _\\_ : Bag → Bag → Bag
infixr 5 _++_
infixl 9 _\\_
postulate b\\b=∅ : ∀ {b : Bag} → b \\ b ≡ emptyBag
postulate b++∅=b : ∀ {b : Bag} → b ++ emptyBag ≡ b
postulate ∅++b=b : ∀ {b : Bag} → emptyBag ++ b ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  [a++b]\\[c++d]=[a\\c]++[b\\d] : ∀ {a b c d} →
    (a ++ b) \\ (c ++ d) ≡ (a \\ c) ++ (b \\ d)
postulate
  [a\\b]\\[c\\d]=[a\\c]\\[b\\d] : ∀ {a b c d} →
    (a \\ b) \\ (c \\ d) ≡ (a \\ c) \\ (b \\ d)

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

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

infixr 5 _⇒_

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

infixr 9 _•_

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

data Term : Context -> Type -> Set where

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

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

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

infix 8 _≼_

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

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

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

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

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

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

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

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

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

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

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

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

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

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

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

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

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

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

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

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

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

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

data Δ-Type : Set where
  nats : Δ-Type
  bags : Δ-Type
  alter_⇒_ : Δ-Type → Δ-Type → Δ-Type
  abide_⇒_ : Δ-Type → Δ-Type → Δ-Type

data Δ-Context : Set where
  ∅ : Δ-Context
  alter_•_ : Δ-Type → Δ-Context → Δ-Context
  abide_•_ : Δ-Type → Δ-Context → Δ-Context

-- Convert a type/context to a Δ-type/Δ-context without any
-- assumption about arguments

Δ-type : Type → Δ-Type
Δ-type nats = nats
Δ-type bags = bags
Δ-type (τ₁ ⇒ τ₂) = alter Δ-type τ₁ ⇒ Δ-type τ₂

Δ-context : Context → Δ-Context
Δ-context ∅ = ∅
Δ-context (τ • Γ) = alter Δ-type τ • Δ-context Γ

{-

⟦_⟧ΔType : ∀ {τ args} → Δ-Type τ {args} → Set

data Δ-Env : (Γ : Context) → {vars : Vars Γ} → Set
data Δ-Term : (Γ : Context) → Type → {vars : Vars Γ} → Set

⟦_⟧ΔTerm : ∀ {τ : Type} {Γ : Context} {vars}
    → Δ-Term Γ τ {vars} → Δ-Env Γ {vars} → ⟦ τ ⟧ΔType
_⊕_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ΔType → ⟦ τ ⟧
_⊝_ : ∀ {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ τ ⟧ΔType
valid : {τ : Type} → ⟦ τ ⟧ → ⟦ τ ⟧ΔType → Set
R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊕ (u ⊝ v) ≡ u
ignore : ∀ {Γ : Context} {vars} → (ρ : Δ-Env Γ {vars}) → ⟦ Γ ⟧
update : ∀ {Γ : Context} {vars} → (ρ : Δ-Env Γ {vars}) → ⟦ Γ ⟧

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

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

⟦ Δ nats ⟧ΔType = ℕ × ℕ
⟦ Δ bags ⟧ΔType = Bag
⟦ Δ (τ₁ ⇒ τ₂) {alter args} ⟧ΔType =
  ∀ {args₁} →
  (v : ⟦ τ₁ ⟧) → (dv : ⟦ Δ τ₁ {args₁} ⟧ΔType) → valid v dv →
  ⟦ Δ τ₂ {args} ⟧ΔType

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

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

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

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

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

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

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

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

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

open Quadruple public

-- The type of environments ensures their consistency and honesty.
-- Δ-Env : (Γ : Context) → {vars : Vars Γ} → Set
data Δ-Env where
  ∅ : Δ-Env ∅ {∅}
  abide : ∀ {τ Γ vars} →
    (v : ⟦ τ ⟧) → (dv : ⟦ τ ⟧Δ) → valid v dv → v ⊕ dv ≡ v →
    Δ-Env Γ {vars} → Δ-Env (τ • Γ) {abide vars}
  alter : ∀ {τ Γ vars} →
    (v : ⟦ τ ⟧) → (dv : ⟦ τ ⟧Δ) → valid v dv →
    Δ-Env Γ {vars} → Δ-Env (τ • Γ) {alter vars}

‖_‖ : ∀ {τ Γ vars} → Δ-Env (τ • Γ) {vars} →
  Quadruple ⟦ τ ⟧ (λ _ → ⟦ τ ⟧Δ) (λ v dv → valid v dv)
    (λ _ _ _ → Δ-Env Γ {cdr vars})

‖ abide v dv R[v,dv] _ ρ ‖ = cons v dv R[v,dv] ρ
‖ alter v dv R[v,dv]   ρ ‖ = cons v dv R[v,dv] ρ

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

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

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

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

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

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

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

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

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

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

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

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

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

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

validity {t = nat n} = refl
validity {t = bag b} = tt
validity {t = var x} = validity-var x
validity {t = map f b} = tt
validity {t = add s t} = cong₂ _+_ (validity {t = s}) (validity {t = t})

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

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

correctVar : ∀ {τ Γ} {x : Var Γ τ} {ρ : Δ-Env Γ} →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (update ρ)

correctVar {x = this  } {cons v dv R[v,dv] ρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] ρ} = correctVar {x = y} {ρ}

correctness {t = nat n} = refl
correctness {t = bag b} = b++∅=b
correctness {t = var x} = correctVar {x = x}

correctness {t = add s t} =
  cong₂ _+_ (correctness {t = s}) (correctness {t = t})

correctness {t = map s t} {ρ} =
  trans (b++[d\\b]=d {mapBag f b} {mapBag (f ⊕ df) (b ⊕ db)})
        (cong₂ mapBag (correctness {t = s}) (correctness {t = t}))
  where
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧ ρ
    db = ⟦ derive t ⟧ ρ

correctness {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧ ρ
  in trans
     (sym (proj₂ (validity {t = s} {ρ} v dv (validity {t = t} {ρ}))))
     (correctness {t = s} ⟨$⟩ correctness {t = t})

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


Alternative definition of function composition

This is the second definition taken from New/Changes.agda. As usual, its
correctness proofs are much simpler (after we've rephrased the
statements cleverly).

module Thesis.Changes where

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

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

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

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

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

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

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

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

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

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

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

  open import Postulate.Extensionality

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open import Data.Integer
open import Data.Unit
open import Theorem.Groups-Nehemiah

private
  intCh = ℤ
instance
  intCS : ChangeStructure ℤ
intCS = record
  { Ch = ℤ
  ; ch_from_to_ = λ dv v1 v2 → v1 + dv ≡ v2
  ; isCompChangeStructure = record
    { isChangeStructure = record
      { _⊕_ = _+_
      ; fromto→⊕ = λ dv v1 v2 v2≡v1+dv → v2≡v1+dv
      ; _⊝_ = _-_
      ; ⊝-fromto = λ a b → n+[m-n]=m {a} {b}
      }
    ; _⊚[_]_ = λ da1 a da2 → da1 + da2
    ; ⊚-fromto = i⊚-fromto
    }
  }
  where
    i⊚-fromto : (a1 a2 a3 : ℤ) (da1 da2 : intCh) →
      a1 + da1 ≡ a2 → a2 + da2 ≡ a3 → a1 + (da1 + da2) ≡ a3
    i⊚-fromto a1 a2 a3 da1 da2 a1+da1≡a2 a2+da2≡a3
      rewrite sym (associative-int a1 da1 da2) | a1+da1≡a2 = a2+da2≡a3

module Thesis.Changes where

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

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

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

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

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

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

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

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

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

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

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

  open import Postulate.Extensionality

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open import Data.Integer
open import Data.Unit
open import Theorem.Groups-Nehemiah

private
  intCh = ℤ
instance
  intCS : ChangeStructure ℤ
intCS = record
  { Ch = ℤ
  ; ch_from_to_ = λ dv v1 v2 → v1 + dv ≡ v2
  ; isCompChangeStructure = record
    { isChangeStructure = record
      { _⊕_ = _+_
      ; fromto→⊕ = λ dv v1 v2 v2≡v1+dv → v2≡v1+dv
      ; _⊝_ = _-_
      ; ⊝-fromto = λ a b → n+[m-n]=m {a} {b}
      }
    ; _⊚[_]_ = λ da1 a da2 → da1 + da2
    ; ⊚-fromto = i⊚-fromto
    }
  }
  where
    i⊚-fromto : (a1 a2 a3 : ℤ) (da1 da2 : intCh) →
      a1 + da1 ≡ a2 → a2 + da2 ≡ a3 → a1 + (da1 + da2) ≡ a3
    i⊚-fromto a1 a2 a3 da1 da2 a1+da1≡a2 a2+da2≡a3
      rewrite sym (associative-int a1 da1 da2) | a1+da1≡a2 = a2+da2≡a3


agda: add extended comment on semantics of Δ

During my walk-throughs on the code, explaining this line was a bit
hard and required a small example. After writing it here during the
walkthrough, I decided to extend it and save it.

Old-commit-hash: 279b6047512b8c934cae49bda5977fa104077e12

module Denotational.Evaluation.Total where

-- EVALUATION with a primitive for TOTAL DERIVATIVES
--
-- This module defines the semantics of terms that support a
-- primitive (Δ e) for computing the total derivative according
-- to all free variables in e and all future arguments of e if e
-- is a function.

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 Changes
open import ChangeContexts

-- TERMS

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ if t₁ t₂ t₃ ⟧Term ρ = if ⟦ t₁ ⟧Term ρ then ⟦ t₂ ⟧Term ρ else ⟦ t₃ ⟧Term ρ
⟦ Δ {{Γ′}} t ⟧Term ρ = diff (⟦ t ⟧Term (update (⟦ Γ′ ⟧ ρ))) (⟦ t ⟧Term (ignore (⟦ Γ′ ⟧ ρ)))

{-

Here is an example to understand the semantics of Δ. I will use a
named variable representation for the task.

Consider the typing judgment:

   x: T |- x: T

Thus, we have that:

   dx : Δ T, x: T |- Δ x : Δ T

Thanks to weakening, we also have:

   y : S, dx : Δ T, x: T |- Δ x : Δ T

In the formalization, we need a proof Γ′ that the context Γ₁ = dx : Δ
T, x: T is a subcontext of Γ₂ = y : S, dx : Δ T, x: T. Thus, Γ′ has
type Γ₁ ≼ Γ₂.

Now take the environment:

   ρ = y ↦ w, dx ↦ dv, x ↦ v

Since the semantics of Γ′ : Γ₁ ≼ Γ₂ is a function from environments
for Γ₂ to environments for Γ₁, we have that:

   ⟦ Γ′ ⟧ ρ = dx ↦ dv, x ↦ v

From the definitions of update and ignore, it follows that:

   update (⟦ Γ′ ⟧ ρ) =  x ↦ dv ⊕ v
   ignore (⟦ Γ′ ⟧ ρ) =  x ↦ v

Hence, finally, we have that:

   diff (⟦ t ⟧Term (update (⟦ Γ′ ⟧ ρ))) (⟦ t ⟧Term (ignore (⟦ Γ′ ⟧ ρ)))

is simply diff (dv ⊕ v) v (or (dv ⊕ v) ⊝ v). If dv is a valid change,
that's just dv, that is ⟦ dx ⟧ ρ. In other words

-}

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

-- PROPERTIES of WEAKENING

weaken-sound : ∀ {Γ₁ Γ₂ τ} (t : Term Γ₁ τ) {Γ′ : Γ₁ ≼ Γ₂} →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ′ ⟧ ρ)
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = ≡-app (weaken-sound t₁ ρ) (weaken-sound t₂ ρ)
weaken-sound (var x) ρ = lift-sound _ x ρ
weaken-sound true ρ = refl
weaken-sound false ρ = refl
weaken-sound (if t₁ t₂ t₃) {Γ′} ρ with weaken-sound t₁ {Γ′} ρ
... | H with ⟦ weaken Γ′ t₁ ⟧ ρ | ⟦ t₁ ⟧ (⟦ Γ′ ⟧ ρ)
weaken-sound (if t₁ t₂ t₃) {Γ′} ρ | refl | true | true = weaken-sound t₂ {Γ′} ρ
weaken-sound (if t₁ t₂ t₃) {Γ′} ρ | refl | false | false = weaken-sound t₃ {Γ′} ρ
weaken-sound (Δ {{Γ′}} t) {Γ″} ρ =
  cong (λ x → diff (⟦ t ⟧ (update x)) (⟦ t ⟧ (ignore x))) (⟦⟧-≼-trans Γ′ Γ″ ρ)

module Denotational.Evaluation.Total where

-- EVALUATION with a primitive for TOTAL DERIVATIVES
--
-- This module defines the semantics of terms that support a
-- primitive (Δ e) for computing the total derivative according
-- to all free variables in e and all future arguments of e if e
-- is a function.

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 Changes
open import ChangeContexts

-- TERMS

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ
⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ if t₁ t₂ t₃ ⟧Term ρ = if ⟦ t₁ ⟧Term ρ then ⟦ t₂ ⟧Term ρ else ⟦ t₃ ⟧Term ρ
⟦ Δ {{Γ′}} t ⟧Term ρ = diff (⟦ t ⟧Term (update (⟦ Γ′ ⟧ ρ))) (⟦ t ⟧Term (ignore (⟦ Γ′ ⟧ ρ)))

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

-- PROPERTIES of WEAKENING

weaken-sound : ∀ {Γ₁ Γ₂ τ} (t : Term Γ₁ τ) {Γ′ : Γ₁ ≼ Γ₂} →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ′ ⟧ ρ)
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = ≡-app (weaken-sound t₁ ρ) (weaken-sound t₂ ρ)
weaken-sound (var x) ρ = lift-sound _ x ρ
weaken-sound true ρ = refl
weaken-sound false ρ = refl
weaken-sound (if t₁ t₂ t₃) {Γ′} ρ with weaken-sound t₁ {Γ′} ρ
... | H with ⟦ weaken Γ′ t₁ ⟧ ρ | ⟦ t₁ ⟧ (⟦ Γ′ ⟧ ρ)
weaken-sound (if t₁ t₂ t₃) {Γ′} ρ | refl | true | true = weaken-sound t₂ {Γ′} ρ
weaken-sound (if t₁ t₂ t₃) {Γ′} ρ | refl | false | false = weaken-sound t₃ {Γ′} ρ
weaken-sound (Δ {{Γ′}} t) {Γ″} ρ =
  cong (λ x → diff (⟦ t ⟧ (update x)) (⟦ t ⟧ (ignore x))) (⟦⟧-≼-trans Γ′ Γ″ ρ)


elgamal cleanups and improvments

elgamal cleanups and improvments

{-# OPTIONS --copatterns #-}
open import Function
open import Data.Product
open import Data.Bool.NP as Bool
open import Data.Unit
open import Data.Maybe.NP
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_)
open import Data.Bits
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup) renaming (map to vmap)
open import Algebra.FunctionProperties
open import Relation.Binary.PropositionalEquality as ≡
import cont as cont
open cont using (Cont; ContA)

module elgamal where

private
    ★₁ : Set₂
    ★₁ = Set₁

    ★ : ★₁
    ★ = Set

[0→_,1→_] : ∀ {a} {A : Set a} → A → A → Bit → A
[0→ e₀ ,1→ e₁ ] b = if b then e₁ else e₀

case_0→_1→_ : ∀ {a} {A : Set a} → Bit → A → A → A
case b 0→ e₀ 1→ e₁ = if b then e₁ else e₀

module Sum where
    Sum : ★ → ★
    Sum A = (A → ℕ) → ℕ

    Count : ★ → ★
    Count A = (A → Bit) → ℕ

    SumExt : ∀ {A} → Sum A → ★
    SumExt sumA = ∀ {f g} → f ≗ g → sumA f ≡ sumA g

    sumToCount : ∀ {A} → Sum A → Count A
    sumToCount sumA f = sumA (Bool.toℕ ∘ f)

    sum⊤ : Sum ⊤
    sum⊤ f = f _

    sum⊤-ext : SumExt sum⊤
    sum⊤-ext f≗g = f≗g _

    sumBit : Sum Bit
    sumBit f = f 0b + f 1b

    sumBit-ext : SumExt sumBit
    sumBit-ext f≗g rewrite f≗g 0b | f≗g 1b = refl

    -- liftM2 _,_ in the continuation monad
    sumProd : ∀ {A B} → Sum A → Sum B → Sum (A × B)
    sumProd sumA sumB f = sumA (λ x₀ →
                           sumB (λ x₁ →
                             f (x₀ , x₁)))

    sumProd-ext : ∀ {A B} {sumA : Sum A} {sumB : Sum B} →
                  SumExt sumA → SumExt sumB → SumExt (sumProd sumA sumB)
    sumProd-ext sumA-ext sumB-ext f≗g = sumA-ext (λ x → sumB-ext (λ y → f≗g (x , y)))

data `★ : ★ where
  `⊤   : `★
  `X   : `★
  _`×_ : `★ → `★ → `★
infixr 2 _`×_

module Univ (X : ★) where
    El : `★ → ★
    El `⊤         = ⊤
    El `X         = X
    El (u₀ `× u₁) = El u₀ × El u₁

    record ↺ (R : `★) (A : ★) : ★ where
      constructor mk
      field
        run↺ : El R → A
    open ↺ public

    EXP : (R : `★) → ★
    EXP R = ↺ R Bit

    Det : ★ → ★
    Det = ↺ `⊤

module EntropySmoothing
  (M    : ★)        -- Message
  (Hash : ★)
  (ℋ   : M → Hash) -- Hashing function
  (Rₐ   : ★)        -- Adversary randomness
  where

  -- Entropy smoothing adversary
  ESAdv : ★
  ESAdv = Rₐ → Hash → Bit

  -- The randomness universe needed for the following games
  R : ★
  R = M × Hash × Rₐ

  -- In this game we always use ℋ on a random message
  ES⅁₀ : ESAdv → R → Bit
  ES⅁₀ A (m , _ , rₐ) = A rₐ (ℋ m)

  -- In this game we just retrun a random Hash value
  ES⅁₁ : ESAdv → R → Bit
  ES⅁₁ A (_ , h , rₐ) = A rₐ h

  ES⅁ : ESAdv → Bit → R → Bit
  ES⅁ A b r = (case b 0→ ES⅁₀ 1→ ES⅁₁) A r

module EntropySmoothingWithKey
  (M    : ★)
  (Key  : ★)
  (Hash : ★)
  (ℋ   : Key → M → Hash) -- Hashing function
  (Rₐ   : ★)              -- Adversary randomness
  where

  -- Entropy smoothing adversary
  ESAdv : ★
  ESAdv = Rₐ → Key → Hash → Bit

  -- The randomness universe needed for the following games
  R : ★
  R = Key × M × Hash × Rₐ

  -- In this game we always use ℋ on a random message
  ES⅁₀ : ESAdv → R → Bit
  ES⅁₀ A (k , m , _ , rₐ) = A rₐ k (ℋ k m)

  -- In this game we just retrun a random Hash value
  ES⅁₁ : ESAdv → R → Bit
  ES⅁₁ A (k , _ , h , rₐ) = A rₐ k h

  ES⅁ : ESAdv → Bit → R → Bit
  ES⅁ A b r = (case b 0→ ES⅁₀ 1→ ES⅁₁) A r

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum.Sum ℤq)
  (sumℤq-ext : Sum.SumExt sumℤq)
  (sumℤq-⊞-lem : ∀ x f → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  where

  open Sum
  open Univ ℤq public
  open `★ public renaming (`X to `ℤq)

  sum : ∀ u → Sum (El u)
  sum `⊤         = sum⊤
  sum `X         = sumℤq
  sum (u₀ `× u₁) = sumProd (sum u₀) (sum u₁)

  sum-ext : ∀ u → SumExt (sum u)
  sum-ext `⊤         = sum⊤-ext
  sum-ext `X         = sumℤq-ext
  sum-ext (u₀ `× u₁) = sumProd-ext (sum-ext u₀) (sum-ext u₁)

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = sum u (Bool.toℕ ∘ run↺ f)

  #q_ : Count ℤq
  #q_ = sumToCount sumℤq

  ⁇ : ∀ R → ↺ R (El R)
  run↺ (⁇ _) = id

  pure↺ : ∀ {R A} → A → ↺ R A
  run↺ (pure↺ x) r = x -- turning r to _ produce an error

  ⟪_⟫ : ∀ {R A} → A → ↺ R A
  ⟪_⟫ = pure↺

  {-
  ⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
  ⟪_⟫ᴰ = pureᴰ
  -}

  map↺ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  run↺ (map↺ f x) r = f (run↺ x r)

  infixl 4 _⊛_
  _⊛_ : ∀ {R S A B} → ↺ R (A → B) → ↺ S A → ↺ (R `× S) B
  run↺ (af ⊛ ax) rs = run↺ af (proj₁ rs) (run↺ ax (proj₂ rs))

  ⟪_·_⟫ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  ⟪ f · x ⟫ = map↺ f x

  ⟪_·_·_⟫ : ∀ {A B C} {R S} →
              (A → B → C) → ↺ R A → ↺ S B → ↺ (R `× S) C
  ⟪ f · x · y ⟫ = map↺ f x ⊛ y

  _⟨⊞⟩_ : ∀ {R S} → ↺ R ℤq → ↺ S ℤq → ↺ (R `× S) ℤq
  x ⟨⊞⟩ y = ⟪ _⊞_ · x · y ⟫

  ⟨_⊞⟩_ : ∀ {R} → ℤq → ↺ R ℤq → ↺ R ℤq
  ⟨ x ⊞⟩ y = ⟪ _⊞_ x · y ⟫

  infix 4 _≈↺_ _≈ᴬ_
  _≈↺_ : ∀ {R : `★} (f g : EXP R) → ★
  _≈↺_ = _≡_ on #_

  _≈ᴬ_ : ∀ {A R} (f g : ↺ R A) → Set _
  _≈ᴬ_ {A} f g = ∀ (Adv : A → Bit) → ⟪ Adv · f ⟫ ≈↺ ⟪ Adv · g ⟫

  lem : ∀ x → ⟨ x ⊞⟩ (⁇ `ℤq) ≈ᴬ ⁇ _
  lem x Adv = sumℤq-⊞-lem x (Bool.toℕ ∘ Adv)

  -- ∀ (A : ℤq → Bit) → # (A ⁇)

open Fin.Modulo renaming (sucmod to [suc])

{-
module ℤq-implem (q-2 : ℕ) where
  q : ℕ
  q = 2 + q-2

  ℤq : ★
  ℤq = Fin q

  [0] : ℤq
  [0] = zero

  [1] : ℤq
  [1] = suc zero
-}
module ℤq-implem (q : ℕ) ([0]' [1]' : Fin q) where
  open Sum
  ℤq : ★
  ℤq = Fin q

  [0] : ℤq
  [0] = [0]'

  [1] : ℤq
  [1] = [1]'

  _ℕ⊞_ : ℕ → ℤq → ℤq
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = m ℕ⊞ ([suc] n)
  {-
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = [suc] (m ℕ⊞ n)
  -}

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin.toℕ m ℕ⊞ n

  _ℕ⊠_ : ℕ → ℤq → ℤq
  zero  ℕ⊠ n = [0]
  suc m ℕ⊠ n = n ⊞ (m ℕ⊠ n)

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin.toℕ m ℕ⊠ n

  _[^]ℕ_ : ℤq → ℕ → ℤq
  m [^]ℕ zero  = [1]
  m [^]ℕ suc n = m ⊠ (m [^]ℕ n)

  _[^]_ : ℤq → ℤq → ℤq
  m [^] n = m [^]ℕ (Fin.toℕ n)

  allℤq : Vec ℤq q
  allℤq = allFin q

  sumℤq : Sum ℤq
  sumℤq f = Vec.sum (vmap f allℤq)

  sumℤq-[suc]-lem : ∀ f → sumℤq (f ∘ [suc]) ≡ sumℤq f
  sumℤq-[suc]-lem f rewrite ≡.sym (Vec.sum-map-rot₁ f allℤq)
                          | Vec.map-∘ f [suc] allℤq
                          | rot₁-map-sucmod q
                          = refl

  --  comm-[suc]-ℕ⊞ : ∀ m n → [suc] (m ℕ⊞ n) ≡ m ℕ⊞ ([suc] n)

  sumℤq-ℕ⊞-lem : ∀ m f → sumℤq (f ∘ _ℕ⊞_ m) ≡ sumℤq f
  sumℤq-ℕ⊞-lem zero f = refl
  sumℤq-ℕ⊞-lem (suc m) f rewrite sumℤq-[suc]-lem (f ∘ _ℕ⊞_ m)
                               | sumℤq-ℕ⊞-lem m f = refl

  sumℤq-⊞-lem : ∀ m f → sumℤq (f ∘ _⊞_ m) ≡ sumℤq f
  sumℤq-⊞-lem = sumℤq-ℕ⊞-lem ∘ Fin.toℕ

  vmap-ext : ∀ {A B : ★} {f g : A → B} {n} → f ≗ g → vmap f ≗ vmap {n = n} g
  vmap-ext f≗g [] = refl
  vmap-ext f≗g (x ∷ xs) rewrite f≗g x | vmap-ext f≗g xs = refl

  sumℤq-ext : SumExt sumℤq
  sumℤq-ext f≗g rewrite vmap-ext f≗g allℤq = refl

module G-implem (p q : ℕ) (g' : Fin p) (0[p] 1[p] : Fin p) (0[q] 1[q] : Fin q) where
  open ℤq-implem q 0[q] 1[q] public
  open ℤq-implem p 0[p] 1[p] public using () renaming (ℤq to G; _⊠_ to _∙_; _[^]ℕ_ to _^[p]_)

  g : G
  g = g'

  _^_ : G → ℤq → G
  x ^ n = x ^[p] Fin.toℕ n

  g^_ : ℤq → G
  g^ n = g ^ n

  {-
  g^-inj : ∀ m n → g^ m ≡ g^ n → m ≡ n
  g^-inj = {!!}
  -}

module G-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum.Sum ℤq)
  (sumℤq-ext : Sum.SumExt sumℤq)
  (sumℤq-⊞-lem : ∀ x f → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (_∙_ : G → G → G)
  where

  g^_ : ℤq → G
  g^ n = g ^ n

  open Sum
  open ℤq-count ℤq _⊞_ sumℤq sumℤq-ext sumℤq-⊞-lem

  ⁇G : ↺ `ℤq G
  run↺ ⁇G x = g^ x

  #G : Count G
  #G f = #q (f ∘ g^_)

  {-
  #G-∙ : ∀ f m → #G (f ∘ _∙_ m) ≡ #G f
  #G-∙ f m = {!!}
  -}

module DDH
  (ℤq  : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G   : ★)
  (g^_ : ℤq → G)
  where
    DDHAdv : ★ → ★
    DDHAdv R = R → G → G → G → Bit

    DDH⅁₀ : ∀ {R} {_I : ★} → DDHAdv R → (R × ℤq × ℤq × _I) → Bit
    DDH⅁₀ D (r , x , y , _) = D r (g^ x) (g^ y) (g^ (x ⊠ y))

    DDH⅁₁ : ∀ {R} → DDHAdv R → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁₁ D (r , x , y , z) = D r (g^ x) (g^ y) (g^ z)

    DDH⅁ : ∀ {R} → DDHAdv R → Bit → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁ D b = (case b 0→ DDH⅁₀ 1→ DDH⅁₁) D

    -- DDH⅁′ : ∀ {R} → DDHAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    -- DDH⅁′ D (b , x , y , z , r) = DDH⅁ D b (x , y , z , r)

    module With↺ where
        open Univ ℤq
        open `★ public renaming (`X to `ℤq)
        DDHAdv↺ : `★ → ★
        DDHAdv↺ R = G → G → G → ↺ R Bit
        DDH⅁₀↺ : ∀ {R _I} → DDHAdv↺ R → ↺ (R `× `ℤq `× `ℤq `× _I) Bit
        run↺ (DDH⅁₀↺ D) = DDH⅁₀ (λ a b c d → run↺ (D b c d) a)

module El-Gamal-Generic
  (ℤq : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (Message : ★)
  (_⊕_ : G → Message → Message)
  (_⊕⁻¹_ : G → Message → Message)
  where

    g^_ : ℤq → G
    g^ x = g ^ x

    -- gˣ is the pk
    -- x is the sk

    PubKey = G
    SecKey = ℤq
    KeyPair = PubKey × SecKey
    CipherText = G × Message

    M = Message
    C = CipherText

    KeyGen : ℤq → KeyPair
    KeyGen x = (g^ x , x)

    -- KeyGen↺ : ↺ ℤq KeyPair
    -- KeyGen↺ = mk KeyGen

    Enc : PubKey → Message → ℤq → CipherText
    Enc gˣ m y = gʸ , ζ where
      gʸ = g^ y
      δ = gˣ ^ y
      ζ = δ ⊕ m

    -- Enc↺ : PubKey → Message → ↺ ℤq CipherText
    -- Enc↺ gˣ m = mk (Enc gˣ m)

    Dec : SecKey → CipherText → Message
    Dec x (gʸ , ζ) = (gʸ ^ x) ⊕⁻¹ ζ

    EncAdv : ★ → ★
    EncAdv R = (R → PubKey → Bit → M) × (R → PubKey → C → Bit)

    SS⅁ : ∀ {R _I : ★} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    SS⅁ (m , D) b (r , x , y , z) =
      let pk = proj₁ (KeyGen x) in
      D r pk (Enc pk (m r pk b) y)

    Game : (i : Bit) → ∀ {R} → EncAdv R → (Bit × R × ℤq × ℤq × ℤq) → Bit
    Game i (m , D) (b , r , x , y , z) =
      let gˣ = g^ x
          gʸ = g^ y
          δ  = gˣ ^ case i 0→ y 1→ z
          ζ  = δ ⊕ m r gˣ b
      in b ==ᵇ D r gˣ (gʸ , ζ)

    {-
    Game-0b≡Game0 : ∀ {R} → Game 0b ≡ Game0 {R}
    Game-0b≡Game0 = refl
      -}

    open DDH ℤq _⊠_ G g^_ public

    -- Game0 ≈ Game 0b
    -- Game1 = Game 1b

    -- Game0 ≤ ε
    -- Game1 ≡ 0

    OTP⅁ : ∀ {R : ★} → (R → G → Message) → (R → G → G → Message → Bit)
                     → (R × ℤq × ℤq × ℤq) → Bit
    OTP⅁ M D (r , x , y , z) = D r gˣ gʸ (gᶻ ⊕ M r gˣ)
      where gˣ = g^ x
            gʸ = g^ y
            gᶻ = g^ z

    TrA : ∀ {R} → Bit → EncAdv R → DDHAdv R
    TrA b (m , D) r gˣ gʸ gˣʸ = D r gˣ (gʸ , gˣʸ ⊕ m r gˣ b)

module El-Gamal-Base
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    (_⁻¹ : G → G)
    (_∙_ : G → G → G)
    where

    _/_ : G → G → G
    x / y = x ∙ (y ⁻¹)
    open El-Gamal-Generic ℤq _⊠_ G g _^_ G _∙_ (flip _/_) public

    like-SS⅁ : ∀ {R _I : ★} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    like-SS⅁ (m , D) b (r , x , y , _z) =
      D r gˣ (gʸ , (gˣ ^ y) ∙ m r gˣ b)
      where gˣ = g^ x
            gʸ = g^ y

    SS⅁≡like-SS⅁ : ∀ {R _I} → SS⅁ {R} {_I} ≡ like-SS⅁
    SS⅁≡like-SS⅁ = refl

    open Sum
    module WithSumRAndℤqProps
        (Rₐ : ★)
        (sumRₐ : Sum Rₐ)
        (sumRₐ-ext : SumExt sumRₐ)
        (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
        (sumℤq : Sum ℤq)
        (sumℤq-ext : SumExt sumℤq)
        where

        module SumR where
          R = Rₐ × ℤq × ℤq × ℤq
          sumR : Sum R
          sumR = sumProd sumRₐ (sumProd sumℤq (sumProd sumℤq sumℤq))
          #R_ : Count R
          #R_ = sumToCount sumR
          sumR-ext : SumExt sumR
          sumR-ext = sumProd-ext sumRₐ-ext (sumProd-ext sumℤq-ext (sumProd-ext sumℤq-ext sumℤq-ext))
        private
            #q_ : Count ℤq
            #q_ = sumToCount sumℤq

        open SumR

        _≈q_ : (f g : ℤq → Bit) → ★
        f ≈q g = #q f ≡ #q g

        _≈R_ : (f g : R → Bit) → ★
        f ≈R g = #R f ≡ #R g

        module EvenMoreProof
            (ddh-hyp : (A : DDHAdv Rₐ) → DDH⅁ A 0b ≈R DDH⅁ A 1b)
            (otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x)))
            where

                otp-lem' : ∀ D M₀ M₁ → OTP⅁ M₀ D ≈R OTP⅁ M₁ D
                otp-lem' D M₀ M₁ = sumRₐ-ext (λ r →
                                     sumℤq-ext (λ x →
                                       sumℤq-ext (λ y →
                                         pf r x y)))
                  where
                  f0 = λ M r x y z → OTP⅁ M D (r , x , y , z)
                  f1 = λ M r x y → sumℤq (Bool.toℕ ∘ f0 M r x y)
                  f2 = λ M r x → sumℤq (f1 M r x)
                  f3 = λ M r → sumℤq (f2 M r)
                  pf : ∀ r x y → f1 M₀ r x y ≡ f1 M₁ r x y
                  pf r x y = pf'
                    where gˣ = g^ x
                          gʸ = g^ y
                          m₀ = M₀ r gˣ
                          m₁ = M₁ r gˣ
                          f5 = λ M z → D r gˣ gʸ (g^ z ∙ M)
                          pf' : f5 m₀ ≈q f5 m₁
                          pf' rewrite otp-lem (D r gˣ gʸ) m₀
                                    | otp-lem (D r gˣ gʸ) m₁ = refl

                projM : EncAdv Rₐ → Bit → Rₐ → G → G
                projM (m , _) b r gˣ = m r gˣ b

                projD : EncAdv Rₐ → Rₐ → G → G → G → Bit
                projD (_ , D) r gˣ gʸ gᶻ∙M = D r gˣ (gʸ , gᶻ∙M)

                module WithAdversary (A : EncAdv Rₐ) b where
                    Aᵇ = TrA b A
                    A¬ᵇ = TrA (not b) A

                    pf0,5 : SS⅁ A b ≗ DDH⅁ Aᵇ 0b
                    pf0,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

                    pf1 : SS⅁ A b ≈R DDH⅁ Aᵇ 0b
                    pf1 = sumR-ext (cong Bool.toℕ ∘ pf0,5)

                    pf2 : DDH⅁ Aᵇ 0b ≈R DDH⅁ Aᵇ 1b
                    pf2 = ddh-hyp Aᵇ

                    pf2,5 : DDH⅁ Aᵇ 1b ≡ OTP⅁ (projM A b) (projD A)
                    pf2,5 = refl

                    pf3 : DDH⅁ Aᵇ 1b ≈R DDH⅁ A¬ᵇ 1b
                    pf3 = otp-lem' (projD A) (projM A b) (projM A (not b))

                    pf4 : DDH⅁ A¬ᵇ 1b ≈R DDH⅁ A¬ᵇ 0b
                    pf4 = ≡.sym (ddh-hyp A¬ᵇ)

                    pf4,5 : SS⅁ A (not b) ≗ DDH⅁ A¬ᵇ 0b
                    pf4,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

                    pf5 : SS⅁ A (not b) ≈R DDH⅁ A¬ᵇ 0b
                    pf5 = sumR-ext (cong Bool.toℕ ∘ pf4,5)

                    final : SS⅁ A b ≈R SS⅁ A (not b)
                    final rewrite pf1 | pf2 | pf3 | pf4 | pf5 = refl

module El-Gamal-Hashed
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    -- (HKey : ★)
    (|M| : ℕ)
    (ℋ : {-HKey →-} G → Bits |M|) where

    Message = Bits |M|

    ℋ⟨_⟩⊕_ : G → Message → Message
    ℋ⟨ δ ⟩⊕ m = ℋ δ ⊕ m

    open El-Gamal-Generic ℤq _⊠_ G g _^_ Message ℋ⟨_⟩⊕_

module ⟨ℤp⟩★ p-3 {- p is prime -} (`Rₐ : `★) where
  p : ℕ
  p = 3 + p-3

  q : ℕ
  q = p ∸ 1

  module G = G-implem p q (## 2) (## 0) (## 1) (## 0) (## 1)
  open G

  postulate
    _⁻¹ : G → G
    dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y

  module EB = El-Gamal-Base _ _⊠_ G g _^_ _⁻¹ _∙_
  open EB hiding (g^_)

  open ℤq-count ℤq _⊞_ sumℤq sumℤq-ext sumℤq-⊞-lem

  Rₐ = El `Rₐ
  sumRₐ = sum `Rₐ
  sumRₐ-ext = sum-ext `Rₐ

  open WithSumRAndℤqProps Rₐ sumRₐ sumRₐ-ext dist-^-⊠ sumℤq sumℤq-ext

  open SumR
  postulate
    ddh-hyp : (A : DDHAdv Rₐ) → DDH⅁ A 0b ≈R DDH⅁ A 1b
    otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x))

  open EvenMoreProof ddh-hyp otp-lem

  final : ∀ A → SS⅁ A 0b ≈R SS⅁ A 1b
  final A = WithAdversary.final A 0b

module ⟨ℤ11⟩★ = ⟨ℤp⟩★ (11 ∸ 3)
                   `X -- the amount of adversary randomness

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

{-# OPTIONS --copatterns #-}
open import Function
open import Data.Product
open import Data.Bool.NP as Bool
open import Data.Unit
open import Data.Maybe.NP
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_)
open import Data.Bits
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup) renaming (map to vmap)
--import Data.Vec.Properties as Vec
open import Algebra.FunctionProperties
open import Relation.Binary.PropositionalEquality as ≡

module elgamal where

★₁ : Set₂
★₁ = Set₁

★ : Set₁
★ = Set

[0→_,1→_] : ∀ {a} {A : Set a} → A → A → Bit → A
[0→ e₀ ,1→ e₁ ] b = if b then e₁ else e₀

case_0→_1→_ : ∀ {a} {A : Set a} → Bit → A → A → A
case b 0→ e₀ 1→ e₁ = if b then e₁ else e₀

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SumExt : ∀ {A} → Sum A → ★
SumExt sumA = ∀ f g → f ≗ g → sumA f ≡ sumA g

sumToCount : ∀ {A} → Sum A → Count A
sumToCount sumA f = sumA (Bool.toℕ ∘ f)

sumBit : Sum Bit
sumBit f = f 0b + f 1b

-- liftM2 _,_ in the continuation monad
sumProd : ∀ {A B : Set} → Sum A → Sum B → Sum (A × B)
sumProd sumA sumB f = sumA (λ x₀ →
                       sumB (λ x₁ →
                         f (x₀ , x₁)))

sumProd-ext : ∀ {A B : Set} {sumA : Sum A} {sumB : Sum B} →
              SumExt sumA → SumExt sumB → SumExt (sumProd sumA sumB)
sumProd-ext sumA-ext sumB-ext f g f≗g = sumA-ext _ _ (λ x → sumB-ext _ _ (λ y → f≗g (x , y)))

data `★ : ★ where
  `⊤   : `★
  `X   : `★
  _`×_ : `★ → `★ → `★
infixr 2 _`×_

module Univ (X : ★) where
    El : `★ → ★
    El `⊤         = ⊤
    El `X         = X
    El (u₀ `× u₁) = El u₀ × El u₁

    record ↺ (R : `★) (A : ★) : ★ where
      constructor mk
      field
        run↺ : El R → A
    open ↺ public

    EXP : (R : `★) → ★
    EXP R = ↺ R Bit

    Det : ★ → ★
    Det = ↺ `⊤

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum ℤq)
  (sumℤq-lem : ∀ f x → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  where

  open Univ ℤq
  open `★ public renaming (`X to `ℤq)

  sum : (u : `★) → Sum (El u)
  sum `⊤         f = f _
  sum `X         f = sumℤq f
  sum (u₀ `× u₁) f = sum u₀ (λ x₀ →
                       sum u₁ (λ x₁ →
                         f (x₀ , x₁)))

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = sum u (Bool.toℕ ∘ run↺ f)

  ⁇ : ∀ R → ↺ R (El R)
  run↺ (⁇ _) = id

  pure↺ : ∀ {R A} → A → ↺ R A
  run↺ (pure↺ x) r = x -- turning r to _ produce an error

  ⟪_⟫ : ∀ {R A} → A → ↺ R A
  ⟪_⟫ = pure↺

  {-
  ⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
  ⟪_⟫ᴰ = pureᴰ
  -}

  map↺ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  run↺ (map↺ f x) r = f (run↺ x r)

  infixl 4 _⊛_
  _⊛_ : ∀ {R S A B} → ↺ R (A → B) → ↺ S A → ↺ (R `× S) B
  run↺ (af ⊛ ax) rs = run↺ af (proj₁ rs) (run↺ ax (proj₂ rs))

  ⟪_·_⟫ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  ⟪ f · x ⟫ = map↺ f x

  ⟪_·_·_⟫ : ∀ {A B C} {R S} →
              (A → B → C) → ↺ R A → ↺ S B → ↺ (R `× S) C
  ⟪ f · x · y ⟫ = map↺ f x ⊛ y

  _⟨⊞⟩_ : ∀ {R S} → ↺ R ℤq → ↺ S ℤq → ↺ (R `× S) ℤq
  x ⟨⊞⟩ y = ⟪ _⊞_ · x · y ⟫

  ⟨_⊞⟩_ : ∀ {R} → ℤq → ↺ R ℤq → ↺ R ℤq
  ⟨ x ⊞⟩ y = ⟪ _⊞_ x · y ⟫

  infix 4 _≈↺_ _≈ᴬ_
  _≈↺_ : ∀ {R : `★} (f g : EXP R) → ★
  _≈↺_ = _≡_ on #_

  _≈ᴬ_ : ∀ {A R} (f g : ↺ R A) → Set _
  _≈ᴬ_ {A} f g = ∀ (Adv : A → Bit) → ⟪ Adv · f ⟫ ≈↺ ⟪ Adv · g ⟫

  lem : ∀ x → ⟨ x ⊞⟩ (⁇ `ℤq) ≈ᴬ ⁇ _
  lem x Adv = sumℤq-lem (Bool.toℕ ∘ Adv) x

  -- ∀ (A : ℤq → Bit) → # (A ⁇)

open Fin.Modulo renaming (sucmod to [suc])

{-
module ℤq-implem (q-2 : ℕ) where
  q : ℕ
  q = 2 + q-2

  ℤq : ★
  ℤq = Fin q

  [0] : ℤq
  [0] = zero

  [1] : ℤq
  [1] = suc zero
-}
module ℤq-implem (q : ℕ) ([0]' [1]' : Fin q) where
  ℤq : ★
  ℤq = Fin q

  [0] : ℤq
  [0] = [0]'

  [1] : ℤq
  [1] = [1]'

  _ℕ⊞_ : ℕ → ℤq → ℤq
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = m ℕ⊞ ([suc] n)
  {-
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = [suc] (m ℕ⊞ n)
  -}

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin.toℕ m ℕ⊞ n

  _ℕ⊠_ : ℕ → ℤq → ℤq
  zero  ℕ⊠ n = [0]
  suc m ℕ⊠ n = n ⊞ (m ℕ⊠ n)

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin.toℕ m ℕ⊠ n

  _[^]ℕ_ : ℤq → ℕ → ℤq
  m [^]ℕ zero  = [1]
  m [^]ℕ suc n = m ⊠ (m [^]ℕ n)

  _[^]_ : ℤq → ℤq → ℤq
  m [^] n = m [^]ℕ (Fin.toℕ n)

  allℤq : Vec ℤq q
  allℤq = allFin q

  sumℤq : Sum ℤq
  sumℤq f = Vec.sum (vmap f allℤq)

  sumℤq-[suc]-lem : ∀ f → sumℤq (f ∘ [suc]) ≡ sumℤq f
  sumℤq-[suc]-lem f rewrite ≡.sym (Vec.sum-map-rot₁ f allℤq)
                          | Vec.map-∘ f [suc] allℤq
                          | rot₁-map-sucmod q
                          = refl

  --  comm-[suc]-ℕ⊞ : ∀ m n → [suc] (m ℕ⊞ n) ≡ m ℕ⊞ ([suc] n)

  sumℤq-ℕ⊞-lem : ∀ m f → sumℤq (f ∘ _ℕ⊞_ m) ≡ sumℤq f
  sumℤq-ℕ⊞-lem zero f = refl
  sumℤq-ℕ⊞-lem (suc m) f rewrite sumℤq-[suc]-lem (f ∘ _ℕ⊞_ m)
                               | sumℤq-ℕ⊞-lem m f = refl

  sumℤq-⊞-lem : ∀ m f → sumℤq (f ∘ _⊞_ m) ≡ sumℤq f
  sumℤq-⊞-lem = sumℤq-ℕ⊞-lem ∘ Fin.toℕ

module G-implem (p q : ℕ) (g' : Fin p) (0[p] 1[p] : Fin p) (0[q] 1[q] : Fin q) where
  open ℤq-implem q 0[q] 1[q] public
  open ℤq-implem p 0[p] 1[p] public using () renaming (ℤq to G; _⊠_ to _∙_; _[^]ℕ_ to _^[p]_)

  g : G
  g = g'

  _^_ : G → ℤq → G
  x ^ n = x ^[p] Fin.toℕ n

  g^_ : ℤq → G
  g^ n = g ^ n

  postulate
    g^-inj : ∀ m n → g^ m ≡ g^ n → m ≡ n

module G-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum ℤq)
  (sumℤq-lem : ∀ f x → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  where

  open Univ ℤq
  open ℤq-count ℤq _⊞_ sumℤq sumℤq-lem

  ⁇G : ↺ `ℤq G
  run↺ ⁇G x = g ^ x

module DDH
  (ℤq  : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G   : ★)
  (g^_ : ℤq → G)
  where
    DDHAdv : ★ → ★
    DDHAdv R = R → G → G → G → Bit

    DDH⅁₀ : ∀ {R} {_I : ★} → DDHAdv R → (R × ℤq × ℤq × _I) → Bit
    DDH⅁₀ D (r , x , y , _) = D r (g^ x) (g^ y) (g^ (x ⊠ y))

    DDH⅁₁ : ∀ {R} → DDHAdv R → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁₁ D (r , x , y , z) = D r (g^ x) (g^ y) (g^ z)

    DDH⅁ : ∀ {R} → DDHAdv R → Bit → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁ D b = (case b 0→ DDH⅁₀ 1→ DDH⅁₁) D

    -- ⅁′ : ∀ {R} → DDHAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    -- ⅁′ D (b , x , y , z , r) = DDH⅁ D b (x , y , z , r)

    module With↺ where
        open Univ ℤq
        open `★ public renaming (`X to `ℤq)
        DDHAdv↺ : `★ → ★
        DDHAdv↺ R = G → G → G → ↺ R Bit
        DDH⅁₀↺ : ∀ {R _I} → DDHAdv↺ R → ↺ (R `× `ℤq `× `ℤq `× _I) Bit
        run↺ (DDH⅁₀↺ D) = DDH⅁₀ (λ a b c d → run↺ (D b c d) a)

module El-Gamal-Generic
  (ℤq : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (Message : ★)
  (_⊕_ : G → Message → Message)
  (_⊕⁻¹_ : G → Message → Message)
  where

    -- α is the pk
    -- α = g ^ x
    -- x is the sk

    PubKey = G
    SecKey = ℤq
    KeyPair = PubKey × SecKey
    CipherText = G × Message

    M = Message
    C = CipherText

    KeyGen : ℤq → KeyPair
    KeyGen x = (g ^ x , x)

    -- KeyGen↺ : ↺ ℤq KeyPair
    -- KeyGen↺ = mk KeyGen

    Enc : PubKey → Message → ℤq → CipherText
    Enc α m y = β , ζ where
      β = g ^ y
      δ = α ^ y
      ζ = δ ⊕ m

    -- Enc↺ : PubKey → Message → ↺ ℤq CipherText
    -- Enc↺ α m = mk (Enc α m)

    Dec : SecKey → CipherText → Message
    Dec x (β , ζ) = (β ^ x) ⊕⁻¹ ζ

    EncAdv : ★ → ★
    EncAdv R = PubKey → R → (Bit → M) × (C → Bit)

    {-
    Game0 : ∀ {R _I : Set} → EncAdv R → (Bit × ℤq × ℤq × _I × R) → Bit
    Game0 A (b , x , y , z , r) =
      let (pk , sk) = KeyGen x
          (m , D) = A pk r in
      D (Enc pk (m b) y)

    Game : (i : Bit) → ∀ {R} → EncAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    Game i A (b , x , y , z , r) =
      let (α , sk) = KeyGen x
          (m , D) = A α r
          β = g ^ y
          δ = α ^ case i 0→ y 1→ z
          ζ = δ ⊕ m b
      in {-b ==ᵇ-} D (β , ζ)

    Game-0b≡Game0 : ∀ {R} → Game 0b ≡ Game0 {R}
    Game-0b≡Game0 = refl
      -}

    SS⅁ : ∀ {R _I : Set} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    SS⅁ A b (r , x , y , z) =
      let -- (pk , sk) = KeyGen x
          (m , D) = A pk r in
      D (Enc pk (m b) y)
         where pk = g ^ x

    open DDH ℤq _⊠_ G (_^_ g) public

    -- Game0 ≈ Game 0b
    -- Game1 = Game 1b

    -- Game0 ≤ ε
    -- Game1 ≡ 0

    -- ⁇ ⊕ x ≈ ⁇

    -- g ^ ⁇ ∙ x ≈ g ^ ⁇

module El-Gamal-Base
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    (_⁻¹ : G → G)
    (_∙_ : G → G → G)
    where

    g^_ : ℤq → G
    g^ x = g ^ x

    _/_ : G → G → G
    x / y = x ∙ (y ⁻¹)
    open El-Gamal-Generic ℤq _⊠_ G g _^_ G _∙_ (flip _/_) public

    TrA : ∀ {R} → Bit → EncAdv R → DDHAdv R
    TrA b A r gˣ gʸ gˣʸ = d (gʸ , gˣʸ ∙ m b)
       where m,d = A gˣ r
             m = proj₁ m,d
             d = proj₂ m,d

    like-SS⅁ : ∀ {R _I : Set} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    like-SS⅁ A b (r , x , y , _z) =
      let -- gˣ = g ^ x
          -- gʸ = g ^ y
          (m , D) = A gˣ r in
      D (gʸ , (gˣ ^ y) ∙ m b)
      where gˣ = g ^ x
            gʸ = g ^ y

    SS⅁≡like-SS⅁ : ∀ {R _I} → SS⅁ {R} {_I} ≡ like-SS⅁
    SS⅁≡like-SS⅁ = refl

    OTP⅁ : ∀ {R : Set} → (R → G → G) → (R → G → G → G → Bit) → (R × ℤq × ℤq × ℤq) → Bit
    OTP⅁ M D (r , x , y , z) = D r gˣ gʸ (gᶻ ∙ M r gˣ)
      where gˣ = g ^ x
            gʸ = g ^ y
            gᶻ = g ^ z

    module WithℤqProps
        (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
      -- (⊠-comm : Commutative _≡_ _⊠_)
      -- (^-comm : ∀ α x y → (α ^ x) ^ y ≡ (α ^ y) ^ x)
        (sumℤq : Sum ℤq)
        (sumℤq-ext : SumExt sumℤq) where
        #q_ : Count ℤq
        #q_ = sumToCount sumℤq

        module SumU
          (R : Set)
          (sumR : Sum R)
          (sumR-ext : SumExt sumR)
          where
          U = R × ℤq × ℤq × ℤq
          sumU : Sum U
          sumU = sumProd sumR (sumProd sumℤq (sumProd sumℤq sumℤq))
          #U_ : Count U
          #U_ = sumToCount sumU
          sumU-ext : SumExt sumU
          sumU-ext = sumProd-ext sumR-ext (sumProd-ext sumℤq-ext (sumProd-ext sumℤq-ext sumℤq-ext))

        module WithSumR
            (R : Set)
            (sumR : Sum R)
            (sumR-ext : SumExt sumR)
           where
           open SumU R sumR sumR-ext

           module EvenMoreProof
            (ddh-hyp : (A : DDHAdv R) → #U (DDH⅁ A 0b) ≡ #U (DDH⅁ A 1b))

            (otp-lem : ∀ (A : G → Bit) m → #q(λ x → A (g^ x ∙ m)) ≡ #q(λ x → A (g^ x)))
            where

                _≈U_ : (f g : U → Bit) → Set
                f ≈U g = #U f ≡ #U g

                otp-lem' : ∀ D M₀ M₁ → OTP⅁ M₀ D ≈U OTP⅁ M₁ D
                otp-lem' D M₀ M₁ = sumR-ext (f3 M₀) (f3 M₁) (λ r →
                                     sumℤq-ext (f2 M₀ r) (f2 M₁ r) (λ x →
                                       sumℤq-ext (f1 M₀ r x) (f1 M₁ r x) (λ y →
                                         pf r x y)))
                  where
                  f0 = λ M r x y z → OTP⅁ M D (r , x , y , z)
                  f1 = λ M r x y → sumℤq (Bool.toℕ ∘ f0 M r x y)
                  f2 = λ M r x → sumℤq (f1 M r x)
                  f3 = λ M r → sumℤq (f2 M r)
                  pf : ∀ r x y → f1 M₀ r x y ≡ f1 M₁ r x y
                  pf r x y = pf'
                    where gˣ = g^ x
                          gʸ = g^ y
                          m0 = M₀ r gˣ
                          m1 = M₁ r gˣ
                          f5 = λ M z → D r gˣ gʸ (g^ z ∙ M)
                          pf' : #q(f5 m0) ≡ #q(f5 m1)
                          pf' rewrite otp-lem (D r gˣ gʸ) m0
                                    | otp-lem (D r gˣ gʸ) m1 = refl

      {-
        #-proj₁ : ∀ {A B : Set} {f g : A → Bit} → # f ≡ # g
                   → #_ {A × B} (f ∘ proj₁) ≡ #_ {A × B} (g ∘ proj₁)
        #-proj₁ = {!!}

        otp-lem'' : ∀ (A : G → Bit) m
           → #(λ { (x , y) → A (g^ x ∙ m) }) ≡ #(λ { (x , y) → A (g ^ x) })
        otp-lem'' = {!!}
        -}
                projM : EncAdv R → Bit → R → G → G
                projM A b r gˣ = proj₁ (A gˣ r) b

                projD : EncAdv R → R → G → G → G → Bit
                projD A r gˣ gʸ gᶻ∙M = proj₂ (A gˣ r) (gʸ , gᶻ∙M)

                module WithAdversary (A : EncAdv R) b where
                    Aᵇ = TrA b A
                    A¬ᵇ = TrA (not b) A

                    pf0,5 : SS⅁ A b ≗ DDH⅁ Aᵇ 0b
                    pf0,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

                    pf1 : #U(SS⅁ A b) ≡ #U(DDH⅁ Aᵇ 0b)
                    pf1 = sumU-ext _ _ (cong Bool.toℕ ∘ pf0,5)

                    pf2 : DDH⅁ Aᵇ 0b ≈U DDH⅁ Aᵇ 1b
                    pf2 = ddh-hyp Aᵇ

                    pf2,5 : DDH⅁ Aᵇ 1b ≡ OTP⅁ (projM A b) (projD A)
                    pf2,5 = refl

                    pf3 : DDH⅁ Aᵇ 1b ≈U DDH⅁ A¬ᵇ 1b
                    pf3 = otp-lem' (projD A) (projM A b) (projM A (not b))

                    pf4 : DDH⅁ A¬ᵇ 1b ≈U DDH⅁ A¬ᵇ 0b
                    pf4 = ≡.sym (ddh-hyp A¬ᵇ)

                    pf4,5 : SS⅁ A (not b) ≗ DDH⅁ A¬ᵇ 0b
                    pf4,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

                    pf5 : #U(SS⅁ A (not b)) ≡ #U(DDH⅁ A¬ᵇ 0b)
                    pf5 = sumU-ext _ _ (cong Bool.toℕ ∘ pf4,5)

                    final : #U(SS⅁ A b) ≡ #U(SS⅁ A (not b))
                    final rewrite pf1 | pf2 | pf3 | pf4 | pf5 = refl

      {-
        pf1 : ∀ {R} A r → Game 0b {R} A r ≡ ⅁′ (TrA 1b A) r
        pf1 A (true , x , y , z , r) rewrite dist-^-⊠ g x y = refl
        pf1 A (false , x , y , z , r) = {!!}

        pf2 : ∀ {R} A r → Game 1b {R} A r ≡ ⅁′ (TrA 0b A) r
        pf2 A (true , x , y , z , r)  = {!!}
        pf2 A (false , x , y , z , r) = {!!}
-}
module El-Gamal-Hashed
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    -- (HKey : ★)
    (|M| : ℕ)
    (ℋ : {-HKey →-} G → Bits |M|) where

    Message = Bits |M|

    ℋ⟨_⟩⊕_ : G → Message → Message
    ℋ⟨ δ ⟩⊕ m = ℋ δ ⊕ m

    open El-Gamal-Generic ℤq _⊠_ G g _^_ Message ℋ⟨_⟩⊕_

    module Proof
      -- (⊠-comm : Commutative _≡_ _⊠_)
      -- (^-lem : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
      (^-comm : ∀ α x y → (α ^ x) ^ y ≡ (α ^ y) ^ x)
      -- (x ∙ x ⁻¹ ≡ 0)
      (ℚ : ★)
      (dist : ℚ → ℚ → ℚ)
      (1/2 : ℚ)
      (_≤_ : ℚ → ℚ → ★)
      (ε-DDH : ℚ)
      where

        Pr[S_] : Bool → ℚ
        Pr[S b ] = {!!}

        -- SS
        -- SS = dist Pr[

        Pr[S₀] = Pr[S 0b ]
        Pr[S₁] = Pr[S 1b ]

        pf1 : Pr[S₁] ≡ 1/2
        pf1 = {!!}

        pf2 : dist Pr[S₀] 1/2 ≡ dist Pr[S₀] Pr[S₁]
        pf2 = {!!}

        pf3 : dist Pr[S₀] Pr[S₁] ≤ ε-DDH
        pf3 = {!!}

        pf4 : dist Pr[S₀] 1/2 ≤ ε-DDH
        pf4 = {!!}

module G11 = G-implem 11 10 (## 2) (## 0) (## 1) (## 0) (## 1)
open G11
module E11 = El-Gamal-Base _ _⊠_ G g _^_ {!!} _∙_
open E11
open WithℤqProps ?
-- open Proof {!!}

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