Fixup old comments

Fixup old comments

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Connecting Parametric.Change.Term and Parametric.Change.Value.
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Type as ChangeType
import Parametric.Change.Term as ChangeTerm
import Parametric.Change.Value as ChangeValue

module Parametric.Change.Evaluation
    {Base : Type.Structure}
    {Const : Term.Structure Base}
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (apply-base : ChangeTerm.ApplyStructure Const ΔBase)
    (diff-base : ChangeTerm.DiffStructure Const ΔBase)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open ChangeType.Structure Base ΔBase
open ChangeTerm.Structure Const ΔBase diff-base apply-base
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation
open import Postulate.Extensionality

-- Extension point 1: Relating ⊕ and its value on base types
ApplyStructure : Set
ApplyStructure = ∀ ι {Γ} →
  {t : Term Γ (base ι)} {Δt : Term Γ (ΔType (base ι))} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ⟦⊕₍ base ι ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕₍ base ι ₎ Δt ⟧ ρ

-- Extension point 2: Relating ⊝ and its value on base types
DiffStructure : Set
DiffStructure = ∀ ι {Γ} →
  {s : Term Γ (base ι)} {t : Term Γ (base ι)} {ρ : ⟦ Γ ⟧} →
  ⟦ s ⟧ ρ ⟦⊝₍ base ι ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝₍ base ι ₎ t ⟧ ρ

