TaggedDeltaTypes: remove unused postulates

Old-commit-hash: 33a5915e3451b89be50eee6831fad85b983cee50

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

module TaggedDeltaTypes where

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

---------------------------------------------------------
-- Postulates: Extensionality and bag properties (#55) --
---------------------------------------------------------

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

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

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

open Quadruple public

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

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

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

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

infixr 5 _⇒_

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

infixr 9 _•_

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

data Term : Context -> Type -> Set where

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

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

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

infix 8 _≼_

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

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

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

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

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

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

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

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

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

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

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

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

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

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

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

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

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

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

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

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

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

-----------------------
-- Syntax of changes --
-----------------------

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

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

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

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

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

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

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

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

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

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

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

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

-- R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {σ ⇒ τ} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v]
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {u = u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {u = u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

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

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

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

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

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

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

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

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

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

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

Δmap₀ s ds t dt is-valid-wrt ρ = couple
  (ds is-valid-wrt ρ)
  (dt is-valid-wrt ρ)
_is-valid-wrt_ (Δmap₁ s db) ρ = db is-valid-wrt ρ

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

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

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

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

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

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

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

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

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

derive (nat n) = Δnat n n
derive (bag b) = Δbag emptyBag
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t)
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module TaggedDeltaTypes where

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

---------------------------------------------------------
-- Postulates: Extensionality and bag properties (#55) --
---------------------------------------------------------

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

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

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

open Quadruple public

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

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

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

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

infixr 5 _⇒_

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

infixr 9 _•_

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

data Term : Context -> Type -> Set where

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

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

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

infix 8 _≼_

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

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

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

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

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

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

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

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

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

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

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

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

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

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

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

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

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

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

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

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

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

-----------------------
-- Syntax of changes --
-----------------------

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

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

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

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

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

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

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

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

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

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

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

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

-- R[v,u⊝v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊝ v)
R[v,u⊝v] {nats} {u} {v} = refl
R[v,u⊝v] {bags} {u} {v} = tt
R[v,u⊝v] {σ ⇒ τ} {u} {v} = λ w dw R[w,dw] →
  let
    w′ = w ⊕ dw
  in
    R[v,u⊝v]
    ,
    (begin
      (v ⊕ (u ⊝ v)) w′
    ≡⟨ cong (λ hole → hole w′) (v⊕[u⊝v]=u {u = u} {v}) ⟩
      u w′
    ≡⟨ sym (v⊕[u⊝v]=u {u = u w′} {v w}) ⟩
      v w ⊕ (u ⊝ v) w dw R[w,dw]
    ∎) where open ≡-Reasoning

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

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

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

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

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

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

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

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

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

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

Δmap₀ s ds t dt is-valid-wrt ρ = couple
  (ds is-valid-wrt ρ)
  (dt is-valid-wrt ρ)
_is-valid-wrt_ (Δmap₁ s db) ρ = db is-valid-wrt ρ

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

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

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

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

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

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

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

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

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

derive (nat n) = Δnat n n
derive (bag b) = Δbag emptyBag
derive (var x) = Δvar x
derive (abs t) = Δabs (derive t)
derive (app s t) = Δapp (derive s) t (derive t)
derive (add s t) = Δadd (derive s) (derive t)
derive (map f b) = Δmap₀ f (derive f) b (derive b)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Describe the purpose of meaning.agda (see #28).

Old-commit-hash: 84cbf4aaec6e61e796b1039fd152d3e0cd4c4d53

module meaning where

-- OVERLOADING ⟦_⟧
--
-- This module defines a general mechanism for overloading the
-- ⟦_⟧ notation, using Agda’s instance arguments.

open import Level

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

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

open Meaning public
  using (⟨_⟩⟦_⟧)

module meaning where

open import Level

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

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

open Meaning public
  using (⟨_⟩⟦_⟧)


Monoid no longer depends on Data.Nat.NP

Monoid no longer depends on Data.Nat.NP

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.NP
  using    (ℕ; fold; zero; suc; 1+_)
  renaming (_+_ to _+ℕ_; _*_ to _*ℕ_)
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-∙-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
-- -}
-- -}
-- -}
-- -}


