module Thesis.ANormalUntyped where

open import Data.Nat.Base
open import Data.Integer.Base
open import Relation.Binary.PropositionalEquality

{- Typed deBruijn indexes for untyped languages. -}

-- Using a record gives an eta rule saying that all types are equal.
record Type : Set where
  constructor Uni

open import Base.Syntax.Context Type public
data Term (Γ : Context) : Set where
  var : (x : Var Γ Uni) →
    Term Γ
  lett : (f : Var Γ Uni) → (x : Var Γ Uni) → Term (Uni • Γ) → Term Γ

{-
deriveC Δ (lett f x t) = dlett df x dx
-}

-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
--   cvar : (x : Var Γ τ) Δ →
--     ΔCTerm Γ τ Δ
--   clett : ∀ {σ τ₁ κ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
--     ΔCTerm (τ₁ • Γ) τ (? • Δ) →
--     ΔCTerm Γ τ Δ

weaken-term : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ →
  Term Γ₂
weaken-term Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
weaken-term Γ₁≼Γ₂ (lett f x t) = lett (weaken-var Γ₁≼Γ₂ f) (weaken-var Γ₁≼Γ₂ x) (weaken-term (keep _ • Γ₁≼Γ₂) t)

data Fun (Γ : Context) : Set where
  term : Term Γ → Fun Γ
  abs : ∀ {σ} → Fun (σ • Γ) → Fun Γ

weaken-fun : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Fun Γ₁ →
  Fun Γ₂
weaken-fun Γ₁≼Γ₂ (term x) = term (weaken-term Γ₁≼Γ₂ x)
weaken-fun Γ₁≼Γ₂ (abs f) = abs (weaken-fun (keep _ • Γ₁≼Γ₂) f)

data Val : Type → Set
-- data Val (τ : Type) : Set

open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

-- data Val (τ : Type) where
data Val where
  closure : ∀ {Γ} → (t : Fun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → Val Uni
  intV : ∀ (n : ℤ) → Val Uni
-- ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
-- ⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
-- ⟦ lett f x t ⟧Term ρ = ⟦ t ⟧Term (⟦ f ⟧Var ρ (⟦ x ⟧Var ρ) • ρ)

data ErrVal : Set where
  Done : (v : Val Uni) → ErrVal
  Error : ErrVal
  TimeOut : ErrVal

_>>=_ : ErrVal → (Val Uni → ErrVal) → ErrVal
Done v >>= f = f v
Error >>= f = Error
TimeOut >>= f = TimeOut

Res : Set
Res = ℕ → ErrVal

eval-fun : ∀ {Γ} → Fun Γ → ⟦ Γ ⟧Context → Res
eval-term : ∀ {Γ} → Term Γ → ⟦ Γ ⟧Context → Res

apply : Val Uni → Val Uni → Res
apply (closure f ρ) a n = eval-fun f (a • ρ) n
apply (intV _) a n = Error

eval-term t ρ zero = TimeOut
eval-term (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval-term (lett f x t) ρ (suc n) = apply (⟦ f ⟧Var ρ) (⟦ x ⟧Var ρ) n >>= (λ v → eval-term t (v • ρ) n)

eval-fun (term t) ρ n = eval-term t ρ n
eval-fun (abs f) ρ n = Done (closure f ρ)

-- Erasure from typed to untyped values.
import Thesis.ANormalBigStep as T

erase-type : T.Type → Type
erase-type _ = Uni

erase-val : ∀ {τ} → T.Val τ → Val (erase-type τ)

erase-errVal : ∀ {τ} → T.ErrVal τ → ErrVal
erase-errVal (T.Done v) = Done (erase-val v)
erase-errVal T.Error = Error
erase-errVal T.TimeOut = TimeOut

erase-res : ∀ {τ} → T.Res τ → Res
erase-res r n = erase-errVal (r n)

erase-ctx : T.Context → Context
erase-ctx ∅ = ∅
erase-ctx (τ • Γ) = erase-type τ • (erase-ctx Γ)

erase-env : ∀ {Γ} → T.Op.⟦ Γ ⟧Context → ⟦ erase-ctx Γ ⟧Context
erase-env ∅ = ∅
erase-env (v • ρ) = erase-val v • erase-env ρ

erase-var : ∀ {Γ τ} → T.Var Γ τ → Var (erase-ctx Γ) (erase-type τ)
erase-var T.this = this
erase-var (T.that x) = that (erase-var x)

erase-term : ∀ {Γ τ} → T.Term Γ τ → Term (erase-ctx Γ)
erase-term (T.var x) = var (erase-var x)
erase-term (T.lett f x t) = lett (erase-var f) (erase-var x) (erase-term t)

erase-fun : ∀ {Γ τ} → T.Fun Γ τ → Fun (erase-ctx Γ)
erase-fun (T.term x) = term (erase-term x)
erase-fun (T.abs f) = abs (erase-fun f)

erase-val (T.closure t ρ) = closure (erase-fun t) (erase-env ρ)
erase-val (T.intV n) = intV n

-- Different erasures commute.
erasure-commute-var : ∀ {Γ τ} (x : T.Var Γ τ) ρ →
  erase-val (T.Op.⟦ x ⟧Var ρ) ≡ ⟦ erase-var x ⟧Var (erase-env ρ)
erasure-commute-var T.this (v • ρ) = refl
erasure-commute-var (T.that x) (v • ρ) = erasure-commute-var x ρ

erase-bind : ∀ {σ τ Γ} a (t : T.Term (σ • Γ) τ) ρ n → erase-errVal (a T.>>= (λ v → T.eval-term t (v • ρ) n)) ≡ erase-errVal a >>= (λ v → eval-term (erase-term t) (v • erase-env ρ) n)

erasure-commute-fun : ∀ {Γ τ} (t : T.Fun Γ τ) ρ n →
  erase-errVal (T.eval-fun t ρ n) ≡ eval-fun (erase-fun t) (erase-env ρ) n

erasure-commute-apply : ∀ {σ τ} (f : T.Val (σ T.⇒ τ)) a n → erase-errVal (T.apply f a n) ≡ apply (erase-val f) (erase-val a) n
erasure-commute-apply {σ} (T.closure t ρ) a n = erasure-commute-fun t (a • ρ) n

erasure-commute-term : ∀ {Γ τ} (t : T.Term Γ τ) ρ n →
  erase-errVal (T.eval-term t ρ n) ≡ eval-term (erase-term t) (erase-env ρ) n

erasure-commute-fun (T.term t) ρ n = erasure-commute-term t ρ n
erasure-commute-fun (T.abs t) ρ n = refl

erasure-commute-term t ρ zero = refl
erasure-commute-term (T.var x) ρ (ℕ.suc n) = cong Done (erasure-commute-var x ρ)
erasure-commute-term (T.lett f x t) ρ (ℕ.suc n) rewrite erase-bind (T.apply (T.Op.⟦ f ⟧Var ρ) (T.Op.⟦ x ⟧Var ρ) n) t ρ n | erasure-commute-apply (T.Op.⟦ f ⟧Var ρ) (T.Op.⟦ x ⟧Var ρ) n | erasure-commute-var f ρ | erasure-commute-var x ρ = refl

erase-bind (T.Done v) t ρ n = erasure-commute-term t (v • ρ) n
erase-bind T.Error t ρ n = refl
erase-bind T.TimeOut t ρ n = refl

module Thesis.ANormalUntyped where

open import Data.Empty
open import Data.Product
open import Data.Nat.Base
import Data.Integer.Base as I
open I using (ℤ)
open import Data.Integer.Base using (ℤ)
open import Relation.Binary.PropositionalEquality

{- Typed deBruijn indexes for untyped languages. -}

-- Using a record gives an eta rule saying that all types are equal.
record Type : Set where
  constructor Uni

record DType : Set where
  constructor DUni

open import Base.Syntax.Context Type public
import Base.Syntax.Context DType as DC

data Term (Γ : Context) : Set where
  var : (x : Var Γ Uni) →
    Term Γ
  lett : (f : Var Γ Uni) → (x : Var Γ Uni) → Term (Uni • Γ) → Term Γ

ΔΔ : Context → DC.Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = DUni • ΔΔ Γ

derive-dvar : ∀ {Δ} → (x : Var Δ Uni) → DC.Var (ΔΔ Δ) DUni
derive-dvar this = DC.this
derive-dvar (that x) = DC.that (derive-dvar x)

data DTerm : (Δ : Context) → Set where
  dvar : ∀ {Δ} (x : DC.Var (ΔΔ Δ) DUni) →
    DTerm Δ
  dlett : ∀ {Δ} →
    (f : Var Δ Uni) →
    (x : Var Δ Uni) →
    (t : Term (Uni • Δ)) →
    (df : DC.Var (ΔΔ Δ) DUni) →
    (dx : DC.Var (ΔΔ Δ) DUni) →
    (dt : DTerm (Uni • Δ)) →
    DTerm Δ

derive-dterm : ∀ {Δ} → (t : Term Δ) → DTerm Δ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

{-
deriveC Δ (lett f x t) = dlett df x dx
-}

-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
-- data ΔCTerm (Γ : Context) (τ : Type) (Δ : Context) : Set where
--   cvar : (x : Var Γ τ) Δ →
--     ΔCTerm Γ τ Δ
--   clett : ∀ {σ τ₁ κ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
--     ΔCTerm (τ₁ • Γ) τ (? • Δ) →
--     ΔCTerm Γ τ Δ

weaken-term : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ →
  Term Γ₂
weaken-term Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
weaken-term Γ₁≼Γ₂ (lett f x t) = lett (weaken-var Γ₁≼Γ₂ f) (weaken-var Γ₁≼Γ₂ x) (weaken-term (keep _ • Γ₁≼Γ₂) t)

-- I don't necessarily recommend having a separate syntactic category for
-- functions, but we should prove a fundamental lemma for them too, somehow.
-- I'll probably end up with some ANF allowing lambdas to do the semantics.
data Fun (Γ : Context) : Set where
  term : Term Γ → Fun Γ
  abs : ∀ {σ} → Fun (σ • Γ) → Fun Γ

data DFun (Δ : Context) : Set where
  dterm : DTerm Δ → DFun Δ
  dabs : DFun (Uni • Δ) → DFun Δ

derive-dfun : ∀ {Δ} → (t : Fun Δ) → DFun Δ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

weaken-fun : ∀ {Γ₁ Γ₂} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Fun Γ₁ →
  Fun Γ₂
weaken-fun Γ₁≼Γ₂ (term x) = term (weaken-term Γ₁≼Γ₂ x)
weaken-fun Γ₁≼Γ₂ (abs f) = abs (weaken-fun (keep _ • Γ₁≼Γ₂) f)

data Val : Type → Set
data DVal : DType → Set
-- data Val (τ : Type) : Set

open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

import Base.Denotation.Environment DType DVal as D

-- data Val (τ : Type) where
data Val where
  closure : ∀ {Γ} → (t : Fun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → Val Uni
  intV : ∀ (n : ℕ) → Val Uni

data DVal where
  dclosure : ∀ {Γ} → (dt : DFun (Uni • Γ)) → (ρ : ⟦ Γ ⟧Context) → (dρ : D.⟦ ΔΔ Γ ⟧Context) → DVal DUni
  dintV : ∀ (n : ℤ) → DVal DUni

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

-- ⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → ⟦ τ ⟧Type
-- ⟦ var x ⟧Term ρ = ⟦ x ⟧Var ρ
-- ⟦ lett f x t ⟧Term ρ = ⟦ t ⟧Term (⟦ f ⟧Var ρ (⟦ x ⟧Var ρ) • ρ)

-- XXX separate syntax is a bit dangerous. Also, do I want to be so accurate relative to the original model?
data _F⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Fun Γ → ℕ → Val Uni → Set where
  abs : ∀ {t : Fun (Uni • Γ)} →
    ρ F⊢ abs t ↓[ 0 ] closure t ρ

data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Term Γ → ℕ → Val Uni → Set where
  var : ∀ (x : Var Γ Uni) →
    ρ ⊢ var x ↓[ 0 ] (⟦ x ⟧Var ρ)
  lett : ∀ n1 n2 {Γ' ρ′ v1 v2 v3} {f x t t'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    ρ ⊢ lett f x t ↓[ suc (suc (n1 + n2)) ] v3
  -- lit : ∀ n →
  --   ρ ⊢ const (lit n) ↓[ 0 ] intV n

-- data _D_⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : D.⟦ ΔΔ Γ ⟧Context) : DTerm Γ → ℕ → DVal DUni → Set where
--   dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
--     ρ D dρ ⊢ dvar x ↓[ 0 ] (D.⟦ x ⟧Var dρ)
--   dlett : ∀ n1 n2 n3 n4 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
--     ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
--     ρ ⊢ var x ↓[ 0 ] v1 →
--     (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
--     (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
--     -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
--     -- definitions.
--     ρ D dρ ⊢ dvar df ↓[ 0 ] dclosure {Γ'} dt' ρ'' dρ' →
--     ρ D dρ ⊢ dvar dx ↓[ 0 ] dv1 →
--     (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓[ n3 ] dv2 →
--     (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓[ n4 ] dv3 →
--     ρ D dρ ⊢ dlett f x t df dx dt ↓[ suc (suc (n1 + n2)) ] dv3

-- Do I need to damn count steps here? No.

data _D_F⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DFun Γ → DVal DUni → Set where
  dabs : ∀ {t : DFun (Uni • Γ)} →
    ρ D dρ F⊢ dabs t ↓ dclosure t ρ dρ

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DTerm Γ → DVal DUni → Set where
  dvar : ∀ (x : DC.Var (ΔΔ Γ) DUni) →
    ρ D dρ ⊢ dvar x ↓ (D.⟦ x ⟧Var dρ)
  dlett : ∀ n1 n2 {Γ' ρ′ ρ'' dρ' v1 v2 v3 dv1 dv2 dv3} {f x t df dx dt t' dt'}  →
    ρ ⊢ var f ↓[ 0 ] closure {Γ'} t' ρ′ →
    ρ ⊢ var x ↓[ 0 ] v1 →
    (v1 • ρ′) F⊢ t' ↓[ n1 ] v2 →
    (v2 • ρ) ⊢ t ↓[ n2 ] v3 →
    -- With a valid input ρ' and ρ'' coincide? Varies among plausible validity
    -- definitions.
    ρ D dρ ⊢ dvar df ↓ dclosure {Γ'} dt' ρ'' dρ' →
    ρ D dρ ⊢ dvar dx ↓ dv1 →
    (v1 • ρ'') D (dv1 • dρ') F⊢ dt' ↓ dv2 →
    (v2 • ρ) D (dv2 • dρ) ⊢ dt ↓ dv3 →
    ρ D dρ ⊢ dlett f x t df dx dt ↓ dv3

{-# TERMINATING #-} -- Dear lord. Why on Earth.
mutual
  -- Single context? Yeah, good, that's what we want in the end...
  -- Though we might want more flexibility till when we have replacement
  -- changes.
  rrelT3 : ∀ {Γ} (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  rrelT3 t1 dt t2 ρ1 dρ ρ2 k =
    (v1 v2 : Val Uni) →
    ∀ j n2 (j<k : j < k) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    rrelV3 v1 dv v2 (k ∸ j)

  rrelV3 : ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → ℕ → Set
  rrelV3 (intV v1) (dintV dv) (intV v2) n = dv I.+ (I.+ v1) ≡ (I.+ v2)
  rrelV3 (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) n =
      -- Require a proof that the two contexts match:
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        rrelV3 v1 dv v2 k →
        rrelT3
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
          k
      }
  rrelV3 _ _ _ n = ⊥

-- -- [_]τ  from v1 to v2) :
-- -- [ τ ]τ dv from v1 to v2) =

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

-- data ErrVal : Set where
--   Done : (v : Val Uni) → ErrVal
--   Error : ErrVal
--   TimeOut : ErrVal

-- _>>=_ : ErrVal → (Val Uni → ErrVal) → ErrVal
-- Done v >>= f = f v
-- Error >>= f = Error
-- TimeOut >>= f = TimeOut

-- Res : Set
-- Res = ℕ → ErrVal

-- -- eval-fun : ∀ {Γ} → Fun Γ → ⟦ Γ ⟧Context → Res
-- -- eval-term : ∀ {Γ} → Term Γ → ⟦ Γ ⟧Context → Res

-- -- apply : Val Uni → Val Uni → Res
-- -- apply (closure f ρ) a n = eval-fun f (a • ρ) n
-- -- apply (intV _) a n = Error

-- -- eval-term t ρ zero = TimeOut
-- -- eval-term (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
-- -- eval-term (lett f x t) ρ (suc n) = apply (⟦ f ⟧Var ρ) (⟦ x ⟧Var ρ) n >>= (λ v → eval-term t (v • ρ) n)

-- -- eval-fun (term t) ρ n = eval-term t ρ n
-- -- eval-fun (abs f) ρ n = Done (closure f ρ)

-- -- -- Erasure from typed to untyped values.
-- -- import Thesis.ANormalBigStep as T

-- -- erase-type : T.Type → Type
-- -- erase-type _ = Uni

-- -- erase-val : ∀ {τ} → T.Val τ → Val (erase-type τ)

-- -- erase-errVal : ∀ {τ} → T.ErrVal τ → ErrVal
-- -- erase-errVal (T.Done v) = Done (erase-val v)
-- -- erase-errVal T.Error = Error
-- -- erase-errVal T.TimeOut = TimeOut

-- -- erase-res : ∀ {τ} → T.Res τ → Res
-- -- erase-res r n = erase-errVal (r n)

-- -- erase-ctx : T.Context → Context
-- -- erase-ctx ∅ = ∅
-- -- erase-ctx (τ • Γ) = erase-type τ • (erase-ctx Γ)

-- -- erase-env : ∀ {Γ} → T.Op.⟦ Γ ⟧Context → ⟦ erase-ctx Γ ⟧Context
-- -- erase-env ∅ = ∅
-- -- erase-env (v • ρ) = erase-val v • erase-env ρ

-- -- erase-var : ∀ {Γ τ} → T.Var Γ τ → Var (erase-ctx Γ) (erase-type τ)
-- -- erase-var T.this = this
-- -- erase-var (T.that x) = that (erase-var x)

-- -- erase-term : ∀ {Γ τ} → T.Term Γ τ → Term (erase-ctx Γ)
-- -- erase-term (T.var x) = var (erase-var x)
-- -- erase-term (T.lett f x t) = lett (erase-var f) (erase-var x) (erase-term t)

-- -- erase-fun : ∀ {Γ τ} → T.Fun Γ τ → Fun (erase-ctx Γ)
-- -- erase-fun (T.term x) = term (erase-term x)
-- -- erase-fun (T.abs f) = abs (erase-fun f)

-- -- erase-val (T.closure t ρ) = closure (erase-fun t) (erase-env ρ)
-- -- erase-val (T.intV n) = intV n

-- -- -- Different erasures commute.
-- -- erasure-commute-var : ∀ {Γ τ} (x : T.Var Γ τ) ρ →
-- --   erase-val (T.Op.⟦ x ⟧Var ρ) ≡ ⟦ erase-var x ⟧Var (erase-env ρ)
-- -- erasure-commute-var T.this (v • ρ) = refl
-- -- erasure-commute-var (T.that x) (v • ρ) = erasure-commute-var x ρ

-- -- erase-bind : ∀ {σ τ Γ} a (t : T.Term (σ • Γ) τ) ρ n → erase-errVal (a T.>>= (λ v → T.eval-term t (v • ρ) n)) ≡ erase-errVal a >>= (λ v → eval-term (erase-term t) (v • erase-env ρ) n)

-- -- erasure-commute-fun : ∀ {Γ τ} (t : T.Fun Γ τ) ρ n →
-- --   erase-errVal (T.eval-fun t ρ n) ≡ eval-fun (erase-fun t) (erase-env ρ) n

-- -- erasure-commute-apply : ∀ {σ τ} (f : T.Val (σ T.⇒ τ)) a n → erase-errVal (T.apply f a n) ≡ apply (erase-val f) (erase-val a) n
-- -- erasure-commute-apply {σ} (T.closure t ρ) a n = erasure-commute-fun t (a • ρ) n

-- -- erasure-commute-term : ∀ {Γ τ} (t : T.Term Γ τ) ρ n →
-- --   erase-errVal (T.eval-term t ρ n) ≡ eval-term (erase-term t) (erase-env ρ) n

-- -- erasure-commute-fun (T.term t) ρ n = erasure-commute-term t ρ n
-- -- erasure-commute-fun (T.abs t) ρ n = refl

-- -- erasure-commute-term t ρ zero = refl
-- -- erasure-commute-term (T.var x) ρ (ℕ.suc n) = cong Done (erasure-commute-var x ρ)
-- -- erasure-commute-term (T.lett f x t) ρ (ℕ.suc n) rewrite erase-bind (T.apply (T.Op.⟦ f ⟧Var ρ) (T.Op.⟦ x ⟧Var ρ) n) t ρ n | erasure-commute-apply (T.Op.⟦ f ⟧Var ρ) (T.Op.⟦ x ⟧Var ρ) n | erasure-commute-var f ρ | erasure-commute-var x ρ = refl

-- -- erase-bind (T.Done v) t ρ n = erasure-commute-term t (v • ρ) n
-- -- erase-bind T.Error t ρ n = refl
-- -- erase-bind T.TimeOut t ρ n = refl

Write down real step-indexed logical relation for untyped terms

Sadly, Agda does not recognize this is terminating, because recursing on k with
k < n is not a structurally recursive call on a subterm. SAD!


{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.One
open import Data.Two
open import Data.Maybe
open import Data.Product
open import Data.Nat
open import Data.Vec hiding (_>>=_ ; _∈_)
open import Data.List as L
open import Data.Fin as Fin using (Fin)
open import Relation.Binary.PropositionalEquality.NP as ≡
open import Control.Strategy renaming (map to mapS)
open import Game.Challenge
import Game.ReceiptFreeness
import Game.IND-CCA2-dagger
import Game.IND-CPA-utils

import Data.List.Any
open Data.List.Any using (here; there)
open Data.List.Any.Membership-≡ using (_∈_ ; _∉_)

module Game.Transformation.ReceiptFreeness-CCA2d.Valid
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (#q : ℕ) (max#q : Fin #q)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CipherText)
  (Dec    : let Message = 𝟚 in
            SecKey → CipherText → Message)
  (Check    : let open Game.ReceiptFreeness PubKey SecKey CipherText SerialNumber Rₑ Rₖ Rₐ #q max#q KeyGen Enc Dec
               in BB → Receipt → 𝟚)
  (CheckMem : ∀ bb r → ✓ (Check bb r) → proj₁ (proj₂ r) ∉ L.map (proj₁ ∘ proj₂) bb)
  -- (CheckEnc : ∀ pk m rₑ → Check (Enc pk m rₑ) ≡ 1₂)
  where

_²' : ★ → ★
X ²' = X × X

r-sn : Receipt → SerialNumber
r-sn (_ , sn , _) = sn

module Simulator-Valid (RFA : RF.Adversary)(RFA-Valid : RF.Valid-Adversary RFA)
  (WRONG-HYP : ∀ r r' → r-sn r ≡ r-sn r' → enc-co r ≡ enc-co r')
  where
  valid : CCA2†.Valid-Adversary (Simulator.A† RFA)
  valid (rₐ , rgb) pk = Phase1 _ (RFA-Valid rₐ pk) where
     open CCA2†.Valid-Adversary (rₐ , rgb) pk
     module RFA = RF.Valid-Adversary rₐ pk
     open Simulator RFA
     open AdversaryParts rgb pk rₐ

     -- could refine r more
     -- {-
     Phase2 : ∀ RF {bb i taA taB r} → r-sn (r 0₂) ∈ L.map r-sn bb → r-sn (r 1₂) ∈ L.map r-sn bb → RFA.Phase2-Valid r RF
            → Phase2-Valid (proj₂ ∘ proj₂ ∘ r) (mapS proj₁ (mitm-to-client-trans (MITM-phase 1₂ i bb (taA , taB)) RF))
     Phase2 (ask REB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RBB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RTally cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask (RCO x) cont) r0 r1 ((r₀ , r₁) , RF-valid) = r₀ , r₁ , (λ r → Phase2 (cont _) r0 r1 (RF-valid _))
     Phase2 (ask (Vote x) cont) {bb} r0 r1 RF-valid with Check bb x | CheckMem bb x
     ... | 0₂ | _ = Phase2 (cont _) r0 r1 (RF-valid _)
     ... | 1₂ | not-in-bb = (λ eq → not-in-bb _ {!subst (λ x → x ∈ L.map r-sn bb) eq!})
                            , {!!},
                            , λ r → Phase2 (cont _) (there r0) (there r1) (RF-valid _)
     Phase2 (done x) r0 r1 RF-valid = RF-valid

     Phase1 : ∀ RF {sn i bb taA taB} → RFA.Phase1-Valid sn RF
            → Phase1-Valid (mapS A†2 (mitm-to-client-trans (MITM-phase 0₂ i bb (taA , taB)) RF))
     Phase1 (ask REB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RBB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RTally cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask (RCO x) cont) RF-valid r = Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) {bb = bb} RF-valid with Check bb x
     Phase1 (ask (Vote x) cont) RF-valid | 1₂ = λ r → Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) RF-valid | 0₂ = Phase1 _ (RF-valid _)
     Phase1 (done x) (sn₀∉sn , sn₁∉sn , RF-valid) cs = Phase2 (put-resp x (proj₂ (put-resp (hack-challenge x) cs) ))
            (here refl) (there (here refl)) (RF-valid _)
    -- -}

-- -}

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

{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.One
open import Data.Two
open import Data.Maybe
open import Data.Product
open import Data.Nat
open import Data.Vec hiding (_>>=_ ; _∈_)
open import Data.List as L
open import Data.Fin as Fin using (Fin)
open import Relation.Binary.PropositionalEquality.NP as ≡
open import Control.Strategy renaming (map to mapS)
open import Control.Strategy.Utils
open import Game.Challenge
import Game.ReceiptFreeness
import Game.IND-CCA2-dagger
import Game.IND-CCA2-dagger.Valid
import Game.IND-CPA-utils

import Data.List.Any
open Data.List.Any using (here; there)
open Data.List.Any.Membership-≡ using (_∈_ ; _∉_)

import Game.ReceiptFreeness.Adversary
import Game.ReceiptFreeness.Valid
import Game.Transformation.ReceiptFreeness-CCA2d.Simulator

module Game.Transformation.ReceiptFreeness-CCA2d.Valid
  (PubKey    : ★)
  (CipherText : ★)

  (SerialNumber : ★)
  (Receipt : ★)
  (MarkedReceipt? : ★)
  (Ballot : ★)
  (Tally : ★)
--  (BB    : ★)
--  ([]    : BB)
--  (_∷_ : Receipt → BB → BB)
  (Rgb   : ★)
  (genBallot : PubKey → Rgb → Ballot)
  (tallyMarkedReceipt? : let CO = 𝟚 in CO → MarkedReceipt? → Tally)
  (0,0   : Tally)
  (1,1   : Tally)
  (_+,+_ : Tally → Tally → Tally)
  (receipts : SerialNumber ² → CipherText ² → Receipt ²)
  (enc-co : Receipt → CipherText)
  (r-sn   : Receipt → SerialNumber)
  (m?     : Receipt → MarkedReceipt?)
  (b-sn   : Ballot → SerialNumber)
  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₐ : ★)
  (#q : ℕ) (max#q : Fin #q)
  (Check    : let BB = List Receipt in BB → Receipt → 𝟚)
  where

_²' : ★ → ★
X ²' = X × X

CO = 𝟚
BB = List Receipt
all-sn : BB → List SerialNumber
all-sn = L.map r-sn

module RF  = Game.ReceiptFreeness.Adversary PubKey (SerialNumber ²) Rₐ Receipt Ballot Tally CO BB
module RFV = Game.ReceiptFreeness.Valid     PubKey SerialNumber Rₐ Receipt Ballot Tally CO BB
                                            CipherText enc-co r-sn b-sn

open Game.Transformation.ReceiptFreeness-CCA2d.Simulator
  PubKey CipherText (SerialNumber ²) Receipt MarkedReceipt? Ballot Tally BB [] _∷_ Rgb genBallot
  tallyMarkedReceipt? 0,0 1,1 _+,+_ receipts enc-co m? Rₐ #q max#q Check

module CCA2†V = Game.IND-CCA2-dagger.Valid PubKey Message CipherText Rₐ†

module Simulator-Valid (RFA : RF.Adversary)(RFA-Valid : RFV.Valid-Adversary RFA)
  (WRONG-HYP : ∀ r r' → enc-co r ≡ enc-co r' → r-sn r ≡ r-sn r')
  (CheckMem : ∀ bb r → ✓ (Check bb r) → r-sn r ∉ all-sn bb)
  where
  valid : CCA2†V.Valid-Adversary (Simulator.A† RFA)
  valid (rₐ , rgb) pk = Phase1 _ (RFA-Valid rₐ pk) where
     open CCA2†V.Valid-Adversary (rₐ , rgb) pk
     module RFVA = RFV.Valid-Adversary rₐ pk
     open RF
     open Simulator RFA
     open AdversaryParts rgb pk rₐ

     -- could refine r more
     -- {-
     Phase2 : ∀ RF {bb i ta r} → r-sn (r 0₂) ∈ all-sn bb → r-sn (r 1₂) ∈ all-sn bb → RFVA.Phase2-Valid r RF
            → Phase2-Valid (enc-co ∘ r) (mapS proj₁ (mitm-to-client-trans (MITM-phase 1₂ i bb ta) RF))
     Phase2 (ask REB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RBB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RTally cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask (RCO x) cont) r0 r1 ((r₀ , r₁) , RF-valid) = r₀ , r₁ , (λ r → Phase2 (cont _) r0 r1 (RF-valid _))
     Phase2 (ask (Vote x) cont) {bb} r0 r1 RF-valid with Check bb x | CheckMem bb x
     ... | 0₂ | _ = Phase2 (cont _) r0 r1 (RF-valid _)
     ... | 1₂ | not-in-bb = (λ eq → not-in-bb _ (subst (λ x₁ → x₁ ∈ all-sn bb) (WRONG-HYP _ _  eq) r0))
                            , (λ eq → not-in-bb _ (subst (λ x₁ → x₁ ∈ all-sn bb) (WRONG-HYP _ _ eq) r1))
                            , λ r → Phase2 (cont _) (there r0) (there r1) (RF-valid _)
                            --Phase2 (cont _) (there r0) (there r1) (RF-valid _)
     Phase2 (done x) r0 r1 RF-valid = RF-valid

     Phase1 : ∀ RF {sn i bb ta} → RFVA.Phase1-Valid sn RF
            → Phase1-Valid (mapS A†2 (mitm-to-client-trans (MITM-phase 0₂ i bb ta) RF))
     Phase1 (ask REB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RBB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RTally cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask (RCO x) cont) RF-valid r = Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) {bb = bb} RF-valid with Check bb x
     Phase1 (ask (Vote x) cont) RF-valid | 1₂ = λ r → Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) RF-valid | 0₂ = Phase1 _ (RF-valid _)
     Phase1 (done x) {bb = bb'}{ta} (sn₀∉sn , sn₁∉sn , RF-valid) cs
       = {!Phase2 (put-resp x (proj₂ (put-resp (hack-challenge x) cs))) (here refl) (there (here refl)) (RF-valid _)!}
       -- Phase2 (put-resp x (proj₂ (put-resp (hack-challenge x) cs) ))
       --     ? ? (RF-valid _)
    -- -}

-- -}

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

update the validity for the simulator

update the validity for the simulator


open import Function.NP
open import Data.Product.NP
open import Data.Nat
  using    (ℕ; fold; zero)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
open import Data.Integer
  using    (ℤ; +_; -[1+_]; _⊖_)
  renaming (_+_ to _+ℤ_; _*_ to _*ℤ_)
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
open import Algebra.FunctionProperties.Eq
open ≡-Reasoning

module Algebra.Monoid where

record Monoid-Ops {ℓ} (M : Set ℓ) : Set ℓ where
  constructor mk
  infixl 7 _∙_

  field
    _∙_ : M → M → M
    ε   : M

  _^⁺_ : M → ℕ → M
  x ^⁺ n = fold ε (_∙_ x) n

  module FromInverseOp
         (_⁻¹   : Op₁ M)
         where
    infixl 7 _/_

    _/_ : M → M → M
    x / y = x ∙ y ⁻¹

    open FromOp₂ _/_ public renaming (op= to /=)

    _^⁻_ _^⁻′_ : M → ℕ → M
    x ^⁻ n = (x ^⁺ n)⁻¹
    x ^⁻′ n = (x ⁻¹)^⁺ n

    _^_ : M → ℤ → M
    x ^ -[1+ n ] = x ^⁻(1+ n)
    x ^ (+ n)    = x ^⁺ n

record Monoid-Struct {ℓ} {M : Set ℓ} (mon-ops : Monoid-Ops M) : Set ℓ where
  open Monoid-Ops mon-ops

  -- laws
  field
    assoc    : Associative _∙_
    identity : Identity  ε _∙_

  open FromOp₂ _∙_ public renaming (op= to ∙=)
  open FromAssoc _∙_ assoc public

  module _ {b} where
    ^⁺0-ε : b ^⁺ 0 ≡ ε
    ^⁺0-ε = idp

    ^⁺1-id : b ^⁺ 1 ≡ b
    ^⁺1-id = snd identity

    ^⁺2-∙ : b ^⁺ 2 ≡ b ∙ b
    ^⁺2-∙ = ap (_∙_ _) ^⁺1-id

    ^⁺-+ : ∀ m {n} → b ^⁺ (m +ℕ n) ≡ b ^⁺ m ∙ b ^⁺ n
    ^⁺-+ 0      = ! fst identity
    ^⁺-+ (1+ m) = ap (_∙_ b) (^⁺-+ m) ♦ ! assoc

    ^⁺-* : ∀ m {n} → b ^⁺(m *ℕ n) ≡ (b ^⁺ n)^⁺ m
    ^⁺-* 0 = idp
    ^⁺-* (1+ m) {n}
      = b ^⁺ (n +ℕ m *ℕ n)     ≡⟨ ^⁺-+ n ⟩
        b ^⁺ n ∙ b ^⁺(m *ℕ n)  ≡⟨ ap (_∙_ (b ^⁺ n)) (^⁺-* m) ⟩
        b ^⁺ n ∙ (b ^⁺ n)^⁺ m  ∎

  comm-ε : ∀ {x} → x ∙ ε ≡ ε ∙ x
  comm-ε = snd identity ♦ ! fst identity

  module _ {c x y} (e : (x ∙ y) ≡ ε) where
    elim-assoc= : (c ∙ x) ∙ y ≡ c
    elim-assoc= = assoc ♦ ∙= idp e ♦ snd identity

    elim-!assoc= : x ∙ (y ∙ c) ≡ c
    elim-!assoc= = ! assoc ♦ ∙= e idp ♦ fst identity

  module _ {c d x y} (e : (x ∙ y) ≡ ε) where
    elim-inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
    elim-inner= = assoc ♦ ap (_∙_ c) (elim-!assoc= e)

  module FromLeftInverse
         (_⁻¹   : Op₁ M)
         (inv-l : LeftInverse ε _⁻¹ _∙_)
         where
    open FromInverseOp _⁻¹

    cancels-∙-left : LeftCancel _∙_
    cancels-∙-left {c} {x} {y} e
      = x              ≡⟨ ! fst identity ⟩
        ε ∙ x          ≡⟨ ∙= (! inv-l) idp ⟩
        c ⁻¹ ∙ c ∙ x   ≡⟨ !assoc= e ⟩
        c ⁻¹ ∙ c ∙ y   ≡⟨ ∙= inv-l idp ⟩
        ε ∙ y          ≡⟨ fst identity ⟩
        y ∎

    inv-r : RightInverse ε _⁻¹ _∙_
    inv-r = cancels-∙-left (! assoc ♦ ∙= inv-l idp ♦ ! comm-ε)

    /-∙ : ∀ {x y} → x ≡ (x / y) ∙ y
    /-∙ {x} {y}
      = x               ≡⟨ ! snd identity ⟩
        x ∙ ε           ≡⟨ ap (_∙_ x) (! inv-l) ⟩
        x ∙ (y ⁻¹ ∙ y)  ≡⟨ ! assoc ⟩
        (x / y) ∙ y     ∎

  module FromRightInverse
         (_⁻¹   : Op₁ M)
         (inv-r : RightInverse ε _⁻¹ _∙_)
         where
    open FromInverseOp _⁻¹

    cancels-∙-right : RightCancel _∙_
    cancels-∙-right {c} {x} {y} e
      = x              ≡⟨ ! snd identity ⟩
        x ∙ ε          ≡⟨ ∙= idp (! inv-r) ⟩
        x ∙ (c ∙ c ⁻¹) ≡⟨ assoc= e ⟩
        y ∙ (c ∙ c ⁻¹) ≡⟨ ∙= idp inv-r ⟩
        y ∙ ε          ≡⟨ snd identity ⟩
        y ∎

    inv-l : LeftInverse ε _⁻¹ _∙_
    inv-l = cancels-∙-right (assoc ♦ ∙= idp inv-r ♦ comm-ε)

    module _ {x y} where
      is-ε-left : x ≡ ε → x ∙ y ≡ y
      is-ε-left e = ap (λ z → z ∙ _) e ♦ fst identity

      is-ε-right : y ≡ ε → x ∙ y ≡ x
      is-ε-right e = ap (λ z → _ ∙ z) e ♦ snd identity

      ∙-/ : x ≡ (x ∙ y) / y
      ∙-/
        = x            ≡⟨ ! snd identity ⟩
          x ∙ ε        ≡⟨ ap (_∙_ x) (! inv-r) ⟩
          x ∙ (y / y)  ≡⟨ ! assoc ⟩
          (x ∙ y) / y  ∎

    module _ {x y} where
      unique-ε-left : x ∙ y ≡ y → x ≡ ε
      unique-ε-left eq
        = x            ≡⟨ ∙-/ ⟩
          (x ∙ y) / y  ≡⟨ /= eq idp ⟩
          y / y        ≡⟨ inv-r ⟩
          ε            ∎

      unique-ε-right : x ∙ y ≡ x → y ≡ ε
      unique-ε-right eq
        = y               ≡⟨ ! is-ε-left inv-l ⟩
          x ⁻¹ ∙  x ∙ y   ≡⟨ assoc ⟩
          x ⁻¹ ∙ (x ∙ y)  ≡⟨ ∙= idp eq ⟩
          x ⁻¹ ∙ x        ≡⟨ inv-l ⟩
          ε               ∎

      unique-⁻¹ : x ∙ y ≡ ε → x ≡ y ⁻¹
      unique-⁻¹ eq
        = x            ≡⟨ ∙-/ ⟩
          (x ∙ y) / y  ≡⟨ /= eq idp ⟩
          ε / y        ≡⟨ fst identity ⟩
          y ⁻¹         ∎

    open FromLeftInverse _⁻¹ inv-l hiding (inv-r)

    ε⁻¹-ε : ε ⁻¹ ≡ ε
    ε⁻¹-ε = unique-ε-left inv-l

    involutive : Involutive _⁻¹
    involutive {x}
      = cancels-∙-right
        (x ⁻¹ ⁻¹ ∙ x ⁻¹ ≡⟨ inv-l ⟩
         ε              ≡⟨ ! inv-r ⟩
         x ∙ x ⁻¹ ∎)

    ⁻¹-hom′ : ∀ {x y} → (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
    ⁻¹-hom′ {x} {y} = cancels-∙-left {x ∙ y}
       ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ inv-r ⟩
        ε                       ≡⟨ ! inv-r ⟩
        x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! fst identity) ⟩
        x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! inv-r) idp) ⟩
        x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
        x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
        (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

    elim-∙-left-⁻¹∙ : ∀ {c x y} → (c ∙ x)⁻¹ ∙ (c ∙ y) ≡ x ⁻¹ ∙ y
    elim-∙-left-⁻¹∙ {c} {x} {y}
      = (c ∙ x)⁻¹   ∙ (c ∙ y)  ≡⟨ ∙= ⁻¹-hom′ idp ⟩
        x ⁻¹ ∙ c ⁻¹ ∙ (c ∙ y)  ≡⟨ elim-inner= inv-l ⟩
        x ⁻¹ ∙ y               ∎

    elim-∙-right-/ : ∀ {c x y} → (x ∙ c) / (y ∙ c) ≡ x / y
    elim-∙-right-/ {c} {x} {y}
      = x ∙ c ∙ (y ∙ c)⁻¹  ≡⟨ ap (_∙_ _) ⁻¹-hom′  ⟩
        x ∙ c ∙ (c ⁻¹ / y) ≡⟨ elim-inner= inv-r ⟩
        x / y ∎

    module _ {b} where
      ^⁺suc : ∀ n → b ^⁺(1+ n) ≡ b ^⁺ n ∙ b
      ^⁺suc 0 = comm-ε
      ^⁺suc (1+ n) = ap (_∙_ b) (^⁺suc n) ♦ ! assoc

      ^⁺-comm : ∀ n → b ∙ b ^⁺ n ≡ b ^⁺ n ∙ b
      ^⁺-comm = ^⁺suc

      ^⁻suc : ∀ n → b ^⁻(1+ n) ≡ b ⁻¹ ∙ b ^⁻ n
      ^⁻suc n = ap _⁻¹ (^⁺suc n) ♦ ⁻¹-hom′

      ^⁻′-spec : ∀ n → b ^⁻′ n ≡ b ^⁻ n
      ^⁻′-spec 0 = ! ε⁻¹-ε
      ^⁻′-spec (1+ n) = ap (_∙_ (b ⁻¹)) (^⁻′-spec n)
                      ♦ ! ⁻¹-hom′
                      ♦ ap _⁻¹ (! ^⁺suc n)

      ^⁻′1-id : b ^⁻′ 1 ≡ b ⁻¹
      ^⁻′1-id = snd identity

      ^⁻1-id : b ^⁻ 1 ≡ b ⁻¹
      ^⁻1-id = ! ^⁻′-spec 1 ♦ ^⁻′1-id

      ^⁻′2-∙ : b ^⁻′ 2 ≡ b ⁻¹ ∙ b ⁻¹
      ^⁻′2-∙ = ap (_∙_ _) ^⁻′1-id

      ^⁻2-∙ : b ^⁻ 2 ≡ b ⁻¹ ∙ b ⁻¹
      ^⁻2-∙ = ! ^⁻′-spec 2 ♦ ^⁻′2-∙

record Monoid (M : Set) : Set where
  field
    mon-ops    : Monoid-Ops M
    mon-struct : Monoid-Struct mon-ops
  open Monoid-Ops    mon-ops    public
  open Monoid-Struct mon-struct public

record Commutative-Monoid-Struct {ℓ} {M : Set ℓ} (mon-ops : Monoid-Ops M) : Set ℓ where
  open Monoid-Ops mon-ops
  field
    mon-struct : Monoid-Struct mon-ops
    comm : Commutative _∙_
  open Monoid-Struct mon-struct public
  open FromAssocComm _∙_ assoc comm public
    hiding (!assoc=; assoc=; inner=)

record Commutative-Monoid (M : Set) : Set where
  field
    mon-ops    : Monoid-Ops M
    mon-comm   : Commutative-Monoid-Struct mon-ops
  open Monoid-Ops    mon-ops    public
  open Commutative-Monoid-Struct mon-comm public
  mon : Monoid M
  mon = record { mon-struct = mon-struct }

-- A renaming of Monoid with additive notation
module Additive-Monoid {M} (mon : Monoid M) = Monoid mon
    renaming ( _∙_ to _+_; ε to 0ᵐ
             ; assoc to +-assoc; identity to +-identity
             ; ∙= to +=
             )

-- A renaming of Monoid with multiplicative notation
module Multiplicative-Monoid {M} (mon : Monoid M) = Monoid mon
    renaming ( _∙_ to _*_; ε to 1ᵐ
             ; assoc to *-assoc; identity to *-identity
             ; ∙= to *=
             )

module Additive-Commutative-Monoid {M} (mon-comm : Commutative-Monoid M)
  = Commutative-Monoid mon-comm
    renaming ( _∙_ to _+_; ε to 0ᵐ
             ; assoc to +-assoc; identity to +-identity
             ; ∙= to +=
             ; assoc= to +-assoc=
             ; !assoc= to +-!assoc=
             ; inner= to +-inner=
             ; assoc-comm to +-assoc-comm
             ; interchange to +-interchange
             ; outer= to +-outer=
             )

module Multiplicative-Commutative-Monoid {M} (mon : Commutative-Monoid M) = Commutative-Monoid mon
    renaming ( _∙_ to _*_; ε to 1ᵐ
             ; assoc to *-assoc; identity to *-identity
             ; ∙= to *=
             ; assoc= to *-assoc=
             ; !assoc= to *-!assoc=
             ; inner= to *-inner=
             ; assoc-comm to *-assoc-comm
             ; interchange to *-interchange
             ; outer= to *-outer=
             )

record MonoidHomomorphism {A B : Set}
                          (monA0+ : Monoid A)
                          (monB1* : Monoid B)
                          (f : A → B) : Set where
  open Additive-Monoid monA0+
  open Multiplicative-Monoid monB1*
  field
    0-hom-1 : f 0ᵐ ≡ 1ᵐ
    +-hom-* : ∀ {x y} → f (x + y) ≡ f x * f y
-- -}
-- -}
-- -}
-- -}

open import Function.NP
open import Data.Product.NP
open import Data.Nat
  using    (ℕ; zero)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_; suc to 1+_)
open import Data.Integer
  using    (ℤ; +_; -[1+_]; _⊖_)
  renaming (_+_ to _+ℤ_; _*_ to _*ℤ_)
open import Relation.Binary.PropositionalEquality.NP renaming (_∙_ to _♦_)
open import Algebra.FunctionProperties.Eq
open ≡-Reasoning

module Algebra.Monoid where

record Monoid-Ops {ℓ} (M : Set ℓ) : Set ℓ where
  constructor mk
  infixl 7 _∙_

  field
    _∙_ : M → M → M
    ε   : M

  _^⁺_ : M → ℕ → M
  x ^⁺ n = nest n (_∙_ x) ε

  module FromInverseOp
         (_⁻¹   : Op₁ M)
         where
    infixl 7 _/_

    _/_ : M → M → M
    x / y = x ∙ y ⁻¹

    open FromOp₂ _/_ public renaming (op= to /=)

    _^⁻_ _^⁻′_ : M → ℕ → M
    x ^⁻ n = (x ^⁺ n)⁻¹
    x ^⁻′ n = (x ⁻¹)^⁺ n

    _^_ : M → ℤ → M
    x ^ -[1+ n ] = x ^⁻(1+ n)
    x ^ (+ n)    = x ^⁺ n

record Monoid-Struct {ℓ} {M : Set ℓ} (mon-ops : Monoid-Ops M) : Set ℓ where
  open Monoid-Ops mon-ops

  -- laws
  field
    assoc    : Associative _∙_
    identity : Identity  ε _∙_

  open FromOp₂ _∙_ public renaming (op= to ∙=)
  open FromAssoc _∙_ assoc public

  module _ {b} where
    ^⁺0-ε : b ^⁺ 0 ≡ ε
    ^⁺0-ε = idp

    ^⁺1-id : b ^⁺ 1 ≡ b
    ^⁺1-id = snd identity

    ^⁺2-∙ : b ^⁺ 2 ≡ b ∙ b
    ^⁺2-∙ = ap (_∙_ _) ^⁺1-id

    ^⁺-+ : ∀ m {n} → b ^⁺ (m +ℕ n) ≡ b ^⁺ m ∙ b ^⁺ n
    ^⁺-+ 0      = ! fst identity
    ^⁺-+ (1+ m) = ap (_∙_ b) (^⁺-+ m) ♦ ! assoc

    ^⁺-* : ∀ m {n} → b ^⁺(m *ℕ n) ≡ (b ^⁺ n)^⁺ m
    ^⁺-* 0 = idp
    ^⁺-* (1+ m) {n}
      = b ^⁺ (n +ℕ m *ℕ n)     ≡⟨ ^⁺-+ n ⟩
        b ^⁺ n ∙ b ^⁺(m *ℕ n)  ≡⟨ ap (_∙_ (b ^⁺ n)) (^⁺-* m) ⟩
        b ^⁺ n ∙ (b ^⁺ n)^⁺ m  ∎

  comm-ε : ∀ {x} → x ∙ ε ≡ ε ∙ x
  comm-ε = snd identity ♦ ! fst identity

  module _ {c x y} (e : (x ∙ y) ≡ ε) where
    elim-assoc= : (c ∙ x) ∙ y ≡ c
    elim-assoc= = assoc ♦ ∙= idp e ♦ snd identity

    elim-!assoc= : x ∙ (y ∙ c) ≡ c
    elim-!assoc= = ! assoc ♦ ∙= e idp ♦ fst identity

  module _ {c d x y} (e : (x ∙ y) ≡ ε) where
    elim-inner= : (c ∙ x) ∙ (y ∙ d) ≡ c ∙ d
    elim-inner= = assoc ♦ ap (_∙_ c) (elim-!assoc= e)

  module FromLeftInverse
         (_⁻¹   : Op₁ M)
         (inv-l : LeftInverse ε _⁻¹ _∙_)
         where
    open FromInverseOp _⁻¹

    cancels-∙-left : LeftCancel _∙_
    cancels-∙-left {c} {x} {y} e
      = x              ≡⟨ ! fst identity ⟩
        ε ∙ x          ≡⟨ ∙= (! inv-l) idp ⟩
        c ⁻¹ ∙ c ∙ x   ≡⟨ !assoc= e ⟩
        c ⁻¹ ∙ c ∙ y   ≡⟨ ∙= inv-l idp ⟩
        ε ∙ y          ≡⟨ fst identity ⟩
        y ∎

    inv-r : RightInverse ε _⁻¹ _∙_
    inv-r = cancels-∙-left (! assoc ♦ ∙= inv-l idp ♦ ! comm-ε)

    /-∙ : ∀ {x y} → x ≡ (x / y) ∙ y
    /-∙ {x} {y}
      = x               ≡⟨ ! snd identity ⟩
        x ∙ ε           ≡⟨ ap (_∙_ x) (! inv-l) ⟩
        x ∙ (y ⁻¹ ∙ y)  ≡⟨ ! assoc ⟩
        (x / y) ∙ y     ∎

  module FromRightInverse
         (_⁻¹   : Op₁ M)
         (inv-r : RightInverse ε _⁻¹ _∙_)
         where
    open FromInverseOp _⁻¹

    cancels-∙-right : RightCancel _∙_
    cancels-∙-right {c} {x} {y} e
      = x              ≡⟨ ! snd identity ⟩
        x ∙ ε          ≡⟨ ∙= idp (! inv-r) ⟩
        x ∙ (c ∙ c ⁻¹) ≡⟨ assoc= e ⟩
        y ∙ (c ∙ c ⁻¹) ≡⟨ ∙= idp inv-r ⟩
        y ∙ ε          ≡⟨ snd identity ⟩
        y ∎

    inv-l : LeftInverse ε _⁻¹ _∙_
    inv-l = cancels-∙-right (assoc ♦ ∙= idp inv-r ♦ comm-ε)

    module _ {x y} where
      is-ε-left : x ≡ ε → x ∙ y ≡ y
      is-ε-left e = ap (λ z → z ∙ _) e ♦ fst identity

      is-ε-right : y ≡ ε → x ∙ y ≡ x
      is-ε-right e = ap (λ z → _ ∙ z) e ♦ snd identity

      ∙-/ : x ≡ (x ∙ y) / y
      ∙-/
        = x            ≡⟨ ! snd identity ⟩
          x ∙ ε        ≡⟨ ap (_∙_ x) (! inv-r) ⟩
          x ∙ (y / y)  ≡⟨ ! assoc ⟩
          (x ∙ y) / y  ∎

    module _ {x y} where
      unique-ε-left : x ∙ y ≡ y → x ≡ ε
      unique-ε-left eq
        = x            ≡⟨ ∙-/ ⟩
          (x ∙ y) / y  ≡⟨ /= eq idp ⟩
          y / y        ≡⟨ inv-r ⟩
          ε            ∎

      unique-ε-right : x ∙ y ≡ x → y ≡ ε
      unique-ε-right eq
        = y               ≡⟨ ! is-ε-left inv-l ⟩
          x ⁻¹ ∙  x ∙ y   ≡⟨ assoc ⟩
          x ⁻¹ ∙ (x ∙ y)  ≡⟨ ∙= idp eq ⟩
          x ⁻¹ ∙ x        ≡⟨ inv-l ⟩
          ε               ∎

      unique-⁻¹ : x ∙ y ≡ ε → x ≡ y ⁻¹
      unique-⁻¹ eq
        = x            ≡⟨ ∙-/ ⟩
          (x ∙ y) / y  ≡⟨ /= eq idp ⟩
          ε / y        ≡⟨ fst identity ⟩
          y ⁻¹         ∎

    open FromLeftInverse _⁻¹ inv-l hiding (inv-r)

    ε⁻¹-ε : ε ⁻¹ ≡ ε
    ε⁻¹-ε = unique-ε-left inv-l

    involutive : Involutive _⁻¹
    involutive {x}
      = cancels-∙-right
        (x ⁻¹ ⁻¹ ∙ x ⁻¹ ≡⟨ inv-l ⟩
         ε              ≡⟨ ! inv-r ⟩
         x ∙ x ⁻¹ ∎)

    ⁻¹-hom′ : ∀ {x y} → (x ∙ y)⁻¹ ≡ y ⁻¹ ∙ x ⁻¹
    ⁻¹-hom′ {x} {y} = cancels-∙-left {x ∙ y}
       ((x ∙ y) ∙ (x ∙ y)⁻¹     ≡⟨ inv-r ⟩
        ε                       ≡⟨ ! inv-r ⟩
        x ∙ x ⁻¹                ≡⟨ ap (_∙_ x) (! fst identity) ⟩
        x ∙ (ε ∙ x ⁻¹)          ≡⟨ ∙= idp (∙= (! inv-r) idp) ⟩
        x ∙ ((y ∙ y ⁻¹) ∙ x ⁻¹) ≡⟨ ap (_∙_ x) assoc ⟩
        x ∙ (y ∙ (y ⁻¹ ∙ x ⁻¹)) ≡⟨ ! assoc ⟩
        (x ∙ y) ∙ (y ⁻¹ ∙ x ⁻¹) ∎)

    elim-∙-left-⁻¹∙ : ∀ {c x y} → (c ∙ x)⁻¹ ∙ (c ∙ y) ≡ x ⁻¹ ∙ y
    elim-∙-left-⁻¹∙ {c} {x} {y}
      = (c ∙ x)⁻¹   ∙ (c ∙ y)  ≡⟨ ∙= ⁻¹-hom′ idp ⟩
        x ⁻¹ ∙ c ⁻¹ ∙ (c ∙ y)  ≡⟨ elim-inner= inv-l ⟩
        x ⁻¹ ∙ y               ∎

    elim-∙-right-/ : ∀ {c x y} → (x ∙ c) / (y ∙ c) ≡ x / y
    elim-∙-right-/ {c} {x} {y}
      = x ∙ c ∙ (y ∙ c)⁻¹  ≡⟨ ap (_∙_ _) ⁻¹-hom′  ⟩
        x ∙ c ∙ (c ⁻¹ / y) ≡⟨ elim-inner= inv-r ⟩
        x / y ∎

    module _ {b} where
      ^⁺suc : ∀ n → b ^⁺(1+ n) ≡ b ^⁺ n ∙ b
      ^⁺suc 0 = comm-ε
      ^⁺suc (1+ n) = ap (_∙_ b) (^⁺suc n) ♦ ! assoc

      ^⁺-comm : ∀ n → b ∙ b ^⁺ n ≡ b ^⁺ n ∙ b
      ^⁺-comm = ^⁺suc

      ^⁻suc : ∀ n → b ^⁻(1+ n) ≡ b ⁻¹ ∙ b ^⁻ n
      ^⁻suc n = ap _⁻¹ (^⁺suc n) ♦ ⁻¹-hom′

      ^⁻′-spec : ∀ n → b ^⁻′ n ≡ b ^⁻ n
      ^⁻′-spec 0 = ! ε⁻¹-ε
      ^⁻′-spec (1+ n) = ap (_∙_ (b ⁻¹)) (^⁻′-spec n)
                      ♦ ! ⁻¹-hom′
                      ♦ ap _⁻¹ (! ^⁺suc n)

      ^⁻′1-id : b ^⁻′ 1 ≡ b ⁻¹
      ^⁻′1-id = snd identity

      ^⁻1-id : b ^⁻ 1 ≡ b ⁻¹
      ^⁻1-id = ! ^⁻′-spec 1 ♦ ^⁻′1-id

      ^⁻′2-∙ : b ^⁻′ 2 ≡ b ⁻¹ ∙ b ⁻¹
      ^⁻′2-∙ = ap (_∙_ _) ^⁻′1-id

      ^⁻2-∙ : b ^⁻ 2 ≡ b ⁻¹ ∙ b ⁻¹
      ^⁻2-∙ = ! ^⁻′-spec 2 ♦ ^⁻′2-∙

record Monoid (M : Set) : Set where
  field
    mon-ops    : Monoid-Ops M
    mon-struct : Monoid-Struct mon-ops
  open Monoid-Ops    mon-ops    public
  open Monoid-Struct mon-struct public

record Commutative-Monoid-Struct {ℓ} {M : Set ℓ} (mon-ops : Monoid-Ops M) : Set ℓ where
  open Monoid-Ops mon-ops
  field
    mon-struct : Monoid-Struct mon-ops
    comm : Commutative _∙_
  open Monoid-Struct mon-struct public
  open FromAssocComm _∙_ assoc comm public
    hiding (!assoc=; assoc=; inner=)

record Commutative-Monoid (M : Set) : Set where
  field
    mon-ops    : Monoid-Ops M
    mon-comm   : Commutative-Monoid-Struct mon-ops
  open Monoid-Ops    mon-ops    public
  open Commutative-Monoid-Struct mon-comm public
  mon : Monoid M
  mon = record { mon-struct = mon-struct }

-- A renaming of Monoid with additive notation
module Additive-Monoid {M} (mon : Monoid M) = Monoid mon
    renaming ( _∙_ to _+_; ε to 0ᵐ
             ; assoc to +-assoc; identity to +-identity
             ; ∙= to +=
             )

-- A renaming of Monoid with multiplicative notation
module Multiplicative-Monoid {M} (mon : Monoid M) = Monoid mon
    renaming ( _∙_ to _*_; ε to 1ᵐ
             ; assoc to *-assoc; identity to *-identity
             ; ∙= to *=
             )

module Additive-Commutative-Monoid {M} (mon-comm : Commutative-Monoid M)
  = Commutative-Monoid mon-comm
    renaming ( _∙_ to _+_; ε to 0ᵐ
             ; assoc to +-assoc; identity to +-identity
             ; ∙= to +=
             ; assoc= to +-assoc=
             ; !assoc= to +-!assoc=
             ; inner= to +-inner=
             ; assoc-comm to +-assoc-comm
             ; interchange to +-interchange
             ; outer= to +-outer=
             )

module Multiplicative-Commutative-Monoid {M} (mon : Commutative-Monoid M) = Commutative-Monoid mon
    renaming ( _∙_ to _*_; ε to 1ᵐ
             ; assoc to *-assoc; identity to *-identity
             ; ∙= to *=
             ; assoc= to *-assoc=
             ; !assoc= to *-!assoc=
             ; inner= to *-inner=
             ; assoc-comm to *-assoc-comm
             ; interchange to *-interchange
             ; outer= to *-outer=
             )

record MonoidHomomorphism {A B : Set}
                          (monA0+ : Monoid A)
                          (monB1* : Monoid B)
                          (f : A → B) : Set where
  open Additive-Monoid monA0+
  open Multiplicative-Monoid monB1*
  field
    0-hom-1 : f 0ᵐ ≡ 1ᵐ
    +-hom-* : ∀ {x y} → f (x + y) ≡ f x * f y
-- -}
-- -}
-- -}
-- -}

use nest and not fold

Monoid: use nest and not fold


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts, prefixes of
-- contexts and variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- Typing Contexts
-- ===============

import Data.List as List
open import Base.Data.ContextList public

Context : Set
Context = List.List Type

-- Variables
-- =========
--
-- Here it is clear that we are using de Bruijn indices,
-- encoded as natural numbers, more or less.
data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- Weakening
-- =========
--
-- We provide two approaches for weakening: context prefixes and
-- and subcontext relationship. In this formalization, we mostly
-- (maybe exclusively?) use the latter.

-- Context Prefixes
-- ----------------
--
-- Useful for making lemmas strong enough to prove by induction.
--
-- Consider using the Subcontexts module instead.

module Prefixes where

-- Prefix of a context

  data Prefix : Context → Set where
    ∅ : ∀ {Γ} → Prefix Γ
    _•_ : ∀ {Γ} → (τ : Type) → Prefix Γ → Prefix (τ • Γ)

-- take only the prefix of a context

  take : (Γ : Context) → Prefix Γ → Context
  take Γ ∅ = ∅
  take (τ • Γ) (.τ • Γ′) = τ • take Γ Γ′

-- drop the prefix of a context

  drop : (Γ : Context) → Prefix Γ → Context
  drop Γ ∅ = Γ
  drop (τ • Γ) (.τ • Γ′) = drop Γ Γ′

-- Extend a context to a super context

  infixr 10 _⋎_

  _⋎_ : (Γ₁ Γ₂ : Context) → Context
  _⋎_ = List._++_

  take-drop : ∀ Γ Γ′ → take Γ Γ′ ⋎ drop Γ Γ′ ≡ Γ
  take-drop ∅ ∅ = refl
  take-drop (τ • Γ) ∅ = refl
  take-drop (τ • Γ) (.τ • Γ′) rewrite take-drop Γ Γ′ = refl

  or-unit : ∀ Γ → Γ ⋎ ∅ ≡ Γ
  or-unit ∅ = refl
  or-unit (τ • Γ) rewrite or-unit Γ = refl

  move-prefix : ∀ Γ τ Γ′ →
    Γ ⋎ (τ • Γ′) ≡ (Γ ⋎ (τ • ∅)) ⋎ Γ′
  move-prefix ∅ τ Γ′ = refl
  move-prefix (τ • Γ) τ₁ ∅ = sym (or-unit (τ • Γ ⋎ (τ₁ • ∅)))
  move-prefix (τ • Γ) τ₁ (τ₂ • Γ′) rewrite move-prefix Γ τ₁ (τ₂ • Γ′) = refl

-- Lift a variable to a super context

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

-- Subcontexts
-- -----------
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

-- This handling of contexts is recommended by [this
-- email](https://lists.chalmers.se/pipermail/agda/2011/003423.html) and
-- attributed to Conor McBride.
--
-- The associated thread discusses a few alternatives solutions, including one
-- where beta-reduction can handle associativity of ++.

module Subcontexts where
  infix 4 _≼_

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

  -- Properties

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

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation as well as the
-- definition of _⋎_.

open Subcontexts public
open Prefixes public using (_⋎_)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Variables and contexts
--
-- This module defines the syntax of contexts and subcontexts,
-- together with variables and properties of these notions.
--
-- This module is parametric in the syntax of types, so it
-- can be reused for different calculi.
------------------------------------------------------------------------

module Base.Syntax.Context
    (Type : Set)
  where

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- Typing Contexts
-- ===============

import Data.List as List
open import Base.Data.ContextList public

Context : Set
Context = List.List Type

-- Variables
-- =========
--
-- Here it is clear that we are using de Bruijn indices,
-- encoded as natural numbers, more or less.
data Var : Context → Type → Set where
  this : ∀ {Γ τ} → Var (τ • Γ) τ
  that : ∀ {Γ σ τ} → (x : Var Γ τ) → Var (σ • Γ) τ

-- Weakening
-- =========
--
-- We define weakening based on subcontext relationship.

-- Subcontexts
-- -----------
--
-- Useful as a reified weakening operation,
-- and for making theorems strong enough to prove by induction.
--
-- The contents of this module are currently exported at the end
-- of this file.

-- This handling of contexts is recommended by [this
-- email](https://lists.chalmers.se/pipermail/agda/2011/003423.html) and
-- attributed to Conor McBride.
--
-- The associated thread discusses a few alternatives solutions, including one
-- where beta-reduction can handle associativity of ++.

module Subcontexts where
  infix 4 _≼_

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

  -- Properties

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

  ≼-refl : Reflexive _≼_
  ≼-refl {∅} = ∅
  ≼-refl {τ • Γ} = keep τ • ≼-refl

  ≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
  ≼-reflexive refl = ≼-refl

  ≼-trans : Transitive _≼_
  ≼-trans ≼₁ ∅ = ≼₁
  ≼-trans (keep .τ • ≼₁) (keep τ • ≼₂) = keep τ • ≼-trans ≼₁ ≼₂
  ≼-trans (drop .τ • ≼₁) (keep τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂
  ≼-trans ≼₁ (drop τ • ≼₂) = drop τ • ≼-trans ≼₁ ≼₂

  ≼-isPreorder : IsPreorder _≡_ _≼_
  ≼-isPreorder = record
    { isEquivalence = isEquivalence
    ; reflexive = ≼-reflexive
    ; trans = ≼-trans
    }

  ≼-preorder : Preorder _ _ _
  ≼-preorder = record
    { Carrier = Context
    ; _≈_ = _≡_
    ; _∼_ = _≼_
    ; isPreorder = ≼-isPreorder
    }

  module ≼-Reasoning where
    open import Relation.Binary.PreorderReasoning ≼-preorder public
      renaming
        ( _≈⟨_⟩_ to _≡⟨_⟩_
        ; _∼⟨_⟩_ to _≼⟨_⟩_
        ; _≈⟨⟩_ to _≡⟨⟩_
        )

  -- Lift a variable to a super context

  weaken-var : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
  weaken-var (keep τ • ≼₁) this = this
  weaken-var (keep τ • ≼₁) (that x) = that (weaken-var ≼₁ x)
  weaken-var (drop τ • ≼₁) x = that (weaken-var ≼₁ x)

-- Currently, we export the subcontext relation.

open Subcontexts public

Drop Prefixes

Drop Prefixes


module Denotation.Change.Popl14 where

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Popl14.Denotation.Value
open import Theorem.Groups-Popl14
open import Postulate.Extensionality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14

---------------
-- Interface --
---------------

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

infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num
-- apply Δv v ::= v ⊞ Δv
_⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
--   diff u v ::= u ⊟ v
_⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ

-- Lemma diff-is-valid
R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟ v)

-- Lemma apply-diff
v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
  let
    _+_ = _⊞_ {τ}
    _-_ = _⊟_ {τ}
  in
  v + (u - v) ≡ u

--------------------
-- Implementation --
--------------------

-- ΔVal τ is intended to be the semantic domain for changes of values
-- of type τ.
--
-- ΔVal τ is the target of the denotational specification ⟦_⟧Δ.
-- Detailed motivation:
--
-- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
--
-- ΔVal : Type → Set
ΔVal (base base-int) = ℤ
ΔVal (base base-bag) = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

-- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊞_ {base base-int} n Δn = n + Δn
_⊞_ {base base-bag} b Δb = b ++ Δb
_⊞_ {σ ⇒ τ} f Δf = λ v → f v ⊞ Δf v (v ⊟ v) (R[v,u-v] {σ})

-- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
_⊟_ {base base-int} m n = m - n
_⊟_ {base base-bag} d b = d \\ b
_⊟_ {σ ⇒ τ} g f = λ v Δv R[v,Δv] → g (v ⊞ Δv) ⊟ f v

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {base base-int} n Δn = ⊤
valid {base base-bag} b Δb = ⊤
valid {σ ⇒ τ} f Δf =
  ∀ (v : ⟦ σ ⟧) (Δv : ΔVal σ) (R[v,Δv] : valid v Δv)
  → valid (f v) (Δf v Δv R[v,Δv])
  -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
  × (_⊞_ {σ ⇒ τ} f Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]

-- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
v+[u-v]=u {base base-int} {u} {v} = n+[m-n]=m {v} {u}
v+[u-v]=u {base base-bag} {u} {v} = a++[b\\a]=b {v} {u}
v+[u-v]=u {σ ⇒ τ} {u} {v} =
  let
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₀_ = _⊞_ {σ}
    _-₀_ = _⊟_ {σ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
      begin
        (v + (u - v)) w
      ≡⟨ refl ⟩
        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] {base base-int} {u} {v} = tt
R[v,u-v] {base base-bag} {u} {v} = tt
R[v,u-v] {σ ⇒ τ} {u} {v} = λ w Δw R[w,Δw] →
  let
    w′ = w ⊞ Δw
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    R[v,u-v] {τ}
    ,
    (begin
      (v + (u - v)) w′
    ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
      u w′
    ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v w}) ⟩
      v w +₁ (u - v) w Δw R[w,Δw]
    ∎) where open ≡-Reasoning

-- `diff` and `apply`, without validity proofs
infixl 6 _⟦⊕⟧_ _⟦⊝⟧_
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧

_⟦⊕⟧_ {base base-int}  n Δn = n +  Δn
_⟦⊕⟧_ {base base-bag}  b Δb = b ++ Δb
_⟦⊕⟧_ {σ ⇒ τ} f Δf = λ v →
  let
    _-₀_ = _⟦⊝⟧_ {σ}
    _+₁_ = _⟦⊕⟧_ {τ}
  in
    f v +₁ Δf v (v -₀ v)

_⟦⊝⟧_ {base base-int}  m n = m -  n
_⟦⊝⟧_ {base base-bag}  a b = a \\ b
_⟦⊝⟧_ {σ ⇒ τ} g f = λ v Δv → _⟦⊝⟧_ {τ} (g (_⟦⊕⟧_ {σ} v Δv)) (f v)

module Denotation.Change.Popl14 where

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Popl14.Denotation.Value
open import Theorem.Groups-Popl14
open import Postulate.Extensionality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14

---------------
-- Interface --
---------------

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

infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num
-- apply Δv v ::= v ⊞ Δv
_⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
--   diff u v ::= u ⊟ v
_⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ

-- Lemma diff-is-valid
R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟ v)

-- Lemma apply-diff
v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
  let
    _+_ = _⊞_ {τ}
    _-_ = _⊟_ {τ}
  in
  v + (u - v) ≡ u

--------------------
-- Implementation --
--------------------

-- (ΔVal τ) is the set of changes of type τ. This set is
-- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
-- particular, (ΔVal (σ ⇒ τ)) is a function that accepts only
-- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
-- changes.
--
-- ΔVal τ is the target of the denotational specification ⟦_⟧Δ.
-- Detailed motivation:
--
-- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
--
-- ΔVal : Type → Set
ΔVal (base base-int) = ℤ
ΔVal (base base-bag) = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

-- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊞_ {base base-int} n Δn = n + Δn
_⊞_ {base base-bag} b Δb = b ++ Δb
_⊞_ {σ ⇒ τ} f Δf = λ v → f v ⊞ Δf v (v ⊟ v) (R[v,u-v] {σ})

-- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
_⊟_ {base base-int} m n = m - n
_⊟_ {base base-bag} d b = d \\ b
_⊟_ {σ ⇒ τ} g f = λ v Δv R[v,Δv] → g (v ⊞ Δv) ⊟ f v

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {base base-int} n Δn = ⊤
valid {base base-bag} b Δb = ⊤
valid {σ ⇒ τ} f Δf =
  ∀ (v : ⟦ σ ⟧) (Δv : ΔVal σ) (R[v,Δv] : valid v Δv)
  → valid (f v) (Δf v Δv R[v,Δv])
  -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
  × (_⊞_ {σ ⇒ τ} f Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]

-- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
v+[u-v]=u {base base-int} {u} {v} = n+[m-n]=m {v} {u}
v+[u-v]=u {base base-bag} {u} {v} = a++[b\\a]=b {v} {u}
v+[u-v]=u {σ ⇒ τ} {u} {v} =
  let
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₀_ = _⊞_ {σ}
    _-₀_ = _⊟_ {σ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
      begin
        (v + (u - v)) w
      ≡⟨ refl ⟩
        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] {base base-int} {u} {v} = tt
R[v,u-v] {base base-bag} {u} {v} = tt
R[v,u-v] {σ ⇒ τ} {u} {v} = λ w Δw R[w,Δw] →
  let
    w′ = w ⊞ Δw
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    R[v,u-v] {τ}
    ,
    (begin
      (v + (u - v)) w′
    ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
      u w′
    ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v w}) ⟩
      v w +₁ (u - v) w Δw R[w,Δw]
    ∎) where open ≡-Reasoning