module Structure
    (meaning-⊕-base : ApplyStructure)
    (meaning-⊝-base : DiffStructure)
  where

  -- unique names with unambiguous types
  -- to help type inference figure things out
  private
    module Disambiguation where
      infixr 9 _⋆_
      _⋆_ : Type → Context → Context
      _⋆_ = _•_

  -- We provide: Relating ⊕ and ⊝ and their values on arbitrary types.
  meaning-⊕ : ∀ {τ Γ}
    {t : Term Γ τ} {Δt : Term Γ (ΔType τ)} {ρ : ⟦ Γ ⟧} →
    ⟦ t ⟧ ρ ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕₍ τ ₎ Δt ⟧ ρ

  meaning-⊝ : ∀ {τ Γ}
    {s : Term Γ τ} {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
    ⟦ s ⟧ ρ ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝₍ τ ₎ t ⟧ ρ

  meaning-⊕ {base ι} {Γ} {τ} {Δt} {ρ} = meaning-⊕-base ι {Γ} {τ} {Δt} {ρ}
  meaning-⊕ {σ ⇒ τ} {Γ} {t} {Δt} {ρ} = ext (λ v →
    let
      Γ′ = σ ⋆ (σ ⇒ τ) ⋆ ΔType (σ ⇒ τ) ⋆ Γ
      ρ′ : ⟦ Γ′ ⟧
      ρ′ = v • (⟦ t ⟧ ρ) • (⟦ Δt ⟧ ρ) • ρ
      x  : Term Γ′ σ
      x  = var this
      f  : Term Γ′ (σ ⇒ τ)
      f  = var (that this)
      Δf : Term Γ′ (ΔType (σ ⇒ τ))
      Δf = var (that (that this))
      y  = app f x
      Δy = app (app Δf x) (x ⊝ x)
    in
      begin
        ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (v ⟦⊝₍ σ ₎⟧ v)
      ≡⟨ cong (λ hole → ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v hole)
           (meaning-⊝ {s = x} {x} {ρ′}) ⟩
        ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (⟦ x ⊝ x ⟧ ρ′)
      ≡⟨ meaning-⊕ {t = y} {Δt = Δy} {ρ′} ⟩
        ⟦ y ⊕₍ τ ₎ Δy ⟧ ρ′
      ∎)
    where
      open ≡-Reasoning
      open Disambiguation

  meaning-⊝ {base ι} {Γ} {s} {t} {ρ} = meaning-⊝-base ι {Γ} {s} {t} {ρ}
  meaning-⊝ {σ ⇒ τ} {Γ} {s} {t} {ρ} =
    ext (λ v → ext (λ Δv →
    let
      Γ′ = ΔType σ ⋆ σ ⋆ (σ ⇒ τ) ⋆ (σ ⇒ τ) ⋆ Γ
      ρ′ : ⟦ Γ′ ⟧Context
      ρ′ = Δv • v • ⟦ t ⟧Term ρ • ⟦ s ⟧Term ρ • ρ
      Δx : Term Γ′ (ΔType σ)
      Δx = var this
      x  : Term Γ′ σ
      x  = var (that this)
      f  : Term Γ′ (σ ⇒ τ)
      f  = var (that (that this))
      g  : Term Γ′ (σ ⇒ τ)
      g  = var (that (that (that this)))
      y  = app f x
      y′ = app g (x ⊕₍ σ ₎ Δx)
    in
      begin
        ⟦ s ⟧ ρ (v ⟦⊕₍ σ ₎⟧ Δv) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
      ≡⟨ cong (λ hole → ⟦ s ⟧ ρ hole ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v)
           (meaning-⊕ {t = x} {Δt = Δx} {ρ′}) ⟩
        ⟦ s ⟧ ρ (⟦ x ⊕₍ σ ₎ Δx ⟧ ρ′) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
      ≡⟨ meaning-⊝ {s = y′} {y} {ρ′} ⟩
        ⟦ y′ ⊝ y ⟧ ρ′
      ∎))
    where
      open ≡-Reasoning
      open Disambiguation

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Connecting Parametric.Change.Term and Parametric.Change.Value.
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Type as ChangeType
import Parametric.Change.Term as ChangeTerm
import Parametric.Change.Value as ChangeValue

module Parametric.Change.Evaluation
    {Base : Type.Structure}
    {Const : Term.Structure Base}
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (apply-base : ChangeTerm.ApplyStructure Const ΔBase)
    (diff-base : ChangeTerm.DiffStructure Const ΔBase)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open ChangeType.Structure Base ΔBase
open ChangeTerm.Structure Const ΔBase diff-base apply-base
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation
open import Postulate.Extensionality

-- Extension point 1: Relating ⊝ and its value on base types
ApplyStructure : Set
ApplyStructure = ∀ ι {Γ} →
  {t : Term Γ (base ι)} {Δt : Term Γ (ΔType (base ι))} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ⟦⊕₍ base ι ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕₍ base ι ₎ Δt ⟧ ρ

-- Extension point 2: Relating ⊕ and its value on base types
DiffStructure : Set
DiffStructure = ∀ ι {Γ} →
  {s : Term Γ (base ι)} {t : Term Γ (base ι)} {ρ : ⟦ Γ ⟧} →
  ⟦ s ⟧ ρ ⟦⊝₍ base ι ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝₍ base ι ₎ t ⟧ ρ

module Structure
    (meaning-⊕-base : ApplyStructure)
    (meaning-⊝-base : DiffStructure)
  where

  -- unique names with unambiguous types
  -- to help type inference figure things out
  private
    module Disambiguation where
      infixr 9 _⋆_
      _⋆_ : Type → Context → Context
      _⋆_ = _•_

  -- We provide: Relating ⊕ and ⊝ and their values on arbitrary types.
  meaning-⊕ : ∀ {τ Γ}
    {t : Term Γ τ} {Δt : Term Γ (ΔType τ)} {ρ : ⟦ Γ ⟧} →
    ⟦ t ⟧ ρ ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕₍ τ ₎ Δt ⟧ ρ

  meaning-⊝ : ∀ {τ Γ}
    {s : Term Γ τ} {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
    ⟦ s ⟧ ρ ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝₍ τ ₎ t ⟧ ρ

  meaning-⊕ {base ι} {Γ} {τ} {Δt} {ρ} = meaning-⊕-base ι {Γ} {τ} {Δt} {ρ}
  meaning-⊕ {σ ⇒ τ} {Γ} {t} {Δt} {ρ} = ext (λ v →
    let
      Γ′ = σ ⋆ (σ ⇒ τ) ⋆ ΔType (σ ⇒ τ) ⋆ Γ
      ρ′ : ⟦ Γ′ ⟧
      ρ′ = v • (⟦ t ⟧ ρ) • (⟦ Δt ⟧ ρ) • ρ
      x  : Term Γ′ σ
      x  = var this
      f  : Term Γ′ (σ ⇒ τ)
      f  = var (that this)
      Δf : Term Γ′ (ΔType (σ ⇒ τ))
      Δf = var (that (that this))
      y  = app f x
      Δy = app (app Δf x) (x ⊝ x)
    in
      begin
        ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (v ⟦⊝₍ σ ₎⟧ v)
      ≡⟨ cong (λ hole → ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v hole)
           (meaning-⊝ {s = x} {x} {ρ′}) ⟩
        ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (⟦ x ⊝ x ⟧ ρ′)
      ≡⟨ meaning-⊕ {t = y} {Δt = Δy} {ρ′} ⟩
        ⟦ y ⊕₍ τ ₎ Δy ⟧ ρ′
      ∎)
    where
      open ≡-Reasoning
      open Disambiguation

  meaning-⊝ {base ι} {Γ} {s} {t} {ρ} = meaning-⊝-base ι {Γ} {s} {t} {ρ}
  meaning-⊝ {σ ⇒ τ} {Γ} {s} {t} {ρ} =
    ext (λ v → ext (λ Δv →
    let
      Γ′ = ΔType σ ⋆ σ ⋆ (σ ⇒ τ) ⋆ (σ ⇒ τ) ⋆ Γ
      ρ′ : ⟦ Γ′ ⟧Context
      ρ′ = Δv • v • ⟦ t ⟧Term ρ • ⟦ s ⟧Term ρ • ρ
      Δx : Term Γ′ (ΔType σ)
      Δx = var this
      x  : Term Γ′ σ
      x  = var (that this)
      f  : Term Γ′ (σ ⇒ τ)
      f  = var (that (that this))
      g  : Term Γ′ (σ ⇒ τ)
      g  = var (that (that (that this)))
      y  = app f x
      y′ = app g (x ⊕₍ σ ₎ Δx)
    in
      begin
        ⟦ s ⟧ ρ (v ⟦⊕₍ σ ₎⟧ Δv) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
      ≡⟨ cong (λ hole → ⟦ s ⟧ ρ hole ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v)
           (meaning-⊕ {t = x} {Δt = Δx} {ρ′}) ⟩
        ⟦ s ⟧ ρ (⟦ x ⊕₍ σ ₎ Δx ⟧ ρ′) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
      ≡⟨ meaning-⊝ {s = y′} {y} {ρ′} ⟩
        ⟦ y′ ⊝ y ⟧ ρ′
      ∎))
    where
      open ≡-Reasoning
      open Disambiguation


Added x≥0 (ER version).

Added x≥0 (ER version).

Ignore-this: 156a203f7f01a3daa606860ed4c0c3ff

darcs-hash:20100502224943-3bd4e-e29c673de3e2161e48fc06c1830f38eee3d7f0f5.gz

------------------------------------------------------------------------------
-- Properties of the inequalities (using equational reasoning)
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Relation.Inequalities
open import LTC.Data.N
open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = true≠false $ trans (sym 0>n ) $ x≥0 Nn

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 {d} Sx≤0 = true≠false $ trans (sym $ lt-0S d ) Sx≤0

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  subst (λ a → a ≡ true ∨ a ≡ false)
        (sym $ lt-SS n m)
        (x>y∨x≤y Nm Nn )

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN          0<0   = ⊥-elim (true≠false (trans (sym 0<0) lt-00))
¬x<x (sN {m} Nm) Sm<Sm = ⊥-elim (¬x<x Nm (trans (sym (lt-SS m m)) Sm<Sm))

------------------------------------------------------------------------------
-- Properties of the inequalities (using equational reasoning)
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Relation.Inequalities
open import LTC.Relation.Inequalities.Properties using ( x≥0 )
open import LTC.Data.N
open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = true≠false $ trans (sym 0>n ) $ x≥0 Nn

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 {d} Sx≤0 = true≠false $ trans (sym $ lt-0S d ) Sx≤0

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  subst (λ a → a ≡ true ∨ a ≡ false)
        (sym $ lt-SS n m)
        (x>y∨x≤y Nm Nn )

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN          0<0   = ⊥-elim (true≠false (trans (sym 0<0) lt-00))
¬x<x (sN {m} Nm) Sm<Sm = ⊥-elim (¬x<x Nm (trans (sym (lt-SS m m)) Sm<Sm))


add ≗₂

add ≗₂

{-# OPTIONS --universe-polymorphism #-}
-- move this to propeq
module Relation.Binary.PropositionalEquality.NP where

open import Relation.Binary.PropositionalEquality public hiding (module ≡-Reasoning)
open import Relation.Binary.NP
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
open import Relation.Nullary

cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {a₁ a₂ b₁ b₂ c₁ c₂}
        → a₁ ≡ a₂ → b₁ ≡ b₂ → c₁ ≡ c₂ → f a₁ b₁ c₁ ≡ f a₂ b₂ c₂
cong₃ f refl refl refl = refl

_≡≡_ : ∀ {a} {A : Set a} {i j : A}
         (i≡j₁ : i ≡ j) (i≡j₂ : i ≡ j) → i≡j₁ ≡ i≡j₂
_≡≡_ refl refl = refl

_≟≡_ : ∀ {a} {A : Set a} {i j : A} → Decidable {A = i ≡ j} _≡_
_≟≡_ refl refl = yes refl

_≗₂_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} (f g : A → B → C) → Set _
f ≗₂ g = ∀ x y → f x y ≡ g x y

injective : ∀ {a} {A : Set a} → InjectiveRel A _≡_
injective refl refl = refl

surjective : ∀ {a} {A : Set a} → SurjectiveRel A _≡_
surjective refl refl = refl

bijective : ∀ {a} {A : Set a} → BijectiveRel A _≡_
bijective = record { injectiveREL = injective; surjectiveREL = surjective }

module ≡-Reasoning {a} {A : Set a} where
  open Setoid-Reasoning (setoid A) public renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

module ≗-Reasoning {a b} {A : Set a} {B : Set b} where
  open Setoid-Reasoning (A →-setoid B) public renaming (_≈⟨_⟩_ to _≗⟨_⟩_)

data ⟦≡⟧ {a₁ a₂ aᵣ}
         {A₁ A₂} (Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂)
         {x₁ x₂} (xᵣ : Aᵣ x₁ x₂)
       : (Aᵣ ⟦→⟧ ⟦Set⟧ aᵣ) (_≡_ x₁) (_≡_ x₂) where
    -- : ∀ {y₁ y₂} (yᵣ : Aᵣ y₁ y₂) → x₁ ≡ y₁ → x₂ ≡ y₂ → Set
  ⟦refl⟧ : ⟦≡⟧ Aᵣ xᵣ xᵣ refl refl

-- Double checking level 0 with a direct ⟦_⟧ encoding
private
  ⟦≡⟧′ : (∀⟨ Aᵣ ∶ ⟦Set₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦Set₀⟧) _≡_ _≡_
  ⟦≡⟧′ = ⟦≡⟧

  ⟦refl⟧′ : (∀⟨ Aᵣ ∶ ⟦Set₀⟧ ⟩⟦→⟧ ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟦≡⟧ Aᵣ xᵣ xᵣ) refl refl
  ⟦refl⟧′ _ _ = ⟦refl⟧

{-# OPTIONS --universe-polymorphism #-}
-- move this to propeq
module Relation.Binary.PropositionalEquality.NP where

open import Relation.Binary.PropositionalEquality public hiding (module ≡-Reasoning)
open import Relation.Binary.NP
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
open import Relation.Nullary

cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {a₁ a₂ b₁ b₂ c₁ c₂}
        → a₁ ≡ a₂ → b₁ ≡ b₂ → c₁ ≡ c₂ → f a₁ b₁ c₁ ≡ f a₂ b₂ c₂
cong₃ f refl refl refl = refl

_≡≡_ : ∀ {a} {A : Set a} {i j : A}
         (i≡j₁ : i ≡ j) (i≡j₂ : i ≡ j) → i≡j₁ ≡ i≡j₂
_≡≡_ refl refl = refl

_≟≡_ : ∀ {a} {A : Set a} {i j : A} → Decidable {A = i ≡ j} _≡_
_≟≡_ refl refl = yes refl

injective : ∀ {a} {A : Set a} → InjectiveRel A _≡_
injective refl refl = refl

surjective : ∀ {a} {A : Set a} → SurjectiveRel A _≡_
surjective refl refl = refl

bijective : ∀ {a} {A : Set a} → BijectiveRel A _≡_
bijective = record { injectiveREL = injective; surjectiveREL = surjective }

module ≡-Reasoning {a} {A : Set a} where
  open Setoid-Reasoning (setoid A) public renaming (_≈⟨_⟩_ to _≡⟨_⟩_)

module ≗-Reasoning {a b} {A : Set a} {B : Set b} where
  open Setoid-Reasoning (A →-setoid B) public renaming (_≈⟨_⟩_ to _≗⟨_⟩_)

data ⟦≡⟧ {a₁ a₂ aᵣ}
         {A₁ A₂} (Aᵣ : ⟦Set⟧ {a₁} {a₂} aᵣ A₁ A₂)
         {x₁ x₂} (xᵣ : Aᵣ x₁ x₂)
       : (Aᵣ ⟦→⟧ ⟦Set⟧ aᵣ) (_≡_ x₁) (_≡_ x₂) where
    -- : ∀ {y₁ y₂} (yᵣ : Aᵣ y₁ y₂) → x₁ ≡ y₁ → x₂ ≡ y₂ → Set
  ⟦refl⟧ : ⟦≡⟧ Aᵣ xᵣ xᵣ refl refl

-- Double checking level 0 with a direct ⟦_⟧ encoding
private
  ⟦≡⟧′ : (∀⟨ Aᵣ ∶ ⟦Set₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦Set₀⟧) _≡_ _≡_
  ⟦≡⟧′ = ⟦≡⟧

  ⟦refl⟧′ : (∀⟨ Aᵣ ∶ ⟦Set₀⟧ ⟩⟦→⟧ ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟦≡⟧ Aᵣ xᵣ xᵣ) refl refl
  ⟦refl⟧′ _ _ = ⟦refl⟧


Desc@ICFP: really update the model this time

I confused myself in the previous patch. I had been editing the
semi-old code, while the good one was in RevisedHutton. I've now
merged RevisedHutton into IDescTT.

 {-# OPTIONS --type-in-type #-}

module IDescTT where

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

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

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

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

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

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

data Zero : Set where
data Unit  : Set where
  Void : Unit

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

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

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

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

subst : forall {x y} -> x == y -> x -> y
subst refl x = x

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

cong2 : {A B C : Set}(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

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

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

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

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

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

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

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

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

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

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

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

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    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

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

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

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

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type
  pair : Type -> Type -> Type

--********************************
-- Typed expressions
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool
Val (pair x y) = (Val x) * (Val y)

-- Fix menu:
exprFixMenu : FixMenu Type
exprFixMenu = ( consE (consE nilE) ,
                \ty -> (const (Val ty),                           -- Val t
                       (prod (var bool) (prod (var ty) (var ty)), -- if b then t1 else t2
                       Void)))

-- Indexed menu:
choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE
choiceMenu (pair x y) = nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )
choiceDessert (pair x y) = Void

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

-- Expression:
expr : TagIDesc Type
expr = exprFixMenu , exprSensitiveMenu

exprIDesc : TagIDesc Type -> (Type -> IDesc Type)
exprIDesc D = toIDesc Type D

--********************************
-- Closed terms
--********************************

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc expr

--********************************
-- Closed term evaluation
--********************************

eval : {ty : Type} -> IMu closeTerm ty -> Val ty
eval {ty} term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)
              evalOneStep (pair x y) (ESu (ESu ()) , _)

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

Empty : Type -> Set
Empty _ = Zero

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (expr ** Empty)

--********************************
-- Closed term' evaluation
--********************************

eval' : {ty : Type} -> IMu closeTerm' ty -> Val ty
eval' {ty} term = cata Type closeTerm' Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm' ty |] Val -> Val ty
              evalOneStep _ (EZe , ())
              evalOneStep _ (ESu EZe , t) = t
              evalOneStep _ ((ESu (ESu EZe)) , (true , ( x , _))) = x
              evalOneStep _ ((ESu (ESu EZe)) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu (ESu EZe))) , (x , y)) = plus x y
              evalOneStep nat (((ESu (ESu (ESu (ESu ()))))) , t)
              evalOneStep bool ((ESu (ESu (ESu EZe))) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu (ESu ())))) , _)
              evalOneStep (pair x y) (ESu (ESu (ESu ())) , _)

