agda: prove most of diff-apply (see #33)

Issue #33 discusses the remaining holes.

Old-commit-hash: a9aeee0162bb9af15ba0d4a4c8b85e53211bbb36

module total where

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

open import Data.Product
open import Data.Unit

open import Relation.Binary.PropositionalEquality

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

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

open import Changes
open import ChangeContexts

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data ValidΔ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds (valid : ValidΔ s ds) → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}
-- What I had to write:
valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {bool} v dv = ⊤
valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds (valid-w : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×
    (apply df f) (apply ds s) ≡ apply (df s ds) (f s)

derive-is-valid : ∀ {τ} (v : ⟦ τ ⟧) → valid-Δ {τ} v (derive v)
derive-is-valid {bool} v = tt
derive-is-valid {τ₁ ⇒ τ₂} v =
  λ s ds valid-Δ-s-ds → {!!} , (
    begin
      (apply (derive v) v) (apply ds s)
    ≡⟨ ≡-cong (λ x → x (apply ds s)) (apply-derive v) ⟩
      v (apply ds s)
    ≡⟨ sym (apply-diff (v s) (v (apply ds s))) ⟩
      apply (derive v s ds) (v s)
    ∎) where open ≡-Reasoning

-- This is a postulate elsewhere, but here I want to start developing a proper proof.

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

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

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

-- LIFTING terms into Δ-Contexts

lift-term : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ τ
lift-term {Γ₁} {Γ₂} {{Γ′}} = weaken (≼-trans ≼-Δ-Context Γ′)

-- PROPERTIES of lift-term

lift-term-ignore : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} {ρ : ⟦ Γ₂ ⟧} (t : Term Γ₁ τ) →
  ⟦ lift-term {{Γ′}} t ⟧ ρ ≡ ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
lift-term-ignore {{Γ′}} {ρ} t = let Γ″ = ≼-trans ≼-Δ-Context Γ′ in
  begin
    ⟦ lift-term {{Γ′}} t ⟧ ρ
  ≡⟨⟩
    ⟦ weaken Γ″ t ⟧ ρ
  ≡⟨ weaken-sound t ρ ⟩
    ⟦ t ⟧ (⟦ ≼-trans ≼-Δ-Context Γ′ ⟧ ρ)
  ≡⟨ cong (λ x → ⟦ t ⟧ x) (⟦⟧-≼-trans ≼-Δ-Context Γ′ ρ) ⟩
    ⟦ t ⟧Term (⟦ ≼-Δ-Context ⟧≼ (⟦ Γ′ ⟧≼ ρ))
  ≡⟨⟩
    ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
  ∎ where open ≡-Reasoning

-- PROPERTIES of Δ

Δ-abs : ∀ {τ₁ τ₂ Γ₁ Γ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t : Term (τ₁ • Γ₁) τ₂) →
  let Γ″ = keep Δ-Type τ₁ • keep τ₁ • Γ′ in
  Δ {{Γ′}} (abs t) ≈ abs (abs (Δ {τ₁ • Γ₁} t))
Δ-abs t = ext-t (λ ρ → refl)

Δ-app : ∀ {Γ₁ Γ₂ τ₁ τ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t₁ : Term Γ₁ (τ₁ ⇒ τ₂)) (t₂ : Term Γ₁ τ₁) →
  Δ {{Γ′}} (app t₁ t₂) ≈ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
Δ-app {{Γ′}} t₁ t₂ = ≈-sym (ext-t (λ ρ′ → let ρ = ⟦ Γ′ ⟧ ρ′ in
  begin
    ⟦ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂) ⟧ ρ′
  ≡⟨⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {{Γ′}} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨⟩
     ⟦ Δ {{Γ′}} (app t₁ t₂) ⟧ ρ′
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var {τ • Γ} this = this
derive-var {τ • Γ} (that x) = that (that (derive-var x))

derive-term : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ (Δ-Type τ)
derive-term {Γ₁} {{Γ′}} (abs {τ} t) = abs (abs (derive-term {τ • Γ₁} {{Γ″}} t))
  where Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term {{Γ′}} (app t₁ t₂) = app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
derive-term {{Γ′}} (var x) = var (lift Γ′ (derive-var x))
derive-term {{Γ′}} true = false
derive-term {{Γ′}} false = false
derive-term {{Γ′}} (if c t e) =
  if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} c))
    (diff-term (apply-term (derive-term {{Γ′}} e) (lift-term {{Γ′}} e)) (lift-term {{Γ′}} t))
    (if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} (! c)))
      (diff-term (apply-term (derive-term {{Γ′}} t) (lift-term {{Γ′}} t)) (lift-term {{Γ′}} e))
      (if (lift-term {{Γ′}} c)
        (derive-term {{Γ′}} t)
        (derive-term {{Γ′}} e)))
derive-term {{Γ′}} (Δ {{Γ″}} t) = Δ {{Γ′}} (derive-term {{Γ″}} t)

-- CORRECTNESS of derivation

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

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

module total where

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

open import Data.Product
open import Data.Unit

open import Relation.Binary.PropositionalEquality

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

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

open import Changes
open import ChangeContexts

-- DEFINITION of valid changes via a logical relation

{-
What I wanted to write:

data ValidΔ : {T : Type} → (v : ⟦ T ⟧) → (dv : ⟦ Δ-Type T ⟧) → Set where
  base : (v : ⟦ bool ⟧) → (dv : ⟦ Δ-Type bool ⟧) → ValidΔ v dv
  fun : ∀ {S T} → (f : ⟦ S ⇒ T ⟧) → (df : ⟦ Δ-Type (S ⇒ T) ⟧) →
    (∀ (s : ⟦ S ⟧) ds (valid : ValidΔ s ds) → (ValidΔ (f s) (df s ds)) × ((apply df f) (apply ds s) ≡ apply (df s ds) (f s))) →
    ValidΔ f df
-}
-- What I had to write:
valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {bool} v dv = ⊤
valid-Δ {S ⇒ T} f df =
  ∀ (s : ⟦ S ⟧) ds (valid-w : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×
    (apply df f) (apply ds s) ≡ apply (df s ds) (f s)

-- LIFTING terms into Δ-Contexts

lift-term : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ τ
lift-term {Γ₁} {Γ₂} {{Γ′}} = weaken (≼-trans ≼-Δ-Context Γ′)

-- PROPERTIES of lift-term

lift-term-ignore : ∀ {Γ₁ Γ₂ τ} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} {ρ : ⟦ Γ₂ ⟧} (t : Term Γ₁ τ) →
  ⟦ lift-term {{Γ′}} t ⟧ ρ ≡ ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
lift-term-ignore {{Γ′}} {ρ} t = let Γ″ = ≼-trans ≼-Δ-Context Γ′ in
  begin
    ⟦ lift-term {{Γ′}} t ⟧ ρ
  ≡⟨⟩
    ⟦ weaken Γ″ t ⟧ ρ
  ≡⟨ weaken-sound t ρ ⟩
    ⟦ t ⟧ (⟦ ≼-trans ≼-Δ-Context Γ′ ⟧ ρ)
  ≡⟨ cong (λ x → ⟦ t ⟧ x) (⟦⟧-≼-trans ≼-Δ-Context Γ′ ρ) ⟩
    ⟦ t ⟧Term (⟦ ≼-Δ-Context ⟧≼ (⟦ Γ′ ⟧≼ ρ))
  ≡⟨⟩
    ⟦ t ⟧ (ignore (⟦ Γ′ ⟧ ρ))
  ∎ where open ≡-Reasoning

-- PROPERTIES of Δ

Δ-abs : ∀ {τ₁ τ₂ Γ₁ Γ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t : Term (τ₁ • Γ₁) τ₂) →
  let Γ″ = keep Δ-Type τ₁ • keep τ₁ • Γ′ in
  Δ {{Γ′}} (abs t) ≈ abs (abs (Δ {τ₁ • Γ₁} t))
Δ-abs t = ext-t (λ ρ → refl)

Δ-app : ∀ {Γ₁ Γ₂ τ₁ τ₂} {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} (t₁ : Term Γ₁ (τ₁ ⇒ τ₂)) (t₂ : Term Γ₁ τ₁) →
  Δ {{Γ′}} (app t₁ t₂) ≈ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
Δ-app {{Γ′}} t₁ t₂ = ≈-sym (ext-t (λ ρ′ → let ρ = ⟦ Γ′ ⟧ ρ′ in
  begin
    ⟦ app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂) ⟧ ρ′
  ≡⟨⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term {{Γ′}} t₂ ⟧ ρ′))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {{Γ′}} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨⟩
     ⟦ Δ {{Γ′}} (app t₁ t₂) ⟧ ρ′
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var {τ • Γ} this = this
derive-var {τ • Γ} (that x) = that (that (derive-var x))

derive-term : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → Term Γ₁ τ → Term Γ₂ (Δ-Type τ)
derive-term {Γ₁} {{Γ′}} (abs {τ} t) = abs (abs (derive-term {τ • Γ₁} {{Γ″}} t))
  where Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term {{Γ′}} (app t₁ t₂) = app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
derive-term {{Γ′}} (var x) = var (lift Γ′ (derive-var x))
derive-term {{Γ′}} true = false
derive-term {{Γ′}} false = false
derive-term {{Γ′}} (if c t e) =
  if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} c))
    (diff-term (apply-term (derive-term {{Γ′}} e) (lift-term {{Γ′}} e)) (lift-term {{Γ′}} t))
    (if ((derive-term {{Γ′}} c) and (lift-term {{Γ′}} (! c)))
      (diff-term (apply-term (derive-term {{Γ′}} t) (lift-term {{Γ′}} t)) (lift-term {{Γ′}} e))
      (if (lift-term {{Γ′}} c)
        (derive-term {{Γ′}} t)
        (derive-term {{Γ′}} e)))
derive-term {{Γ′}} (Δ {{Γ″}} t) = Δ {{Γ′}} (derive-term {{Γ″}} t)

-- CORRECTNESS of derivation

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

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