-- `diff` and `apply`, without validity proofs
infixl 6 _⟦⊕⟧_ _⟦⊝⟧_
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧

_⟦⊕⟧_ {base base-int}  n Δn = n +  Δn
_⟦⊕⟧_ {base base-bag}  b Δb = b ++ Δb
_⟦⊕⟧_ {σ ⇒ τ} f Δf = λ v →
  let
    _-₀_ = _⟦⊝⟧_ {σ}
    _+₁_ = _⟦⊕⟧_ {τ}
  in
    f v +₁ Δf v (v -₀ v)

_⟦⊝⟧_ {base base-int}  m n = m -  n
_⟦⊝⟧_ {base base-bag}  a b = a \\ b
_⟦⊝⟧_ {σ ⇒ τ} g f = λ v Δv → _⟦⊝⟧_ {τ} (g (_⟦⊕⟧_ {σ} v Δv)) (f v)

Improve documentation of ΔVal.

Improve documentation of ΔVal.

Old-commit-hash: fb71a0ea6af97c62b01a9d8b7d3089e5cd3139ed


module total where

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

open import Relation.Binary.PropositionalEquality

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

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

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

-- CORRECTNESS of derivation

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

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

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

module total where

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

open import Relation.Binary.PropositionalEquality

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

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

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

