agda: Document ΔVal

agda: Document ΔVal

Old-commit-hash: 0db0b8be91a20a06651cdeb565c7e6d63de28db6

{-
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
-- Instead of:
-- 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 ++ emptyBag ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  map-over-++ : ∀ {f b d} →
    mapBag f (b ++ d) ≡ mapBag f b ++ mapBag f d

----------------------------
-- Useful data structures --
----------------------------

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

couple : Set → Set → Set
couple A B = Quadruple A (λ _ → B) (λ _ _ → ⊤) (λ _ _ _ → ⊤)

triple : Set → Set → Set → Set
triple A B C = Quadruple A (λ _ → B) (λ _ _ → C) (λ _ _ _ → ⊤)

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

-- Validity proofs are not literally embedded in terms.
-- They are introduced and checked at interpretation time.
-- Invalid programs are well-formed terms,
-- they just denote the empty function.
--
-- Thus do we avoid the horrible mutual recursions between
-- the syntax and semantics of changes and between the
-- program transformation and its correctness, which drives
-- the type checker to thrashing.

data ΔTerm : Context → Type → Set where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → ΔTerm Γ nats
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → ΔTerm Γ bags
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → ΔTerm Γ τ
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (dt : ΔTerm (τ₁ • Γ) τ₂) →
         ΔTerm Γ (τ₁ ⇒ τ₂)
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {σ τ Γ}
    (ds : ΔTerm Γ (σ ⇒ τ))
    ( t :  Term Γ σ)
    (dt : ΔTerm Γ σ) →
    ΔTerm Γ τ
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ}
    (ds : ΔTerm Γ nats)
    (dt : ΔTerm Γ nats) →
    ΔTerm Γ nats
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ}
    ( s :   Term Γ (nats ⇒ nats))
    (ds : ΔTerm Γ (nats ⇒ nats))
    ( t :   Term Γ bags)
    (dt : ΔTerm Γ bags) →
    ΔTerm Γ bags
  Δmap₁ : ∀ {Γ}
    ( s :   Term Γ (nats ⇒ nats))
    (dt : ΔTerm Γ bags) →
    ΔTerm Γ bags

---------------------------------
-- Semantic domains of changes --
---------------------------------

ΔVal : Type → Set
ΔEnv : Context → Set
valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set

--
-- ΔVal τ is intended to be the semantic domain for changes of values of type
-- τ, which was obtained by ⟦ Δ-Type τ ⟧ in other formalizations.
--
-- ΔVal : Type → Set
ΔVal nats = ℕ × ℕ
ΔVal bags = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

-- ΔEnv : Context → Set
ΔEnv ∅ = EmptySet
ΔEnv (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ _ → ΔVal τ)
  (λ v dv → valid v dv)
  (λ _ _ _ → ΔEnv Γ)

_⊕_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊝_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {σ ⇒ τ} f df =
  ∀ (v : ⟦ σ ⟧) (dv : ΔVal σ) (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]

R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)

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

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

v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → 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] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
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]
    ,
    (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

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

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

--------------------------
-- Semantics of changes --
--------------------------

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

-- Used to signal free variables of a term.
-- Totally like subcontext relation _≼_ : (Γ₁ Γ₂ : Context) → Set
data Vars : Context → Set where
  ∅ : Vars ∅
  alter : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ)
  abide : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ)

-- Declare everything in Γ to be volatile.
select-none : {Γ : Context} → Vars Γ
select-none {∅} = ∅
select-none {τ • Γ} = alter (select-none {Γ})

select-just : ∀ {τ Γ} → Var Γ τ → Vars Γ
select-just {Γ = τ • Γ₀} this = abide select-none
select-just (that x) = alter (select-just x)

-- De-facto union of free variables
FV-union : ∀ {Γ} → Vars Γ → Vars Γ → Vars Γ
FV-union ∅ ∅ = ∅
FV-union (alter us) (alter vs) = alter (FV-union us vs)
FV-union (alter us) (abide vs) = abide (FV-union us vs)
FV-union (abide us) (alter vs) = abide (FV-union us vs)
FV-union (abide us) (abide vs) = abide (FV-union us vs)

tail : ∀ {τ Γ} → Vars (τ • Γ) → Vars Γ
tail (abide vars) = vars
tail (alter vars) = vars

-- Free variables of a term.
-- Free variables are marked as abiding, bound variables altering.
FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
FV {Γ = Γ} (nat n) = select-none
FV {Γ = Γ} (bag b) = select-none
FV (var x) = select-just x
FV (abs t) = tail (FV t)
FV (app s t) = FV-union (FV s) (FV t)
FV (add s t) = FV-union (FV s) (FV t)
FV (map s t) = FV-union (FV s) (FV t)

-- A description of variables is honest w.r.t. a Δ-environment
-- if every variable described as stable receives the nil change.
data Honest : ∀ {Γ} → ΔEnv Γ → Vars Γ → Set where
  clearly : Honest ∅ ∅
  alter : ∀ {Γ τ} {v : ⟦ τ ⟧} {dv R[v,dv] vars ρ} →
          Honest {Γ} ρ vars →
          Honest {τ • Γ} (cons v dv R[v,dv] ρ) (alter vars)
  abide : ∀ {Γ τ} {v : ⟦ τ ⟧} {dv R[v,dv] vars ρ} →
          v ⊕ dv ≡ v →
          Honest {Γ} ρ vars →
          Honest {τ • Γ} (cons v dv R[v,dv] ρ) (abide vars)

_is-valid-for_ : ∀ {τ Γ} → ΔTerm Γ τ → ΔEnv Γ → Set

⟦_⟧Δ : ∀ {τ Γ} →
  (t : ΔTerm Γ τ) → (ρ : ΔEnv Γ) → t is-valid-for ρ →
  ΔVal τ

-- _is-valid-for_ : ∀ {τ Γ} → ΔTerm Γ τ → ΔEnv Γ → Set
Δnat old new is-valid-for ρ = ⊤
Δbag db is-valid-for ρ = ⊤
Δvar x is-valid-for ρ = ⊤

_is-valid-for_ {σ ⇒ τ} (Δabs dt) ρ =
  (v : ⟦ σ ⟧) (dv : ΔVal σ) (R[v,dv] : valid v dv) →
  _is-valid-for_ dt (cons v dv R[v,dv] ρ)

Δapp ds t dt is-valid-for ρ = Quadruple
  (ds is-valid-for ρ)
  (λ _ → dt is-valid-for ρ)
  (λ _ v-dt → valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt))
  (λ _ _ _ → ⊤)

Δadd ds dt is-valid-for ρ = couple
  (ds is-valid-for ρ)
  (dt is-valid-for ρ)

Δmap₀ s ds t dt is-valid-for ρ = couple
  (ds is-valid-for ρ)
  (dt is-valid-for ρ)

Δmap₁ s db is-valid-for ρ = couple
  (db is-valid-for ρ)
  (Honest ρ (FV s))

⟦ Δnat old new ⟧Δ ρ tt = old , new
⟦ Δbag db ⟧Δ ρ tt = db
⟦ Δvar x ⟧Δ ρ tt = ⟦ x ⟧ΔVar ρ

⟦ Δabs dt ⟧Δ ρ make-valid = λ v dv R[v,dv] →
  ⟦ dt ⟧Δ (cons v dv R[v,dv] ρ) (make-valid v dv R[v,dv])

⟦ Δapp ds t dt ⟧Δ ρ (cons v-ds v-dt R[ds,dt] _) =
  ⟦ ds ⟧Δ ρ v-ds (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt) R[ds,dt]

⟦ Δadd ds dt ⟧Δ ρ (cons v-ds v-dt _ _) =
  let
    (old-s , new-s) = ⟦ ds ⟧Δ ρ v-ds
    (old-t , new-t) = ⟦ dt ⟧Δ ρ v-dt
  in
    (old-s + old-t , new-s + new-t)

⟦ Δmap₀ s ds t dt ⟧Δ ρ (cons v-ds v-dt _ _) =
  let
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ v-ds
    dv = ⟦ dt ⟧Δ ρ v-dt
  in
    mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v

⟦ Δmap₁ s dt ⟧Δ ρ (cons v-dt honesty _ _) =
  mapBag (⟦ s ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt)