--********************************
-- Open terms
--********************************

-- A context is a snoc-list of types
-- put otherwise, a context is a type telescope
data Context : Set where
  [] : Context
  _,_ : Context -> Type -> Context

-- The environment realizes the context, having a value for each type
Env : Context -> Set
Env []      = Unit
Env (G , S)  = Env G * Val S

-- A typed-variable indexes into the context, obtaining a proof that
-- what we get is what you want (WWGIWYW)
Var : Context -> Type -> Set
Var []      T = Zero
Var (G , S) T = Var G T + (S == T)

-- The lookup gets into the context to extract the value
lookup : (G : Context) -> Env G -> (T : Type) -> Var G T -> Val T
lookup []        _       T ()
lookup (G , .T)  (g , t) T (r refl) = t
lookup (G , S)   (g , t) T (l x)    = lookup G g T x

-- Open term: holes are either values or variables in a context
openTerm : Context -> Type -> IDesc Type
openTerm c = toIDesc Type (expr ** (Var c))

--********************************
-- Evaluation of open terms
--********************************

-- |discharge| is the local substitution expected by |substI|. It is
-- just sugar around context lookup
discharge : (context : Context) ->
            Env context ->
            (ty : Type) ->
            Var context ty ->
            IMu closeTerm' ty
discharge ctxt env ty variable = con (ESu EZe , lookup ctxt env ty variable )