-- CORRECTNESS of derivation

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

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

derive-term-correct {{Γ′}} (Δ {{Γ″}} t) = ≈-Δ {{Γ′}} (derive-term-correct {{Γ″}} t)

Resolve implicit arguments.

Resolve implicit arguments.

When I filled the last hole in total.agda in the previous commit,
Agda told me to 'resolve implicit argument', so I added explicit
implicit arguments until Agda was satisfied. I don't know whether
or why it matters to do this.

Old-commit-hash: ed138bd06659ab2caac47a670b7d3d60c4d97f3a


module Denotational.WeakValidChanges where

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

open import Syntactic.Types
open import Syntactic.ChangeTypes.ChangesAreDerivatives

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Changes
open import Denotational.EqualityLemmas

-- DEFINITION of weakly valid changes via a logical relation

-- Strong validity:
open import Denotational.ValidChanges

-- Weak validity, defined through a function producing a type.
--
-- Since this is a logical relation, this couldn't be defined as a
-- datatype, since it is not strictly positive.

Weak-Valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
Weak-Valid-Δ {bool} v dv = ⊤
Weak-Valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds (valid-w : Weak-Valid-Δ s ds) →
    Weak-Valid-Δ (f s) (df s ds) ×
    df is-correct-for f on s and ds