-- Minor issue about concrete syntax
--
-- Because ⟦_⟧Δ have dependently typed arguments,
-- we can't make it an instance of the Meaning
-- type class and can't use ⟦_⟧ on ΔTerms.
--
-- Error message:
-- Cannot instantiate the metavariable _872 to solution ((ρ : ΔEnv .Γ)
-- → t is-valid-for ρ → ΔVal .τ) since it contains the variable t
-- which is not in scope of the metavariable or irrelevant in the
-- metavariable but relevant in the solution
-- when checking that the expression ⟦_⟧Δ has type
-- ΔTerm .Γ .τ → _Semantics_872
--
--     meaning-ΔTerm : ∀ {τ Γ} → Meaning (ΔTerm Γ τ)
--     meaning-ΔTerm = meaning ⟦_⟧Δ

----------------------------
-- Program transformation --
----------------------------

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)
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

-----------------
-- Correctness --
-----------------

unrestricted : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} →
  derive t is-valid-for ρ

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

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

-- Corollary: (f ⊕ df) (v ⊕ dv) = f v ⊕ df v dv

corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {ρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore ρ) ⊕ ⟦ derive s ⟧Δ ρ (unrestricted s))
    (⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted t))
  ≡  ⟦ s ⟧ (ignore ρ) (⟦ t ⟧ (ignore ρ)) ⊕
     ⟦ derive s ⟧Δ ρ (unrestricted s) (⟦ t ⟧ (ignore ρ))
    (⟦ derive t ⟧Δ ρ (unrestricted t)) (validity {t = t})

corollary s t {ρ} = proj₂
  (validity {t = s} (⟦ t ⟧ (ignore ρ))
    (⟦ derive t ⟧Δ ρ (unrestricted t)) (validity {t = t}))

unrestricted (nat n) = tt
unrestricted (bag b) = tt
unrestricted (var x) {ρ} = tt
unrestricted (abs t) {ρ} = (λ _ _ _ → unrestricted t)
unrestricted (app s t) {ρ} = cons
  (unrestricted (s))
  (unrestricted (t))
  (validity {t = t}) tt
unrestricted (add s t) {ρ} = cons
  (unrestricted (s))
  (unrestricted (t)) tt tt
unrestricted (map s t) {ρ} = cons
  (unrestricted (s))
  (unrestricted (t)) tt tt

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 ⟧Δ ρ (unrestricted 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 ⟧Δ ρ₂ (unrestricted 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 ⟧Δ ρ₁ (unrestricted 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 ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)

correctness {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted 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 ⟧Δ ρ′ (unrestricted 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
-- Instead of:
-- 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 ++ emptyBag ≡ b
postulate b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d
postulate [b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d
postulate
  map-over-++ : ∀ {f b d} →
    mapBag f (b ++ d) ≡ mapBag f b ++ mapBag f d

----------------------------
-- Useful data structures --
----------------------------

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

couple : Set → Set → Set
couple A B = Quadruple A (λ _ → B) (λ _ _ → ⊤) (λ _ _ _ → ⊤)

triple : Set → Set → Set → Set
triple A B C = Quadruple A (λ _ → B) (λ _ _ → C) (λ _ _ _ → ⊤)

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

-- Validity proofs are not literally embedded in terms.
-- They are introduced and checked at interpretation time.
-- Invalid programs are well-formed terms,
-- they just denote the empty function.
--
-- Thus do we avoid the horrible mutual recursions between
-- the syntax and semantics of changes and between the
-- program transformation and its correctness, which drives
-- the type checker to thrashing.

data ΔTerm : Context → Type → Set where
  -- changes to numbers are replacement pairs
  Δnat : ∀ {Γ} → (old : ℕ) → (new : ℕ) → ΔTerm Γ nats
  -- changes to bags are bags
  Δbag : ∀ {Γ} → (db : Bag) → ΔTerm Γ bags
  -- changes to variables are variables
  Δvar : ∀ {τ Γ} → (x : Var Γ τ) → ΔTerm Γ τ
  -- changes to abstractions are binders of x and dx
  Δabs : ∀ {τ₁ τ₂ Γ} → (dt : ΔTerm (τ₁ • Γ) τ₂) →
         ΔTerm Γ (τ₁ ⇒ τ₂)
  -- changes to applications are applications of a value and a change
  Δapp : ∀ {σ τ Γ}
    (ds : ΔTerm Γ (σ ⇒ τ))
    ( t :  Term Γ σ)
    (dt : ΔTerm Γ σ) →
    ΔTerm Γ τ
  -- changes to addition are changes to their components
  Δadd : ∀ {Γ}
    (ds : ΔTerm Γ nats)
    (dt : ΔTerm Γ nats) →
    ΔTerm Γ nats
  -- There are two kinds of changes to maps:
  -- 0. recomputation,
  -- 1. mapping over changes,
  -- the latter used only with some form of isNil available.
  Δmap₀ : ∀ {Γ}
    ( s :   Term Γ (nats ⇒ nats))
    (ds : ΔTerm Γ (nats ⇒ nats))
    ( t :   Term Γ bags)
    (dt : ΔTerm Γ bags) →
    ΔTerm Γ bags
  Δmap₁ : ∀ {Γ}
    ( s :   Term Γ (nats ⇒ nats))
    (dt : ΔTerm Γ bags) →
    ΔTerm Γ bags

---------------------------------
-- Semantic domains of changes --
---------------------------------

ΔVal : Type → Set
ΔEnv : Context → Set
valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set

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

-- ΔEnv : Context → Set
ΔEnv ∅ = EmptySet
ΔEnv (τ • Γ) = Quadruple
  ⟦ τ ⟧
  (λ _ → ΔVal τ)
  (λ v dv → valid v dv)
  (λ _ _ _ → ΔEnv Γ)

_⊕_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊝_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
infixl 6 _⊕_ _⊝_ -- as with + - in GHC.Num

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {nats} n dn = n ≡ proj₁ dn
valid {bags} b db = ⊤
valid {σ ⇒ τ} f df =
  ∀ (v : ⟦ σ ⟧) (dv : ΔVal σ) (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]

R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)

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

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

v⊕[u⊝v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → 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] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
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]
    ,
    (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

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

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

--------------------------
-- Semantics of changes --
--------------------------

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

-- Used to signal free variables of a term.
-- Totally like subcontext relation _≼_ : (Γ₁ Γ₂ : Context) → Set
data Vars : Context → Set where
  ∅ : Vars ∅
  alter : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ)
  abide : ∀ {τ Γ} → Vars Γ → Vars (τ • Γ)

-- Declare everything in Γ to be volatile.
select-none : {Γ : Context} → Vars Γ
select-none {∅} = ∅
select-none {τ • Γ} = alter (select-none {Γ})

select-just : ∀ {τ Γ} → Var Γ τ → Vars Γ
select-just {Γ = τ • Γ₀} this = abide select-none
select-just (that x) = alter (select-just x)

-- De-facto union of free variables
FV-union : ∀ {Γ} → Vars Γ → Vars Γ → Vars Γ
FV-union ∅ ∅ = ∅
FV-union (alter us) (alter vs) = alter (FV-union us vs)
FV-union (alter us) (abide vs) = abide (FV-union us vs)
FV-union (abide us) (alter vs) = abide (FV-union us vs)
FV-union (abide us) (abide vs) = abide (FV-union us vs)

tail : ∀ {τ Γ} → Vars (τ • Γ) → Vars Γ
tail (abide vars) = vars
tail (alter vars) = vars

-- Free variables of a term.
-- Free variables are marked as abiding, bound variables altering.
FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
FV {Γ = Γ} (nat n) = select-none
FV {Γ = Γ} (bag b) = select-none
FV (var x) = select-just x
FV (abs t) = tail (FV t)
FV (app s t) = FV-union (FV s) (FV t)
FV (add s t) = FV-union (FV s) (FV t)
FV (map s t) = FV-union (FV s) (FV t)

-- A description of variables is honest w.r.t. a Δ-environment
-- if every variable described as stable receives the nil change.
data Honest : ∀ {Γ} → ΔEnv Γ → Vars Γ → Set where
  clearly : Honest ∅ ∅
  alter : ∀ {Γ τ} {v : ⟦ τ ⟧} {dv R[v,dv] vars ρ} →
          Honest {Γ} ρ vars →
          Honest {τ • Γ} (cons v dv R[v,dv] ρ) (alter vars)
  abide : ∀ {Γ τ} {v : ⟦ τ ⟧} {dv R[v,dv] vars ρ} →
          v ⊕ dv ≡ v →
          Honest {Γ} ρ vars →
          Honest {τ • Γ} (cons v dv R[v,dv] ρ) (abide vars)

_is-valid-for_ : ∀ {τ Γ} → ΔTerm Γ τ → ΔEnv Γ → Set

⟦_⟧Δ : ∀ {τ Γ} →
  (t : ΔTerm Γ τ) → (ρ : ΔEnv Γ) → t is-valid-for ρ →
  ΔVal τ

-- _is-valid-for_ : ∀ {τ Γ} → ΔTerm Γ τ → ΔEnv Γ → Set
Δnat old new is-valid-for ρ = ⊤
Δbag db is-valid-for ρ = ⊤
Δvar x is-valid-for ρ = ⊤

_is-valid-for_ {σ ⇒ τ} (Δabs dt) ρ =
  (v : ⟦ σ ⟧) (dv : ΔVal σ) (R[v,dv] : valid v dv) →
  _is-valid-for_ dt (cons v dv R[v,dv] ρ)

Δapp ds t dt is-valid-for ρ = Quadruple
  (ds is-valid-for ρ)
  (λ _ → dt is-valid-for ρ)
  (λ _ v-dt → valid (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt))
  (λ _ _ _ → ⊤)

Δadd ds dt is-valid-for ρ = couple
  (ds is-valid-for ρ)
  (dt is-valid-for ρ)

Δmap₀ s ds t dt is-valid-for ρ = couple
  (ds is-valid-for ρ)
  (dt is-valid-for ρ)

Δmap₁ s db is-valid-for ρ = couple
  (db is-valid-for ρ)
  (Honest ρ (FV s))

⟦ Δnat old new ⟧Δ ρ tt = old , new
⟦ Δbag db ⟧Δ ρ tt = db
⟦ Δvar x ⟧Δ ρ tt = ⟦ x ⟧ΔVar ρ

⟦ Δabs dt ⟧Δ ρ make-valid = λ v dv R[v,dv] →
  ⟦ dt ⟧Δ (cons v dv R[v,dv] ρ) (make-valid v dv R[v,dv])

⟦ Δapp ds t dt ⟧Δ ρ (cons v-ds v-dt R[ds,dt] _) =
  ⟦ ds ⟧Δ ρ v-ds (⟦ t ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt) R[ds,dt]

⟦ Δadd ds dt ⟧Δ ρ (cons v-ds v-dt _ _) =
  let
    (old-s , new-s) = ⟦ ds ⟧Δ ρ v-ds
    (old-t , new-t) = ⟦ dt ⟧Δ ρ v-dt
  in
    (old-s + old-t , new-s + new-t)

⟦ Δmap₀ s ds t dt ⟧Δ ρ (cons v-ds v-dt _ _) =
  let
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ v-ds
    dv = ⟦ dt ⟧Δ ρ v-dt
  in
    mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v

⟦ Δmap₁ s dt ⟧Δ ρ (cons v-dt honesty _ _) =
  mapBag (⟦ s ⟧ (ignore ρ)) (⟦ dt ⟧Δ ρ v-dt)

-- Minor issue about concrete syntax
--
-- Because ⟦_⟧Δ have dependently typed arguments,
-- we can't make it an instance of the Meaning
-- type class and can't use ⟦_⟧ on ΔTerms.
--
-- Error message:
-- Cannot instantiate the metavariable _872 to solution ((ρ : ΔEnv .Γ)
-- → t is-valid-for ρ → ΔVal .τ) since it contains the variable t
-- which is not in scope of the metavariable or irrelevant in the
-- metavariable but relevant in the solution
-- when checking that the expression ⟦_⟧Δ has type
-- ΔTerm .Γ .τ → _Semantics_872
--
--     meaning-ΔTerm : ∀ {τ Γ} → Meaning (ΔTerm Γ τ)
--     meaning-ΔTerm = meaning ⟦_⟧Δ

----------------------------
-- Program transformation --
----------------------------

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)
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

-----------------
-- Correctness --
-----------------

unrestricted : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} →
  derive t is-valid-for ρ

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

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

-- Corollary: (f ⊕ df) (v ⊕ dv) = f v ⊕ df v dv

corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {ρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore ρ) ⊕ ⟦ derive s ⟧Δ ρ (unrestricted s))
    (⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted t))
  ≡  ⟦ s ⟧ (ignore ρ) (⟦ t ⟧ (ignore ρ)) ⊕
     ⟦ derive s ⟧Δ ρ (unrestricted s) (⟦ t ⟧ (ignore ρ))
    (⟦ derive t ⟧Δ ρ (unrestricted t)) (validity {t = t})