Step-indexed evaluation: simplify back

Step-indexed evaluation: simplify back

{-# OPTIONS --allow-unsolved-metas #-}
-- 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 "Imperative self-adjusting
-- computation", POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

module Thesis.FunBigStepSILR2 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; _<_; _≤_)
open import Data.Nat.Properties
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

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.
-- 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 instead.

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

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

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

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

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

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
-- eval (app s t) ρ = eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)
eval (app s t) ρ n0 with eval s ρ n0
... | Error = Error
... | TimeOut = TimeOut
... | Done sv n1 with eval t ρ n1
... | Done tv n2 = apply sv tv n2
... | Error = Error
... | TimeOut = TimeOut

{-# OPTIONS --allow-unsolved-metas #-}
-- 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 "Imperative self-adjusting
-- computation", POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

module Thesis.FunBigStepSILR2 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; _<_; _≤_)
open import Data.Nat.Properties
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

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.
-- 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 instead.

data ErrVal (τ : Type) (n0 : ℕ) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → (n≤ : n1 ≤ n0) → ErrVal τ n0
  Error : ErrVal τ n0
  TimeOut : ErrVal τ n0

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ n

up : ∀ {τ n0 n1} → ErrVal τ n1 → (n1 ≤ n0) → ErrVal τ n0
up (Done v n2 n2≤n1) n1≤n0 = Done v n2 (≤-trans n2≤n1 n1≤n0)
up Error n≤ = Error
up TimeOut n≤ = TimeOut

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 n≤ = up (t v n1) n≤
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) zero = TimeOut
evalConst (lit v) (suc n) = Done (intV v) n (≤-step ≤-refl)

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

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a (suc n) = up (eval t (a • ρ) n) (≤-step ≤-refl)
apply (closure t ρ) a zero = TimeOut

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n ≤-refl
eval (abs t) ρ n = Done (closure t ρ) n ≤-refl
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
-- eval (app s t) ρ = eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)
eval (app s t) ρ n0 with eval s ρ n0
... | Error = Error
... | TimeOut = TimeOut
... | Done sv n1 n1≤n0 with eval t ρ n1
... | Done tv n2 n2≤n1 = up (apply sv tv n2) (≤-trans n2≤n1 n1≤n0)
... | Error = Error
... | TimeOut = TimeOut


tried to analyze a slightly larger example, but it is too big already

Old-commit-hash: 3e1af00454de058acf5ca90a5d63198a5b3aca11

module Examples.Examples1 where

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

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

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation
open import Natural.Evaluation
open import Relation.Binary.PropositionalEquality

-- only some finger exercises to get used to the definitions

bool-identity : Term ∅ (bool ⇒ bool)
bool-identity = abs (var this)

term1 : Term ∅ bool
term1 = app bool-identity true

res : ⟦ bool ⟧
res = ⟦ term1 ⟧ ∅

-- test the denotational semantics

-- is this a good way to write unit tests in Agda?
test1 : res ≡ true
test1 = refl

-- test the natural semantics
open import Natural.Lookup
test2 : ∅ ⊢ term1 ↓ vtrue
test2 = app abs e-true (var this)

term2 : Term (bool • bool • bool • ∅) bool
term2 = if (var this) (if (var (that this)) false true) (if (var (that (that this))) false true)

term3 : Term ∅ (bool ⇒ bool ⇒ bool ⇒ bool)
term3 = abs (abs (abs term2))

open import SymbolicDerivation
-- presumably there is some shorter way to do this?
-- I don't understand instance arguments sufficiently
term4 = derive-term {∅} {∅} {bool ⇒ bool ⇒ bool ⇒ bool} {{∅ }} term3

-- it turns out that term4 is already way too complicated to be analyzed by hand


Change argument order of carry-over.

Change argument order of carry-over.

This commit prepares for uncurrying cary-over.

Old-commit-hash: e1a21bdcbe7ee2b217917bd6ac9dfc576487102a

module Denotation.Implementation.Popl14 where

-- Notions of programs being implementations of specifications
-- for Calculus Popl14

open import Denotation.Specification.Canon-Popl14 public

open import Popl14.Syntax.Type
open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Derive
open import Popl14.Change.Value
open import Popl14.Change.Validity

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Tuples
open import Structure.Bag.Popl14
open import Postulate.Extensionality

infix 4 implements
syntax implements τ u v = u ≈₍ τ ₎ v
implements : ∀ (τ : Type) → Change τ → ⟦ ΔType τ ⟧ → Set

u ≈₍ int ₎ v = u ≡ v
u ≈₍ bag ₎ v = u ≡ v
u ≈₍ σ ⇒ τ ₎ v =
  (w : ⟦ σ ⟧) (Δw : Change σ) (R[w,Δw] : valid {σ} w Δw)
  (Δw′ : ⟦ ΔType σ ⟧) (Δw≈Δw′ : implements σ Δw Δw′) →
  implements τ (u (cons w Δw R[w,Δw])) (v w Δw′)

infix 4 _≈_
_≈_ : ∀ {τ} → Change τ → ⟦ ΔType τ ⟧ → Set
_≈_ {τ} = implements τ

module Disambiguation (τ : Type) where
  _✚_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚_ = _⟦⊕⟧_ {τ}
  _−_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚_ _−_
  _≃_ : Change τ → ⟦ ΔType τ ⟧ → Set
  _≃_ = _≈_ {τ}
  infix 4 _≃_

module FunctionDisambiguation (σ : Type) (τ : Type) where
  open Disambiguation (σ ⇒ τ) public
  _✚₁_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚₁_ = _⟦⊕⟧_ {τ}
  _−₁_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−₁_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚₁_ _−₁_
  _≃₁_ : Change τ → ⟦ ΔType τ ⟧ → Set
  _≃₁_ = _≈_ {τ}
  infix 4 _≃₁_
  _✚₀_ : ⟦ σ ⟧ → ⟦ ΔType σ ⟧ → ⟦ σ ⟧
  _✚₀_ = _⟦⊕⟧_ {σ}
  _−₀_ : ⟦ σ ⟧ → ⟦ σ ⟧ → ⟦ ΔType σ ⟧
  _−₀_ = _⟦⊝⟧_ {σ}
  infixl 6 _✚₀_ _−₀_
  _≃₀_ : Change σ → ⟦ ΔType σ ⟧ → Set
  _≃₀_ = _≈_ {σ}
  infix 4 _≃₀_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ ΔContext Γ ⟧ → Set
compatible {∅} ∅ ∅ = ⊤
compatible {τ • Γ} (cons v Δv _ • ρ) (Δv′ • v′ • ρ′) =
  Triple (v ≡ v′) (λ _ → Δv ≈₍ τ ₎ Δv′) (λ _ _ → compatible ρ ρ′)

-- If a program implements a specification, then certain things
-- proven about the specification carry over to the programs.
carry-over : ∀ {τ}
  {v : ⟦ τ ⟧} {Δv : Change τ} (R[v,Δv] : valid {τ} v Δv)
  {Δv′ : ⟦ ΔType τ ⟧} (Δv≈Δv′ : Δv ≈₍ τ ₎ Δv′) →
 let open Disambiguation τ in
   v ⊞₍ τ ₎ Δv ≡ v ✚ Δv′

u⊟v≈u⊝v : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
  let open Disambiguation τ in
    u ⊟₍ τ ₎ v ≃ u − v
u⊟v≈u⊝v {base base-int} = refl
u⊟v≈u⊝v {base base-bag} = refl
u⊟v≈u⊝v {σ ⇒ τ} {g} {f} = result where
  open FunctionDisambiguation σ τ
  result : (w : ⟦ σ ⟧) (Δw : Change σ) → valid {σ} w Δw →
    (Δw′ : ⟦ ΔType σ ⟧) → Δw ≈₍ σ ₎ Δw′ →
    g (w ⊞₍ σ ₎ Δw) ⊟₍ τ ₎ f w ≃₁ g (w ✚₀ Δw′) −₁ f w
  result w Δw R[w,Δw] Δw′ Δw≈Δw′
    rewrite carry-over {σ} {w} R[w,Δw] Δw≈Δw′ =
    u⊟v≈u⊝v {τ} {g (w ✚₀ Δw′)} {f w}
carry-over {base base-int} {v} _ Δv≈Δv′ = cong (_+_  v) Δv≈Δv′
carry-over {base base-bag} {v} _ Δv≈Δv′ = cong (_++_ v) Δv≈Δv′
carry-over {σ ⇒ τ} {f} {Δf} R[f,Δf] {Δf′} Δf≈Δf′ =
  ext (λ v →
  let
    open FunctionDisambiguation σ τ
    V = R[v,u-v] {σ} {v} {v}
    S = u⊟v≈u⊝v {σ} {v} {v}
  in
    carry-over {τ} {f v}
      {Δf (nil-valid-change σ v)} (proj₁ (R[f,Δf] (nil-valid-change σ v)))
      {Δf′ v (v −₀ v)}
      (Δf≈Δf′ v (v ⊟₍ σ ₎ v) V (v −₀ v) S))

-- A property relating `ignore` and the subcontext relation Γ≼ΔΓ
⟦Γ≼ΔΓ⟧ : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′
⟦Γ≼ΔΓ⟧ {∅} {∅} {∅} _ = refl
⟦Γ≼ΔΓ⟧ {τ • Γ} {cons v dv _ • ρ} {dv′ • v′ • ρ′}
  (cons v≡v′ _ C) = cong₂ _•_ v≡v′ (⟦Γ≼ΔΓ⟧ C)

-- A specialization of the soundness of weakening
⟦fit⟧ : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ fit t ⟧ ρ′
⟦fit⟧ t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (⟦Γ≼ΔΓ⟧ C)) (sym (weaken-sound t ρ′))

module Denotation.Implementation.Popl14 where

-- Notions of programs being implementations of specifications
-- for Calculus Popl14

open import Denotation.Specification.Canon-Popl14 public