strong-to-weak-validity : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv} → Valid-Δ v dv → Weak-Valid-Δ v dv
strong-to-weak-validity {bool} _ = tt
strong-to-weak-validity {τ ⇒ τ₁} {v} {dv} s-valid-v-dv s ds _ = strong-to-weak-validity dv-s-ds-valid-on-v-s , dv-is-correct-for-v-on-s-and-ds
  where
    proofs = s-valid-v-dv s ds
    dv-s-ds-valid-on-v-s = proj₁ proofs
    dv-is-correct-for-v-on-s-and-ds = proj₂ proofs

{-
-- This proof doesn't go through: the desired equivalence is too
-- strong, and we can't fill the holes because dv is arbitrary.

diff-apply-proof-weak : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
    (Weak-Valid-Δ v dv) → diff (apply dv v) v ≡ dv

diff-apply-proof-weak {τ₁ ⇒ τ₂} df f df-valid = ext (λ v → ext (λ dv →
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v)) (strong-to-weak-validity (derive-is-valid (apply dv v)))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv {!!})) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ≡⟨ diff-apply-proof-weak {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv {!!})) ⟩
    df v dv
  ∎)) where open ≡-Reasoning

diff-apply-proof-weak {bool} db b _ = xor-cancellative b db

-- That'd be the core of the proof of diff-apply-weak, if we relax the
-- equivalence in the goal to something more correct. We need a proof
-- of validity only for the first argument, somehow: maybe because
-- diff itself produces strongly valid changes?
--
-- Ahah! Not really: below we use the unprovable
-- diff-apply-proof-weak. To be able to use induction, we need to use
-- this weaker lemma again. Hence, we'll only be able to prove the
-- same equivalence, which will needs another proof of validity to
-- unfold further until the base case.