Desc stratified model: put implicits up to DescDConst. Troubles starting.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set l) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set l} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set l}(R : I -> IDesc I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set l}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const X
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : (l : Level) -> Set l -> DescDConst -> IDesc Unit
descDChoice _ I lvar = const (lift I)
descDChoice x _ lconst = const (Set x)
descDChoice _ _ lprod = prod (var Void) (var Void)
descDChoice x _ lpi = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))
descDChoice x _ lsigma = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc Unit
descD x I = sigma DescDConst (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst  {l = suc x}
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst {l = suc x}
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst {l = suc x}
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst {l = suc x}
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s

--********************************************
-- From the embedding to the host
--********************************************

-- desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
-- descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
-- IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l

-- cases : (l : Level)
--         (I : Set l)
--         (xs : desc (suc l) (lift I) (descD l I) (IMu (suc l) Unit (\ _ -> descD l I)))
--         (hs : desc l I (box l I (descD l I) (IMu l Unit (λ _ -> descD l I)) xs) (λ _ -> IDesc (suc l) I)) ->
--         IDesc (suc l) I
-- cases x I ( lvar , i ) hs =  var i
-- cases x I ( lconst , X ) hs =  const X
-- cases x I ( lprod , (D , D') ) ( d , d' ) =  prod d d'
-- cases x I ( lpi , ( S , T ) ) hs =  pi S hs
-- cases x I ( lsigma , ( S , T ) ) hs = sigma S hs

-- phi : {I : Set} -> IDescl I -> IDesc I
-- phi {I} d = induction (\_ -> descD I) (\_ -> IDesc I) (\_ -> cases) Void d

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {l : Level}{A : Set l}(x : A) : A -> Set l where
  refl : x == x

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc (l : Level)(I : Set l) : Set (suc l) where
  var : I -> IDesc l I
  const : Set l -> IDesc l I
  prod : IDesc l I -> IDesc l I -> IDesc l I
  sigma : (S : Set l) -> (S -> IDesc l I) -> IDesc l I
  pi : (S : Set l) -> (S -> IDesc l I) -> IDesc l I

--********************************************
-- Desc interpretation
--********************************************

desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
desc _ I (var i) P = P i
desc _ I (const X) P = X
desc x I (prod D D') P = desc x I D P * desc x I D' P
desc x I (sigma S T) P = Sigma S (\s -> desc x I (T s) P)
desc x I (pi S T) P = (s : S) -> desc x I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l where
  con : desc l I (R i) (\j -> IMu l I R j) -> IMu l I R i

--********************************************
-- Predicate: Box
--********************************************

box : (l : Level)(I : Set l)(D : IDesc l I)(P : I -> Set l) -> desc l I D P -> IDesc l (Sigma I P)
box _ I (var i)     P x        = var (i , x)
box _ I (const X)   P x        = const X
box x I (prod D D') P (d , d') = prod (box x I D P d) (box x I D' P d')
box x I (sigma S T) P (a , b)  = box x I (T a) P b
box x I (pi S T)    P f        = pi S (\s -> box x I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu l I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc l I) ->
           (xs : desc l I D (IMu l I R)) ->
           desc l (Sigma I (IMu l I R)) (box l I D (IMu l I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu l I R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst (l : Level) : Set l where
  lvar   : DescDConst l
  lconst : DescDConst l
  lprod  : DescDConst l
  lpi    : DescDConst l
  lsigma : DescDConst l

descDChoice : (l : Level) -> Set l -> DescDConst (suc l) -> IDesc (suc l) Unit
descDChoice _ I lvar = const (lift I)
descDChoice x _ lconst = const (Set x)
descDChoice _ _ lprod = prod (var Void) (var Void)
descDChoice x _ lpi = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))
descDChoice x _ lsigma = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
descD x I = sigma (DescDConst (suc x)) (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (suc x) Unit (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst (suc x)
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst (suc x)
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst (suc x)
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst (suc x)
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst (suc x)
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s


Fixed a note.

Fixed a note.

Ignore-this: f347072c6b8284ab860fd1f642643ef5

darcs-hash:20120611210021-3bd4e-2465917dcf0f41f68d67bb666d8fc2554918628e.gz

------------------------------------------------------------------------------
-- Well-founded relation on lists
------------------------------------------------------------------------------

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

-- Tested with the development version of the standard library on
-- 11 June 2012.

module WellFoundedRelationsSL {A : Set} where

open import Data.Product
open import Data.List hiding ( length )
open import Data.Nat

open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------------
-- We use our own version of the function length because we have
-- better reductions.
length : List A → ℕ
length []       = 0
length (x ∷ xs) = 1 + length xs

open module II = Induction.WellFounded.Inverse-image {_<_ = _<′_} length

-- Well-founded relation on lists based on their length.
LTL : List A → List A → Set
LTL xs ys = length xs <′ length ys

-- The relation LTL is well-founded (using the image inverse
-- combinator).
wfLTL : Well-founded LTL
wfLTL = II.well-founded <-well-founded

-- Well-founded relation on lists based on their structure.
LTC : List A → List A → Set
LTC xs ys = Σ A (λ a → ys ≡ a ∷ xs)

LTC→LTL : ∀ {xs ys} → LTC xs ys → LTL xs ys
LTC→LTL (x , ys≡x∷xs) = helper ys≡x∷xs
  where
    helper : ∀ {x xs ys} → ys ≡ x ∷ xs → length xs <′ length ys
    helper refl = ≤′-refl

open module S = Induction.WellFounded.Subrelation {_<₁_ = LTC} LTC→LTL

-- The relation LTC is well-founded (using the subrelation combinator).
wfLTC : Well-founded LTC
wfLTC = S.well-founded wfLTL

------------------------------------------------------------------------------
-- Well-founded relation on lists
------------------------------------------------------------------------------

-- Tested with the development version of the standard library on
-- 05 March 2011.

module WellFoundedRelationsSL {A : Set} where

open import Data.Product
open import Data.List hiding ( length )
open import Data.Nat

open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------------
-- We use our own version of the function length because we have
-- better reductions.
length : List A → ℕ
length []       = 0
length (x ∷ xs) = 1 + length xs

open module II = Induction.WellFounded.Inverse-image length

-- Well-founded relation on lists based on their length.
LTL : List A → List A → Set
LTL xs ys = length xs <′ length ys

-- The relation LTL is well-founded (using the image inverse
-- combinator).
wfLTL : Well-founded LTL
wfLTL = II.well-founded <-well-founded

-- Well-founded relation on lists based on their structure.
LTC : List A → List A → Set
LTC xs ys = Σ A (λ a → ys ≡ a ∷ xs)

LTC→LTL : ∀ {xs ys} → LTC xs ys → LTL xs ys
LTC→LTL (x , ys≡x∷xs) = helper ys≡x∷xs
  where
    helper : ∀ {x xs ys} → ys ≡ x ∷ xs → length xs <′ length ys
    helper refl = ≤′-refl

open module S = Induction.WellFounded.Subrelation LTC→LTL

-- The relation LTC is well-founded (using the subrelation combinator).
wfLTC : Well-founded LTC
wfLTC = S.well-founded wfLTL


Desc model: varl, constl, prodl, sigmal, pil implicit.


Cosmetic changes.

Cosmetic changes.

------------------------------------------------------------------------------
-- Conversion rules for inequalities
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.Inequalities.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Inequalities

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

private

  -- Before to prove some properties for lt it is convenient
  -- to descompose the behavior of the function step by step.

  -- Initially, we define the possible states (lt-s₁,
  -- lt-s₂, ...). Then we write down the proof for
  -- the execution step from the state p to the state q, e.g.
  --
  -- proof₁→proof₂ : ∀ m n → lt-s₂ m n → lt-s₃ m n.

  -- The terms lt-00, lt-0S, lt-S0, and lt-SS show the use of the
  -- states lt-s₁, lt-s₂, ..., and the proofs associated with the
  -- execution steps.

  ----------------------------------------------------------------------
  -- The steps of lt.

  -- Initially, the conversion rule fix-eq is applied.
  lt-s₁ : D → D → D
  lt-s₁ m n = lth (fix lth) · m · n

  -- First argument application.
  lt-s₂ : D → D
  lt-s₂ m = lam (λ n →
               if (iszero₁ n)
                  then false
                  else (if (iszero₁ m)
                           then true
                           else (fix lth · pred₁ m · pred₁ n)))

  -- Second argument application.
  lt-s₃ : D → D → D
  lt-s₃ m n = if (iszero₁ n)
                 then false
                 else (if (iszero₁ m)
                          then true
                          else (fix lth · pred₁ m · pred₁ n))

  -- Reduction iszero₁ n ≡ b.
  lt-s₄ : D → D → D → D
  lt-s₄ m n b = if b
                   then false
                   else (if (iszero₁ m)
                            then true
                            else (fix lth · pred₁ m · pred₁ n))

  -- Reduction iszero₁ n ≡ true.
  -- It should be
  -- lt-s₅ : D → D → D
  -- lt-s₅ m n = false
  -- but we do not give a name to this step.

  -- Reduction iszero₁ n ≡ false.
  lt-s₅ : D → D → D
  lt-s₅ m n = if (iszero₁ m)
                 then true
                 else (fix lth · pred₁ m · pred₁ n)

  -- Reduction iszero₁ m ≡ b.
  lt-s₆ : D → D → D → D
  lt-s₆ m n b = if b
                   then true
                   else (fix lth · pred₁ m · pred₁ n)

  -- Reduction iszero₁ m ≡ true.
  -- It should be
  -- lt-s₇ : D → D → D
  -- lt-s₇ m n = true
  -- but we do not give a name to this step.

   -- Reduction iszero₁ m ≡ false.
  lt-s₇ : D → D → D
  lt-s₇ m n = fix lth · pred₁ m · pred₁ n

  -- Reduction pred₁ (succ m) ≡ m.
  lt-s₈ : D → D → D
  lt-s₈ m n = fix lth · m · pred₁ n

  -- Reduction pred₁ (succ n) ≡ n.
  lt-s₉ : D → D → D
  lt-s₉ m n = fix lth · m · n

  ----------------------------------------------------------------------
  -- The execution steps

  {-

    To prove the execution steps, e.g.

    proof₃→proof₄ : ∀ m n → lt-s₃ m n → lt-s₄ m n)

    we usually need to prove that

                         C [m] ≡ C [n]    (1)

    given that
                             m ≡ n,       (2)

    where (2) is a conversion rule usually.

    We prove (1) using

    subst : ∀ {x y} (A : D → Set) → x ≡ y → A x → A y

    where
      • P is given by λ t → C [m] ≡ C [t],
      • x ≡ y is given m ≡ n, and
      • P x is given by C [m] ≡ C [m] (i.e. refl).
  -}

  -- Application of the conversion rule fix-eq.
  proof₀₋₁ : ∀ m n → fix lth · m · n  ≡ lt-s₁ m n
  proof₀₋₁ m n = subst (λ x → x · m · n  ≡ lth (fix lth) · m · n)
                       (sym (fix-eq lth))
                       refl

  -- Application of the first argument.
  proof₁₋₂ : ∀ m n → lt-s₁ m n ≡ lt-s₂ m · n
  proof₁₋₂ m n = subst (λ x → x · n ≡ lt-s₂ m · n)
                       (sym (beta lt-s₂ m))
                       refl

  -- Application of the second argument.
  proof₂₋₃ : ∀ m n → lt-s₂ m · n ≡ lt-s₃ m n
  proof₂₋₃ m n = beta (lt-s₃ m) n

  -- 01 June 2013. This proof could use pattern matching on _≡_. See
  -- Agda issue 865.
  --
  -- Reduction iszero n ≡ b using that proof.
  proof₃₋₄ : ∀ m n b → iszero₁ n ≡ b → lt-s₃ m n ≡ lt-s₄ m n b
  proof₃₋₄ m n b h = subst (λ x → lt-s₄ m n x ≡ lt-s₄ m n b)
                           (sym h)
                           refl

  -- Reduction of iszero₁ n ≡ true using the conversion rule if-true.
  proof₄₊ : ∀ m n → lt-s₄ m n true ≡ false
  proof₄₊ m n = if-true false

  -- Reduction of iszero₁ n ≡ false ... using the conversion rule
  -- if-false.
  proof₄₋₅ : ∀ m n → lt-s₄ m n false ≡ lt-s₅ m n
  proof₄₋₅ m n = if-false (lt-s₅ m n)

  -- 01 June 2013. This proof could use pattern matching on _≡_. See
  -- Agda issue 865.

  -- Reduction iszero₁ m ≡ b using that proof.
  proof₅₋₆ : ∀ m n b → iszero₁ m ≡ b → lt-s₅ m n ≡ lt-s₆ m n b
  proof₅₋₆ m n b h = subst (λ x → lt-s₆ m n x ≡ lt-s₆ m n b)
                           (sym h)
                           refl

  -- Reduction of iszero₁ m ≡ true using the conversion rule if-true.
  proof₆₊ : ∀ m n → lt-s₆ m n true ≡ true
  proof₆₊ m n = if-true true

  -- Reduction of iszero₁ m ≡ false ... using the conversion rule
  -- if-false.
  proof₆₋₇ : ∀ m n → lt-s₆ m n false ≡ lt-s₇ m n
  proof₆₋₇ m n = if-false (lt-s₇ m n)

  -- Reduction pred (succ m) ≡ m using the conversion rule pred-S.
  proof₇₋₈ : ∀ m n → lt-s₇ (succ₁ m) n ≡ lt-s₈ m n
  proof₇₋₈ m n = subst (λ x → lt-s₈ x n ≡ lt-s₈ m n)
                       (sym (pred-S m))
                       refl

  -- Reduction pred (succ n) ≡ n using the conversion rule pred-S.
  proof₈₋₉ : ∀ m n → lt-s₈ m (succ₁ n) ≡ lt-s₉ m n
  proof₈₋₉ m n = subst (λ x → lt-s₉ m x ≡ lt-s₉ m n)
                       (sym (pred-S n))
                       refl

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

private
  X≮0 : ∀ n → n ≮ zero
  X≮0 n = fix lth · n · zero  ≡⟨ proof₀₋₁ n zero ⟩
          lt-s₁ n zero        ≡⟨ proof₁₋₂ n zero ⟩
          lt-s₂ n · zero      ≡⟨ proof₂₋₃ n zero ⟩
          lt-s₃ n zero        ≡⟨ proof₃₋₄ n zero true iszero-0 ⟩
          lt-s₄ n zero true   ≡⟨ proof₄₊ n zero ⟩
          false              ∎

lt-00 : zero ≮ zero
lt-00 = X≮0 zero

lt-0S : ∀ n → zero < succ₁ n
lt-0S n =
  fix lth · zero · (succ₁ n)    ≡⟨ proof₀₋₁ zero (succ₁ n) ⟩
  lt-s₁ zero (succ₁ n)          ≡⟨ proof₁₋₂ zero (succ₁ n) ⟩
  lt-s₂ zero · (succ₁ n)        ≡⟨ proof₂₋₃ zero (succ₁ n) ⟩
  lt-s₃ zero (succ₁ n)          ≡⟨ proof₃₋₄ zero (succ₁ n) false (iszero-S n) ⟩
  lt-s₄ zero (succ₁ n) false    ≡⟨ proof₄₋₅ zero (succ₁ n) ⟩
  lt-s₅ zero (succ₁ n)          ≡⟨ proof₅₋₆ zero (succ₁ n) true iszero-0 ⟩
  lt-s₆ zero (succ₁ n) true     ≡⟨ proof₆₊  zero (succ₁ n) ⟩
  true                         ∎

lt-S0 : ∀ n → succ₁ n ≮ zero
lt-S0 n = X≮0 (succ₁ n)

lt-SS : ∀ m n → lt (succ₁ m) (succ₁ n) ≡ lt m n
lt-SS m n =
  fix lth · (succ₁ m) · (succ₁ n)  ≡⟨ proof₀₋₁ (succ₁ m) (succ₁ n) ⟩
  lt-s₁ (succ₁ m) (succ₁ n)        ≡⟨ proof₁₋₂ (succ₁ m) (succ₁ n) ⟩
  lt-s₂ (succ₁ m) · (succ₁ n)      ≡⟨ proof₂₋₃ (succ₁ m) (succ₁ n) ⟩
  lt-s₃ (succ₁ m) (succ₁ n)        ≡⟨ proof₃₋₄ (succ₁ m) (succ₁ n) false (iszero-S n) ⟩
  lt-s₄ (succ₁ m) (succ₁ n) false  ≡⟨ proof₄₋₅ (succ₁ m) (succ₁ n) ⟩
  lt-s₅ (succ₁ m) (succ₁ n)        ≡⟨ proof₅₋₆ (succ₁ m) (succ₁ n) false (iszero-S m) ⟩
  lt-s₆ (succ₁ m) (succ₁ n) false  ≡⟨ proof₆₋₇ (succ₁ m) (succ₁ n) ⟩
  lt-s₇ (succ₁ m) (succ₁ n)        ≡⟨ proof₇₋₈ m (succ₁ n) ⟩
  lt-s₈ m (succ₁ n)                ≡⟨ proof₈₋₉ m n ⟩
  lt-s₉ m n                        ∎

------------------------------------------------------------------------------
-- Conversion rules for inequalities
------------------------------------------------------------------------------

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

module LTC-PCF.Data.Nat.Inequalities.ConversionRules where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Inequalities

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

private

  -- Before to prove some properties for lt it is convenient
  -- to descompose the behavior of the function step by step.

  -- Initially, we define the possible states (lt-s₁,
  -- lt-s₂, ...). Then we write down the proof for
  -- the execution step from the state p to the state q, e.g.
  --
  -- proof₁→proof₂ : ∀ m n → lt-s₂ m n → lt-s₃ m n.

  -- The terms lt-00, lt-0S, lt-S0, and lt-SS show the use of the
  -- states lt-s₁, lt-s₂, ..., and the proofs associated with the
  -- execution steps.

  ----------------------------------------------------------------------
  -- The steps of lt.

  -- Initially, the conversion rule fix-eq is applied.
  lt-s₁ : D → D → D
  lt-s₁ m n = lth (fix lth) · m · n

  -- First argument application.
  lt-s₂ : D → D
  lt-s₂ m = lam (λ n →
               if (iszero₁ n)
                  then false
                  else (if (iszero₁ m)
                           then true
                           else (fix lth · pred₁ m · pred₁ n)))

  -- Second argument application.
  lt-s₃ : D → D → D
  lt-s₃ m n = if (iszero₁ n)
                 then false
                 else (if (iszero₁ m)
                          then true
                          else (fix lth · pred₁ m · pred₁ n))

  -- Reduction iszero₁ n ≡ b.
  lt-s₄ : D → D → D → D
  lt-s₄ m n b = if b
                   then false
                   else (if (iszero₁ m)
                            then true
                            else (fix lth · pred₁ m · pred₁ n))

  -- Reduction iszero₁ n ≡ true.
  -- It should be
  -- lt-s₅ : D → D → D
  -- lt-s₅ m n = false
  -- but we do not give a name to this step.

  -- Reduction iszero₁ n ≡ false.
  lt-s₅ : D → D → D
  lt-s₅ m n = if (iszero₁ m)
                 then true
                 else (fix lth · pred₁ m · pred₁ n)

  -- Reduction iszero₁ m ≡ b.
  lt-s₆ : D → D → D → D
  lt-s₆ m n b = if b
                   then true
                   else (fix lth · pred₁ m · pred₁ n)

  -- Reduction iszero₁ m ≡ true.
  -- It should be
  -- lt-s₇ : D → D → D
  -- lt-s₇ m n = true
  -- but we do not give a name to this step.

   -- Reduction iszero₁ m ≡ false.
  lt-s₇ : D → D → D
  lt-s₇ m n = fix lth · pred₁ m · pred₁ n

  -- Reduction pred₁ (succ m) ≡ m.
  lt-s₈ : D → D → D
  lt-s₈ m n = fix lth · m · pred₁ n

  -- Reduction pred₁ (succ n) ≡ n.
  lt-s₉ : D → D → D
  lt-s₉ m n = fix lth · m · n

  ----------------------------------------------------------------------
  -- The execution steps

  {-

    To prove the execution steps, e.g.

    proof₃→proof₄ : ∀ m n → lt-s₃ m n → lt-s₄ m n)

    we usually need to prove that

                         C [m] ≡ C [n]    (1)

    given that
                             m ≡ n,       (2)

    where (2) is a conversion rule usually.

    We prove (1) using

    subst : ∀ {x y} (A : D → Set) → x ≡ y → A x → A y

    where
      • P is given by λ t → C [m] ≡ C [t],
      • x ≡ y is given m ≡ n, and
      • P x is given by C [m] ≡ C [m] (i.e. refl).
  -}

  -- Application of the conversion rule fix-eq.
  proof₀₋₁ : ∀ m n → fix lth · m · n  ≡ lt-s₁ m n
  proof₀₋₁ m n = subst (λ x → x · m · n  ≡ lth (fix lth) · m · n )
                       (sym (fix-eq lth ))
                       refl

  -- Application of the first argument.
  proof₁₋₂ : ∀ m n → lt-s₁ m n ≡ lt-s₂ m · n
  proof₁₋₂ m n = subst (λ x → x · n ≡ lt-s₂ m · n)
                       (sym (beta lt-s₂ m))
                       refl

  -- Application of the second argument.
  proof₂₋₃ : ∀ m n → lt-s₂ m · n ≡ lt-s₃ m n
  proof₂₋₃ m n = beta (lt-s₃ m) n

  -- 01 June 2013. This proof could use pattern matching on _≡_. See
  -- Agda issue 865.
  --
  -- Reduction iszero n ≡ b using that proof.
  proof₃₋₄ : ∀ m n b → iszero₁ n ≡ b → lt-s₃ m n ≡ lt-s₄ m n b
  proof₃₋₄ m n b h = subst (λ x → lt-s₄ m n x ≡ lt-s₄ m n b )
                           (sym h)
                           refl

  -- Reduction of iszero₁ n ≡ true using the conversion rule if-true.
  proof₄₊ : ∀ m n → lt-s₄ m n true ≡ false
  proof₄₊ m n = if-true false

  -- Reduction of iszero₁ n ≡ false ... using the conversion rule
  -- if-false.
  proof₄₋₅ : ∀ m n → lt-s₄ m n false ≡ lt-s₅ m n
  proof₄₋₅ m n = if-false (lt-s₅ m n)

  -- 01 June 2013. This proof could use pattern matching on _≡_. See
  -- Agda issue 865.
  --
  -- Reduction iszero₁ m ≡ b using that proof.
  proof₅₋₆ : ∀ m n b → iszero₁ m ≡ b → lt-s₅ m n ≡ lt-s₆ m n b
  proof₅₋₆ m n b h = subst (λ x → lt-s₆ m n x ≡ lt-s₆ m n b )
                           (sym h)
                           refl

  -- Reduction of iszero₁ m ≡ true using the conversion rule if-true.
  proof₆₊ : ∀ m n → lt-s₆ m n true ≡ true
  proof₆₊ m n = if-true true

  -- Reduction of iszero₁ m ≡ false ... using the conversion rule
  -- if-false.
  proof₆₋₇ : ∀ m n → lt-s₆ m n false ≡ lt-s₇ m n
  proof₆₋₇ m n = if-false (lt-s₇ m n)

  -- Reduction pred (succ m) ≡ m using the conversion rule pred-S.
  proof₇₋₈ : ∀ m n → lt-s₇ (succ₁ m) n  ≡ lt-s₈ m n
  proof₇₋₈ m n = subst (λ x → lt-s₈ x n ≡ lt-s₈ m n)
                       (sym (pred-S m ))
                       refl

  -- Reduction pred (succ n) ≡ n using the conversion rule pred-S.
  proof₈₋₉ : ∀ m n → lt-s₈ m (succ₁ n)  ≡ lt-s₉ m n
  proof₈₋₉ m n = subst (λ x → lt-s₉ m x ≡ lt-s₉ m n)
                       (sym (pred-S n ))
                       refl

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

private
  X≮0 : ∀ n → n ≮ zero
  X≮0 n = fix lth · n · zero  ≡⟨ proof₀₋₁ n zero ⟩
          lt-s₁ n zero        ≡⟨ proof₁₋₂ n zero ⟩
          lt-s₂ n · zero      ≡⟨ proof₂₋₃ n zero ⟩
          lt-s₃ n zero        ≡⟨ proof₃₋₄ n zero true iszero-0 ⟩
          lt-s₄ n zero true   ≡⟨ proof₄₊ n zero ⟩
          false              ∎

lt-00 : zero ≮ zero
lt-00 = X≮0 zero

lt-0S : ∀ n → zero < succ₁ n
lt-0S n =
  fix lth · zero · (succ₁ n)    ≡⟨ proof₀₋₁ zero (succ₁ n) ⟩
  lt-s₁ zero (succ₁ n)          ≡⟨ proof₁₋₂ zero (succ₁ n) ⟩
  lt-s₂ zero · (succ₁ n)        ≡⟨ proof₂₋₃ zero (succ₁ n) ⟩
  lt-s₃ zero (succ₁ n)          ≡⟨ proof₃₋₄ zero (succ₁ n) false (iszero-S n) ⟩
  lt-s₄ zero (succ₁ n) false    ≡⟨ proof₄₋₅ zero (succ₁ n) ⟩
  lt-s₅ zero (succ₁ n)          ≡⟨ proof₅₋₆ zero (succ₁ n) true iszero-0 ⟩
  lt-s₆ zero (succ₁ n) true     ≡⟨ proof₆₊  zero (succ₁ n) ⟩
  true                         ∎

lt-S0 : ∀ n → succ₁ n ≮ zero
lt-S0 n = X≮0 (succ₁ n)

lt-SS : ∀ m n → lt (succ₁ m) (succ₁ n) ≡ lt m n
lt-SS m n =
  fix lth · (succ₁ m) · (succ₁ n)  ≡⟨ proof₀₋₁ (succ₁ m) (succ₁ n) ⟩
  lt-s₁ (succ₁ m) (succ₁ n)        ≡⟨ proof₁₋₂ (succ₁ m) (succ₁ n) ⟩
  lt-s₂ (succ₁ m) · (succ₁ n)      ≡⟨ proof₂₋₃ (succ₁ m) (succ₁ n) ⟩
  lt-s₃ (succ₁ m) (succ₁ n)        ≡⟨ proof₃₋₄ (succ₁ m) (succ₁ n) false (iszero-S n) ⟩
  lt-s₄ (succ₁ m) (succ₁ n) false  ≡⟨ proof₄₋₅ (succ₁ m) (succ₁ n) ⟩
  lt-s₅ (succ₁ m) (succ₁ n)        ≡⟨ proof₅₋₆ (succ₁ m) (succ₁ n) false (iszero-S m) ⟩
  lt-s₆ (succ₁ m) (succ₁ n) false  ≡⟨ proof₆₋₇ (succ₁ m) (succ₁ n) ⟩
  lt-s₇ (succ₁ m) (succ₁ n)        ≡⟨ proof₇₋₈ m (succ₁ n) ⟩
  lt-s₈ m (succ₁ n)                ≡⟨ proof₈₋₉ m n ⟩
  lt-s₉ m n                        ∎


Agda: update description of Plotkin's context

Reason: the previous description contains a modularization task
that is already partially carried out.

Reference:
https://github.com/ps-mr/ilc/commit/249e99d807e2382a37fb35aee78c235b98e427aa#commitcomment-3659727

Old-commit-hash: 3c52ba4a07600646db8de764b1460fa6b69c3014

module Syntax.Context.Plotkin where

-- Context for Plotkin-stype language descriptions
--
-- This module will tend to duplicate Syntax.Context to a large
-- extent. Consider having Syntax.Context specialize future
-- content of this module to maintain its interface.

infixr 9 _•_

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

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

module Syntax.Context.Plotkin where

-- Context for Plotkin-stype language descriptions
--
-- Duplicates Syntax.Context to a large extent.
-- Consider having Syntax.Context import this module.

infixr 9 _•_

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

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