open import Popl14.Syntax.Type
open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Derive
open import Popl14.Change.Value
open import Popl14.Change.Validity

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Tuples
open import Structure.Bag.Popl14
open import Postulate.Extensionality

infix 4 implements
syntax implements τ u v = u ≈₍ τ ₎ v
implements : ∀ (τ : Type) → Change τ → ⟦ ΔType τ ⟧ → Set

u ≈₍ int ₎ v = u ≡ v
u ≈₍ bag ₎ v = u ≡ v
u ≈₍ σ ⇒ τ ₎ v =
  (w : ⟦ σ ⟧) (Δw : Change σ) (R[w,Δw] : valid {σ} w Δw)
  (Δw′ : ⟦ ΔType σ ⟧) (Δw≈Δw′ : implements σ Δw Δw′) →
  implements τ (u (cons w Δw R[w,Δw])) (v w Δw′)

infix 4 _≈_
_≈_ : ∀ {τ} → Change τ → ⟦ ΔType τ ⟧ → Set
_≈_ {τ} = implements τ

module Disambiguation (τ : Type) where
  _✚_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚_ = _⟦⊕⟧_ {τ}
  _−_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚_ _−_
  _≃_ : Change τ → ⟦ ΔType τ ⟧ → Set
  _≃_ = _≈_ {τ}
  infix 4 _≃_

module FunctionDisambiguation (σ : Type) (τ : Type) where
  open Disambiguation (σ ⇒ τ) public
  _✚₁_ : ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
  _✚₁_ = _⟦⊕⟧_ {τ}
  _−₁_ : ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧
  _−₁_ = _⟦⊝⟧_ {τ}
  infixl 6 _✚₁_ _−₁_
  _≃₁_ : Change τ → ⟦ ΔType τ ⟧ → Set
  _≃₁_ = _≈_ {τ}
  infix 4 _≃₁_
  _✚₀_ : ⟦ σ ⟧ → ⟦ ΔType σ ⟧ → ⟦ σ ⟧
  _✚₀_ = _⟦⊕⟧_ {σ}
  _−₀_ : ⟦ σ ⟧ → ⟦ σ ⟧ → ⟦ ΔType σ ⟧
  _−₀_ = _⟦⊝⟧_ {σ}
  infixl 6 _✚₀_ _−₀_
  _≃₀_ : Change σ → ⟦ ΔType σ ⟧ → Set
  _≃₀_ = _≈_ {σ}
  infix 4 _≃₀_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ ΔContext Γ ⟧ → Set
compatible {∅} ∅ ∅ = ⊤
compatible {τ • Γ} (cons v Δv _ • ρ) (Δv′ • v′ • ρ′) =
  Triple (v ≡ v′) (λ _ → Δv ≈₍ τ ₎ Δv′) (λ _ _ → compatible ρ ρ′)

-- If a program implements a specification, then certain things
-- proven about the specification carry over to the programs.
carry-over : ∀ {τ}
  {v : ⟦ τ ⟧} {Δv : Change τ} {Δv′ : ⟦ ΔType τ ⟧}
 (R[v,Δv] : valid {τ} v Δv) (Δv≈Δv′ : Δv ≈₍ τ ₎ Δv′) →
 let open Disambiguation τ in
   v ⊞₍ τ ₎ Δv ≡ v ✚ Δv′

u⊟v≈u⊝v : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
  let open Disambiguation τ in
    u ⊟₍ τ ₎ v ≃ u − v
u⊟v≈u⊝v {base base-int} = refl
u⊟v≈u⊝v {base base-bag} = refl
u⊟v≈u⊝v {σ ⇒ τ} {g} {f} = result where
  open FunctionDisambiguation σ τ
  result : (w : ⟦ σ ⟧) (Δw : Change σ) → valid {σ} w Δw →
    (Δw′ : ⟦ ΔType σ ⟧) → Δw ≈₍ σ ₎ Δw′ →
    g (w ⊞₍ σ ₎ Δw) ⊟₍ τ ₎ f w ≃₁ g (w ✚₀ Δw′) −₁ f w
  result w Δw R[w,Δw] Δw′ Δw≈Δw′
    rewrite carry-over {σ} {w} R[w,Δw] Δw≈Δw′ =
    u⊟v≈u⊝v {τ} {g (w ✚₀ Δw′)} {f w}
carry-over {base base-int} {v} _ Δv≈Δv′ = cong (_+_  v) Δv≈Δv′
carry-over {base base-bag} {v} _ Δv≈Δv′ = cong (_++_ v) Δv≈Δv′
carry-over {σ ⇒ τ} {f} {Δf} {Δf′} R[f,Δf] Δf≈Δf′ =
  ext (λ v →
  let
    open FunctionDisambiguation σ τ
    V = R[v,u-v] {σ} {v} {v}
    S = u⊟v≈u⊝v {σ} {v} {v}
  in
    carry-over {τ} {f v}
      {Δf (nil-valid-change σ v)} {Δf′ v (v −₀ v)}
      (proj₁ (R[f,Δf] (nil-valid-change σ v)))
      (Δf≈Δf′ v (v ⊟₍ σ ₎ v) V (v −₀ v) S))

-- A property relating `ignore` and the subcontext relation Γ≼ΔΓ
⟦Γ≼ΔΓ⟧ : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′
⟦Γ≼ΔΓ⟧ {∅} {∅} {∅} _ = refl
⟦Γ≼ΔΓ⟧ {τ • Γ} {cons v dv _ • ρ} {dv′ • v′ • ρ′}
  (cons v≡v′ _ C) = cong₂ _•_ v≡v′ (⟦Γ≼ΔΓ⟧ C)

-- A specialization of the soundness of weakening
⟦fit⟧ : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ ΔContext Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ fit t ⟧ ρ′
⟦fit⟧ t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (⟦Γ≼ΔΓ⟧ C)) (sym (weaken-sound t ρ′))


Revert "agda/...: misc (to revert)"

Revert "agda/...: misc (to revert)"

This reverts commit ae3a9db6fb87ddc01573ae236f8850b322bec8db.