diff-apply-proof-weak-f : ∀ {τ₁ τ₂} (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (f : ⟦ τ₁ ⇒ τ₂ ⟧) →
    (Weak-Valid-Δ f df) → ∀ dv v → (Weak-Valid-Δ v dv) → (diff (apply df f) f) v dv ≡ df v dv

diff-apply-proof-weak-f {τ₁} {τ₂} df f df-valid dv v dv-valid =
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v)) (strong-to-weak-validity (derive-is-valid (apply dv v)))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv dv-valid)) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ≡⟨ diff-apply-proof-weak {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv dv-valid)) ⟩
    df v dv
  ∎ where open ≡-Reasoning
-}

-- A stronger delta equivalence. Note this isn't a congruence; it
-- should be possible to define some congruence rules, but those will
-- be more complex.

data _≈_ : {τ : Type} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → Set where
  --base : ∀ (v : ⟦ bool ⟧) → v ≈ v
  base : ∀ (v1 v2 : ⟦ bool ⟧) → (≡ : v1 ≡ v2) → v1 ≈ v2
  fun : ∀ {σ τ} (f1 f2 : ⟦ Δ-Type (σ ⇒ τ) ⟧) →
    (t≈ : ∀ s ds (valid : Weak-Valid-Δ s ds) → f1 s ds ≈ f2 s ds) →
    f1 ≈ f2