-- |substExpr| is the specialized |substI| to expressions. We get it
-- generically from the free monad construction.
substExpr : {ty : Type}
            (context : Context)
            (sigma : (ty : Type) ->
                     Var context ty ->
                     IMu closeTerm' ty) ->
            IMu (openTerm context) ty ->
            IMu closeTerm' ty
substExpr {ty} c sig term =
    substI (Var c) Empty expr sig ty term

-- By first doing substitution to close the term, we can use
-- evaluation of closed terms, obtaining evaluation of open terms
-- under a valid context.
evalOpen : {ty : Type}(context : Context) ->
           Env context ->
           IMu (openTerm context) ty ->
           Val ty
evalOpen ctxt env tm = eval' (substExpr ctxt (discharge ctxt env) tm)

--********************************
-- Tests
--********************************

-- Test context:
-- V 0 :-> true, V 1 :-> 2, V 2 :-> ( false , 1 )
testContext : Context
testContext = (([] , bool) , nat) , pair bool nat
testEnv : Env testContext
testEnv = ((Void , true ) , su (su ze)) , (false , su ze)

-- V 1
test1 : IMu (openTerm testContext) nat
test1 = con (EZe , ( l (r refl) ) )

testSubst1 : IMu closeTerm' nat
testSubst1 = substExpr testContext
                       (discharge testContext testEnv)
                       test1
-- = 2
testEval1 : Val nat
testEval1 = evalOpen testContext testEnv test1

-- add 1 (V 1)
test2 : IMu (openTerm testContext) nat
test2 = con (ESu (ESu (ESu EZe)) , (con (ESu EZe , su ze) , con ( EZe , l (r refl) )) )

testSubst2 : IMu closeTerm' nat
testSubst2 = substExpr testContext
                       (discharge testContext testEnv)
                        test2

-- = 3
testEval2 : Val nat
testEval2 = evalOpen testContext testEnv test2

-- if (V 0) then (V 1) else 0
test3 : IMu (openTerm testContext) nat
test3 = con (ESu (ESu EZe) , (con (EZe , l (l (r refl))) ,
                             (con (EZe , l (r refl)) ,
                              con (ESu EZe , ze))))

testSubst3 : IMu closeTerm' nat
testSubst3 = substExpr testContext
                       (discharge testContext testEnv)
                       test3

-- = 2
testEval3 : Val nat
testEval3 = evalOpen testContext testEnv test3

-- V 2
test4 : IMu (openTerm testContext) (pair bool nat)
test4 = con (EZe ,  r refl  )

testSubst4 : IMu closeTerm' (pair bool nat)
testSubst4 = substExpr testContext
                       (discharge testContext testEnv)
                       test4
-- = (false , 1)
testEval4 : Val (pair bool nat)
testEval4 = evalOpen testContext testEnv test4

 {-# OPTIONS --type-in-type #-}

module IDescTT where

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

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

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

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

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

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

data Zero : Set where
data Unit  : Set where
  Void : Unit

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

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

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

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

subst : forall {x y} -> x == y -> x -> y
subst refl x = x

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

cong2 : {A B C : Set}(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

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

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

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

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

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

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

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

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

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

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

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

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    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

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

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

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

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type
  pair : Type -> Type -> Type

--********************************
-- Typed expressions
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool
Val (pair x y) = (Val x) * (Val y)

-- Fix menu:
exprFixMenu : FixMenu Type
exprFixMenu = ( consE (consE nilE) ,
                \ty -> (const (Val ty),                           -- Val t
                       (prod (var bool) (prod (var ty) (var ty)), -- if b then t1 else t2
                       Void)))

-- Indexed menu:
choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE
choiceMenu (pair x y) = nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )
choiceDessert (pair x y) = Void

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

-- Expression:
expr : TagIDesc Type
expr = exprFixMenu , exprSensitiveMenu

exprIDesc : TagIDesc Type -> (Type -> IDesc Type)
exprIDesc D = toIDesc Type D

--********************************
-- Closed terms
--********************************

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc expr

--********************************
-- Closed term evaluation
--********************************

eval : {ty : Type} -> IMu closeTerm ty -> Val ty
eval {ty} term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)
              evalOneStep (pair x y) (ESu (ESu ()) , _)

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

Empty : Type -> Set
Empty _ = Zero

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (expr ** Empty)

--********************************
-- Closed term' evaluation
--********************************

eval' : {ty : Type} -> IMu closeTerm' ty -> Val ty
eval' {ty} term = cata Type closeTerm' Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm' ty |] Val -> Val ty
              evalOneStep _ (EZe , ())
              evalOneStep _ (ESu EZe , t) = t
              evalOneStep _ ((ESu (ESu EZe)) , (true , ( x , _))) = x
              evalOneStep _ ((ESu (ESu EZe)) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu (ESu EZe))) , (x , y)) = plus x y
              evalOneStep nat (((ESu (ESu (ESu (ESu ()))))) , t)
              evalOneStep bool ((ESu (ESu (ESu EZe))) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu (ESu ())))) , _)
              evalOneStep (pair x y) (ESu (ESu (ESu ())) , _)