Old-commit-hash: fa2ae9742c4282275b8f242a197b35ef1acf5932

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import IlcModel
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ {.(Δ-Context Γ)} {.(Δ-Type τ)} Γ′ (Δ {Γ} {τ} t) = weakenMore t
  where
    open import Relation.Binary.PropositionalEquality using (sym)

    doWeakenMore : ∀ Γprefix Γrest {τ} →
      Term (Γprefix ⋎ Γrest) (Δ-Type τ) →
      Term (Γprefix ⋎ Δ-Context Γrest) (Δ-Type τ)

    doWeakenMore Γprefix ∅ t₁ = t₁
    doWeakenMore ∅ (τ₂ • Γrest) t₁ =
      weakenOne ∅ (Δ-Type τ₂) (doWeakenMore (τ₂ • ∅) Γrest t₁)
    doWeakenMore Γprefix (τ₂ • Γrest) {τ} t₁ =
      weakenOne Γprefix (Δ-Type τ₂)
        (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
          (doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
            (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

    prefix : ∀ Γ → (Γ′ : Prefix (Δ-Context Γ)) → Context
    prefix Γ Γ′ = take (Δ-Context Γ) Γ′

    rest   : ∀ Γ → (Γ′ : Prefix (Δ-Context Γ)) → Context
    rest   Γ Γ′ = drop (Δ-Context Γ) Γ′

    weakenMore2 : ∀ Γ Γ′ {τ} →
      Term Γ τ →
      Term (prefix Γ Γ′ ⋎ Δ-Context (rest Γ Γ′)) (Δ-Type τ)
    weakenMore2 Γ Γ′ t =
      doWeakenMore (prefix Γ Γ′) (rest Γ Γ′) (
      substTerm (sym (take-drop (Δ-Context Γ) Γ′)) (Δ t))

    weakenMore : --∀ {Γ τ} Γ′ →
      Term Γ τ → Term (Δ-Context′ (Δ-Context Γ) Γ′) (Δ-Type τ)
    weakenMore t =
      substTerm
        (sym (take-⋎-Δ-Context-drop-Δ-Context′ (Δ-Context Γ) Γ′))
        (weakenMore2 Γ Γ′ t)

lift-term′ {._} {_} _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | bool = lift-term-ignore′ Γ′ t₂
... | false | false | bool = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

diff-term : ∀ {Γ τ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term = {!!}

apply-term : ∀ {Γ τ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term = {!!}

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = {!!}

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = {!!}

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

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

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext (λ ρ → ≡-refl)
derive-term-correct false = ext (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import IlcModel
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

lift-var-3 : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context (Δ-Context Γ)) τ
lift-var-3 this = that (that (that this))
lift-var-3 (that x) = that (that (that (that (lift-var-3 x))))

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ {.(Δ-Context Γ)} {.(Δ-Type τ)} Γ′ (Δ {Γ} {τ} t) = weakenMore t
  where
    open import Relation.Binary.PropositionalEquality using (sym)

    doWeakenMore : ∀ Γprefix Γrest {τ} →
      Term (Γprefix ⋎ Γrest) (Δ-Type τ) →
      Term (Γprefix ⋎ Δ-Context Γrest) (Δ-Type τ)

    doWeakenMore Γprefix ∅ t₁ = t₁
    doWeakenMore ∅ (τ₂ • Γrest) t₁ =
      weakenOne ∅ (Δ-Type τ₂) (doWeakenMore (τ₂ • ∅) Γrest t₁)
    doWeakenMore Γprefix (τ₂ • Γrest) {τ} t₁ =
      weakenOne Γprefix (Δ-Type τ₂)
        (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
          (doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
            (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

    prefix : ∀ Γ → (Γ′ : Prefix (Δ-Context Γ)) → Context
    prefix Γ Γ′ = take (Δ-Context Γ) Γ′

    rest   : ∀ Γ → (Γ′ : Prefix (Δ-Context Γ)) → Context
    rest   Γ Γ′ = drop (Δ-Context Γ) Γ′

    weakenMore2 : ∀ Γ Γ′ {τ} →
      Term Γ τ →
      Term (prefix Γ Γ′ ⋎ Δ-Context (rest Γ Γ′)) (Δ-Type τ)
    weakenMore2 Γ Γ′ t =
      doWeakenMore (prefix Γ Γ′) (rest Γ Γ′) (
      substTerm (sym (take-drop (Δ-Context Γ) Γ′)) (Δ t))

    weakenMore : --∀ {Γ τ} Γ′ →
      Term Γ τ → Term (Δ-Context′ (Δ-Context Γ) Γ′) (Δ-Type τ)
    weakenMore t =
      substTerm
        (sym (take-⋎-Δ-Context-drop-Δ-Context′ (Δ-Context Γ) Γ′))
        (weakenMore2 Γ Γ′ t)

{-
    weakenMore2 : ∀ Γ Γ′ {τ} →
      Term Γ τ →
      Term (prefix Γ Γ′ ⋎ Δ-Context (rest Γ Γ′)) (Δ-Type τ)
    weakenMore2 ∅ ∅ t₁ = Δ t₁
    weakenMore2 (τ₁ • Γ₁) ∅ t₁ =
      weakenOne ∅ (Δ-Type (Δ-Type τ₁))
        (weakenOne (Δ-Type τ₁ • ∅) (Δ-Type τ₁) {!
          weakenMore2
            (Δ {τ₁ • Γ₁} {τ} t₁)!})
          --(weakenMore2 {τ₁ • Γ₁} (Δ-Type τ₁ • τ₁ • ∅) t₁ ))

--        (Δ {τ₁ • Γ₁} {τ} t₁)))

    weakenMore2 (τ₁ • Γ₁) (.(Δ-Type τ₁) • Γ′₁) t₁ = {!!}
-}

lift-term′ {._} {_} _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | bool = lift-term-ignore′ Γ′ t₂
... | false | false | bool = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

diff-term : ∀ {Γ τ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term = {!!}

apply-term : ∀ {Γ τ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term = {!!}

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = {!!}

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = {!!}

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

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

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext (λ ρ → ≡-refl)
derive-term-correct false = ext (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}


Desc model: proof-phi-psi implicit.

Desc model: proof-phi-psi implicit.


Universe: Π→Πᵁ

Universe: Π→Πᵁ

open import Level.NP
open import Type
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Product.NP
open import Data.Sum.NP
open import Data.Sum.Logical
open import Data.Nat
open import Data.Fin
open import Relation.Nullary.NP
open import Relation.Binary.PropositionalEquality.NP
open import Relation.Binary.Logical

open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Properties
open import Explore.Zero
open import Explore.One
open import Explore.Two
open import Explore.Product
open import Explore.Sum
open import Explore.Explorable
import Explore.Isomorphism

module Explore.Universe where

open Operators

infixr 2 _×ᵁ_

data U : ★
El : U → ★

data U where
  𝟘ᵁ 𝟙ᵁ 𝟚ᵁ : U
  _×ᵁ_ _⊎ᵁ_ : U → U → U
  Σᵁ : (t : U) (f : El t → U) → U

El 𝟘ᵁ = 𝟘
El 𝟙ᵁ = 𝟙
El 𝟚ᵁ = 𝟚
El (s ×ᵁ t) = El s × El t
El (s ⊎ᵁ t) = El s ⊎ El t
El (Σᵁ t f) = Σ (El t) λ x → El (f x)

data ⟦U⟧ : ⟦★₀⟧ U U
⟦El⟧ : (⟦U⟧ ⟦→⟧ ⟦★₀⟧) El El

data ⟦U⟧ where
  ⟦𝟘ᵁ⟧ : ⟦U⟧ 𝟘ᵁ 𝟘ᵁ
  ⟦𝟙ᵁ⟧ : ⟦U⟧ 𝟙ᵁ 𝟙ᵁ
  ⟦𝟚ᵁ⟧ : ⟦U⟧ 𝟚ᵁ 𝟚ᵁ
  _⟦×ᵁ⟧_ : ⟦Op₂⟧ ⟦U⟧ _×ᵁ_ _×ᵁ_
  _⟦⊎ᵁ⟧_ : ⟦Op₂⟧ ⟦U⟧ _⊎ᵁ_ _⊎ᵁ_
  ⟦Σᵁ⟧ : (⟨ t ∶ ⟦U⟧ ⟩⟦→⟧ (⟦El⟧ t ⟦→⟧ ⟦U⟧) ⟦→⟧ ⟦U⟧) Σᵁ Σᵁ

⟦El⟧ ⟦𝟘ᵁ⟧ = _≡_
⟦El⟧ ⟦𝟙ᵁ⟧ = _≡_
⟦El⟧ ⟦𝟚ᵁ⟧ = _≡_
⟦El⟧ (s ⟦×ᵁ⟧ t) = ⟦El⟧ s ⟦×⟧ ⟦El⟧ t
⟦El⟧ (s ⟦⊎ᵁ⟧ t) = ⟦El⟧ s ⟦⊎⟧ ⟦El⟧ t
⟦El⟧ (⟦Σᵁ⟧ t f) = ⟦Σ⟧ (⟦El⟧ t) λ x → ⟦El⟧ (f x)

module _ {k} {K : ★_ k} {a} {A : ★_ a} {x y : A} (p : x ≡ y) where
    tr-const : tr (const K) p ≡ id
    tr-const = J (λ x₁ p₁ → tr (const K) p₁ ≡ id) refl p

    {-
⟦U⟧-sound : ∀ {{_ : FunExt}} {x y} → ⟦U⟧ x y → x ≡ y
⟦U⟧-refl : ∀ x → ⟦U⟧ x x

{-
⟦El⟧-refl : ∀ x → {!⟦El⟧ x x!}
⟦El⟧-refl = {!!}
-}

⟦U⟧-sound ⟦𝟘ᵁ⟧ = refl
⟦U⟧-sound ⟦𝟙ᵁ⟧ = refl
⟦U⟧-sound ⟦𝟚ᵁ⟧ = refl
⟦U⟧-sound (u ⟦×ᵁ⟧ u₁) = ap₂ _×ᵁ_ (⟦U⟧-sound u) (⟦U⟧-sound u₁)
⟦U⟧-sound (u ⟦⊎ᵁ⟧ u₁) = ap₂ _⊎ᵁ_ (⟦U⟧-sound u) (⟦U⟧-sound u₁)
⟦U⟧-sound (⟦Σᵁ⟧ {u₀} {u₁} u {f₀} {f₁} fᵣ) = apd₂ Σᵁ (⟦U⟧-sound u) (tr-→ El (const U) (⟦U⟧-sound u) f₀ ∙ λ= (λ A → ap (λ z → z (f₀ (tr El (! ⟦U⟧-sound u) A))) (tr-const (⟦U⟧-sound u)) ∙ ⟦U⟧-sound (fᵣ {!!}))) -- (λ= (λ y → let foo = xᵣ {{!!}} {y} {!xᵣ!} in {!tr-→ El (const U) (⟦U⟧-sound u)!}))

⟦U⟧-refl 𝟘ᵁ = ⟦𝟘ᵁ⟧
⟦U⟧-refl 𝟙ᵁ = ⟦𝟙ᵁ⟧
⟦U⟧-refl 𝟚ᵁ = ⟦𝟚ᵁ⟧
⟦U⟧-refl (x ×ᵁ x₁) = ⟦U⟧-refl x ⟦×ᵁ⟧ ⟦U⟧-refl x₁
⟦U⟧-refl (x ⊎ᵁ x₁) = ⟦U⟧-refl x ⟦⊎ᵁ⟧ ⟦U⟧-refl x₁
⟦U⟧-refl (Σᵁ x f) = ⟦Σᵁ⟧ (⟦U⟧-refl x) (λ y → {!⟦U⟧-refl ?!})
-}

infix  8 _^ᵁ_
_^ᵁ_ : U → ℕ → U
t ^ᵁ zero  = t
t ^ᵁ suc n = t ×ᵁ t ^ᵁ n

module _ {ℓ} where

    explore : ∀ t → Explore ℓ (El t)
    explore 𝟘ᵁ = 𝟘ᵉ
    explore 𝟙ᵁ = 𝟙ᵉ
    explore 𝟚ᵁ = 𝟚ᵉ
    explore (s ×ᵁ t) = explore s ×ᵉ explore t
    explore (s ⊎ᵁ t) = explore s ⊎ᵉ explore t
    explore (Σᵁ t f) = exploreΣ (explore t) λ {x} → explore (f x)

    exploreU-ind : ∀ {p} t → ExploreInd p (explore t)
    exploreU-ind 𝟘ᵁ = 𝟘ⁱ
    exploreU-ind 𝟙ᵁ = 𝟙ⁱ
    exploreU-ind 𝟚ᵁ = 𝟚ⁱ
    exploreU-ind (s ×ᵁ t) = exploreU-ind s ×ⁱ exploreU-ind t
    exploreU-ind (s ⊎ᵁ t) = exploreU-ind s ⊎ⁱ exploreU-ind t
    exploreU-ind (Σᵁ t f) = exploreΣ-ind (exploreU-ind t) λ {x} → exploreU-ind (f x)

module _ {ℓ₀ ℓ₁ ℓᵣ} where
    ⟦explore⟧ : ∀ {t₀ t₁} (t : ⟦U⟧ t₀ t₁) → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ (⟦El⟧ t) (explore t₀) (explore t₁)
    ⟦explore⟧ ⟦𝟘ᵁ⟧        = ⟦𝟘ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ}
    ⟦explore⟧ ⟦𝟙ᵁ⟧        = ⟦𝟙ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_} {refl}
    ⟦explore⟧ ⟦𝟚ᵁ⟧        = ⟦𝟚ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_} {refl} {refl}
    ⟦explore⟧ (t ⟦×ᵁ⟧ t₁) = ⟦explore×⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ t) (⟦explore⟧ t₁)
    ⟦explore⟧ (t ⟦⊎ᵁ⟧ t₁) = ⟦explore⊎⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ t) (⟦explore⟧ t₁)
    ⟦explore⟧ (⟦Σᵁ⟧ t f)  = ⟦exploreΣ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ t) (⟦explore⟧ ∘ f)

module _ (t : U) where
  private
    tᵉ : ∀ {ℓ} → Explore ℓ (El t)
    tᵉ = explore t
    tⁱ : ∀ {ℓ p} → ExploreInd {ℓ} p tᵉ
    tⁱ = exploreU-ind t

  open FromExploreInd tⁱ public hiding (⟦explore⟧)
  {-
  open From⟦Explore⟧ (λ {ℓ₁} {ℓ₂} {ℓᵣ} → ⟦explore⟧' {ℓ₁} {ℓ₂} {ℓᵣ} t) public
  -}

adequate-sumU : ∀ {{_ : UA}}{{_ : FunExt}} t → Adequate-sum (sum t)
adequate-sumU 𝟘ᵁ       = 𝟘ˢ-ok
adequate-sumU 𝟙ᵁ       = 𝟙ˢ-ok
adequate-sumU 𝟚ᵁ       = 𝟚ˢ-ok
adequate-sumU (s ×ᵁ t) = adequate-sumΣ (adequate-sumU s) (adequate-sumU t)
adequate-sumU (s ⊎ᵁ t) = adequate-sum⊎ (adequate-sumU s) (adequate-sumU t)
adequate-sumU (Σᵁ t f) = adequate-sumΣ (adequate-sumU t) (λ {x} → adequate-sumU (f x))

module _ {ℓ} where
    lookupU : ∀ t → Lookup {ℓ} (explore t)
    lookupU 𝟘ᵁ = 𝟘ˡ
    lookupU 𝟙ᵁ = 𝟙ˡ
    lookupU 𝟚ᵁ = 𝟚ˡ
    lookupU (s ×ᵁ t) = lookup× {eᴬ = explore s} {eᴮ = explore t} (lookupU s) (lookupU t)
    lookupU (s ⊎ᵁ t) = lookup⊎ {eᴬ = explore s} {eᴮ = explore t} (lookupU s) (lookupU t)
    lookupU (Σᵁ t f) = lookupΣ {eᴬ = explore t} {eᴮ = λ {x} → explore (f x)} (lookupU t) (λ {x} → lookupU (f x))

    focusU : ∀ t → Focus {ℓ} (explore t)
    focusU 𝟘ᵁ = 𝟘ᶠ
    focusU 𝟙ᵁ = 𝟙ᶠ
    focusU 𝟚ᵁ = 𝟚ᶠ
    focusU (s ×ᵁ t) = focus× {eᴬ = explore s} {eᴮ = explore t} (focusU s) (focusU t)
    focusU (s ⊎ᵁ t) = focus⊎ {eᴬ = explore s} {eᴮ = explore t} (focusU s) (focusU t)
    focusU (Σᵁ t f) = focusΣ {eᴬ = explore t} {eᴮ = λ {x} → explore (f x)} (focusU t) (λ {x} → focusU (f x))

    ΣᵉU : ∀ A {ℓ} → (El A → ★_ ℓ) → ★_ ℓ
    ΣᵉU = λ A → Σᵉ (explore A)
    ΠᵉU : ∀ A {ℓ} → (El A → ★_ ℓ) → ★_ ℓ
    ΠᵉU = λ A → Πᵉ (explore A)

    module _ {{_ : UA}}{{_ : FunExt}} where
        ΣᵉU-ok : ∀ t → Adequate-Σ {ℓ} (ΣᵉU t)
        ΣᵉU-ok 𝟘ᵁ       = Σᵉ𝟘-ok
        ΣᵉU-ok 𝟙ᵁ       = Σᵉ𝟙-ok
        ΣᵉU-ok 𝟚ᵁ       = Σᵉ𝟚-ok
        ΣᵉU-ok (t ×ᵁ u) = Σᵉ×-ok {eᴬ = explore t} {eᴮ = explore u} (ΣᵉU-ok t) (ΣᵉU-ok u)
        ΣᵉU-ok (t ⊎ᵁ u) = Σᵉ⊎-ok {eᴬ = explore t} {eᴮ = explore u} (ΣᵉU-ok t) (ΣᵉU-ok u)
        ΣᵉU-ok (Σᵁ t u) = ΣᵉΣ-ok {eᴬ = explore t} {eᴮ = λ {x} → explore (u x)} (ΣᵉU-ok t) (λ {x} → ΣᵉU-ok (u x))

        ΠᵉU-ok : ∀ t → Adequate-Π {ℓ} (ΠᵉU t)
        ΠᵉU-ok 𝟘ᵁ       = Πᵉ𝟘-ok
        ΠᵉU-ok 𝟙ᵁ       = Πᵉ𝟙-ok
        ΠᵉU-ok 𝟚ᵁ       = Πᵉ𝟚-ok
        ΠᵉU-ok (t ×ᵁ u) = Πᵉ×-ok {eᴬ = explore t} {eᴮ = explore u} (ΠᵉU-ok t) (ΠᵉU-ok u)
        ΠᵉU-ok (t ⊎ᵁ u) = Πᵉ⊎-ok {eᴬ = explore t} {eᴮ = explore u} (ΠᵉU-ok t) (ΠᵉU-ok u)
        ΠᵉU-ok (Σᵁ t u) = ΠᵉΣ-ok {eᴬ = explore t} {eᴮ = λ {x} → explore (u x)} (ΠᵉU-ok t) (λ {x} → ΠᵉU-ok (u x))

{-
module _ (t : U) {{_ : UA}} {{_ : FunExt}} where
  open FromAdequate-Σᵉ t (ΣᵉU-ok t) public
  open FromAdequate-Πᵉ t (ΠᵉU-ok t) public
-}

module _ (A : U) (P : El A → ★₀) where
    Dec-Σ : Π (El A) (Dec ∘ P) → Dec (Σ (El A) P)
    Dec-Σ = map-Dec (unfocus A) (focusU A) ∘ lift-Dec A P ∘ reify A

-- See Explore.Fin for an example of the use of this module
module Isomorphism {A : ★₀} u (e : El u ≃ A) where
  open Explore.Isomorphism e

  module _ {ℓ} where
    isoᵉ : Explore ℓ A
    isoᵉ = explore-iso (explore u)

    module _ {p} where
      isoⁱ : ExploreInd p isoᵉ
      isoⁱ = explore-iso-ind (exploreU-ind u)

  module _ {ℓ} where
  {-
    isoˡ : Lookup {ℓ} isoᵉ
    isoˡ = lookup-iso {ℓ} {exploreU u} (lookupU u)

    isoᶠ : Focus {ℓ} isoᵉ
    isoᶠ = focus-iso {ℓ} {exploreU u} (focusU u)
    -}

    isoʳ : Reify {ℓ} isoᵉ
    isoʳ = FromExploreInd-iso.reify (exploreU-ind u)

    isoᵘ : Unfocus {ℓ} isoᵉ
    isoᵘ = FromExploreInd-iso.unfocus (exploreU-ind u)

  isoˢ : Sum A
  isoˢ = sum-iso (sum u)

  isoᵖ : Product A
  isoᵖ = product-iso (sum u)

  module _ {{_ : UA}}{{_ : FunExt}} where
    isoˢ-ok : Adequate-sum isoˢ
    isoˢ-ok = sum-iso-ok (adequate-sumU u)

    open Adequate-sum₀ isoˢ-ok isoˢ-ok public renaming (sumStableUnder to isoˢ-stableUnder)

Finᵁ : ℕ → U
Finᵁ zero    = 𝟘ᵁ
Finᵁ (suc n) = 𝟙ᵁ ⊎ᵁ Finᵁ n

Finᵁ' : ℕ → U
Finᵁ' zero          = 𝟘ᵁ
Finᵁ' (suc zero)    = 𝟙ᵁ
Finᵁ' (suc (suc n)) = 𝟙ᵁ ⊎ᵁ Finᵁ' (suc n)

Finᵁ-Fin : ∀ n → El (Finᵁ n) ≃ Fin n
Finᵁ-Fin zero    = ≃-! Fin0≃𝟘
Finᵁ-Fin (suc n) = ⊎≃ ≃-refl (Finᵁ-Fin n) ≃-∙ ≃-! Fin∘suc≃𝟙⊎Fin

Finᵁ'-Fin : ∀ n → El (Finᵁ' n) ≃ Fin n
Finᵁ'-Fin zero          = ≃-! Fin0≃𝟘
Finᵁ'-Fin (suc zero)    = ≃-! Fin1≃𝟙
Finᵁ'-Fin (suc (suc n)) = ⊎≃ ≃-refl (Finᵁ'-Fin (suc n)) ≃-∙ ≃-! Fin∘suc≃𝟙⊎Fin