≡→≈ : ∀ {τ} {v1 v2 : ⟦ Δ-Type τ ⟧} → v1 ≡ v2 → v1 ≈ v2
≡→≈ {bool} {v1} {.v1} refl = base v1 v1 refl
≡→≈ {τ₁ ⇒ τ₂} {v1} {.v1} refl = fun v1 v1 (λ s ds _ → ≡→≈ refl)

open import Relation.Binary hiding (_⇒_)

≈-refl : ∀ {τ} → Reflexive (_≈_ {τ})
≈-refl = ≡→≈ refl

≈-sym : ∀ {τ} → Symmetric (_≈_ {τ})
≈-sym (base v1 v2 ≡) = base _ _ (sym ≡)
≈-sym {(σ ⇒ τ)} (fun f1 f2 t≈) = fun _ _  (λ s ds valid → ≈-sym (t≈ s ds valid))

≈-trans : ∀ {τ} → Transitive (_≈_ {τ})
≈-trans {.bool} {.k} {.k} {k} (base .k .k refl) (base .k .k refl) = base k k refl
≈-trans {σ ⇒ τ} {.f1} {.f2} {k} (fun f1 .f2 ≈₁) (fun f2 .k ≈₂) = fun f1 k (λ s ds valid → ≈-trans (≈₁ _ _ valid) (≈₂ _ _ valid))