corollary s t {ρ} = proj₂
  (validity {t = s} (⟦ t ⟧ (ignore ρ))
    (⟦ derive t ⟧Δ ρ (unrestricted t)) (validity {t = t}))

unrestricted (nat n) = tt
unrestricted (bag b) = tt
unrestricted (var x) {ρ} = tt
unrestricted (abs t) {ρ} = (λ _ _ _ → unrestricted t)
unrestricted (app s t) {ρ} = cons
  (unrestricted (s))
  (unrestricted (t))
  (validity {t = t}) tt
unrestricted (add s t) {ρ} = cons
  (unrestricted (s))
  (unrestricted (t)) tt tt
unrestricted (map s t) {ρ} = cons
  (unrestricted (s))
  (unrestricted (t)) tt tt

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 ⟧Δ ρ (unrestricted 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 ⟧Δ ρ₂ (unrestricted 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 ⟧Δ ρ₁ (unrestricted 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 ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)

correctness {t = app s t} {ρ} =
  let
    v = ⟦ t ⟧ (ignore ρ)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted 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 ⟧Δ ρ′ (unrestricted t)
    ≡⟨ correctness {t = t} {ρ′} ⟩
      ⟦ t ⟧ (update ρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update ρ)) v⊕[u⊝v]=u ⟩
      ⟦ t ⟧ (v • update ρ)
    ∎
  ) where open ≡-Reasoning


Updated doc for an unproven conjecture.

Updated doc for an unproven conjecture.

------------------------------------------------------------------------------
-- Unproven PA properties
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.Properties.UnprovedATP where

open import PA.Axiomatic.Mendelson.Base
open import PA.Axiomatic.Mendelson.PropertiesATP

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

+-asocc : ∀ m n o → m + n + o ≈ m + (n + o)
+-asocc m n o = S₉ A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≈ i + (n + o)
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 +-leftCong #-}

  -- 25 November 2013: Vampire 0.6 proves the theorem using a time out
  -- of (300 sec).
  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is +-leftCong #-}

------------------------------------------------------------------------------
-- Unproven PA properties
------------------------------------------------------------------------------

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

module PA.Axiomatic.Mendelson.Properties.UnprovedATP where

open import PA.Axiomatic.Mendelson.Base
open import PA.Axiomatic.Mendelson.PropertiesATP

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

+-asocc : ∀ m n o → m + n + o ≈ m + (n + o)
+-asocc m n o = S₉ A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≈ i + (n + o)
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 +-leftCong #-}

  -- 31 July 2013: The ATPs could not prove the theorem (240 sec).
  --
  -- After the addition of the inequality _≉_, no ATP proves the
  -- theorem. Before it, only Equinox 5.0alpha (2010-06-29) had proved
  -- the theorem.
  postulate is : ∀ i → A i → A (succ i)
  {-# ATP prove is +-leftCong #-}


Agda 2.4.2 regression? (see issue 1264)

Agda 2.4.2 regression? (see issue 1264)

------------------------------------------------------------------------------
-- The ABP using Agda standard library
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.ABP-SL where

open import Coinduction
open import Data.Bool
open import Data.Product
open import Data.Stream
open import Relation.Nullary

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

Bit : Set
Bit = Bool

-- Data type used to model the fair unreliable transmission channel.
data Err (A : Set) : Set where
  ok    : (x : A) → Err A
  error : Err A

-- The mutual sender functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
sendA  : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bool)
awaitA : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bit)

sendA b (i ∷ is) ds = (i , b) ∷ ♯ awaitA b (i ∷ is) ds

awaitA b (i ∷ is) (ok b' ∷ ds) with b ≟ b'
... | yes p = sendA (not b) (♭ is) (♭ ds)
... | no ¬p = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))
awaitA b (i ∷ is) (error ∷ ds) = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))