Πᵁ : (u : U) (v : El u → U) → U
Πᵁ 𝟘ᵁ        v = 𝟙ᵁ
Πᵁ 𝟙ᵁ        v = v _
Πᵁ 𝟚ᵁ        v = v 0₂ ×ᵁ v 1₂
Πᵁ (u ×ᵁ u₁) v = Πᵁ u λ x → Πᵁ u₁ λ y → v (x , y)
Πᵁ (u ⊎ᵁ u₁) v = (Πᵁ u (v ∘ inl)) ×ᵁ (Πᵁ u₁ (v ∘ inr))
Πᵁ (Σᵁ u f)  v = Πᵁ u λ x → Πᵁ (f x) (v ∘ _,_ x)

_→ᵁ_ : (u : U) (v : U) → U
u →ᵁ v = Πᵁ u (const v)

{-
𝟛ᵁ : U
𝟛ᵁ = 𝟙ᵁ ⊎ᵁ 𝟚ᵁ

list22 = list (𝟚ᵁ →ᵁ 𝟚ᵁ)
list33 = list (𝟛ᵁ →ᵁ 𝟛ᵁ)
-}

module _ {{_ : UA}}{{_ : FunExt}} where
    Πᵁ-Π : ∀ u v → El (Πᵁ u v) ≡ Π (El u) (El ∘ v)
    Πᵁ-Π 𝟘ᵁ        v = ! Π𝟘-uniq₀ _
    Πᵁ-Π 𝟙ᵁ        v = ! Π𝟙-uniq _
    Πᵁ-Π 𝟚ᵁ        v = ! Π𝟚-×
    Πᵁ-Π (u ×ᵁ u₁) v = Πᵁ-Π u (λ x → Πᵁ u₁ (v ∘ _,_ x)) ∙ Π=′ _ (λ _ → Πᵁ-Π u₁ _) ∙ ! ΠΣ-curry
    Πᵁ-Π (u ⊎ᵁ u₁) v = ×= (Πᵁ-Π u (v ∘ inl)) (Πᵁ-Π u₁ (v ∘ inr)) ∙ ! dist-×-Π
    Πᵁ-Π (Σᵁ u f)  v = Πᵁ-Π u (λ x → Πᵁ (f _) (v ∘ _,_ x)) ∙ Π=′ _ (λ _ → Πᵁ-Π (f _) _) ∙ ! ΠΣ-curry

    →ᵁ-→ : ∀ u v → El (u →ᵁ v) ≡ (El u → El v)
    →ᵁ-→ u v = Πᵁ-Π u (const v)

    Πᵁ→Π : ∀ u v → El (Πᵁ u v) → Π (El u) (El ∘ v)
    Πᵁ→Π 𝟘ᵁ v x₂ ()
    Πᵁ→Π 𝟙ᵁ v x₂ x₃ = x₂
    Πᵁ→Π 𝟚ᵁ v (x , y) 0₂ = x
    Πᵁ→Π 𝟚ᵁ v (x , y) 1₂ = y
    Πᵁ→Π (u ×ᵁ u₁) v x (z , t) = Πᵁ→Π u₁ (v ∘ _,_ z) (Πᵁ→Π u (λ x → Πᵁ u₁ (v ∘ _,_ x)) x z) t
    Πᵁ→Π (u ⊎ᵁ _) v (x , _) (inl y) = Πᵁ→Π u (v ∘ inl) x y
    Πᵁ→Π (_ ⊎ᵁ u) v (_ , x) (inr y) = Πᵁ→Π u (v ∘ inr) x y
    Πᵁ→Π (Σᵁ u f) v x       (y , z) = Πᵁ→Π (f _) (v ∘ _,_ y) (Πᵁ→Π u (λ x → Πᵁ (f _) (v ∘ _,_ x)) x y) z

    Π→Πᵁ : ∀ u v → Π (El u) (El ∘ v) → El (Πᵁ u v)
    Π→Πᵁ 𝟘ᵁ v f = 0₁
    Π→Πᵁ 𝟙ᵁ v f = f 0₁
    Π→Πᵁ 𝟚ᵁ v f = f 0₂ , f 1₂
    Π→Πᵁ (u ×ᵁ u₁) v f = Π→Πᵁ u (λ x → Πᵁ u₁ (v ∘ _,_ x))
                           (λ x → Π→Πᵁ u₁ (v ∘ _,_ x) (f ∘ _,_ x))
    Π→Πᵁ (u ⊎ᵁ u₁) v f = Π→Πᵁ u (v ∘ inl) (f ∘ inl) ,
                           Π→Πᵁ u₁ (v ∘ inr) (f ∘ inr)
    Π→Πᵁ (Σᵁ u F) v f = Π→Πᵁ u (λ x → Πᵁ (F x) (v ∘ _,_ x))
                          (λ x → Π→Πᵁ (F x) (v ∘ _,_ x) (f ∘ _,_ x))

    →ᵁ→→ : ∀ u v → El (u →ᵁ v) → (El u → El v)
    →ᵁ→→ u v = Πᵁ→Π u (const v)

    →→→ᵁ : ∀ u v → (El u → El v) → El (u →ᵁ v)
    →→→ᵁ u v = Π→Πᵁ u (const v)

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