≈-isEquivalence : ∀ {τ} → IsEquivalence (_≈_ {τ})
≈-isEquivalence = record
  { refl  = ≈-refl
  ; sym   = ≈-sym
  ; trans = ≈-trans
  }

≈-setoid : Type → Setoid _ _
≈-setoid τ = record
  { Carrier       = ⟦ Δ-Type τ ⟧
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

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

-- Correct proof, to refactor using ≈-Reasoning

diff-apply-proof-weak-real : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
    (Weak-Valid-Δ v dv) → diff (apply dv v) v ≈ dv
diff-apply-proof-weak-real {τ₁ ⇒ τ₂} df f df-valid = fun _ _ (λ v dv dv-valid → ≈-trans (≡→≈ (
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v)) (strong-to-weak-validity (derive-is-valid (apply dv v)))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv dv-valid)) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ∎)) (diff-apply-proof-weak-real {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv dv-valid))))
  --≈⟨ fill in the above proof ⟩
    --df v dv

  where open ≡-Reasoning

diff-apply-proof-weak-real {bool} db b _ = ≡→≈ (xor-cancellative b db)

module Denotational.WeakValidChanges where

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

open import Syntactic.Types
open import Syntactic.ChangeTypes.ChangesAreDerivatives

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Changes
open import Denotational.EqualityLemmas

-- DEFINITION of weakly valid changes via a logical relation

-- Strong validity:
open import Denotational.ValidChanges

-- Weak validity, defined through a function producing a type.
--
-- Since this is a logical relation, this couldn't be defined as a
-- datatype, since it is not strictly positive.

Weak-Valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
Weak-Valid-Δ {bool} v dv = ⊤
Weak-Valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds (valid-w : Weak-Valid-Δ s ds) →
    Weak-Valid-Δ (f s) (df s ds) ×
    df is-correct-for f on s and ds

strong-to-weak-validity : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv} → Valid-Δ v dv → Weak-Valid-Δ v dv
strong-to-weak-validity {bool} _ = tt
strong-to-weak-validity {τ ⇒ τ₁} {v} {dv} s-valid-v-dv = λ s ds _ →
  let
    proofs = s-valid-v-dv s ds
    dv-s-ds-valid-on-v-s = proj₁ proofs
    dv-is-correct-for-v-on-s-and-ds = proj₂ proofs
  in
    strong-to-weak-validity dv-s-ds-valid-on-v-s , dv-is-correct-for-v-on-s-and-ds

{-
-- This proof doesn't go through: the desired equivalence is too
-- strong, and we can't fill the holes because dv is arbitrary.

diff-apply-proof-weak : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
    (Weak-Valid-Δ v dv) → diff (apply dv v) v ≡ dv

diff-apply-proof-weak {τ₁ ⇒ τ₂} df f df-valid = ext (λ v → ext (λ dv →
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v)) (strong-to-weak-validity (derive-is-valid (apply dv v)))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv {!!})) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ≡⟨ diff-apply-proof-weak {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv {!!})) ⟩
    df v dv
  ∎)) where open ≡-Reasoning

diff-apply-proof-weak {bool} db b _ = xor-cancellative b db

-- That'd be the core of the proof of diff-apply-weak, if we relax the
-- equivalence in the goal to something more correct. We need a proof
-- of validity only for the first argument, somehow: maybe because
-- diff itself produces strongly valid changes?
--
-- Ahah! Not really: below we use the unprovable
-- diff-apply-proof-weak. To be able to use induction, we need to use
-- this weaker lemma again. Hence, we'll only be able to prove the
-- same equivalence, which will needs another proof of validity to
-- unfold further until the base case.

diff-apply-proof-weak-f : ∀ {τ₁ τ₂} (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (f : ⟦ τ₁ ⇒ τ₂ ⟧) →
    (Weak-Valid-Δ f df) → ∀ dv v → (Weak-Valid-Δ v dv) → (diff (apply df f) f) v dv ≡ df v dv

diff-apply-proof-weak-f {τ₁} {τ₂} df f df-valid dv v dv-valid =
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v)) (strong-to-weak-validity (derive-is-valid (apply dv v)))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv dv-valid)) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ≡⟨ diff-apply-proof-weak {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv dv-valid)) ⟩
    df v dv
  ∎ where open ≡-Reasoning
-}

-- A stronger delta equivalence. Note this isn't a congruence; it
-- should be possible to define some congruence rules, but those will
-- be more complex.

data _≈_ : {τ : Type} → ⟦ Δ-Type τ ⟧ → ⟦ Δ-Type τ ⟧ → Set where
  --base : ∀ (v : ⟦ bool ⟧) → v ≈ v
  base : ∀ (v1 v2 : ⟦ bool ⟧) → (≡ : v1 ≡ v2) → v1 ≈ v2
  fun : ∀ {σ τ} (f1 f2 : ⟦ Δ-Type (σ ⇒ τ) ⟧) →
    (t≈ : ∀ s ds (valid : Weak-Valid-Δ s ds) → f1 s ds ≈ f2 s ds) →
    f1 ≈ f2

≡→≈ : ∀ {τ} {v1 v2 : ⟦ Δ-Type τ ⟧} → v1 ≡ v2 → v1 ≈ v2
≡→≈ {bool} {v1} {.v1} refl = base v1 v1 refl
≡→≈ {τ₁ ⇒ τ₂} {v1} {.v1} refl = fun v1 v1 (λ s ds _ → ≡→≈ refl)

open import Relation.Binary hiding (_⇒_)

≈-refl : ∀ {τ} → Reflexive (_≈_ {τ})
≈-refl = ≡→≈ refl

≈-sym : ∀ {τ} → Symmetric (_≈_ {τ})
≈-sym (base v1 v2 ≡) = base _ _ (sym ≡)
≈-sym {(σ ⇒ τ)} (fun f1 f2 t≈) = fun _ _  (λ s ds valid → ≈-sym (t≈ s ds valid))

≈-trans : ∀ {τ} → Transitive (_≈_ {τ})
≈-trans {.bool} {.k} {.k} {k} (base .k .k refl) (base .k .k refl) = base k k refl
≈-trans {σ ⇒ τ} {.f1} {.f2} {k} (fun f1 .f2 ≈₁) (fun f2 .k ≈₂) = fun f1 k (λ s ds valid → ≈-trans (≈₁ _ _ valid) (≈₂ _ _ valid))

≈-isEquivalence : ∀ {τ} → IsEquivalence (_≈_ {τ})
≈-isEquivalence = record
  { refl  = ≈-refl
  ; sym   = ≈-sym
  ; trans = ≈-trans
  }