-- The receiver functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
ackA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream Bit
ackA b (ok (_ , b') ∷ bs) with b ≟ b'
... | yes p = b ∷ ♯ (ackA (not b) (♭ bs))
... | no ¬p = not b ∷ ♯ (ackA b (♭ bs))
ackA b (error ∷ bs) = not b ∷ ♯ (ackA b (♭ bs))

{-# NO_TERMINATION_CHECK #-}
outA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream A
outA b (ok (i , b') ∷ bs) with b ≟ b'
... | yes p = i ∷ ♯ (outA (not b) (♭ bs))
... | no ¬p = outA b (♭ bs)
outA b (error ∷ bs) = outA b (♭ bs)

-- Model the fair unreliable tranmission channel.
--
-- 29 August 2014 Requires the non-termination flag when using
-- --without-K after the release of Agda 2.4.2. See issue 1264.
{-# NO_TERMINATION_CHECK #-}
corruptA : {A : Set} → Stream Bit → Stream A → Stream (Err A)
corruptA (true ∷ os)  (_ ∷ xs) = error ∷ ♯ (corruptA (♭ os) (♭ xs))
corruptA (false ∷ os) (x ∷ xs) = ok x ∷ ♯ (corruptA (♭ os) (♭ xs))

-- The ABP transfer function.
{-# NO_TERMINATION_CHECK #-}
abpTransA : {A : Set} → Bit → Stream Bit → Stream Bit → Stream A → Stream A
abpTransA {A} b os₁ os₂ is = outA b bs
  where
  as : Stream (A × Bit)
  bs : Stream (Err (A × Bit))
  cs : Stream Bit
  ds : Stream (Err Bit)

  as = sendA b is ds
  bs = corruptA os₁ as
  cs = ackA b bs
  ds = corruptA os₂ cs

------------------------------------------------------------------------------
-- The ABP using Agda standard library
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.ABP.ABP-SL where

open import Coinduction
open import Data.Bool
open import Data.Product
open import Data.Stream
open import Relation.Nullary

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

Bit : Set
Bit = Bool

-- Data type used to model the fair unreliable transmission channel.
data Err (A : Set) : Set where
  ok    : (x : A) → Err A
  error : Err A

-- The mutual sender functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
sendA  : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bool)
awaitA : {A : Set} → Bit → Stream A → Stream (Err Bit) → Stream (A × Bit)

sendA b (i ∷ is) ds = (i , b) ∷ ♯ awaitA b (i ∷ is) ds

awaitA b (i ∷ is) (ok b' ∷ ds) with b ≟ b'
... | yes p = sendA (not b) (♭ is) (♭ ds)
... | no ¬p = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))
awaitA b (i ∷ is) (error ∷ ds) = (i , b) ∷ ♯ (awaitA b (i ∷ is) (♭ ds))

-- The receiver functions.
--
-- 25 June 2014. Requires the non-termination flag when using
-- --without-K. See Agda issue 1214.
{-# NO_TERMINATION_CHECK #-}
ackA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream Bit
ackA b (ok (_ , b') ∷ bs) with b ≟ b'
... | yes p = b ∷ ♯ (ackA (not b) (♭ bs))
... | no ¬p = not b ∷ ♯ (ackA b (♭ bs))
ackA b (error ∷ bs) = not b ∷ ♯ (ackA b (♭ bs))

{-# NO_TERMINATION_CHECK #-}
outA : {A : Set} → Bit → Stream (Err (A × Bit)) → Stream A
outA b (ok (i , b') ∷ bs) with b ≟ b'
... | yes p = i ∷ ♯ (outA (not b) (♭ bs))
... | no ¬p = outA b (♭ bs)
outA b (error ∷ bs) = outA b (♭ bs)

-- Model the fair unreliable tranmission channel.
corruptA : {A : Set} → Stream Bit → Stream A → Stream (Err A)
corruptA (true ∷ os)  (_ ∷ xs) = error ∷ ♯ (corruptA (♭ os) (♭ xs))
corruptA (false ∷ os) (x ∷ xs) = ok x ∷ ♯ (corruptA (♭ os) (♭ xs))

-- The ABP transfer function.
{-# NO_TERMINATION_CHECK #-}
abpTransA : {A : Set} → Bit → Stream Bit → Stream Bit → Stream A → Stream A
abpTransA {A} b os₁ os₂ is = outA b bs
  where
  as : Stream (A × Bit)
  bs : Stream (Err (A × Bit))
  cs : Stream Bit
  ds : Stream (Err Bit)

  as = sendA b is ds
  bs = corruptA os₁ as
  cs = ackA b bs
  ds = corruptA os₂ cs


Cosmetic changes.

Cosmetic changes.

Ignore-this: 2c3aec9f499291f0b940d407c92b0b57

darcs-hash:20110404171438-3bd4e-6e04071ad7513f0de4e7893d81c5d1aec08974a5.gz

module LTC where

module Core where

{-
Agda as a logical framework for LTC

LTC                              Agda
* Logical constants              * Curry-Howard isomorphism
* Equality                       * Identity type
* Term language                  * Postulates
* Inductive predicates           * Inductive families
-}

-- Fixity declarations (precedence level and associativity)
-- Agda default: infix 20

infixl 80 _`_
infixl 60 _∧_
infixl 50 _∨_
infix  40 if#_then_else_
infix  30 _==_

-------------------------------------------------------------------------
-- Equality: identity type
-------------------------------------------------------------------------

-- The identity type
data _==_ {A : Set} : A -> A -> Set where
  ==-refl : {x : A} -> x == x

==-subst : {A : Set}(P : A -> Set){x y : A} -> x == y -> P x -> P y
==-subst P ==-refl px = px

==-sym : {A : Set} {x y : A} -> x == y ->  y == x
==-sym ==-refl = ==-refl

==-trans : {A : Set} {x y z : A} -> x == y -> y == z -> x == z
==-trans ==-refl y==z  = y==z

-------------------------------------------------------------------------
-- Logical constants: Curry-Howard isomorphism
-------------------------------------------------------------------------

-- The false type
data ⊥ : Set where

⊥-elim : {A : Set} -> ⊥ -> A
⊥-elim ()

¬ : Set -> Set
¬ A = A -> ⊥

-- The disjunction type ('\vee', not 'v')
data _∨_ (A B : Set) : Set where
  ∨-il : A -> A ∨ B
  ∨-ir : B -> A ∨ B

∨-elim : {A B C : Set} -> (A -> C) -> (B -> C) -> A ∨ B -> C
∨-elim f g (∨-il a) = f a
∨-elim f g (∨-ir b) = g b

-- The conjunction type
data _∧_ (A B : Set) : Set where
  ∧-i : A -> B -> A ∧ B

∧-fst : {A B : Set} -> A ∧ B -> A
∧-fst (∧-i a b) = a

∧-snd : {A B : Set} -> A ∧ B -> B
∧-snd (∧-i a b) = b

-- The existential quantifier type
data ∃ (A : Set)(P : A -> Set) : Set where
  ∃-i : (witness : A)  -> P witness -> ∃ A P

∃-fst : {A : Set}{P : A -> Set} -> ∃ A P -> A
∃-fst (∃-i x px) = x

∃-snd : {A : Set}{P : A -> Set} -> (x-px : ∃ A P) -> P (∃-fst x-px)
∃-snd (∃-i x px) = px

-- The implication and the universal quantifier
-- We use Agda (dependent) function type

-------------------------------------------------------------------------
--  The term language: postulates
-------------------------------------------------------------------------

{-
D : a universal domain of terms

Pre-types (or weak types): Agda's simple type lambda calculus on 'D'

              T ::= D | T -> T
                t := x | \x -> t | t t | c (constants)

-}

-------------------------
-- The universal domain

postulate D : Set

--------------------
-- Constants terms

postulate

  -- LTC booleans
  true#          : D
  false#         : D
  if#_then_else_ : D -> D -> D -> D

  -- LTC natural numbers
  -- We will refer to these partial numbers as 'N#'
  zero# : D
  suc#  : D -> D
  rec#  : D -> D -> (D -> D -> D) -> D

  -- LTC abstraction and application
  λ   : (D -> D) -> D
  -- Left associative aplication operator
  _`_ : D -> D -> D

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

postulate
  -- Conversion rules for booleans
  CB1 : (a : D){b : D} -> if# true# then a else b == a
  CB2 : {a : D}(b : D) -> if# false# then a else b == b

  -- Conversion rules for natural numbers
  CN1 : (a : D){f : D -> D -> D} -> rec# zero# a f == a
  CN2 : (a n : D)(f : D -> D -> D) ->
        rec# (suc# n) a f == f n (rec# n a f)

  -- Conversion rule for the abstraction and the application
  beta : (f : D -> D)(a : D) -> (λ f) ` a == f a

--------------------------------------------------------------
-- Inductive predicate for natural numbers : Inductive family
--------------------------------------------------------------
-- The inductive predicate 'N' represents the type of the natural
-- numbers. They are a subset of 'D'.

-- The natural numbers type
data N : D -> Set where
  N-zero : N zero#
  N-suc : {n : D} -> N n -> N (suc# n)

-- Induction principle on 'N'  (elimination rule)
N-ind : (P : D -> Set) ->
        P zero# ->
        ({n : D} -> N n -> P n -> P (suc#  n)) ->
        {n : D} -> N n -> P n
N-ind P p0 h N-zero     = p0
N-ind P p0 h (N-suc Nn) = h Nn (N-ind P  p0  h Nn)

module Recursive-Functions-LTC where

  -- We define some primitive recursive functions via LTC terms

  open Core

  import Equality-Reasoning
  open module ER-Recursive-Functions-LTC =
              Equality-Reasoning (_==_ {D}) ==-refl ==-trans

   ------------------------------------------------------------------------
  -- Remark: We are using Agda's definitional equality '=' as
  -- LTC's definitional equality

  -- Fixity declarations (precedence level and associativity)
  -- Agda default: infix 20

  infixl 70 _*_
  infixl 60 _+_ _-_

  _+_ : D -> D -> D
  m + n = rec# n m (\x y -> suc# y)

  -- recursion on the second argument
  _*_ : D -> D -> D
  m * n = rec# n zero# (\x y -> y + n)

  pred : D -> D
  pred n = rec# n zero# (\x y -> x)

  -- m - 0        = m
  -- m - (succ n) = pred (m - n)
  _-_ : D -> D -> D
  m - n = rec# n m (\x y -> pred y)

  or : D -> D -> D
  or a b = if#  a then true# else b

  isZero : D -> D
  isZero n = rec# n true# (\x y -> false#)

  -- The function 'equi n' return a function which establish if an
  -- argument 'm' is equal to 'n'
  -- equi zero     = \m -> isZero m
  -- equi (succ n) = \m -> case m of
  --                         zero -> false
  --                         (succ m') -> (equi n) m

  equi : D -> D
  equi n = rec# n  (λ (\m -> isZero m))
               (\x y -> λ (\m -> rec# m  false#  (\m' z -> y ` m')))

  -- equality on N#
  eq : D -> D -> D
  eq m n = (equi n) ` m

  -- inequality on N#
  -- lt m 0        = false#
  -- lt m (succ n) = (lt m n) ∨ (m = n)
  lt : D -> D -> D
  lt m n = rec# n false# (\x y -> or y  (eq m  x))

  -- inequality on N#
  gt : D -> D -> D
  gt m n = lt n m


ZK.JSChecker: better error message while checking the type of the statement

{-# OPTIONS --without-K #-}
module ZK.JSChecker where

open import Function         using (id; _∘′_; case_of_)
open import Data.Bool.Base   using (Bool; true; false; _∧_)
open import Data.List.Base   using (List; []; _∷_; and; foldr)
open import Data.String.Base using (String)

open import FFI.JS
open import FFI.JS.Check
-- open import FFI.JS.Proc using (URI; JSProc; showURI; server)
-- open import Control.Process.Type
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS

import FFI.JS.BigI as BigI
open BigI using (BigI; bigI)

import Crypto.JS.BigI.ZqZp as ZqZp

-- TODO dynamise me
primality-test-probability-bound : Number
primality-test-probability-bound = readNumber "10"

-- TODO: check if this is large enough
min-bits-q : Number
min-bits-q = 256N

min-bits-p : Number
min-bits-p = 2048N

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

-- TODO bug (undefined)!
record ZK-chaum-pedersen-pok-elgamal-rnd {--(ℤq ℤp★ : Set)--} : Set where
  field
    m c s : BigI {--ℤq--}
    g p q y α β A B : BigI --ℤp★

zk-check-chaum-pedersen-pok-elgamal-rnd! : ZK-chaum-pedersen-pok-elgamal-rnd {-BigI BigI-} → JS!
zk-check-chaum-pedersen-pok-elgamal-rnd! pf
      = trace "g=" g λ _ →
        trace "p=" I.p λ _ →
        trace "q=" I.q λ _ →
        trace "y=" y λ _ →
        trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
         checks!
      >> check! "g^s==A·α^c"     ((g ^ s) == (A · (α ^ c)))        (λ _ → "")
      >> check! "y^s==B·(β/M)^c" ((y ^ s) == (B · ((β ·/ M) ^ c))) (λ _ → "")
  module ZK-check-chaum-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    params = record
      { primality-test-probability-bound = primality-test-probability-bound
      ; min-bits-q = min-bits-q
      ; min-bits-p = min-bits-p
      ; qI = I.q
      ; pI = I.p
      ; gI = I.g
      }
    open module [ℤq]ℤp★ = ZqZp params
    A = BigI▹ℤp★ I.A
    B = BigI▹ℤp★ I.B
    α = BigI▹ℤp★ I.α
    β = BigI▹ℤp★ I.β
    y = BigI▹ℤp★ I.y
    s = BigI▹ℤq  I.s
    c = BigI▹ℤq  I.c
    m = BigI▹ℤq  I.m
    M = g ^ m

zk-check! : JSValue → JS!
zk-check! arg =
    check! "type of statement" (typ === fromString cpt)
                               (λ _ → "Expected type of statement: " ++ cpt ++ " not " ++ toString typ)
 >> zk-check-chaum-pedersen-pok-elgamal-rnd! pok
 module Zk-check where
    cpt = "chaum-pedersen-pok-elgamal-rnd"
    stm = arg ·« "statement" »
    typ = stm ·« "type" »
    dat = stm ·« "data" »
    g   = bigdec (dat ·« "g" »)
    p   = bigdec (dat ·« "p" »)
    q   = bigdec (dat ·« "q" »)
    y   = bigdec (dat ·« "y" »)
    m   = bigdec (dat ·« "plain" »)
    enc = dat ·« "enc" »
    α   = bigdec (enc ·« "alpha" »)
    β   = bigdec (enc ·« "beta"  »)
    prf = arg ·« "proof" »
    com = prf ·« "commitment" »
    A   = bigdec (com ·« "A" »)
    B   = bigdec (com ·« "B" »)
    c   = bigdec (prf ·« "challenge" »)
    s   = bigdec (prf ·« "response" »)
    pok = record { g = g; p = p; q = q; y = y; α = α; β = β; A = A; B = B; c = c; s = s; m = m }

{-
srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (zk-check q))
  end
-}

-- Working around Agda.Primitive.lsuc being undefined
-- case_of_ : {A : Set} {B : Set} → A → (A → B) → B
-- case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
        Console.log "usage: No arguments"
        {- server "127.0.0.1" "1337" srv !₁ λ uri →
           Console.log (showURI uri)
         -}
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              Console.log ("Reading input file: " ++ arg) >>
              FS.readFile arg nullJS !₂ λ err dat →
                check! "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check! (JSON-parse (toString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module ZK.JSChecker where

open import Function         using (id; _∘′_; case_of_)
open import Data.Bool.Base   using (Bool; true; false; _∧_)
open import Data.List.Base   using (List; []; _∷_; and; foldr)
open import Data.String.Base using (String)

open import FFI.JS
open import FFI.JS.Check
-- open import FFI.JS.Proc using (URI; JSProc; showURI; server)
-- open import Control.Process.Type
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS

import FFI.JS.BigI as BigI
open BigI using (BigI; bigI)

import Crypto.JS.BigI.ZqZp as ZqZp

-- TODO dynamise me
primality-test-probability-bound : Number
primality-test-probability-bound = readNumber "10"

-- TODO: check if this is large enough
min-bits-q : Number
min-bits-q = 256N

min-bits-p : Number
min-bits-p = 2048N

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

-- TODO bug (undefined)!
record ZK-chaum-pedersen-pok-elgamal-rnd {--(ℤq ℤp★ : Set)--} : Set where
  field
    m c s : BigI {--ℤq--}
    g p q y α β A B : BigI --ℤp★

zk-check-chaum-pedersen-pok-elgamal-rnd! : ZK-chaum-pedersen-pok-elgamal-rnd {-BigI BigI-} → JS!
zk-check-chaum-pedersen-pok-elgamal-rnd! pf
      = trace "g=" g λ _ →
        trace "p=" I.p λ _ →
        trace "q=" I.q λ _ →
        trace "y=" y λ _ →
        trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
         checks!
      >> check! "g^s==A·α^c"     ((g ^ s) == (A · (α ^ c)))        (λ _ → "")
      >> check! "y^s==B·(β/M)^c" ((y ^ s) == (B · ((β ·/ M) ^ c))) (λ _ → "")
  module ZK-check-chaum-pedersen-pok-elgamal-rnd where
    module I = ZK-chaum-pedersen-pok-elgamal-rnd pf
    params = record
      { primality-test-probability-bound = primality-test-probability-bound
      ; min-bits-q = min-bits-q
      ; min-bits-p = min-bits-p
      ; qI = I.q
      ; pI = I.p
      ; gI = I.g
      }
    open module [ℤq]ℤp★ = ZqZp params
    A = BigI▹ℤp★ I.A
    B = BigI▹ℤp★ I.B
    α = BigI▹ℤp★ I.α
    β = BigI▹ℤp★ I.β
    y = BigI▹ℤp★ I.y
    s = BigI▹ℤq  I.s
    c = BigI▹ℤq  I.c
    m = BigI▹ℤq  I.m
    M = g ^ m

zk-check! : JSValue → JS!
zk-check! arg =
    check! "type of statement" (typ === fromString "chaum-pedersen-pok-elgamal-rnd")
                               (λ _ → "")
 >> zk-check-chaum-pedersen-pok-elgamal-rnd! pok
 module Zk-check where
    stm = arg ·« "statement" »
    typ = stm ·« "type" »
    dat = stm ·« "data" »
    g   = bigdec (dat ·« "g" »)
    p   = bigdec (dat ·« "p" »)
    q   = bigdec (dat ·« "q" »)
    y   = bigdec (dat ·« "y" »)
    m   = bigdec (dat ·« "plain" »)
    enc = dat ·« "enc" »
    α   = bigdec (enc ·« "alpha" »)
    β   = bigdec (enc ·« "beta"  »)
    prf = arg ·« "proof" »
    com = prf ·« "commitment" »
    A   = bigdec (com ·« "A" »)
    B   = bigdec (com ·« "B" »)
    c   = bigdec (prf ·« "challenge" »)
    s   = bigdec (prf ·« "response" »)
    pok = record { g = g; p = p; q = q; y = y; α = α; β = β; A = A; B = B; c = c; s = s; m = m }

{-
srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (zk-check q))
  end
-}

-- Working around Agda.Primitive.lsuc being undefined
-- case_of_ : {A : Set} {B : Set} → A → (A → B) → B
-- case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
        Console.log "usage: No arguments"
        {- server "127.0.0.1" "1337" srv !₁ λ uri →
           Console.log (showURI uri)
         -}
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              Console.log ("Reading input file: " ++ arg) >>
              FS.readFile arg nullJS !₂ λ err dat →
                check! "reading input file" (is-null err)
                       (λ _ → "readFile error: " ++ toString err) >>
                zk-check! (JSON-parse (toString dat))
          ; _ →
              Console.log "usage: Too many arguments"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}


Remove extra imports

Remove extra imports

Old-commit-hash: 3a9775f6afd97585f6b425390b5431b43807b03e

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

open import Base.Denotation.Notation public

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

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {ℓ} {A} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely. That should be true for functions
    -- using changes parametrically, for derivatives and function changes, and
    -- for functions using only the interface to changes (including the fact
    -- that function changes are functions). Stating the general result, though,
    -- seems hard, we should rather have lemmas proving that certain classes of
    -- functions respect this equivalence.

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value

module Parametric.Change.Equivalence
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

open import Base.Denotation.Notation public

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

-- Extension Point: None (currently). Do we need to allow plugins to customize
-- this concept?
Structure : Set
Structure = Unit

module Structure (unused : Structure) where

  module _ {ℓ} {A} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely. That should be true for functions
    -- using changes parametrically, for derivatives and function changes, and
    -- for functions using only the interface to changes (including the fact
    -- that function changes are functions). Stating the general result, though,
    -- seems hard, we should rather have lemmas proving that certain classes of
    -- functions respect this equivalence.


Use standard syntax

Use standard syntax

data Bool : Set where
  true  : Bool
  false : Bool

_∨_ : Bool → Bool → Bool
true ∨ _  = true
false ∨ b = b

_∧_ : Bool → Bool → Bool
false ∧ _ = false
true ∧ b  = b

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_==_ : ℕ → ℕ → Bool
zero == zero   = true
suc n == suc m = n == m
_ == _         = false

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

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A
infixr 5 _∷_

[_] : {A : Set} → A → List A
[ x ] = x ∷ []

any : {A : Set} → (A → Bool) → List A → Bool
any _ []       = false
any f (x ∷ xs) = (f x) ∨ (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ []       = false
x ∈ (y ∷ ys) with x == y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q == s
(p ⇒ q) ≡≡ (r ⇒ s) = (p == r) ∧ (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ []       = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) ∨ (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs ([ n ]))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr     = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ []

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ []) (5 ∷ 3 ∷ 7 ∷ 7 ∷ [])) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (5 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ []) (6 ∷ 3 ∷ [])) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ []) (6 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ []) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ []) (3 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ [])) ∷
  (model (10 ∷ 9 ∷ []) (1 ∷ [])) ∷
  (model (3 ∷ 4 ∷ 11 ∷ []) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ [])) ∷
  (model (12 ∷ 7 ∷ 1 ∷ []) (4 ∷ 11 ∷ 8 ∷ [])) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ []) (11 ∷ [])) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ []) (11 ∷ 3 ∷ [])) ∷
  (model (3 ∷ 6 ∷ 5 ∷ []) ([])) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ []) (12 ∷ [])) ∷ []

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

data Bool : Set where
  true  : Bool
  false : Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

infixr 5 _∷_

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ ∘

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (5 ∷ 3 ∷ 7 ∷ 7 ∷ ∘)) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (5 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (6 ∷ 3 ∷ ∘)) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (6 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ ∘) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ ∘) (3 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ ∘)) ∷
  (model (10 ∷ 9 ∷ ∘) (1 ∷ ∘)) ∷
  (model (3 ∷ 4 ∷ 11 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 7 ∷ 1 ∷ ∘) (4 ∷ 11 ∷ 8 ∷ ∘)) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ ∘) (11 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ ∘) (11 ∷ 3 ∷ ∘)) ∷
  (model (3 ∷ 6 ∷ 5 ∷ ∘) (∘)) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ ∘) (12 ∷ ∘)) ∷ ∘

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))


Bits: +and +✓-and +✓-and'

Bits: +and +✓-and +✓-and'

{-# OPTIONS --without-K #-}
module Data.Bits where

open import Algebra
open import Level.NP
open import Type hiding (★)
open import Data.Nat.NP hiding (_==_) renaming (_<=_ to _ℕ<=_)
open import Data.Bit using (Bit)
open import Data.Two renaming (_==_ to _==ᵇ_)
open import Data.Fin.NP using (Fin; zero; suc; inject₁; inject+; raise; Fin▹ℕ)
open import Data.Vec.NP
open import Function.NP
import Data.List.NP as L

-- Re-export some vector functions, maybe they should be given
-- less generic types.
open Data.Vec.NP public using ([]; _∷_; _++_; head; tail; map; replicate; RewireTbl; rewire; rewireTbl; onᵢ)

Bits : ℕ → ★₀
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → ★₀
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0₂

-- Notice that all empty vectors are the same, hence 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1₂

pattern 0∷_ xs = 0₂ ∷ xs
pattern 1∷_ xs = 1₂ ∷ xs
{-
0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0₂ ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1₂ ∷ xs
-}

_!_ : ∀ {a n} {A : ★ a} → Vec A n → Fin n → A
_!_ = flip lookup

-- see Data.Bits.Properties
_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bit
[]         == []         = 1₂
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

_<=_ : ∀ {n} (xs ys : Bits n) → Bit
[]        <= []        = 1₂
(1₂ ∷ xs) <= (0₂ ∷ ys) = 0₂
(0₂ ∷ xs) <= (1₂ ∷ ys) = 1₂
(_  ∷ xs) <= (_  ∷ ys) = xs <= ys

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

⊕-group : ℕ → Group ₀ ₀
⊕-group = LiftGroup.group Xor°.+-group

module ⊕-Group  (n : ℕ) = Group (⊕-group n)
module ⊕-Monoid (n : ℕ) = Monoid (⊕-Group.monoid n)

-- Negate all bits, i.e. "xor"ing them by one.
vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

-- Negate the i-th bit.
notᵢ : ∀ {n} (i : Fin n) → Bits n → Bits n
notᵢ = onᵢ not

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ k {n} → Bits (n + k) → Bits k
lsb _ {n} = drop n

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0∷ bs) = inject₁ (#1 bs)
#1 (1∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ map not

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM (toList (0∷ 1∷ []))
  where open L.Monad

allBits : ∀ n → Vec (Bits n) (2^ n)
allBits zero    = [] ∷ []
allBits (suc n) = map 0∷_ bs ++ map 1∷_ bs
  where bs = allBits n

always : ∀ n → Bits n → Bit
always _ _ = 1₂

never  : ∀ n → Bits n → Bit
never _ _ = 0₂

_∨°_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_∨°_ f g x = f x ∨ g x

_∧°_ : ∀ {n} → (f g : Bits n → Bit) → Bits n → Bit
_∧°_ f g x = f x ∧ g x

not° : ∀ {n} (f : Bits n → Bit) → Bits n → Bit
not° f = not ∘ f

view∷ : ∀ {n a b} {A : ★ a} {B : ★ b} → (A → Vec A n → B) → Vec A (suc n) → B
view∷ f (x ∷ xs) = f x xs

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry []      = 0∷ []
sucBCarry (0∷ xs) = 0∷ sucBCarry xs
sucBCarry (1∷ xs) = view∷ (λ x xs → x ∷ not x ∷ xs) (sucBCarry xs)

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

--_[mod_] : ℕ → ℕ → ★₀
--a [mod b ] = DivMod' a b

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0∷ xs) = 1∷ xs
  sucRB (1∷ xs) = 0∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2^ n)
toFin         []      = zero
toFin         (0∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1∷ xs) = raise (2^ n) (toFin xs)

Bits▹ℕ : ∀ {n} → Bits n → ℕ
Bits▹ℕ         []      = zero
Bits▹ℕ         (0∷ xs) = Bits▹ℕ xs
Bits▹ℕ {suc n} (1∷ xs) = 2^ n + Bits▹ℕ xs

ℕ▹Bits : ∀ {n} → ℕ → Bits n
ℕ▹Bits {zero}  _ = []
ℕ▹Bits {suc n} x = [0: 0∷ ℕ▹Bits x
                    1: 1∷ ℕ▹Bits (x ∸ 2^ n)
                   ]′ (2^ n ℕ<= x)

ℕ▹Bits′ : ∀ {n} → ℕ → Bits n
ℕ▹Bits′ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2^ n) → Bits n
fromFin = ℕ▹Bits ∘ Fin▹ℕ

lookupTbl : ∀ {n a} {A : ★ a} → Bits n → Vec A (2^ n) → A
lookupTbl         []       = head
lookupTbl         (0∷ key) = lookupTbl key ∘ take _
lookupTbl {suc n} (1∷ key) = lookupTbl key ∘ drop (2^ n)

funFromTbl : ∀ {n a} {A : ★ a} → Vec A (2^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : ★ a} → (Bits n → A) → Vec A (2^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero}  f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_)
                    ++ tblFromFun {n} (f ∘ 1∷_)

and : ∀ {n} → Bits n → 𝟚
and = foldr _ _∧_ 1₂

✓-and : ∀ {n}{xs : Bits n} → (∀ l → ✓(xs ‼ l)) → ✓(and xs)
✓-and {xs = []}     p = _
✓-and {xs = x ∷ xs} p = ✓∧ (p zero) (✓-and (p ∘ suc))

✓-and' : ∀ {n}{xs : Bits n} → ✓(and xs) → ∀ l → ✓(xs ‼ l)
✓-and' {xs = x ∷ xs} e zero = ✓∧₁ {x} e
✓-and' {xs = x ∷ xs} e (suc l) = ✓-and' (✓∧₂ {x} e) l


Nicer statement for fromtoDeriveConst

Nicer statement for fromtoDeriveConst

module Thesis.DeriveCorrect where

open import Thesis.Lang
open import Thesis.Changes
open import Thesis.LangChanges
open import Thesis.Derive

open import Relation.Binary.PropositionalEquality

open import Theorem.Groups-Nehemiah

fromtoDeriveConst : ∀ {τ : Type} (c : Const τ) →
  ch ⟦ c ⟧ΔConst from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst (lit n) = right-id-int n
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite sym daa | sym dbb = sym (mn·pq=mp·nq {a1} {da} {b1} {db})
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite sym daa | sym dbb | sym (-m·-n=-mn {b1} {db}) = sym (mn·pq=mp·nq {a1} {da} { - b1} { - db})
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = sft₁ daa
fromtoDeriveConst rinj db b1 b2 dbb = sft₂ dbb
fromtoDeriveConst match .(inj₁ (inj₁ _)) .(inj₁ _) .(inj₁ _) (sft₁ daa) df f1 f2 dff dg g1 g2 dgg = dff _ _ _ daa
fromtoDeriveConst match .(inj₁ (inj₂ _)) .(inj₂ _) .(inj₂ _) (sft₂ dbb) df f1 f2 dff dg g1 g2 dgg = dgg _ _ _ dbb
fromtoDeriveConst match .(inj₂ (inj₂ b2)) .(inj₁ a1) .(inj₂ b2) (sftrp₁ a1 b2) df f1 f2 dff dg g1 g2 dgg
 rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2
 | sym (fromto→⊕ dg g1 g2 dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match .(inj₂ (inj₁ a2)) .(inj₂ b1) .(inj₁ a2) (sftrp₂ b1 a2) df f1 f2 dff dg g1 g2 dgg
  rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2
  | sym (fromto→⊕ df f1 f2 dff)
   = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

-- Getting to the original equation 1 from PLDI'14.

correctDeriveOplus : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ t ⟧Term ρ1) ⊕ (⟦ t ⟧ΔTerm ρ1 dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplus τ t dρρ = fromto→⊕ _ _ _ (fromtoDerive τ t dρρ)

open import Thesis.LangOps

correctDeriveOplusτ : ∀ {Γ} τ → (t : Term Γ τ)
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit t) (derive t) ⟧Term dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplusτ τ t {dρ = dρ} {ρ1 = ρ1} dρρ
  rewrite oplusτ-equiv _ dρ _ (⟦ fit t ⟧Term dρ) (⟦ derive t ⟧Term dρ)
  | sym (fit-sound t dρρ)
  = correctDeriveOplus τ t dρρ

deriveGivesDerivative : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ)→
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app f a ⟧Term ρ1) ⊕ (⟦ app f a ⟧ΔTerm ρ1 dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative σ τ f a dρρ = correctDeriveOplus τ (app f a) dρρ

deriveGivesDerivative₂ : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) (derive a)) ⟧Term dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative₂ σ τ f a dρρ = correctDeriveOplusτ τ (app f a) dρρ

-- Proof of the original equation 1 from PLDI'14. The original was restricted to
-- closed terms. This is a generalization, because it holds also for open terms,
-- *as long as* the environment change is a nil change.
eq1 : ∀ {Γ} σ τ →
  {nilρ : ChΓ Γ} {ρ : ⟦ Γ ⟧Context} → [ Γ ]Γ nilρ from ρ to ρ →
  ∀ (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) (da : Term (ΔΓ Γ) (Δt σ)) →
  (daa : [ σ ]τ (⟦ da ⟧Term nilρ) from (⟦ a ⟧Term ρ) to (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ)) →
    ⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) da) ⟧Term nilρ ≡ ⟦ app (fit f) (app₂ (oplusτo σ) (fit a) da) ⟧Term nilρ
eq1 σ τ {nilρ} {ρ} dρρ f a da daa
  rewrite
    oplusτ-equiv _ nilρ _ (⟦ fit (app f a) ⟧Term nilρ) (⟦ (app₂ (derive f) (fit a) da) ⟧Term nilρ)
  | sym (fit-sound f dρρ)
  | oplusτ-equiv _ nilρ _ (⟦ fit a ⟧Term nilρ) (⟦ da ⟧Term nilρ)
  | sym (fit-sound a dρρ)
  = fromto→⊕ (⟦ f ⟧ΔTerm ρ nilρ (⟦ a ⟧Term ρ) (⟦ da ⟧Term nilρ)) _ _
    (fromtoDerive _ f dρρ (⟦ da ⟧Term nilρ) (⟦ a ⟧Term ρ)
      (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ) daa)

module Thesis.DeriveCorrect where

open import Thesis.Lang
open import Thesis.Changes
open import Thesis.LangChanges
open import Thesis.Derive

open import Relation.Binary.PropositionalEquality

open import Theorem.Groups-Nehemiah

fromtoDeriveConst : ∀ {τ} c →
  [ τ ]τ ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst (lit n) = right-id-int n
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite sym daa | sym dbb = sym (mn·pq=mp·nq {a1} {da} {b1} {db})
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite sym daa | sym dbb | sym (-m·-n=-mn {b1} {db}) = sym (mn·pq=mp·nq {a1} {da} { - b1} { - db})
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = sft₁ daa
fromtoDeriveConst rinj db b1 b2 dbb = sft₂ dbb
fromtoDeriveConst match .(inj₁ (inj₁ _)) .(inj₁ _) .(inj₁ _) (sft₁ daa) df f1 f2 dff dg g1 g2 dgg = dff _ _ _ daa
fromtoDeriveConst match .(inj₁ (inj₂ _)) .(inj₂ _) .(inj₂ _) (sft₂ dbb) df f1 f2 dff dg g1 g2 dgg = dgg _ _ _ dbb
fromtoDeriveConst match .(inj₂ (inj₂ b2)) .(inj₁ a1) .(inj₂ b2) (sftrp₁ a1 b2) df f1 f2 dff dg g1 g2 dgg
 rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2
 | sym (fromto→⊕ dg g1 g2 dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match .(inj₂ (inj₁ a2)) .(inj₂ b1) .(inj₁ a2) (sftrp₂ b1 a2) df f1 f2 dff dg g1 g2 dgg
  rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2
  | sym (fromto→⊕ df f1 f2 dff)
   = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

-- Getting to the original equation 1 from PLDI'14.

correctDeriveOplus : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ t ⟧Term ρ1) ⊕ (⟦ t ⟧ΔTerm ρ1 dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplus τ t dρρ = fromto→⊕ _ _ _ (fromtoDerive τ t dρρ)

open import Thesis.LangOps

correctDeriveOplusτ : ∀ {Γ} τ → (t : Term Γ τ)
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit t) (derive t) ⟧Term dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplusτ τ t {dρ = dρ} {ρ1 = ρ1} dρρ
  rewrite oplusτ-equiv _ dρ _ (⟦ fit t ⟧Term dρ) (⟦ derive t ⟧Term dρ)
  | sym (fit-sound t dρρ)
  = correctDeriveOplus τ t dρρ

deriveGivesDerivative : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ)→
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app f a ⟧Term ρ1) ⊕ (⟦ app f a ⟧ΔTerm ρ1 dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative σ τ f a dρρ = correctDeriveOplus τ (app f a) dρρ

deriveGivesDerivative₂ : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) →
  {dρ : ChΓ Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) (derive a)) ⟧Term dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative₂ σ τ f a dρρ = correctDeriveOplusτ τ (app f a) dρρ

-- Proof of the original equation 1 from PLDI'14. The original was restricted to
-- closed terms. This is a generalization, because it holds also for open terms,
-- *as long as* the environment change is a nil change.
eq1 : ∀ {Γ} σ τ →
  {nilρ : ChΓ Γ} {ρ : ⟦ Γ ⟧Context} → [ Γ ]Γ nilρ from ρ to ρ →
  ∀ (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) (da : Term (ΔΓ Γ) (Δt σ)) →
  (daa : [ σ ]τ (⟦ da ⟧Term nilρ) from (⟦ a ⟧Term ρ) to (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ)) →
    ⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) da) ⟧Term nilρ ≡ ⟦ app (fit f) (app₂ (oplusτo σ) (fit a) da) ⟧Term nilρ
eq1 σ τ {nilρ} {ρ} dρρ f a da daa
  rewrite
    oplusτ-equiv _ nilρ _ (⟦ fit (app f a) ⟧Term nilρ) (⟦ (app₂ (derive f) (fit a) da) ⟧Term nilρ)
  | sym (fit-sound f dρρ)
  | oplusτ-equiv _ nilρ _ (⟦ fit a ⟧Term nilρ) (⟦ da ⟧Term nilρ)
  | sym (fit-sound a dρρ)
  = fromto→⊕ (⟦ f ⟧ΔTerm ρ nilρ (⟦ a ⟧Term ρ) (⟦ da ⟧Term nilρ)) _ _
    (fromtoDerive _ f dρρ (⟦ da ⟧Term nilρ) (⟦ a ⟧Term ρ)
      (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ) daa)


lam case

lam case

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = d' , Δ' , ESAsc2 D
    ... | Inr x = (< _ > d') , Δ' , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = X n , ∅ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = ((< τ2 ==> ⦇⦈ > d1) ∘ d2) , (Δ1 ∪ Δ2) , {!!} -- ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = (d1 ∘ (< {!!} > d2)) , (Δ1 ∪ Δ2) , ESAp2 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = (d1 ∘ d2) , (Δ1 ∪ Δ2) , ESAp3 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume wt x₁) =  _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e' ⦈[ x ]} (ASubsume (SNEHole wt) x₁) with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EANEHole D
    expandability-ana {e = c} (ASubsume SConst x₁) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ())  ESConst x₁
    expandability-ana {e = e ·: x} (ASubsume (SAsc x₁) x₂) = {!!}
    expandability-ana {e = X x} (ASubsume (SVar x₁) x₂) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESVar x₁) x₂
    expandability-ana {e = ·λ x e} (ASubsume () x₁)
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume (SLam x₂ wt) x₃) with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EASubsume (λ u → λ ()) (λ e' u → λ ()) (ESLam x₂ D) x₃
    expandability-ana {e = e1 ∘ e₁} (ASubsume (SAp wt MAHole x₁) x₂) = {!!}
    expandability-ana {e = e1 ∘ e₁} (ASubsume (SAp wt MAArr x₁) x₂) = {!!}
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D' = {!!} , {!!} , {!!} , {!!}
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import htype-decidable

module expandability where
  mutual
    expandability-synth : {Γ : tctx} {e : hexp} {τ : htyp} →
                          Γ ⊢ e => τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ]
                            (Γ ⊢ e ⇒ τ ~> d ⊣ Δ)
    expandability-synth SConst = c , ∅ , ESConst
    expandability-synth (SAsc {τ = τ} wt)
      with expandability-ana wt
    ... | d' , Δ' , τ' , D with htype-dec τ τ'
    ... | Inl _ = d' , Δ' , ESAsc2 D
    ... | Inr x = (< _ > d') , Δ' , ESAsc1 D x
    expandability-synth (SVar {n = n} x) = X n , ∅ , ESVar x
    expandability-synth (SAp wt1 MAHole wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2 , D2  = ((< τ2 ==> ⦇⦈ > d1) ∘ d2) , (Δ1 ∪ Δ2) , {!!} -- ESAp1 {!!} wt1 {!!} D2
    expandability-synth (SAp wt1 (MAArr {τ2 = τ2}) wt2)
      with expandability-synth wt1 | expandability-ana wt2
    ... | d1 , Δ1 , D1
        | d2 , Δ2 , τ2' , D2
      with htype-dec τ2 τ2'
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2' , D2 | Inr neq  = (d1 ∘ (< {!!} > d2)) , (Δ1 ∪ Δ2) , ESAp2 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!} neq
    expandability-synth (SAp wt1 MAArr wt2) | d1 , Δ1 , D1 | d2 , Δ2 , τ2 , D2  | Inl refl = (d1 ∘ d2) , (Δ1 ∪ Δ2) , ESAp3 {Δ1 = Δ1} {Δ2 = Δ2} {!!} {!D1!} {!!}
    expandability-synth SEHole = _ , _ , ESEHole
    expandability-synth (SNEHole wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESNEHole wt'
    expandability-synth (SLam x₁ wt) with expandability-synth wt
    ... | d' , Δ' , wt' = _ , _ , ESLam x₁ wt'

    expandability-ana : {Γ : tctx} {e : hexp} {τ : htyp} →
                         Γ ⊢ e <= τ →
                          Σ[ d ∈ dhexp ] Σ[ Δ ∈ hctx ] Σ[ τ' ∈ htyp ]
                            (Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ)
    expandability-ana {e = ⦇⦈[ x ]} (ASubsume wt x₁) =  _ , _ , _ , EAEHole
    expandability-ana {e = ⦇ e' ⦈[ x ]} (ASubsume (SNEHole wt) x₁) with expandability-synth wt
    ... | d , Δ , D = _ , _ , _ , EANEHole D
    expandability-ana {e = c} (ASubsume SConst x₁) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ())  ESConst x₁
    expandability-ana {e = e ·: x} (ASubsume (SAsc x₁) x₂) = {!!}
    expandability-ana {e = X x} (ASubsume (SVar x₁) x₂) = _ , _ , _ , EASubsume (λ _ ()) (λ _ _ ()) (ESVar x₁) x₂
    expandability-ana {e = ·λ x e} (ASubsume () x₁)
    expandability-ana {e = ·λ x [ x₁ ] e} (ASubsume (SLam x₂ wt) x₃) = _ , _ , _ , EASubsume {!!} {!!} (ESLam x₂ {!!}) x₃
    expandability-ana {e = e1 ∘ e₁} (ASubsume (SAp wt MAHole x₁) x₂) = {!!}
    expandability-ana {e = e1 ∘ e₁} (ASubsume (SAp wt MAArr x₁) x₂) = {!!}
    expandability-ana (ALam x₁ MAHole wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D'  = {!!}
    expandability-ana (ALam x₁ MAArr wt) with expandability-ana wt
    ... | d' , Δ' , τ' , D' = _ , _ , _ , EALam x₁ D'