open import Level.NP
open import Type
open import Type.Identities
open import Function.NP
open import Function.Extensionality
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Product.NP
open import Data.Sum.NP
open import Data.Sum.Logical
open import Data.Nat
open import Data.Fin
open import Relation.Nullary.NP
open import Relation.Binary.PropositionalEquality.NP
open import Relation.Binary.Logical

open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Properties
open import Explore.Zero
open import Explore.One
open import Explore.Two
open import Explore.Product
open import Explore.Sum
open import Explore.Explorable
import Explore.Isomorphism

module Explore.Universe where

open Operators

infixr 2 _×ᵁ_

data U : ★
El : U → ★

data U where
  𝟘ᵁ 𝟙ᵁ 𝟚ᵁ : U
  _×ᵁ_ _⊎ᵁ_ : U → U → U
  Σᵁ : (t : U) (f : El t → U) → U

El 𝟘ᵁ = 𝟘
El 𝟙ᵁ = 𝟙
El 𝟚ᵁ = 𝟚
El (s ×ᵁ t) = El s × El t
El (s ⊎ᵁ t) = El s ⊎ El t
El (Σᵁ t f) = Σ (El t) λ x → El (f x)

data ⟦U⟧ : ⟦★₀⟧ U U
⟦El⟧ : (⟦U⟧ ⟦→⟧ ⟦★₀⟧) El El

data ⟦U⟧ where
  ⟦𝟘ᵁ⟧ : ⟦U⟧ 𝟘ᵁ 𝟘ᵁ
  ⟦𝟙ᵁ⟧ : ⟦U⟧ 𝟙ᵁ 𝟙ᵁ
  ⟦𝟚ᵁ⟧ : ⟦U⟧ 𝟚ᵁ 𝟚ᵁ
  _⟦×ᵁ⟧_ : ⟦Op₂⟧ ⟦U⟧ _×ᵁ_ _×ᵁ_
  _⟦⊎ᵁ⟧_ : ⟦Op₂⟧ ⟦U⟧ _⊎ᵁ_ _⊎ᵁ_
  ⟦Σᵁ⟧ : (⟨ t ∶ ⟦U⟧ ⟩⟦→⟧ (⟦El⟧ t ⟦→⟧ ⟦U⟧) ⟦→⟧ ⟦U⟧) Σᵁ Σᵁ

⟦El⟧ ⟦𝟘ᵁ⟧ = _≡_
⟦El⟧ ⟦𝟙ᵁ⟧ = _≡_
⟦El⟧ ⟦𝟚ᵁ⟧ = _≡_
⟦El⟧ (s ⟦×ᵁ⟧ t) = ⟦El⟧ s ⟦×⟧ ⟦El⟧ t
⟦El⟧ (s ⟦⊎ᵁ⟧ t) = ⟦El⟧ s ⟦⊎⟧ ⟦El⟧ t
⟦El⟧ (⟦Σᵁ⟧ t f) = ⟦Σ⟧ (⟦El⟧ t) λ x → ⟦El⟧ (f x)

module _ {k} {K : ★_ k} {a} {A : ★_ a} {x y : A} (p : x ≡ y) where
    tr-const : tr (const K) p ≡ id
    tr-const = J (λ x₁ p₁ → tr (const K) p₁ ≡ id) refl p

    {-
⟦U⟧-sound : ∀ {{_ : FunExt}} {x y} → ⟦U⟧ x y → x ≡ y
⟦U⟧-refl : ∀ x → ⟦U⟧ x x

{-
⟦El⟧-refl : ∀ x → {!⟦El⟧ x x!}
⟦El⟧-refl = {!!}
-}

⟦U⟧-sound ⟦𝟘ᵁ⟧ = refl
⟦U⟧-sound ⟦𝟙ᵁ⟧ = refl
⟦U⟧-sound ⟦𝟚ᵁ⟧ = refl
⟦U⟧-sound (u ⟦×ᵁ⟧ u₁) = ap₂ _×ᵁ_ (⟦U⟧-sound u) (⟦U⟧-sound u₁)
⟦U⟧-sound (u ⟦⊎ᵁ⟧ u₁) = ap₂ _⊎ᵁ_ (⟦U⟧-sound u) (⟦U⟧-sound u₁)
⟦U⟧-sound (⟦Σᵁ⟧ {u₀} {u₁} u {f₀} {f₁} fᵣ) = apd₂ Σᵁ (⟦U⟧-sound u) (tr-→ El (const U) (⟦U⟧-sound u) f₀ ∙ λ= (λ A → ap (λ z → z (f₀ (tr El (! ⟦U⟧-sound u) A))) (tr-const (⟦U⟧-sound u)) ∙ ⟦U⟧-sound (fᵣ {!!}))) -- (λ= (λ y → let foo = xᵣ {{!!}} {y} {!xᵣ!} in {!tr-→ El (const U) (⟦U⟧-sound u)!}))

⟦U⟧-refl 𝟘ᵁ = ⟦𝟘ᵁ⟧
⟦U⟧-refl 𝟙ᵁ = ⟦𝟙ᵁ⟧
⟦U⟧-refl 𝟚ᵁ = ⟦𝟚ᵁ⟧
⟦U⟧-refl (x ×ᵁ x₁) = ⟦U⟧-refl x ⟦×ᵁ⟧ ⟦U⟧-refl x₁
⟦U⟧-refl (x ⊎ᵁ x₁) = ⟦U⟧-refl x ⟦⊎ᵁ⟧ ⟦U⟧-refl x₁
⟦U⟧-refl (Σᵁ x f) = ⟦Σᵁ⟧ (⟦U⟧-refl x) (λ y → {!⟦U⟧-refl ?!})
-}

infix  8 _^ᵁ_
_^ᵁ_ : U → ℕ → U
t ^ᵁ zero  = t
t ^ᵁ suc n = t ×ᵁ t ^ᵁ n