≈-setoid : Type → Setoid _ _
≈-setoid τ = record
  { Carrier       = ⟦ Δ-Type τ ⟧
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

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

-- Correct proof, to refactor using ≈-Reasoning

diff-apply-proof-weak-real : ∀ {τ} (dv : ⟦ Δ-Type τ ⟧) (v : ⟦ τ ⟧) →
    (Weak-Valid-Δ v dv) → diff (apply dv v) v ≈ dv
diff-apply-proof-weak-real {τ₁ ⇒ τ₂} df f df-valid = fun _ _ (λ v dv dv-valid → ≈-trans (≡→≈ (
  begin
    diff (apply (df (apply dv v) (derive (apply dv v))) (f (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (sym (proj₂ (df-valid (apply dv v) (derive (apply dv v)) (strong-to-weak-validity (derive-is-valid (apply dv v)))))) ⟩
    diff ((apply df f) (apply (derive (apply dv v)) (apply dv v))) (f v)
  ≡⟨ ≡-cong
     (λ x → diff (apply df f x) (f v))
       (apply-derive (apply dv v)) ⟩
    diff ((apply df f) (apply dv v)) (f v)
  ≡⟨ ≡-cong
     (λ x → diff x (f v))
       (proj₂ (df-valid v dv dv-valid)) ⟩
    diff (apply (df v dv) (f v)) (f v)
  ∎)) (diff-apply-proof-weak-real {τ₂} (df v dv) (f v) (proj₁ (df-valid v dv dv-valid))))
  --≈⟨ fill in the above proof ⟩
    --df v dv

  where open ≡-Reasoning

diff-apply-proof-weak-real {bool} db b _ = ≡→≈ (xor-cancellative b db)

Change where-clause to let-expr so that agda 2.3.2 typechecks README

Old-commit-hash: 6ffa74c100a7ee9d51e15d960db14c801f06e27c


{-# OPTIONS --without-K #-}
module Explore.BinTree where

open import Data.Tree.Binary

open import Explore.Core
open import Explore.Properties

fromBinTree : ∀ {m} {A} → BinTree A → Explore m A
fromBinTree empty      = empty-explore
fromBinTree (leaf x)   = point-explore x
fromBinTree (fork ℓ r) = merge-explore (fromBinTree ℓ) (fromBinTree r)

fromBinTree-ind : ∀ {m p A} (t : BinTree A) → ExploreInd p (fromBinTree {m} t)
fromBinTree-ind empty      = empty-explore-ind
fromBinTree-ind (leaf x)   = point-explore-ind x
fromBinTree-ind (fork ℓ r) = merge-explore-ind (fromBinTree-ind ℓ)
                                               (fromBinTree-ind r)
{-
fromBinTree : ∀ {m A} → BinTree A → Explore m A
fromBinTree (leaf x)   _ _   f = f x
fromBinTree (fork ℓ r) ε _∙_ f = fromBinTree ℓ ε _∙_ f ∙ fromBinTree r ε _∙_ f

fromBinTree-ind : ∀ {m p A} (t : BinTree A) → ExploreInd p (fromBinTree {m} t)
fromBinTree-ind (leaf x)   P _  P∙ Pf = Pf x
fromBinTree-ind (fork ℓ r) P Pε P∙ Pf = P∙ (fromBinTree-ind ℓ P Pε P∙ Pf)
                                           (fromBinTree-ind r P Pε P∙ Pf)
-}

{-# OPTIONS --without-K #-}
module Explore.BinTree where

open import Level.NP
open import Type hiding (★)
open import Data.Tree.Binary
open import Data.Zero
open import Data.Product

open import Relation.Binary.PropositionalEquality.NP
open import HoTT
open Equivalences
open import Type.Identities
open import Function.Extensionality

open import Explore.Core
open import Explore.Properties
open import Explore.Zero
open import Explore.Sum
open import Explore.Isomorphism

fromBinTree : ∀ {m} {A} → BinTree A → Explore m A
fromBinTree empty      = empty-explore
fromBinTree (leaf x)   = point-explore x
fromBinTree (fork ℓ r) = merge-explore (fromBinTree ℓ) (fromBinTree r)

fromBinTree-ind : ∀ {m p A} (t : BinTree A) → ExploreInd p (fromBinTree {m} t)
fromBinTree-ind empty      = empty-explore-ind
fromBinTree-ind (leaf x)   = point-explore-ind x
fromBinTree-ind (fork ℓ r) = merge-explore-ind (fromBinTree-ind ℓ)
                                               (fromBinTree-ind r)
{-
fromBinTree : ∀ {m A} → BinTree A → Explore m A
fromBinTree (leaf x)   _ _   f = f x
fromBinTree (fork ℓ r) ε _∙_ f = fromBinTree ℓ ε _∙_ f ∙ fromBinTree r ε _∙_ f

fromBinTree-ind : ∀ {m p A} (t : BinTree A) → ExploreInd p (fromBinTree {m} t)
fromBinTree-ind (leaf x)   P _  P∙ Pf = Pf x
fromBinTree-ind (fork ℓ r) P Pε P∙ Pf = P∙ (fromBinTree-ind ℓ P Pε P∙ Pf)
                                           (fromBinTree-ind r P Pε P∙ Pf)
-}

AnyP≡ΣfromBinTree : ∀ {p}{A : ★ _}{P : A → ★ p}(xs : BinTree A) → Any P xs ≡ Σᵉ (fromBinTree xs) P
AnyP≡ΣfromBinTree empty    = idp
AnyP≡ΣfromBinTree (leaf x) = idp
AnyP≡ΣfromBinTree (fork xs xs₁) = ⊎= (AnyP≡ΣfromBinTree xs) (AnyP≡ΣfromBinTree xs₁)

module _ {{_ : UA}}{{_ : FunExt}}{A : ★ ₀} where

  exploreΣ∈ : ∀ {m} xs → Explore m (Σ A λ x → Any (_≡_ x) xs)
  exploreΣ∈ empty = explore-iso (coe-equiv (Lift≡id ∙ ! ×𝟘-snd  ∙ ×= idp (! Lift≡id))) Lift𝟘ᵉ
  exploreΣ∈ (leaf x) = point-explore (x , idp)
  exploreΣ∈ (fork xs xs₁) = explore-iso (coe-equiv (! Σ⊎-split)) (exploreΣ∈ xs ⊎ᵉ exploreΣ∈ xs₁)

  Σᵉ-adq-exploreΣ∈ : ∀ {m} xs → Adequate-Σᵉ {m} (exploreΣ∈ xs)
  Σᵉ-adq-exploreΣ∈ empty = Σ-iso-ok (coe-equiv (Lift≡id ∙ ! ×𝟘-snd ∙ ×= idp (! Lift≡id)))
    {Aᵉ = Lift𝟘ᵉ} ΣᵉLift𝟘-ok
  Σᵉ-adq-exploreΣ∈ (leaf x₁) F = ! Σ𝟙-snd ∙ Σ-fst≃ (≃-sym (Σx≡≃𝟙 x₁)) F
  Σᵉ-adq-exploreΣ∈ (fork xs xs₁) = Σ-iso-ok (coe-equiv (! Σ⊎-split)) {Aᵉ = exploreΣ∈ xs ⊎ᵉ exploreΣ∈ xs₁}
               (Σᵉ⊎-ok {eᴬ = exploreΣ∈ xs}{eᴮ = exploreΣ∈ xs₁} (Σᵉ-adq-exploreΣ∈ xs) (Σᵉ-adq-exploreΣ∈ xs₁))

module _ {{_ : UA}}{{_ : FunExt}}{A : ★ ₀}{P : A → ★ _}(explore-P : ∀ {m} x → Explore m (P x)) where
  open import Explore.Zero
  open import Explore.Sum
  open import Explore.Isomorphism

  exploreAny : ∀ {m} xs → Explore m (Any P xs)
  exploreAny empty         = Lift𝟘ᵉ
  exploreAny (leaf x)      = explore-P x
  exploreAny (fork xs xs₁) = exploreAny xs ⊎ᵉ exploreAny xs₁

  module _ (Σᵉ-adq-explore-P : ∀ {m} x → Adequate-Σᵉ {m} (explore-P x)) where
    Σᵉ-adq-exploreAny : ∀ {m} xs → Adequate-Σᵉ {m} (exploreAny xs)
    Σᵉ-adq-exploreAny empty F         = ! Σ𝟘-lift∘fst ∙ Σ-fst= (! Lift≡id) _
    Σᵉ-adq-exploreAny (leaf x₁) F     = Σᵉ-adq-explore-P x₁ F
    Σᵉ-adq-exploreAny (fork xs xs₁) F = ⊎= (Σᵉ-adq-exploreAny xs _) (Σᵉ-adq-exploreAny xs₁ _) ∙ ! dist-⊎-Σ

  exploreΣᵉ : ∀ {m} xs → Explore m (Σᵉ (fromBinTree xs) P)
  exploreΣᵉ {m} xs = fromBinTree-ind xs (λ e → Explore m (Σᵉ e P)) Lift𝟘ᵉ _⊎ᵉ_ explore-P

  module _ (Σᵉ-adq-explore-P : ∀ {m} x → Adequate-Σᵉ {m} (explore-P x)) where
    Σᵉ-adq-exploreΣᵉ : ∀ {m} xs → Adequate-Σᵉ {m} (exploreΣᵉ xs)
    Σᵉ-adq-exploreΣᵉ empty F         = ! Σ𝟘-lift∘fst ∙ Σ-fst= (! Lift≡id) _
    Σᵉ-adq-exploreΣᵉ (leaf x₁) F     = Σᵉ-adq-explore-P x₁ F
    Σᵉ-adq-exploreΣᵉ (fork xs xs₁) F = ⊎= (Σᵉ-adq-exploreΣᵉ xs _) (Σᵉ-adq-exploreΣᵉ xs₁ _) ∙ ! dist-⊎-Σ

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

Add more exploration functions about binary trees


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for caching evaluation of MTerm
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Syntax.MType as MType

import Parametric.Denotation.Value as Value
import Parametric.Denotation.MValue as MValue

module Parametric.Denotation.CachingMValue
    (Base : Type.Structure)
    (⟦_⟧Base : Value.Structure Base)
  where

open import Base.Denotation.Notation

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

open import Data.Product hiding (map)
open import Data.Sum hiding (map)
open import Data.Unit
open import Level
open import Function hiding (const)

module Structure where
  -- XXX: below we need to override just a few cases. Inheritance would handle
  -- this precisely; without inheritance, we might want to use one of the
  -- standard encodings of related features (delegation?).

  ⟦_⟧ValTypeHidCacheWrong : (τ : ValType) → Set₁
  ⟦_⟧CompTypeHidCacheWrong : (τ : CompType) → Set₁

  -- This line is the only change, up to now, for the caching semantics starting from CBPV.
  ⟦ F τ ⟧CompTypeHidCacheWrong = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCacheWrong × ⟦ τ₁ ⟧ValTypeHidCacheWrong )
  -- Delegation upward.
  ⟦ τ ⟧CompTypeHidCacheWrong = Lift ⟦ τ ⟧CompType
  ⟦_⟧ValTypeHidCacheWrong = Lift ∘ ⟦_⟧ValType
  -- The above does not override what happens in recursive occurrences.

  {-# NO_TERMINATION_CHECK #-}
  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  -- This line is the only change, up to now, for the caching semantics.
  --
  -- XXX The termination checker isn't happy with it, and it may be right ─ if
  -- you keep substituting τ₁ = U (F τ), you can make the cache arbitrarily big.
  -- I think we don't do that unless we are caching a non-terminating
  -- computation to begin with, but I'm not entirely sure.
  --
  -- However, the termination checker can't prove that the function is
  -- terminating because it's not structurally recursive, but one call of the
  -- function will produce another call of the function stuck on a neutral term:
  -- So the computation will have terminated, just in an unusual way!
  --
  -- Anyway, I need not mechanize this part of the proof for my goals.
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCache × ⟦ τ₁ ⟧ValTypeHidCache )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Values for caching evaluation of MTerm
------------------------------------------------------------------------
import Parametric.Syntax.Type as Type
import Parametric.Syntax.MType as MType

import Parametric.Denotation.Value as Value
import Parametric.Denotation.MValue as MValue

module Parametric.Denotation.CachingMValue
    (Base : Type.Structure)
    (⟦_⟧Base : Value.Structure Base)
  where

open import Base.Denotation.Notation

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

open import Data.Product hiding (map)
open import Data.Sum hiding (map)
open import Data.Unit
open import Level
open import Function hiding (const)

module Structure where
  {-# NO_TERMINATION_CHECK #-}
  ⟦_⟧ValTypeHidCache : (τ : ValType) → Set
  ⟦_⟧CompTypeHidCache : (τ : CompType) → Set

  ⟦ U c ⟧ValTypeHidCache = ⟦ c ⟧CompTypeHidCache
  ⟦ B ι ⟧ValTypeHidCache = ⟦ base ι ⟧
  ⟦ vUnit ⟧ValTypeHidCache = ⊤
  ⟦ τ₁ v× τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache × ⟦ τ₂ ⟧ValTypeHidCache
  ⟦ τ₁ v+ τ₂ ⟧ValTypeHidCache = ⟦ τ₁ ⟧ValTypeHidCache ⊎ ⟦ τ₂ ⟧ValTypeHidCache

  --
  -- XXX The termination checker isn't happy with it, and it may be right ─ if
  -- you keep substituting τ₁ = U (F τ), you can make the cache arbitrarily big.
  -- I think we don't do that unless we are caching a non-terminating
  -- computation to begin with, but I'm not entirely sure.
  --
  -- However, the termination checker can't prove that the function is
  -- terminating because it's not structurally recursive, but one call of the
  -- function will produce another call of the function stuck on a neutral term:
  -- So the computation will have terminated, just in an unusual way!
  --
  -- Anyway, I need not mechanize this part of the proof for my goals.
  --
  -- XXX: This line is the only change, up to now, for the caching semantics,
  -- the rest is copied. Inheritance would handle this precisely; without
  -- inheritance, we might want to use one of the standard encodings of related
  -- features (delegation?).
  ⟦ F τ ⟧CompTypeHidCache = (Σ[ τ₁ ∈ ValType ] ⟦ τ ⟧ValTypeHidCache × ⟦ τ₁ ⟧ValTypeHidCache )
  ⟦ σ ⇛ τ ⟧CompTypeHidCache = ⟦ σ ⟧ValTypeHidCache → ⟦ τ ⟧CompTypeHidCache

  ⟦_⟧ValCtxHidCache : (Γ : ValContext) → Set
  ⟦_⟧ValCtxHidCache = DependentList ⟦_⟧ValTypeHidCache

  {-
  ⟦_⟧CompCtxHidCache : (Γ : CompContext) → Set₁
  ⟦_⟧CompCtxHidCache = DependentList ⟦_⟧CompTypeHidCache
  -}

Drop ⟦_⟧*TypeHidCacheWrong

Drop ⟦_⟧*TypeHidCacheWrong

This wrong definition should not be counted among the failures before
CBPV, since it was created after and it is due to a separate limitation.


module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎

module Nat where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC  succ #-}

_+_ : ℕ → ℕ → ℕ
zero   + b = b
succ a + b = succ (a + b)

_×_ : ℕ → ℕ → ℕ
zero   × b = zero
succ a × b = (a × b) + b

open import Relation.Binary.PropositionalEquality

0-is-right-identity-of-+ : ∀ (n : ℕ) → n + zero ≡ n
0-is-right-identity-of-+ zero     = refl
0-is-right-identity-of-+ (succ n) = cong succ (0-is-right-identity-of-+ n)

+-is-associative : ∀ (a b c : ℕ) → a + (b + c) ≡ (a + b) + c
+-is-associative zero     b c = refl
+-is-associative (succ a) b c = cong succ (+-is-associative a b c)

lemma : ∀ (a b : ℕ) → a + succ b ≡ succ (a + b)
lemma zero     b = refl
lemma (succ a) b = cong succ (lemma a b)

import Relation.Binary.EqReasoning as EqR
open module EqNat = EqR (setoid ℕ)

+-is-commutative : ∀ (a b : ℕ) → a + b ≡ b + a
+-is-commutative a zero     = 0-is-right-identity-of-+ a
+-is-commutative a (succ b) =
  begin
    a + succ b
      ≈⟨ lemma a b ⟩
    succ (a + b)
      ≈⟨ cong succ (+-is-commutative a b) ⟩
    succ (b + a)
      ≈⟨ refl ⟩
    succ b + a
  ∎

allow the use of more natural notation in Nat


import Parametric.Syntax.Type as Type
import Base.Syntax.Context as Context

module Parametric.Change.Term
    {Base : Set}
    (Constant : Context.Context (Type.Type Base) → Type.Type Base → Set {- of constants -})
  where

-- Terms that operate on changes

open Type Base
open Context Type

open import Parametric.Change.Type Δbase
open import Parametric.Syntax.Term Constant

open import Data.Product

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : Base → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : Base → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : Base → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

import Parametric.Syntax.Type as Type
import Base.Syntax.Context as Context

module Parametric.Change.Term
    {Base : Set}
    (Constant : Context.Context (Type.Type Base) → Type.Type Base → Set {- of constants -})
    {Δbase : Base → Type.Type Base}
  where

-- Terms that operate on changes

open Type Base
open Context Type

open import Parametric.Change.Type Δbase
open import Parametric.Syntax.Term Constant

open import Data.Product

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply :
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff :
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply :
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

Move parameter to module level.

Move parameter to module level.

All definitions in this module take the same parameter, so moving that
parameter to the module level makes it easier to instantiate all of the
definitions at once.

Old-commit-hash: c9a73b24cd02aed1ee75b46416c1893c8c37b130