--********************************
-- Open terms
--********************************

data Vec (A : Set) : Nat -> Set where
   vnil : Vec A ze
   vcons : {n : Nat} -> A -> Vec A n -> Vec A (su n)

data Fin : Nat -> Set where
  fze : {n : Nat} -> Fin (su n)
  fsu : {n : Nat} -> Fin n -> Fin (su n)

Context : Nat -> Set
Context n = Vec (Sigma Type (\ty -> IMu closeTerm' ty)) n

typeAt : {n : Nat}(c : Context n) -> Fin n -> Type
typeAt {ze} c ()
typeAt {.(su n)} (vcons x xs) (fze {n}) = fst x
typeAt {.(su n)} (vcons x xs) (fsu {n} y) = typeAt xs y

lookup : {n : Nat}(c : Context n)(i : Fin n) -> IMu closeTerm' (typeAt c i)
lookup {ze} c ()
lookup {su _} (vcons x _) fze = snd x
lookup {su _} (vcons _ xs) (fsu y) = lookup xs y

Var : {n : Nat} -> Context n -> Type -> Set
Var {n} c ty = Sigma (Fin n) (\i -> typeAt c i == ty)

openTerm : {n : Nat} -> Context n -> Type -> IDesc Type
openTerm c = toIDesc Type (expr ** (Var c))

--********************************
-- Evaluation of open terms
--********************************

discharge : {n : Nat}
             {context : Context n}
             (ty : Type) ->
             Var context ty ->
             IMu closeTerm' ty
discharge {n} {c} ty variable = subst (cong (IMu closeTerm') (snd variable)) (lookup c (fst variable))

substExpr : {n : Nat}
             {ty : Type}
             (context : Context n)
             (sigma : (ty : Type) ->
                      Var context ty ->
                      IMu closeTerm' ty) ->
             IMu (openTerm context) ty ->
             IMu closeTerm' ty
substExpr {n} {ty} c sig term =
    substI (Var c) Empty expr sig ty term

evalOpen : {n : Nat}{ty : Type}
           (context : Context n) ->
           IMu (openTerm context) ty ->
           Val ty
evalOpen context tm = eval' (substExpr context discharge tm)

--********************************
-- Tests
--********************************

-- V 0 :-> true, V 1 :-> 2, V 2 :-> ( false , 1 )
testContext : Context _
testContext =  vcons (bool , con ((ESu EZe) , true ))
              (vcons (nat , con ((ESu EZe) , su (su ze)) )
              (vcons (pair bool nat , con ((ESu EZe) , ( false , su ze )))
               vnil))

-- V 1
test1 : IMu (openTerm testContext) nat
test1 = con (EZe , ( fsu fze , refl ) )

testSubst1 : IMu closeTerm' nat
testSubst1 = substExpr testContext
                       discharge
                       test1
-- = 2
testEval1 : Val nat
testEval1 = evalOpen testContext test1

-- add 1 (V 1)
test2 : IMu (openTerm testContext) nat
test2 = con ((ESu (ESu (ESu EZe))) , (con ((ESu EZe) , (su ze)) , con ( EZe , (fsu fze , refl) )) )

testSubst2 : IMu closeTerm' nat
testSubst2 = substExpr testContext
                        discharge
                        test2

-- = 3
testEval2 : Val nat
testEval2 = evalOpen testContext test2

-- if (V 0) then (V 1) else 0
test3 : IMu (openTerm testContext) nat
test3 = con (ESu (ESu EZe) , (con (EZe , (fze , refl)) ,
                             (con (EZe , (fsu fze , refl)) ,
                              con (ESu EZe , ze))))

testSubst3 : IMu closeTerm' nat
testSubst3 = substExpr testContext
                       discharge
                       test3

-- = 2
testEval3 : Val nat
testEval3 = evalOpen testContext test3

-- V 2
test4 : IMu (openTerm testContext) (pair bool nat)
test4 = con (EZe , ( fsu (fsu fze) , refl ) )

testSubst4 : IMu closeTerm' (pair bool nat)
testSubst4 = substExpr testContext
                       discharge
                       test4
-- = (false , 1)
testEval4 : Val (pair bool nat)
testEval4 = evalOpen testContext test4


FunBigStepSILR.agda: progress till I get stuck

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by Dargaye and Leroy (2010), "A
-- verified framework for higher-order uncurrying optimizations" (and a bit by
-- "Functional Big-Step Semantics"), though I deviate somewhere.
module Thesis.FunBigStepSILR where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)

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

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool! (Commented out until I paste that semantics here.)
-- eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
--   eval t ρ n ≡ Done v →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

-- apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
--   ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
--   apply f a n ≡ Done v →
--   ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
-- apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

-- eval-sound ρ v zero t ()
-- eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
-- eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
-- eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
-- eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
-- eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
--   let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
-- eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
-- eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- -- eval-sound n (const c) eq = {!!}
-- -- eval-sound n (var x) eq = {!!}
-- -- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- -- eval-sound n (abs t) eq = {!!}
-- -- eval-sound n (const c) eq = {!!}
-- -- eval-sound n (var x) eq = {!!}
-- -- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- -- eval-sound n (abs t) eq = {!!}

relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

-- Indexing not according to source. But I can't quite write the correct
-- indexing without changing the definitions a lot.
relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
relT {τ} t1 t2 ρ1 ρ2 n =
  (v1 : Val τ) →
  eval t1 ρ1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (eval t2 ρ2 n ≡ Done v2 × relV τ v1 v2 n)

relV τ v1 v2 zero = ⊤
relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) =
  ∀ (k : ℕ) (k≤n : k ≤ n) →
  ∀ v1 v2 → relV σ v1 v2 k → relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
relV nat v1 v2 (suc n) = v1 ≡ v2

open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl)

relV-apply-go : ∀ {σ τ} sv1 sv2 tv1 tv2
  n
  (svv : relV (σ ⇒ τ) sv1 sv2 n)
  (tvv : relV σ tv1 tv2 n)
  v1 →
  apply sv1 tv1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (apply sv2 tv2 n ≡ Done v2 × relV τ v1 v2 (suc n))
relV-apply-go (closure st1 ρ1) (closure st2 ρ2) tv1 tv2 zero svv tvv v1 ()
relV-apply-go (closure st1 ρ1) (closure st2 ρ2) tv1 tv2 (suc n) svv tvv v1 eqv1 with svv n ≤-refl tv1 tv2 {! tvv !} v1 {! eqv1 !}
... | v2 , eqv2 , final-v = v2 , {! eqv2 !} , {! final-v !}

relV-apply : ∀ {σ τ sv1 sv2 tv1 tv2}
  n
  (svv : relV (σ ⇒ τ) sv1 sv2 n)
  (tvv : relV σ tv1 tv2 n)
  {v1} →
  apply sv1 tv1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (apply sv2 tv2 n ≡ Done v2 × relV τ v1 v2 (suc n))
relV-apply n svv tvv eqv1 = relV-apply-go _ _ _ _ n svv tvv _ eqv1

open import Data.Nat.Properties

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono zero n m≤n τ v1 v2 vv = tt
relV-mono (suc m) zero () τ v1 v2 vv
relV-mono (suc m) (suc n) m≤n nat v1 v2 vv = vv
relV-mono (suc m) (suc n) (_≤_.s≤s m≤n) (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) vv k k≤m = vv k (DecTotalOrder.trans decTotalOrder k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

-- relV-mono τ v1 v2 vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k ?

-- relV-mono : ∀ τ v1 v2 n → relV τ v1 v2 (suc n) → relV τ v1 v2 n
-- relV-mono τ v1 v2 zero vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k (≤-step k≤n)

-- fundamental lemma of logical relations.
fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero _ _ _ _ ()
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 refl = v2 , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ v ()
-- XXX trivial case for constants.
fundamental (const (lit nv)) (suc n) ρ1 ρ2 ρρ .(intV nv) refl = intV nv , refl , refl
fundamental (var x) (suc n) ρ1 ρ2 ρρ v1 refl = fundamentalV x (suc n) ρ1 ρ2 ρρ (⟦ x ⟧Var ρ1) refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ (closure .t .ρ1) refl =
  closure t ρ2 , refl , λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k _ (≤-step k≤n) _ _ _ ρρ)
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 with eval s ρ1 n | inspect (eval s ρ1) n | eval t ρ1 n | inspect (eval t ρ1) n
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 seq1 | fundamental t n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) tv1 teq1
fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] | Done sv2 | [ seq2 ] | Done tv2 | (.sv2 , refl , svv) | (.tv2 , refl , tvv) = relV-apply n svv tvv tρ1↓v1
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv1 | [ seq1 ] | TimeOut | [ teq1 ]
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | [ seq1 ] | tv1 | [ teq1 ]