module _ {ℓ} where

    explore : ∀ t → Explore ℓ (El t)
    explore 𝟘ᵁ = 𝟘ᵉ
    explore 𝟙ᵁ = 𝟙ᵉ
    explore 𝟚ᵁ = 𝟚ᵉ
    explore (s ×ᵁ t) = explore s ×ᵉ explore t
    explore (s ⊎ᵁ t) = explore s ⊎ᵉ explore t
    explore (Σᵁ t f) = exploreΣ (explore t) λ {x} → explore (f x)

    exploreU-ind : ∀ {p} t → ExploreInd p (explore t)
    exploreU-ind 𝟘ᵁ = 𝟘ⁱ
    exploreU-ind 𝟙ᵁ = 𝟙ⁱ
    exploreU-ind 𝟚ᵁ = 𝟚ⁱ
    exploreU-ind (s ×ᵁ t) = exploreU-ind s ×ⁱ exploreU-ind t
    exploreU-ind (s ⊎ᵁ t) = exploreU-ind s ⊎ⁱ exploreU-ind t
    exploreU-ind (Σᵁ t f) = exploreΣ-ind (exploreU-ind t) λ {x} → exploreU-ind (f x)

module _ {ℓ₀ ℓ₁ ℓᵣ} where
    ⟦explore⟧ : ∀ {t₀ t₁} (t : ⟦U⟧ t₀ t₁) → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ (⟦El⟧ t) (explore t₀) (explore t₁)
    ⟦explore⟧ ⟦𝟘ᵁ⟧        = ⟦𝟘ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ}
    ⟦explore⟧ ⟦𝟙ᵁ⟧        = ⟦𝟙ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_} {refl}
    ⟦explore⟧ ⟦𝟚ᵁ⟧        = ⟦𝟚ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_} {refl} {refl}
    ⟦explore⟧ (t ⟦×ᵁ⟧ t₁) = ⟦explore×⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ t) (⟦explore⟧ t₁)
    ⟦explore⟧ (t ⟦⊎ᵁ⟧ t₁) = ⟦explore⊎⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ t) (⟦explore⟧ t₁)
    ⟦explore⟧ (⟦Σᵁ⟧ t f)  = ⟦exploreΣ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ t) (⟦explore⟧ ∘ f)

module _ (t : U) where
  private
    tᵉ : ∀ {ℓ} → Explore ℓ (El t)
    tᵉ = explore t
    tⁱ : ∀ {ℓ p} → ExploreInd {ℓ} p tᵉ
    tⁱ = exploreU-ind t

  open FromExploreInd tⁱ public hiding (⟦explore⟧)
  {-
  open From⟦Explore⟧ (λ {ℓ₁} {ℓ₂} {ℓᵣ} → ⟦explore⟧' {ℓ₁} {ℓ₂} {ℓᵣ} t) public
  -}

adequate-sumU : ∀ {{_ : UA}}{{_ : FunExt}} t → Adequate-sum (sum t)
adequate-sumU 𝟘ᵁ       = 𝟘ˢ-ok
adequate-sumU 𝟙ᵁ       = 𝟙ˢ-ok
adequate-sumU 𝟚ᵁ       = 𝟚ˢ-ok
adequate-sumU (s ×ᵁ t) = adequate-sumΣ (adequate-sumU s) (adequate-sumU t)
adequate-sumU (s ⊎ᵁ t) = adequate-sum⊎ (adequate-sumU s) (adequate-sumU t)
adequate-sumU (Σᵁ t f) = adequate-sumΣ (adequate-sumU t) (λ {x} → adequate-sumU (f x))

module _ {ℓ} where
    lookupU : ∀ t → Lookup {ℓ} (explore t)
    lookupU 𝟘ᵁ = 𝟘ˡ
    lookupU 𝟙ᵁ = 𝟙ˡ
    lookupU 𝟚ᵁ = 𝟚ˡ
    lookupU (s ×ᵁ t) = lookup× {eᴬ = explore s} {eᴮ = explore t} (lookupU s) (lookupU t)
    lookupU (s ⊎ᵁ t) = lookup⊎ {eᴬ = explore s} {eᴮ = explore t} (lookupU s) (lookupU t)
    lookupU (Σᵁ t f) = lookupΣ {eᴬ = explore t} {eᴮ = λ {x} → explore (f x)} (lookupU t) (λ {x} → lookupU (f x))

    focusU : ∀ t → Focus {ℓ} (explore t)
    focusU 𝟘ᵁ = 𝟘ᶠ
    focusU 𝟙ᵁ = 𝟙ᶠ
    focusU 𝟚ᵁ = 𝟚ᶠ
    focusU (s ×ᵁ t) = focus× {eᴬ = explore s} {eᴮ = explore t} (focusU s) (focusU t)
    focusU (s ⊎ᵁ t) = focus⊎ {eᴬ = explore s} {eᴮ = explore t} (focusU s) (focusU t)
    focusU (Σᵁ t f) = focusΣ {eᴬ = explore t} {eᴮ = λ {x} → explore (f x)} (focusU t) (λ {x} → focusU (f x))

    ΣᵉU : ∀ A {ℓ} → (El A → ★_ ℓ) → ★_ ℓ
    ΣᵉU = λ A → Σᵉ (explore A)
    ΠᵉU : ∀ A {ℓ} → (El A → ★_ ℓ) → ★_ ℓ
    ΠᵉU = λ A → Πᵉ (explore A)

    module _ {{_ : UA}}{{_ : FunExt}} where
        ΣᵉU-ok : ∀ t → Adequate-Σ {ℓ} (ΣᵉU t)
        ΣᵉU-ok 𝟘ᵁ       = Σᵉ𝟘-ok
        ΣᵉU-ok 𝟙ᵁ       = Σᵉ𝟙-ok
        ΣᵉU-ok 𝟚ᵁ       = Σᵉ𝟚-ok
        ΣᵉU-ok (t ×ᵁ u) = Σᵉ×-ok {eᴬ = explore t} {eᴮ = explore u} (ΣᵉU-ok t) (ΣᵉU-ok u)
        ΣᵉU-ok (t ⊎ᵁ u) = Σᵉ⊎-ok {eᴬ = explore t} {eᴮ = explore u} (ΣᵉU-ok t) (ΣᵉU-ok u)
        ΣᵉU-ok (Σᵁ t u) = ΣᵉΣ-ok {eᴬ = explore t} {eᴮ = λ {x} → explore (u x)} (ΣᵉU-ok t) (λ {x} → ΣᵉU-ok (u x))

        ΠᵉU-ok : ∀ t → Adequate-Π {ℓ} (ΠᵉU t)
        ΠᵉU-ok 𝟘ᵁ       = Πᵉ𝟘-ok
        ΠᵉU-ok 𝟙ᵁ       = Πᵉ𝟙-ok
        ΠᵉU-ok 𝟚ᵁ       = Πᵉ𝟚-ok
        ΠᵉU-ok (t ×ᵁ u) = Πᵉ×-ok {eᴬ = explore t} {eᴮ = explore u} (ΠᵉU-ok t) (ΠᵉU-ok u)
        ΠᵉU-ok (t ⊎ᵁ u) = Πᵉ⊎-ok {eᴬ = explore t} {eᴮ = explore u} (ΠᵉU-ok t) (ΠᵉU-ok u)
        ΠᵉU-ok (Σᵁ t u) = ΠᵉΣ-ok {eᴬ = explore t} {eᴮ = λ {x} → explore (u x)} (ΠᵉU-ok t) (λ {x} → ΠᵉU-ok (u x))

{-
module _ (t : U) {{_ : UA}} {{_ : FunExt}} where
  open FromAdequate-Σᵉ t (ΣᵉU-ok t) public
  open FromAdequate-Πᵉ t (ΠᵉU-ok t) public
-}

module _ (A : U) (P : El A → ★₀) where
    Dec-Σ : Π (El A) (Dec ∘ P) → Dec (Σ (El A) P)
    Dec-Σ = map-Dec (unfocus A) (focusU A) ∘ lift-Dec A P ∘ reify A

-- See Explore.Fin for an example of the use of this module
module Isomorphism {A : ★₀} u (e : El u ≃ A) where
  open Explore.Isomorphism e

  module _ {ℓ} where
    isoᵉ : Explore ℓ A
    isoᵉ = explore-iso (explore u)

    module _ {p} where
      isoⁱ : ExploreInd p isoᵉ
      isoⁱ = explore-iso-ind (exploreU-ind u)

  module _ {ℓ} where
  {-
    isoˡ : Lookup {ℓ} isoᵉ
    isoˡ = lookup-iso {ℓ} {exploreU u} (lookupU u)

    isoᶠ : Focus {ℓ} isoᵉ
    isoᶠ = focus-iso {ℓ} {exploreU u} (focusU u)
    -}

    isoʳ : Reify {ℓ} isoᵉ
    isoʳ = FromExploreInd-iso.reify (exploreU-ind u)

    isoᵘ : Unfocus {ℓ} isoᵉ
    isoᵘ = FromExploreInd-iso.unfocus (exploreU-ind u)

  isoˢ : Sum A
  isoˢ = sum-iso (sum u)

  isoᵖ : Product A
  isoᵖ = product-iso (sum u)

  module _ {{_ : UA}}{{_ : FunExt}} where
    isoˢ-ok : Adequate-sum isoˢ
    isoˢ-ok = sum-iso-ok (adequate-sumU u)

    open Adequate-sum₀ isoˢ-ok isoˢ-ok public renaming (sumStableUnder to isoˢ-stableUnder)

Finᵁ : ℕ → U
Finᵁ zero    = 𝟘ᵁ
Finᵁ (suc n) = 𝟙ᵁ ⊎ᵁ Finᵁ n

Finᵁ' : ℕ → U
Finᵁ' zero          = 𝟘ᵁ
Finᵁ' (suc zero)    = 𝟙ᵁ
Finᵁ' (suc (suc n)) = 𝟙ᵁ ⊎ᵁ Finᵁ' (suc n)

Finᵁ-Fin : ∀ n → El (Finᵁ n) ≃ Fin n
Finᵁ-Fin zero    = ≃-! Fin0≃𝟘
Finᵁ-Fin (suc n) = ⊎≃ ≃-refl (Finᵁ-Fin n) ≃-∙ ≃-! Fin∘suc≃𝟙⊎Fin

Finᵁ'-Fin : ∀ n → El (Finᵁ' n) ≃ Fin n
Finᵁ'-Fin zero          = ≃-! Fin0≃𝟘
Finᵁ'-Fin (suc zero)    = ≃-! Fin1≃𝟙
Finᵁ'-Fin (suc (suc n)) = ⊎≃ ≃-refl (Finᵁ'-Fin (suc n)) ≃-∙ ≃-! Fin∘suc≃𝟙⊎Fin