-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 seq1
--... | sv2 | [ seq2 ] | tv2 | (sv2' , sρ2↓sv2 , svv) = ?

-- TODO: match sv2 before matching on fundamental s.
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) | [ teq1 ] | (sv2' , sρ2↓sv2 , svv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | TimeOut | [ teq1 ] | (sv2' , sρ2↓sv2 , svv) with fundamental t n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) tv1 {!teq1!}
-- ... | (tv2' , tρ2↓tv2 , tvv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | TimeOut | [ eq2 ] | b | [ teq1 ] | (sv2' , () , svv)

-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) | (sv2' , sρ2↓sv2 , svv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | TimeOut = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | TimeOut | [ eq2 ] | tv2 = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 | (sv2 , sρ2↓sv2 , svv) = v2 , {!!}
--   where
--     v2 : Val τ
--     v2 = {!!}
--     -- tρ2↓v2 : apply sv2 tv2 n ≡ Done v1
--     -- tρ2↓v2 = ?
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv | _ | TimeOut
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | Done tv1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | TimeOut

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "A verified framework for
-- higher-order uncurrying optimizations" (and a bit by "Functional Big-Step
-- Semantics"), though I deviate somewhere.
module Thesis.FunBigStepSILR where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)

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

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool! (Commented out until I paste that semantics here.)
-- eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
--   eval t ρ n ≡ Done v →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

-- apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
--   ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
--   ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
--   apply f a n ≡ Done v →
--   ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
-- apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

-- eval-sound ρ v zero t ()
-- eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
-- eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
-- eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
-- eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
-- eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
--   let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
-- eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
-- eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- -- eval-sound n (const c) eq = {!!}
-- -- eval-sound n (var x) eq = {!!}
-- -- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- -- eval-sound n (abs t) eq = {!!}
-- -- eval-sound n (const c) eq = {!!}
-- -- eval-sound n (var x) eq = {!!}
-- -- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- -- eval-sound n (abs t) eq = {!!}

relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

-- Indexing not according to source. But I can't quite write the correct
-- indexing without changing the definitions a lot.
relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
relT {τ} t1 t2 ρ1 ρ2 n =
  (v1 : Val τ) →
  eval t1 ρ1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (eval t2 ρ2 n ≡ Done v2 × relV τ v1 v2 n)

relV τ v1 v2 zero = ⊤
relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) =
  ∀ (k : ℕ) (k≤n : k ≤ n) →
  ∀ v1 v2 → relV σ v1 v2 k → relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
relV nat v1 v2 (suc n) = v1 ≡ v2

open import Data.Nat.Properties

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono zero n m≤n τ v1 v2 vv = tt
relV-mono (suc m) zero () τ v1 v2 vv
relV-mono (suc m) (suc n) m≤n nat v1 v2 vv = vv
relV-mono (suc m) (suc n) (_≤_.s≤s m≤n) (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) vv k k≤m = vv k (DecTotalOrder.trans decTotalOrder k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

-- relV-mono τ v1 v2 vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k ?

-- relV-mono : ∀ τ v1 v2 n → relV τ v1 v2 (suc n) → relV τ v1 v2 n
-- relV-mono τ v1 v2 zero vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k (≤-step k≤n)

-- fundamental lemma of logical relations.
fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero _ _ _ _ ()
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 refl = v2 , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ v ()
-- XXX trivial case for constants.
fundamental (const (lit nv)) (suc n) ρ1 ρ2 ρρ .(intV nv) refl = intV nv , refl , refl
fundamental (var x) (suc n) ρ1 ρ2 ρρ v1 refl = fundamentalV x (suc n) ρ1 ρ2 ρρ (⟦ x ⟧Var ρ1) refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ (closure .t .ρ1) refl =
  closure t ρ2 , refl , λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k _ (≤-step k≤n) _ _ _ ρρ)
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 with eval s ρ1 n | inspect (eval s ρ1) n | eval t ρ1 n
-- TODO: match sv2 before matching on fundamental s.
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq ] | Done tv1 with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq
fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq ] | Done tv1 | (sv2 , sρ2↓sv2 , svv) = v2 , {!!}
  where
    v2 : Val τ
    v2 = {!!}
    -- tρ2↓v2 : apply sv2 tv2 n ≡ Done v1
    -- tρ2↓v2 = ?
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv | _ | TimeOut
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | Done tv1
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | TimeOut


Add elimBool to operational semantics.

Add elimBool to operational semantics.

module Spire.Operational where

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

data Level : Set where
  zero : Level
  suc : Level → Level

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

data Context : Set
data Type (Γ : Context) : Set
data Value (Γ : Context) : Type Γ → Set
data Neutral (Γ : Context) : Type Γ → Set

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

data Context where
  ∅ : Context
  _,_ : (Γ : Context) → Type Γ → Context

data Type Γ where
  `⊥ `⊤ `Bool : Type Γ
  `Type : (ℓ : Level) → Type Γ
  `Π `Σ : (A : Type Γ) (B : Type (Γ , A)) → Type Γ
  `⟦_⟧ : ∀{ℓ} → Neutral Γ (`Type ℓ) → Type Γ

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

⟦_⟧ : ∀{Γ ℓ} → Value Γ (`Type ℓ) →  Type Γ

postulate
  wknT : ∀{Γ A} → Type Γ → Type (Γ , A)
  subT : ∀{Γ A} → Type (Γ , A) → Value Γ A → Type Γ
  subV : ∀{Γ A B} → Value (Γ , A) B → (x : Value Γ A) → Value Γ (subT B x)

data Var : (Γ : Context) (A : Type Γ) → Set where
  here : ∀{Γ A} → Var (Γ , A) (wknT A)
  there : ∀{Γ A B} → Var Γ A → Var (Γ , B) (wknT A)

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

data Value Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Value Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Value Γ (`Type ℓ)) (B : Value (Γ , ⟦ A ⟧) (`Type ℓ)) → Value Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Value Γ (`Type ℓ) → Value Γ (`Type (suc ℓ))

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

data Neutral Γ where
  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Neutral Γ A
  `if_`then_`else_ : ∀{C} (b : Neutral Γ `Bool) (c₁ c₂ : Value Γ C) → Neutral Γ C
  `elimBool : ∀{ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
    (pt : Value Γ (subT ⟦ P ⟧ `true))
    (pf : Value Γ (subT ⟦ P ⟧ `false))
    (b : Neutral Γ `Bool) → Neutral Γ (subT ⟦ P ⟧ (`neut b))
  `proj₁ : ∀{A B} → Neutral Γ (`Σ A B) → Neutral Γ A
  `proj₂ : ∀{A B} (ab : Neutral Γ (`Σ A B)) → Neutral Γ (subT B (`neut (`proj₁ ab)))
  _`$_ : ∀{A B} (f : Neutral Γ (`Π A B)) (a : Value Γ A) → Neutral Γ (subT B a)

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