Πᵁ : (u : U) (v : El u → U) → U
Πᵁ 𝟘ᵁ        v = 𝟙ᵁ
Πᵁ 𝟙ᵁ        v = v _
Πᵁ 𝟚ᵁ        v = v 0₂ ×ᵁ v 1₂
Πᵁ (u ×ᵁ u₁) v = Πᵁ u λ x → Πᵁ u₁ λ y → v (x , y)
Πᵁ (u ⊎ᵁ u₁) v = (Πᵁ u (v ∘ inl)) ×ᵁ (Πᵁ u₁ (v ∘ inr))
Πᵁ (Σᵁ u f)  v = Πᵁ u λ x → Πᵁ (f x) (v ∘ _,_ x)

_→ᵁ_ : (u : U) (v : U) → U
u →ᵁ v = Πᵁ u (const v)

{-
𝟛ᵁ : U
𝟛ᵁ = 𝟙ᵁ ⊎ᵁ 𝟚ᵁ

list22 = list (𝟚ᵁ →ᵁ 𝟚ᵁ)
list33 = list (𝟛ᵁ →ᵁ 𝟛ᵁ)
-}

module _ {{_ : UA}}{{_ : FunExt}} where
    Πᵁ-Π : ∀ u v → El (Πᵁ u v) ≡ Π (El u) (El ∘ v)
    Πᵁ-Π 𝟘ᵁ        v = ! Π𝟘-uniq₀ _
    Πᵁ-Π 𝟙ᵁ        v = ! Π𝟙-uniq _
    Πᵁ-Π 𝟚ᵁ        v = ! Π𝟚-×
    Πᵁ-Π (u ×ᵁ u₁) v = Πᵁ-Π u (λ x → Πᵁ u₁ (v ∘ _,_ x)) ∙ Π=′ _ (λ _ → Πᵁ-Π u₁ _) ∙ ! ΠΣ-curry
    Πᵁ-Π (u ⊎ᵁ u₁) v = ×= (Πᵁ-Π u (v ∘ inl)) (Πᵁ-Π u₁ (v ∘ inr)) ∙ ! dist-×-Π
    Πᵁ-Π (Σᵁ u f)  v = Πᵁ-Π u (λ x → Πᵁ (f _) (v ∘ _,_ x)) ∙ Π=′ _ (λ _ → Πᵁ-Π (f _) _) ∙ ! ΠΣ-curry

    →ᵁ-→ : ∀ u v → El (u →ᵁ v) ≡ (El u → El v)
    →ᵁ-→ u v = Πᵁ-Π u (const v)

    Πᵁ→Π : ∀ u v → El (Πᵁ u v) → Π (El u) (El ∘ v)
    Πᵁ→Π 𝟘ᵁ v x₂ ()
    Πᵁ→Π 𝟙ᵁ v x₂ x₃ = x₂
    Πᵁ→Π 𝟚ᵁ v (x , y) 0₂ = x
    Πᵁ→Π 𝟚ᵁ v (x , y) 1₂ = y
    Πᵁ→Π (u ×ᵁ u₁) v x (z , t) = Πᵁ→Π u₁ (v ∘ _,_ z) (Πᵁ→Π u (λ x → Πᵁ u₁ (v ∘ _,_ x)) x z) t
    Πᵁ→Π (u ⊎ᵁ _) v (x , _) (inl y) = Πᵁ→Π u (v ∘ inl) x y
    Πᵁ→Π (_ ⊎ᵁ u) v (_ , x) (inr y) = Πᵁ→Π u (v ∘ inr) x y
    Πᵁ→Π (Σᵁ u f) v x       (y , z) = Πᵁ→Π (f _) (v ∘ _,_ y) (Πᵁ→Π u (λ x → Πᵁ (f _) (v ∘ _,_ x)) x y) z

    →ᵁ→→ : ∀ u v → El (u →ᵁ v) → (El u → El v)
    →ᵁ→→ u v = Πᵁ→Π u (const v)

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


Write down real step-indexed logical relation for untyped terms

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

module Thesis.ANormalUntyped where

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

{- Typed deBruijn indexes for untyped languages. -}

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

record DType : Set where
  constructor DUni

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

import Base.Denotation.Environment DType DVal as D

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

module Thesis.ANormalUntyped where

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

{- Typed deBruijn indexes for untyped languages. -}

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

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

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

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

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

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

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

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

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

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

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

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

Res : Set
Res = ℕ → ErrVal

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


scraps

scraps

open import Nat
open import Prelude
open import List
open import core
open import contexts

module expansion-unicity where
  mutual
    expansion-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    expansion-unicity-synth ESConst ESConst = refl , refl , refl
    expansion-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl
    expansion-unicity-synth (ESLam apt1 d1) (ESLam apt2 d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = ap1 _ ih1  , ap1 _ ih2 , {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp1 x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp2 x₄ d5 x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp3 x₄ d5 x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp1 x₃ x₄ x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp2 x₃ d6 x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp3 x₃ d6 x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp1 x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp2 x₂ d6 x₃ x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp3 x₂ d6 x₃) = {!!}
    expansion-unicity-synth ESEHole ESEHole = refl , refl , refl
    expansion-unicity-synth (ESNEHole d1) (ESNEHole d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc1 x₂ x₃) = {!!}
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc2 x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc1 x₁ x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc2 x₁) = {!!}

    expansion-unicity-ana : {Γ : tctx} {e : hexp} {τ1 τ1' τ2 τ2' : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                          Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' ⊣ Δ1 →
                          Γ ⊢ e ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
                          τ1 == τ2 × d1 == d2 × τ1' == τ2' × Δ1 == Δ2
    expansion-unicity-ana (EALam apt1 d1) (EALam apt2 d2) = {!!}
    expansion-unicity-ana (EALam apt1 d1) (EASubsume x₁ x₂ x₃ x₄) = {!!}
    expansion-unicity-ana (EASubsume x₁ x₂ x₃ x₄) (EALam apt2 d2) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole x₄ x₅) = {!!}
    expansion-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = {!!}
    expansion-unicity-ana EAEHole EAEHole = {!!}
    expansion-unicity-ana (EANEHole x x₁) (EASubsume x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-ana (EANEHole x x₁) (EANEHole x₂ x₃) = {!!}

open import Nat
open import Prelude
open import List
open import core
open import contexts

module expansion-unicity where
  mutual
    expansion-unicity-synth : {Γ : tctx} {e : hexp} {τ1 τ2 : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                            Γ ⊢ e ⇒ τ1 ~> d1 ⊣ Δ1 →
                            Γ ⊢ e ⇒ τ2 ~> d2 ⊣ Δ2 →
                            τ1 == τ2 × d1 == d2 × Δ1 == Δ2
    expansion-unicity-synth ESConst ESConst = refl , refl , refl
    expansion-unicity-synth (ESVar {Γ = Γ} x₁) (ESVar x₂) = ctxunicity {Γ = Γ} x₁ x₂ , refl , refl
    expansion-unicity-synth (ESLam d1) (ESLam d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = ap1 _ ih1  , ap1 _ ih2 , refl
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp1 x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp2 x₄ d5 x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp1 x x₁ x₂ x₃) (ESAp3 x₄ d5 x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp1 x₃ x₄ x₅ x₆) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp2 x₃ d6 x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp2 x d5 x₁ x₂) (ESAp3 x₃ d6 x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp1 x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp2 x₂ d6 x₃ x₄) = {!!}
    expansion-unicity-synth (ESAp3 x d5 x₁) (ESAp3 x₂ d6 x₃) = {!!}
    expansion-unicity-synth ESEHole ESEHole = refl , refl , refl
    expansion-unicity-synth (ESNEHole d1) (ESNEHole d2) with expansion-unicity-synth d1 d2
    ... | ih1 , ih2 , ih3 = refl , ap1 _ ih2 , ap1 _ ih3
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc1 x₂ x₃) = {!!}
    expansion-unicity-synth (ESAsc1 x x₁) (ESAsc2 x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc1 x₁ x₂) = {!!}
    expansion-unicity-synth (ESAsc2 x) (ESAsc2 x₁) = {!!}

    expansion-unicity-ana : {Γ : tctx} {e : hexp} {τ1 τ1' τ2 τ2' : htyp} {d1 d2 : dhexp} {Δ1 Δ2 : hctx} →
                          Γ ⊢ e ⇐ τ1 ~> d1 :: τ1' ⊣ Δ1 →
                          Γ ⊢ e ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
                          τ1 == τ2 × d1 == d2 × τ1' == τ2' × Δ1 == Δ2
    expansion-unicity-ana (EALam d1) (EALam d2) = {!!}
    expansion-unicity-ana (EALam d1) (EASubsume x₁ x₂ x₃ x₄) = {!!}
    expansion-unicity-ana (EASubsume x₁ x₂ x₃ x₄) (EALam d2) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EASubsume x₄ x₅ x₆ x₇) = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) EAEHole = {!!}
    expansion-unicity-ana (EASubsume x x₁ x₂ x₃) (EANEHole x₄ x₅) = {!!}
    expansion-unicity-ana EAEHole (EASubsume x x₁ x₂ x₃) = {!!}
    expansion-unicity-ana EAEHole EAEHole = {!!}
    expansion-unicity-ana (EANEHole x x₁) (EASubsume x₂ x₃ x₄ x₅) = {!!}
    expansion-unicity-ana (EANEHole x x₁) (EANEHole x₂ x₃) = {!!}