⟦ `Π A B ⟧ = `Π ⟦ A ⟧ ⟦ B ⟧
⟦ `Σ A B ⟧ = `Σ ⟦ A ⟧ ⟦ B ⟧
⟦ `⊥ ⟧ = `⊥
⟦ `⊤ ⟧ = `⊤
⟦ `Bool ⟧ = `Bool
⟦ `Type {zero} ⟧ = `⊥
⟦ `Type {suc ℓ} ⟧ = `Type ℓ
⟦ `⟦ A ⟧ ⟧ = ⟦ A ⟧
⟦ `neut A ⟧ = `⟦ A ⟧

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

if_then_else_ : ∀{Γ C} (b : Value Γ `Bool) (c₁ c₂ : Value Γ C) → Value Γ C
if `true then c₁ else c₂ = c₁
if `false then c₁ else c₂ = c₂
if `neut b then c₁ else c₂ = `neut (`if b `then c₁ `else c₂)

elimBool : ∀{Γ ℓ} (P : Value (Γ , `Bool) (`Type ℓ))
  (pt : Value Γ (subT ⟦ P ⟧ `true))
  (pf : Value Γ (subT ⟦ P ⟧ `false))
  (b : Value Γ `Bool)
  → Value Γ (subT ⟦ P ⟧ b)
elimBool P pt pf `true = pt
elimBool P pt pf `false = pf
elimBool P pt pf (`neut b) = `neut (`elimBool P pt pf b)

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

proj₁ : ∀{Γ A B} → Value Γ (`Σ A B) → Value Γ A
proj₁ (a `, b) = a
proj₁ (`neut ab) = `neut (`proj₁ ab)

proj₂ : ∀{Γ A B} (ab : Value Γ (`Σ A B)) → Value Γ (subT B (proj₁ ab))
proj₂ (a `, b) = b
proj₂ (`neut ab) = `neut (`proj₂ ab)

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

_$_ : ∀{Γ A B} → Value Γ (`Π A B) → (a : Value Γ A) → Value Γ (subT B a)
`λ b $ a = subV b a
`neut f $ a = `neut (f `$ a)

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

data Term (Γ : Context) : Type Γ → Set
eval : ∀{Γ A} → Term Γ A → Value Γ A

data Term Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Term Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Term Γ (`Type ℓ)) (B : Term (Γ , ⟦ eval A ⟧) (`Type ℓ)) → Term Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Term Γ (`Type ℓ) → Term Γ (`Type (suc ℓ))

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)

  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Term Γ A
  `if_`then_`else_ : ∀{C}
    (b : Term Γ `Bool)
    (c₁ c₂ : Term Γ C)
    → Term Γ C
  _`$_ : ∀{A B} (f : Term Γ (`Π A B)) (a : Term Γ A) → Term Γ (subT B (eval a))
  `proj₁ : ∀{A B} → Term Γ (`Σ A B) → Term Γ A
  `proj₂ : ∀{A B} (ab : Term Γ (`Σ A B)) → Term Γ (subT B (proj₁ (eval ab)))
  `elimBool : ∀{ℓ} (P : Term (Γ , `Bool) (`Type ℓ))
    (pt : Term Γ (subT ⟦ eval P ⟧ `true))
    (pf : Term Γ (subT ⟦ eval P ⟧ `false))
    (b : Term Γ `Bool)
    → Term Γ (subT ⟦ eval P ⟧ (eval b))

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

{- Type introduction -}
eval `⊥ = `⊥
eval `⊤ = `⊤
eval `Bool = `Bool
eval `Type = `Type
eval (`Π A B) = `Π (eval A) (eval B)
eval (`Σ A B) = `Σ (eval A) (eval B)
eval `⟦ A ⟧ = `⟦ eval A ⟧

{- Value introduction -}
eval `tt = `tt
eval `true = `true
eval `false = `false
eval (a `, b) = eval a `, eval b

{- Value elimination -}
eval (`var i) = `neut (`var i)
eval (`if b `then c₁ `else c₂) = if eval b then eval c₁ else eval c₂
eval (f `$ a) = eval f $ eval a
eval (`proj₁ ab) = proj₁ (eval ab)
eval (`proj₂ ab) = proj₂ (eval ab)
eval (`elimBool P pt pf b) = elimBool (eval P) (eval pt) (eval pf) (eval b)

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

module Spire.Operational where

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

data Level : Set where
  zero : Level
  suc : Level → Level

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

data Context : Set
data Type (Γ : Context) : Set
data Value (Γ : Context) : Type Γ → Set
data Neutral (Γ : Context) : Type Γ → Set

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

data Context where
  ∅ : Context
  _,_ : (Γ : Context) → Type Γ → Context

data Type Γ where
  `⊥ `⊤ `Bool : Type Γ
  `Type : (ℓ : Level) → Type Γ
  `Π `Σ : (A : Type Γ) (B : Type (Γ , A)) → Type Γ
  `⟦_⟧ : ∀{ℓ} → Neutral Γ (`Type ℓ) → Type Γ

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

⟦_⟧ : ∀{Γ ℓ} → Value Γ (`Type ℓ) →  Type Γ

postulate
  wknT : ∀{Γ A} → Type Γ → Type (Γ , A)
  subT : ∀{Γ A} → Type (Γ , A) → Value Γ A → Type Γ
  subV : ∀{Γ A B} → Value (Γ , A) B → (x : Value Γ A) → Value Γ (subT B x)

data Var : (Γ : Context) (A : Type Γ) → Set where
  here : ∀{Γ A} → Var (Γ , A) (wknT A)
  there : ∀{Γ A B} → Var Γ A → Var (Γ , B) (wknT A)

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

data Value Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Value Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Value Γ (`Type ℓ)) (B : Value (Γ , ⟦ A ⟧) (`Type ℓ)) → Value Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Value Γ (`Type ℓ) → Value Γ (`Type (suc ℓ))

  {- Value introduction -}
  `tt : Value Γ `⊤
  `true `false : Value Γ `Bool
  _`,_ : ∀{A B} (a : Value Γ A) (b : Value Γ (subT B a)) → Value Γ (`Σ A B)
  `λ : ∀{A B} → Value (Γ , A) B → Value Γ (`Π A B)
  `neut : ∀{A} → Neutral Γ A → Value Γ A

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

data Neutral Γ where
  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Neutral Γ A
  `if_`then_`else_ : ∀{C} (b : Neutral Γ `Bool) (c₁ c₂ : Value Γ C) → Neutral Γ C
  `proj₁ : ∀{A B} → Neutral Γ (`Σ A B) → Neutral Γ A
  `proj₂ : ∀{A B} (ab : Neutral Γ (`Σ A B)) → Neutral Γ (subT B (`neut (`proj₁ ab)))
  _`$_ : ∀{A B} (f : Neutral Γ (`Π A B)) (a : Value Γ A) → Neutral Γ (subT B a)

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

⟦ `Π A B ⟧ = `Π ⟦ A ⟧ ⟦ B ⟧
⟦ `Σ A B ⟧ = `Σ ⟦ A ⟧ ⟦ B ⟧
⟦ `⊥ ⟧ = `⊥
⟦ `⊤ ⟧ = `⊤
⟦ `Bool ⟧ = `Bool
⟦ `Type {zero} ⟧ = `⊥
⟦ `Type {suc ℓ} ⟧ = `Type ℓ
⟦ `⟦ A ⟧ ⟧ = ⟦ A ⟧
⟦ `neut A ⟧ = `⟦ A ⟧

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

if_then_else_ : ∀{Γ C} (b : Value Γ `Bool) (c₁ c₂ : Value Γ C) → Value Γ C
if `true then c₁ else c₂ = c₁
if `false then c₁ else c₂ = c₂
if `neut b then c₁ else c₂ = `neut (`if b `then c₁ `else c₂)

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

proj₁ : ∀{Γ A B} → Value Γ (`Σ A B) → Value Γ A
proj₁ (a `, b) = a
proj₁ (`neut ab) = `neut (`proj₁ ab)

proj₂ : ∀{Γ A B} (ab : Value Γ (`Σ A B)) → Value Γ (subT B (proj₁ ab))
proj₂ (a `, b) = b
proj₂ (`neut ab) = `neut (`proj₂ ab)

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

_$_ : ∀{Γ A B} → Value Γ (`Π A B) → (a : Value Γ A) → Value Γ (subT B a)
`λ b $ a = subV b a
`neut f $ a = `neut (f `$ a)

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

data Term (Γ : Context) : Type Γ → Set
eval : ∀{Γ A} → Term Γ A → Value Γ A

data Term Γ where
  {- Type introduction -}
  `⊥ `⊤ `Bool `Type : ∀{ℓ} → Term Γ (`Type ℓ)
  `Π `Σ : ∀{ℓ} (A : Term Γ (`Type ℓ)) (B : Term (Γ , ⟦ eval A ⟧) (`Type ℓ)) → Term Γ (`Type ℓ)
  `⟦_⟧ : ∀{ℓ} → Term Γ (`Type ℓ) → Term Γ (`Type (suc ℓ))

  {- Value introduction -}
  `tt : Term Γ `⊤
  `true `false : Term Γ `Bool
  _`,_ : ∀{A B}
    (a : Term Γ A) (b : Term Γ (subT B (eval a)))
    → Term Γ (`Σ A B)

  {- Value elimination -}
  `var : ∀{A} → Var Γ A → Term Γ A
  `if_`then_`else_ : ∀{C}
    (b : Term Γ `Bool)
    (c₁ c₂ : Term Γ C)
    → Term Γ C
  _`$_ : ∀{A B} (f : Term Γ (`Π A B)) (a : Term Γ A) → Term Γ (subT B (eval a))
  `proj₁ : ∀{A B} → Term Γ (`Σ A B) → Term Γ A
  `proj₂ : ∀{A B} (ab : Term Γ (`Σ A B)) → Term Γ (subT B (proj₁ (eval ab)))

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

{- Type introduction -}
eval `⊥ = `⊥
eval `⊤ = `⊤
eval `Bool = `Bool
eval `Type = `Type
eval (`Π A B) = `Π (eval A) (eval B)
eval (`Σ A B) = `Σ (eval A) (eval B)
eval `⟦ A ⟧ = `⟦ eval A ⟧

{- Value introduction -}
eval `tt = `tt
eval `true = `true
eval `false = `false
eval (a `, b) = eval a `, eval b

{- Value elimination -}
eval (`var i) = `neut (`var i)
eval (`if b `then c₁ `else c₂) = if eval b then eval c₁ else eval c₂
eval (f `$ a) = eval f $ eval a
eval (`proj₁ ab) = proj₁ (eval ab)
eval (`proj₂ ab) = proj₂ (eval ab)

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