agda: we don't need a proof that the input change is valid (#33)

diff is defined on the semantic domain, so it produces a valid change
on functions even when the input is not a valid change (maybe this
extends to the syntactic domain, but I won't claim that).

However, the proof of correctness of symbolic derivation uses
diff-apply, which is still only valid on valid changes, as visible in
the type of diff-apply-proof.

Currently, diff-is-valid and derive-is-valid are unused. However, when
the proof of derive-term will use diff-apply-proof, derive-term will
only be valid on valid changes; so diff-is-valid and derive-is-valid
will be required to prove that we can produce such valid changes.

Additionally, remark that now validity proofs form a strictly positive
datatype, so they could be encoded with a standard datatype.

Moreover, validity proofs are not any more a logical relation.

Old-commit-hash: 1a3d91d1304701dead9c75f987d7e19b4fb45401

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:
-- Note: now I could go back to using a datatype, since the datatype is now strictly positive.
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)

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

derive-is-valid : ∀ {τ} (v : ⟦ τ ⟧) → valid-Δ {τ} v (derive v)
derive-is-valid v rewrite sym (diff-derive v) = diff-is-valid v v

-- This is a postulate elsewhere, but here I provide 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))))) ⟩
    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)

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

derive-is-valid : ∀ {τ} (v : ⟦ τ ⟧) → valid-Δ {τ} v (derive v)
derive-is-valid v rewrite sym (diff-derive v) = diff-is-valid v v

-- 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)


bintree: adapt sorting proofs

bintree: adapt sorting proofs

module prefect-bintree-sorting where
import Level as L
open import Function.NP
import Data.Nat.NP as Nat
open Nat using (ℕ; zero; suc; 2^_; _+_; _∸_; module ℕ°; module ℕ≤; +-≤-inj; ¬n+≤y<n; sucx≰x; ¬n≤x<n; module ℕcmp) renaming (module <= to ℕ<=; _<=_ to _ℕ<=_)
open import Data.Bool.NP hiding (toℕ)
open import Data.Sum
open import Data.Bits
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product using (_×_; _,_; proj₁; proj₂; ∃; uncurry) renaming (swap to swap-×)
open import Data.Vec.NP using (Vec; _++_; module Alternative-Reverse; shallow-η)
open import Relation.Nullary
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning; [_])
open import Algebra.FunctionProperties
import Relation.Binary.ToNat as ToNat
open import prefect-bintree
open import Data.Nat.Properties
open Nat using (z≤n; s≤s; ≤-pred; 2*_; 2*′_; 2*-spec; 2*′-spec; suc-injective) renaming (_≤_ to _ℕ≤_; _<_ to _ℕ<_)

module MM where
 open Nat using (_≤_; _<_)
 split-≤ : ∀ {x y} → x ≤ y → x ≡ y ⊎ x < y
 split-≤ {zero} {zero} p = inj₁ ≡.refl
 split-≤ {zero} {suc y} p = inj₂ (s≤s z≤n)
 split-≤ {suc x} {zero} ()
 split-≤ {suc x} {suc y} (s≤s p) with split-≤ {x} {y} p
 ... | inj₁ q rewrite q = inj₁ ≡.refl
 ... | inj₂ q = inj₂ (s≤s q)

 <→≤ : ∀ {x y} → x < y → x ≤ y
 <→≤ (s≤s p) = ≤-steps 1 p

 Monotone : ℕ → Endo ℕ → Set
 Monotone ub f = ∀ {x y} → x ≤ y → y < ub → f x ≤ f y

 IsInj : ℕ → Endo ℕ → Set
 IsInj ub f = ∀ {x y} → x < ub → y < ub → f x ≡ f y → x ≡ y

 Bounded : ℕ → Endo ℕ → Set
 Bounded ub f = ∀ x → x < ub → f x < ub

 module M (f : ℕ → ℕ) {ub}
          (f-mono : Monotone ub f)
          (f-inj : IsInj ub f)
          (f-bounded : Bounded ub f) where

  f-mono-< : ∀ {x y} → x < y → y < ub → f x < f y
  f-mono-< {x} {y} p y<ub with split-≤ (f-mono {x} {y} (<→≤ p) y<ub)
  ... | inj₁ q = ⊥-elim (sucx≰x y (≡.subst (λ z → suc z ℕ≤ y) (f-inj {x} {y} (<-trans p y<ub) y<ub q) p))
  ... | inj₂ q = q

  -- f-mono-<′ : ∀ {x} → suc x < ub → f x < f (suc x)

  le : ∀ n → suc n < ub → f (suc n) ≤ n → f n < n
  le n 1+n<ub p = ℕ≤.trans (f-mono-< {n} {suc n} ℕ≤.refl 1+n<ub) p

  bo : ∀ b → b < ub → ¬(f b < b)
  bo zero _ ()
  bo (suc b) b<ub (s≤s p) = bo b (ℕ≤.trans (s≤s (≤-step ℕ≤.refl)) b<ub) (le b b<ub p)

  fp : ∀ b → b < ub → Bounded (suc b) f → f b ≡ b
  fp b b<ub bub with split-≤ (bub b ℕ≤.refl)
  ... | inj₁ p = suc-injective p
  ... | inj₂ p = ⊥-elim (bo b b<ub (≤-pred p))

  ob : ∀ b → b ≤ ub → Bounded b f → ∀ x → x < b → f x ≡ x
  ob zero b≤ub bub _ ()
  ob (suc b) b≤ub bub x pf with split-≤ pf
  ... | inj₁ p rewrite suc-injective p = fp b b≤ub bub
  ... | inj₂ (s≤s p) = ob b (<→≤ b≤ub) ((λ y y<b → ℕ≤.trans (f-mono-< y<b b≤ub) (ℕ≤.reflexive (fp b b≤ub bub)))) x p

  is-id : ∀ x → x < ub → f x ≡ x
  is-id = ob ub ℕ≤.refl f-bounded

open BitsSorting
open OperationSyntax
open BijSpec
open EvalTree
open Alternative-Reverse
open SPP

mkBijT : ∀ {n} → Tree (Bits n) n → Bij n
mkBijT = bij ∘ sort-bij

mkBijT⁻¹ : ∀ {n} → Tree (Bits n) n → Bij n
mkBijT⁻¹ f = mkBijT f ⁻¹

mkBij : ∀ {n} → Endo (Bits n) → Bij n
mkBij f = mkBijT (fromFun f) ⁻¹

mkBij-p : ∀ {n} (t : Tree (Bits n) n) → t ≡ evalTree (mkBijT t) (sort t)
mkBij-p = proof ∘ sort-bij

IsInj : ∀ {i o} → (Bits i → Bits o) → Set
IsInj f = ∀ {x y} → f x ≡ f y → x ≡ y

idT : ∀ {n} → Tree (Bits n) n
idT = fromFun id

toFun-idT : ∀ {n} → toFun idT ≗ id {A = Bits n}
toFun-idT x = toFun∘fromFun id x

InjT : ∀ {n} → Tree (Bits n) n → Set
InjT = IsInj ∘ toFun

_⁻¹-inverseTree : ∀ {n} f → evalTree (f `⁏ f ⁻¹) ≗ id {A = Tree (Bits n) n}
(f ⁻¹-inverseTree) t = evalTree (f `⁏ f ⁻¹) t
                     ≡⟨ ≡.sym (fromFun∘toFun (evalTree (f `⁏ f ⁻¹) t)) ⟩
                       fromFun (toFun (evalTree (f `⁏ f ⁻¹) t))
                     ≡⟨ fromFun-≗ (evalTree-eval′ (f `⁏ f ⁻¹) t) ⟩
                       fromFun (toFun t ∘ eval (f ⁻¹ ⁻¹ `⁏ f ⁻¹))
                     ≡⟨ fromFun-≗ (λ x → ≡.cong (toFun t) (VecBijKit._⁻¹-inverse′ _ (f ⁻¹) x)) ⟩
                       fromFun (toFun t)
                     ≡⟨ fromFun∘toFun t ⟩
                       t
                     ∎ where open ≡-Reasoning

mkBij-p⁻¹ : ∀ {n} (t : Tree (Bits n) n) → evalTree (mkBijT⁻¹ t) t ≡ sort t
mkBij-p⁻¹ t = ≡.trans (≡.cong (evalTree (mkBijT⁻¹ t)) (mkBij-p t)) (((mkBijT t) ⁻¹-inverseTree) (sort t))

foo : ∀ {n} (t : Tree (Bits n) n) → toFun t ≗ toFun (sort t) ∘ eval (mkBijT⁻¹ t)
foo t xs = toFun t xs
         ≡⟨ ≡.cong (λ t → toFun t xs) (mkBij-p t) ⟩
           toFun (evalTree (mkBijT t) (sort t)) xs
         ≡⟨ evalTree-eval (mkBijT⁻¹ t) (evalTree (mkBijT t) (sort t)) xs ⟩
           toFun (evalTree (mkBijT⁻¹ t) (evalTree (mkBijT t) (sort t))) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ ≡.refl ⟩
           toFun (evalTree (mkBijT t `⁏ mkBijT⁻¹ t) (sort t)) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ ≡.cong (λ u → toFun u (eval (mkBijT⁻¹ t) xs)) (((mkBijT t) ⁻¹-inverseTree) (sort t)) ⟩
           toFun (sort t) (eval (mkBijT⁻¹ t) xs)
         ∎ where open ≡-Reasoning

module SortedMonotonicFunctionsBits {n} where
    open SortedMonotonicFunctions (_≤_ {n}) isPreorder public
open SortedMonotonicFunctionsBits hiding (Sorted)

-- _∘-inj_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {f : B → C} {g : A → B} → IsInj f → IsInj g → IsInj (f ∘ g)
_∘-inj_ : ∀ {a b c} {f : Bits b → Bits c} {g : Bits a → Bits b} → IsInj f → IsInj g → IsInj (f ∘ g)
f-inj ∘-inj g-inj = g-inj ∘ f-inj

_∷-inj : ∀ {n} b → IsInj (_∷_ {n = n} b)
(_ ∷-inj) ≡.refl = ≡.refl

lemvec : ∀ {n} (xs ys : Bits (suc n)) → head xs ≡ head ys → tail xs ≡ tail ys → xs ≡ ys
lemvec (x ∷ xs) (.x ∷ .xs) ≡.refl ≡.refl = ≡.refl

≤→≤ᴮ : ∀ {n} {x y : Bits n} → x ≤ y → x ≤ᴮ y
≤→≤ᴮ {x = []}         {[]}         p = []
≤→≤ᴮ {suc n} {true ∷ xs}  {true ∷ ys}  p = there 1b (≤→≤ᴮ {x = xs} {ys} (ℕ<=.complete {toℕ xs} {toℕ ys} (+-≤-inj (2^ n) (ℕ<=.sound _ _ p))))
≤→≤ᴮ {x = false ∷ xs} {false ∷ ys} p = there 0b (≤→≤ᴮ {x = xs} {ys} p)
≤→≤ᴮ {suc n} {true ∷ xs}  {false ∷ ys} p = ⊥-elim (2ⁿ+≰toℕ ys (ℕ<=.sound (2^ n + toℕ xs) (toℕ ys) p))
≤→≤ᴮ {x = false ∷ xs} {true ∷ ys}  p = 0-1 xs ys

≤ᴮ→≤ : ∀ {n} {x y : Bits n} → x ≤ᴮ y → x ≤ y
≤ᴮ→≤ [] = _
≤ᴮ→≤ {suc n} (there true p) = ℕ<=.complete (ℕ≤.refl {2^ n} +-mono (ℕ<=.sound _ _ (≤ᴮ→≤ p)))
≤ᴮ→≤ (there false p) = ≤ᴮ→≤ p
≤ᴮ→≤ (0-1 p q) = ℕ<=.complete (toℕ≤2ⁿ+ p {toℕ q})

Monotone' : ∀ {i o} → (Bits i → Bits o) → Set _
Monotone' {i} {o} f = ∀ {p q : Bits i} → p ≤ᴮ q → f p ≤ᴮ f q

toEndoℕ : ∀ {n} → Endo (Bits n) → Endo ℕ
toEndoℕ f = toℕ ∘ f ∘ fromℕ

open Nat using (_≰_)

module ToEndoℕ {n} (f : Endo (Bits n)) where
    fℕ = toEndoℕ f

    fromℕn = fromℕ {n}

    mono : Monotone f → MM.Monotone (2^ n) fℕ
    mono f-mono {x} {y} x≤y y<2ⁿ
       = ℕ<=.sound _ _
          (f-mono
            (≤→≤ᴮ (ℕ<=.complete {toℕ (fromℕn x)} {toℕ (fromℕn y)}
                     (ℕ≤.trans (ℕ≤.reflexive (toℕ∘fromℕ {n} x (ℕ≤.trans (s≤s x≤y) y<2ⁿ)))
                        (ℕ≤.trans x≤y (ℕ≤.reflexive (≡.sym (toℕ∘fromℕ {n} y y<2ⁿ))))))))

    inj : IsInj f → MM.IsInj (2^ n) fℕ
    inj f-inj {x} {y} x< y< = fromℕ-inj x< y< ∘ f-inj ∘ toℕ-inj _ _

    bounded : MM.Bounded (2^ n) fℕ
    bounded x x≤2ⁿ = toℕ-bound (f (fromℕ x))

lem : ∀ {n} (f : Endo (Bits n)) → Monotone f → IsInj f → f ≗ id
lem {n} f f-mono f-inj x = toℕ-inj _ _ (≡.trans (≡.cong (toℕ ∘ f) (≡.sym (fromℕ∘toℕ x))) (MM.M.is-id (toEndoℕ f) {2^ n} (mono f-mono) (inj f-inj) bounded (toℕ x) (toℕ-bound x)))
  where open ToEndoℕ f

IsInj-toFunFromFun : ∀ {n} (f : Endo (Bits n)) → IsInj f → IsInj (toFun (fromFun f))
IsInj-toFunFromFun f f-inj {x} {y} eq
  rewrite toFun∘fromFun f x
        | toFun∘fromFun f y
        = f-inj eq

sort-spec′ : ∀ {n} (t : Tree (Bits n) n) → Sorted (evalTree (mkBijT⁻¹ t) t)
sort-spec′ t rewrite mkBij-p⁻¹ t = sort-spec t

sort-id′′ : ∀ {n} (t : Tree (Bits n) n) → InjT t → Sorted t → toFun t ≗ id
sort-id′′ t Pt st x = lem (toFun t) (DataSorted→Sorted st) Pt x

toFun-eval-inj : ∀ {n} (f : Bij n) → IsInj (eval f)
toFun-eval-inj f {x} {y} eq = x
                            ≡⟨ ≡.sym ((f ⁻¹-inverse) x) ⟩
                              eval (f ⁻¹) (eval f x)
                            ≡⟨ ≡.cong (eval (f ⁻¹)) eq ⟩
                              eval (f ⁻¹) (eval f y)
                            ≡⟨ (f ⁻¹-inverse) y ⟩
                              y
                            ∎ where open ≡-Reasoning

toFun-evalTree-inj : ∀ {n} f (t : Tree (Bits n) n) → InjT t → InjT (evalTree f t)
toFun-evalTree-inj f t Pt {x} {y} eq
  rewrite evalTree-eval′ f t x
        | evalTree-eval′ f t y = toFun-eval-inj (f ⁻¹) (Pt eq)

sort-id′ : ∀ {n} f (t : Tree (Bits n) n) → InjT t → Sorted (evalTree f t) → toFun (evalTree f t) ≗ id
sort-id′ f t Pt = sort-id′′ (evalTree f t) (λ {x} {y} eq → toFun-evalTree-inj f t Pt eq)

sort-id : ∀ {n} (t : Tree (Bits n) n) → InjT t → toFun (sort t) ≗ id
sort-id t Pt rewrite ≡.sym (mkBij-p⁻¹ t) = sort-id′ (mkBijT⁻¹ t) t Pt (sort-spec′ t)

bar : ∀ {n} (t : Tree (Bits n) n) → InjT t → toFun t ≗ eval (mkBijT⁻¹ t)
bar t Pt xs = toFun t xs
         ≡⟨ foo t xs ⟩
           toFun (sort t) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ sort-id t Pt (eval (mkBijT⁻¹ t) xs) ⟩
           eval (mkBijT⁻¹ t) xs
         ∎ where open ≡-Reasoning

thm : ∀ {n} (f : Endo (Bits n)) (f-inj : IsInj f) →
        eval (mkBij f) ≗ f
thm f f-inj xs = eval (mkBij f) xs
               ≡⟨ ≡.sym (bar (fromFun f) (IsInj-toFunFromFun f f-inj) xs) ⟩
                 toFun (fromFun f) xs
               ≡⟨ toFun∘fromFun f xs ⟩
                 f xs
               ∎ where open ≡-Reasoning

thm# : ∀ {n} (f : Endo (Bits n)) (f-inj : IsInj f) (g : Bits n → Bit) →
       #⟨ g ∘ f ⟩ ≡ #⟨ g ⟩
thm# f f-inj g = #⟨ g ∘ f ⟩
               ≡⟨ #-≗ (g ∘ f) (g ∘ eval (mkBij f)) (λ x → ≡.cong g (≡.sym (thm f f-inj x))) ⟩
                 #⟨ g ∘ eval (mkBij f) ⟩
               ≡⟨ #-bij (mkBij f) g ⟩
                 #⟨ g ⟩
               ∎ where open ≡-Reasoning

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

module prefect-bintree-sorting where
import Level as L
open import Function.NP
import Data.Nat.NP as Nat
open Nat using (ℕ; zero; suc; 2^_; _+_; _∸_; module ℕ°; module ℕ≤; +-≤-inj; ¬n+≤y<n; sucx≰x; ¬n≤x<n; module ℕcmp) renaming (module <= to ℕ<=; _<=_ to _ℕ<=_)
open import Data.Bool.NP hiding (toℕ)
open import Data.Sum
open import Data.Bits
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product using (_×_; _,_; proj₁; proj₂; ∃; uncurry) renaming (swap to swap-×)
open import Data.Vec.NP using (Vec; _++_; module Alternative-Reverse; shallow-η)
open import Relation.Nullary
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning; [_])
open import Algebra.FunctionProperties
import Relation.Binary.ToNat as ToNat
open import prefect-bintree
open import Data.Nat.Properties
open Nat using (z≤n; s≤s; ≤-pred; 2*_; 2*′_; 2*-spec; 2*′-spec; suc-injective) renaming (_≤_ to _ℕ≤_; _<_ to _ℕ<_)

module MM where
 open Nat using (_≤_; _<_)
 split-≤ : ∀ {x y} → x ≤ y → x ≡ y ⊎ x < y
 split-≤ {zero} {zero} p = inj₁ ≡.refl
 split-≤ {zero} {suc y} p = inj₂ (s≤s z≤n)
 split-≤ {suc x} {zero} ()
 split-≤ {suc x} {suc y} (s≤s p) with split-≤ {x} {y} p
 ... | inj₁ q rewrite q = inj₁ ≡.refl
 ... | inj₂ q = inj₂ (s≤s q)

 <→≤ : ∀ {x y} → x < y → x ≤ y
 <→≤ (s≤s p) = ≤-steps 1 p

 Monotone : ℕ → Endo ℕ → Set
 Monotone ub f = ∀ {x y} → x ≤ y → y < ub → f x ≤ f y

 IsInj : ℕ → Endo ℕ → Set
 IsInj ub f = ∀ {x y} → x < ub → y < ub → f x ≡ f y → x ≡ y

 Bounded : ℕ → Endo ℕ → Set
 Bounded ub f = ∀ x → x < ub → f x < ub

 module M (f : ℕ → ℕ) {ub}
          (f-mono : Monotone ub f)
          (f-inj : IsInj ub f)
          (f-bounded : Bounded ub f) where

  f-mono-< : ∀ {x y} → x < y → y < ub → f x < f y
  f-mono-< {x} {y} p y<ub with split-≤ (f-mono {x} {y} (<→≤ p) y<ub)
  ... | inj₁ q = ⊥-elim (sucx≰x y (≡.subst (λ z → suc z ℕ≤ y) (f-inj {x} {y} (<-trans p y<ub) y<ub q) p))
  ... | inj₂ q = q

  -- f-mono-<′ : ∀ {x} → suc x < ub → f x < f (suc x)

  le : ∀ n → suc n < ub → f (suc n) ≤ n → f n < n
  le n 1+n<ub p = ℕ≤.trans (f-mono-< {n} {suc n} ℕ≤.refl 1+n<ub) p

  bo : ∀ b → b < ub → ¬(f b < b)
  bo zero _ ()
  bo (suc b) b<ub (s≤s p) = bo b (ℕ≤.trans (s≤s (≤-step ℕ≤.refl)) b<ub) (le b b<ub p)

  fp : ∀ b → b < ub → Bounded (suc b) f → f b ≡ b
  fp b b<ub bub with split-≤ (bub b ℕ≤.refl)
  ... | inj₁ p = suc-injective p
  ... | inj₂ p = ⊥-elim (bo b b<ub (≤-pred p))

  ob : ∀ b → b ≤ ub → Bounded b f → ∀ x → x < b → f x ≡ x
  ob zero b≤ub bub _ ()
  ob (suc b) b≤ub bub x pf with split-≤ pf
  ... | inj₁ p rewrite suc-injective p = fp b b≤ub bub
  ... | inj₂ (s≤s p) = ob b (<→≤ b≤ub) ((λ y y<b → ℕ≤.trans (f-mono-< y<b b≤ub) (ℕ≤.reflexive (fp b b≤ub bub)))) x p

  is-id : ∀ x → x < ub → f x ≡ x
  is-id = ob ub ℕ≤.refl f-bounded

open BitsSorting
open OperationSyntax
open PermTreeProof
open EvalTree
open Alternative-Reverse

mkBijT : ∀ {n} → Tree (Bits n) n → Bij n
mkBijT = Perm.perm SPP.sort-proof

mkBijT⁻¹ : ∀ {n} → Tree (Bits n) n → Bij n
mkBijT⁻¹ f = mkBijT f ⁻¹

mkBij : ∀ {n} → Endo (Bits n) → Bij n
mkBij f = mkBijT (fromFun f) ⁻¹

mkBij-p : ∀ {n} (t : Tree (Bits n) n) → t ≡ evalTree (mkBijT t) (sort t)
mkBij-p t = Perm.proof SPP.sort-proof t

IsInj : ∀ {i o} → (Bits i → Bits o) → Set
IsInj f = ∀ {x y} → f x ≡ f y → x ≡ y

idT : ∀ {n} → Tree (Bits n) n
idT = fromFun id

toFun-idT : ∀ {n} → toFun idT ≗ id {A = Bits n}
toFun-idT x = toFun∘fromFun id x

InjT : ∀ {n} → Tree (Bits n) n → Set
InjT = IsInj ∘ toFun

_⁻¹-inverseTree : ∀ {n} f → evalTree (f `⁏ f ⁻¹) ≗ id {A = Tree (Bits n) n}
(f ⁻¹-inverseTree) t = evalTree (f `⁏ f ⁻¹) t
                     ≡⟨ ≡.sym (fromFun∘toFun (evalTree (f `⁏ f ⁻¹) t)) ⟩
                       fromFun (toFun (evalTree (f `⁏ f ⁻¹) t))
                     ≡⟨ fromFun-≗ (evalTree-eval′ (f `⁏ f ⁻¹) t) ⟩
                       fromFun (toFun t ∘ eval (f ⁻¹ ⁻¹ `⁏ f ⁻¹))
                     ≡⟨ fromFun-≗ (λ x → ≡.cong (toFun t) (VecBijKit._⁻¹-inverse′ _ (f ⁻¹) x)) ⟩
                       fromFun (toFun t)
                     ≡⟨ fromFun∘toFun t ⟩
                       t
                     ∎ where open ≡-Reasoning

mkBij-p⁻¹ : ∀ {n} (t : Tree (Bits n) n) → evalTree (mkBijT⁻¹ t) t ≡ sort t
mkBij-p⁻¹ t = ≡.trans (≡.cong (evalTree (mkBijT⁻¹ t)) (mkBij-p t)) (((mkBijT t) ⁻¹-inverseTree) (sort t))

foo : ∀ {n} (t : Tree (Bits n) n) → toFun t ≗ toFun (sort t) ∘ eval (mkBijT⁻¹ t)
foo t xs = toFun t xs
         ≡⟨ ≡.cong (λ t → toFun t xs) (Perm.proof SPP.sort-proof t) ⟩
           toFun (evalTree (mkBijT t) (sort t)) xs
         ≡⟨ evalTree-eval (mkBijT⁻¹ t) (evalTree (mkBijT t) (sort t)) xs ⟩
           toFun (evalTree (mkBijT⁻¹ t) (evalTree (mkBijT t) (sort t))) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ ≡.refl ⟩
           toFun (evalTree (mkBijT t `⁏ mkBijT⁻¹ t) (sort t)) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ ≡.cong (λ u → toFun u (eval (mkBijT⁻¹ t) xs)) (((mkBijT t) ⁻¹-inverseTree) (sort t)) ⟩
           toFun (sort t) (eval (mkBijT⁻¹ t) xs)
         ∎ where open ≡-Reasoning

module SortedMonotonicFunctionsBits {n} where
    open SortedMonotonicFunctions (_≤_ {n}) isPreorder public
open SortedMonotonicFunctionsBits hiding (Sorted)

-- _∘-inj_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {f : B → C} {g : A → B} → IsInj f → IsInj g → IsInj (f ∘ g)
_∘-inj_ : ∀ {a b c} {f : Bits b → Bits c} {g : Bits a → Bits b} → IsInj f → IsInj g → IsInj (f ∘ g)
f-inj ∘-inj g-inj = g-inj ∘ f-inj

_∷-inj : ∀ {n} b → IsInj (_∷_ {n = n} b)
(_ ∷-inj) ≡.refl = ≡.refl

lemvec : ∀ {n} (xs ys : Bits (suc n)) → head xs ≡ head ys → tail xs ≡ tail ys → xs ≡ ys
lemvec (x ∷ xs) (.x ∷ .xs) ≡.refl ≡.refl = ≡.refl

≤→≤ᴮ : ∀ {n} {x y : Bits n} → x ≤ y → x ≤ᴮ y
≤→≤ᴮ {x = []}         {[]}         p = []
≤→≤ᴮ {suc n} {true ∷ xs}  {true ∷ ys}  p = there 1b (≤→≤ᴮ {x = xs} {ys} (ℕ<=.complete {toℕ xs} {toℕ ys} (+-≤-inj (2^ n) (ℕ<=.sound _ _ p))))
≤→≤ᴮ {x = false ∷ xs} {false ∷ ys} p = there 0b (≤→≤ᴮ {x = xs} {ys} p)
≤→≤ᴮ {suc n} {true ∷ xs}  {false ∷ ys} p = ⊥-elim (2ⁿ+≰toℕ ys (ℕ<=.sound (2^ n + toℕ xs) (toℕ ys) p))
≤→≤ᴮ {x = false ∷ xs} {true ∷ ys}  p = 0-1 xs ys

≤ᴮ→≤ : ∀ {n} {x y : Bits n} → x ≤ᴮ y → x ≤ y
≤ᴮ→≤ [] = _
≤ᴮ→≤ {suc n} (there true p) = ℕ<=.complete (ℕ≤.refl {2^ n} +-mono (ℕ<=.sound _ _ (≤ᴮ→≤ p)))
≤ᴮ→≤ (there false p) = ≤ᴮ→≤ p
≤ᴮ→≤ (0-1 p q) = ℕ<=.complete (toℕ≤2ⁿ+ p {toℕ q})

Monotone' : ∀ {i o} → (Bits i → Bits o) → Set _
Monotone' {i} {o} f = ∀ {p q : Bits i} → p ≤ᴮ q → f p ≤ᴮ f q

toEndoℕ : ∀ {n} → Endo (Bits n) → Endo ℕ
toEndoℕ f = toℕ ∘ f ∘ fromℕ

open Nat using (_≰_)

module ToEndoℕ {n} (f : Endo (Bits n)) where
    fℕ = toEndoℕ f

    fromℕn = fromℕ {n}

    mono : Monotone f → MM.Monotone (2^ n) fℕ
    mono f-mono {x} {y} x≤y y<2ⁿ
       = ℕ<=.sound _ _
          (f-mono
            (≤→≤ᴮ (ℕ<=.complete {toℕ (fromℕn x)} {toℕ (fromℕn y)}
                     (ℕ≤.trans (ℕ≤.reflexive (toℕ∘fromℕ {n} x (ℕ≤.trans (s≤s x≤y) y<2ⁿ)))
                        (ℕ≤.trans x≤y (ℕ≤.reflexive (≡.sym (toℕ∘fromℕ {n} y y<2ⁿ))))))))

    inj : IsInj f → MM.IsInj (2^ n) fℕ
    inj f-inj {x} {y} x< y< = fromℕ-inj x< y< ∘ f-inj ∘ toℕ-inj _ _

    bounded : MM.Bounded (2^ n) fℕ
    bounded x x≤2ⁿ = toℕ-bound (f (fromℕ x))

lem : ∀ {n} (f : Endo (Bits n)) → Monotone f → IsInj f → f ≗ id
lem {n} f f-mono f-inj x = toℕ-inj _ _ (≡.trans (≡.cong (toℕ ∘ f) (≡.sym (fromℕ∘toℕ x))) (MM.M.is-id (toEndoℕ f) {2^ n} (mono f-mono) (inj f-inj) bounded (toℕ x) (toℕ-bound x)))
  where open ToEndoℕ f

IsInj-toFunFromFun : ∀ {n} (f : Endo (Bits n)) → IsInj f → IsInj (toFun (fromFun f))
IsInj-toFunFromFun f f-inj {x} {y} eq
  rewrite toFun∘fromFun f x
        | toFun∘fromFun f y
        = f-inj eq

sort-spec′ : ∀ {n} (t : Tree (Bits n) n) → Sorted (evalTree (mkBijT⁻¹ t) t)
sort-spec′ t rewrite mkBij-p⁻¹ t = sort-spec t

sort-id′′ : ∀ {n} (t : Tree (Bits n) n) → InjT t → Sorted t → toFun t ≗ id
sort-id′′ t Pt st x = lem (toFun t) (DataSorted→Sorted st) Pt x

toFun-eval-inj : ∀ {n} (f : Bij n) → IsInj (eval f)
toFun-eval-inj f {x} {y} eq = x
                            ≡⟨ ≡.sym ((f ⁻¹-inverse) x) ⟩
                              eval (f ⁻¹) (eval f x)
                            ≡⟨ ≡.cong (eval (f ⁻¹)) eq ⟩
                              eval (f ⁻¹) (eval f y)
                            ≡⟨ (f ⁻¹-inverse) y ⟩
                              y
                            ∎ where open ≡-Reasoning

toFun-evalTree-inj : ∀ {n} f (t : Tree (Bits n) n) → InjT t → InjT (evalTree f t)
toFun-evalTree-inj f t Pt {x} {y} eq
  rewrite evalTree-eval′ f t x
        | evalTree-eval′ f t y = toFun-eval-inj (f ⁻¹) (Pt eq)

sort-id′ : ∀ {n} f (t : Tree (Bits n) n) → InjT t → Sorted (evalTree f t) → toFun (evalTree f t) ≗ id
sort-id′ f t Pt = sort-id′′ (evalTree f t) (λ {x} {y} eq → toFun-evalTree-inj f t Pt eq)

sort-id : ∀ {n} (t : Tree (Bits n) n) → InjT t → toFun (sort t) ≗ id
sort-id t Pt rewrite ≡.sym (mkBij-p⁻¹ t) = sort-id′ (mkBijT⁻¹ t) t Pt (sort-spec′ t)

bar : ∀ {n} (t : Tree (Bits n) n) → InjT t → toFun t ≗ eval (mkBijT⁻¹ t)
bar t Pt xs = toFun t xs
         ≡⟨ foo t xs ⟩
           toFun (sort t) (eval (mkBijT⁻¹ t) xs)
         ≡⟨ sort-id t Pt (eval (mkBijT⁻¹ t) xs) ⟩
           eval (mkBijT⁻¹ t) xs
         ∎ where open ≡-Reasoning

thm : ∀ {n} (f : Endo (Bits n)) (f-inj : IsInj f) →
        eval (mkBij f) ≗ f
thm f f-inj xs = eval (mkBij f) xs
               ≡⟨ ≡.sym (bar (fromFun f) (IsInj-toFunFromFun f f-inj) xs) ⟩
                 toFun (fromFun f) xs
               ≡⟨ toFun∘fromFun f xs ⟩
                 f xs
               ∎ where open ≡-Reasoning

thm# : ∀ {n} (f : Endo (Bits n)) (f-inj : IsInj f) (g : Bits n → Bit) →
       #⟨ g ∘ f ⟩ ≡ #⟨ g ⟩
thm# f f-inj g = #⟨ g ∘ f ⟩
               ≡⟨ #-≗ (g ∘ f) (g ∘ eval (mkBij f)) (λ x → ≡.cong g (≡.sym (thm f f-inj x))) ⟩
                 #⟨ g ∘ eval (mkBij f) ⟩
               ≡⟨ #-bij (mkBij f) g ⟩
                 #⟨ g ⟩
               ∎ where open ≡-Reasoning

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


inline type function Soundness-of-weakening at its 1 call site

Old-commit-hash: bfe5b5057816935a44cd3465f3669d62cd210dca

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation

module Parametric.Denotation.WeakenSound
  {Base : Type.Structure}
  (Const : Term.Structure Base)
  {⟦_⟧Base : Value.Structure Base}
  (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
  where
  -- importing modules couldn't resolve constraints
  -- unless Const is explicit.

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation
open import Base.Denotation.Environment Type ⟦_⟧Type
open import Theorem.CongApp
open import Postulate.Extensionality

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ lift subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound = lift-sound

weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken Γ₁≼Γ₂ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ₁≼Γ₂ ⟧ ρ)

weaken-sound-terms : ∀ {Γ₁ Γ₂ Σ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (terms : Terms Γ₁ Σ) (ρ : ⟦ Γ₂ ⟧) →
  ⟦ weakenAll Γ₁≼Γ₂ terms ⟧Terms ρ ≡ ⟦ terms ⟧Terms (⟦ Γ₁≼Γ₂ ⟧ ρ)

weaken-sound-terms ∅ ρ = refl
weaken-sound-terms (t • terms) ρ =
  cong₂ _•_ (weaken-sound t ρ) (weaken-sound-terms terms ρ)

weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weakenVar-sound Γ₁≼Γ₂ x ρ
weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound {Γ₁} {Γ₂} {Γ₁≼Γ₂ = Γ₁≼Γ₂} (const {Σ} {τ} c args) ρ =
  cong ⟦ c ⟧Const (weaken-sound-terms args ρ)

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation

module Parametric.Denotation.WeakenSound
  {Base : Type.Structure}
  (Const : Term.Structure Base)
  {⟦_⟧Base : Value.Structure Base}
  (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
  where
  -- importing modules couldn't resolve constraints
  -- unless Const is explicit.

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation
open import Base.Denotation.Environment Type ⟦_⟧Type
open import Theorem.CongApp
open import Postulate.Extensionality

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ lift subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound = lift-sound

Soundness-of-weakening : ∀ {Γ₁ Γ₂ : Context} {τ}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧) (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) → Set
Soundness-of-weakening t ρ Γ₁≼Γ₂ =
  ⟦ weaken Γ₁≼Γ₂ t ⟧ ρ ≡ ⟦ t ⟧ (⟦ Γ₁≼Γ₂ ⟧ ρ)

weaken-sound : ∀ {Γ₁ Γ₂ τ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (t : Term Γ₁ τ) (ρ : ⟦ Γ₂ ⟧) → Soundness-of-weakening t ρ Γ₁≼Γ₂

weaken-sound-terms : ∀ {Γ₁ Γ₂ Σ} {Γ₁≼Γ₂ : Γ₁ ≼ Γ₂}
  (terms : Terms Γ₁ Σ) (ρ : ⟦ Γ₂ ⟧) →
  ⟦ weakenAll Γ₁≼Γ₂ terms ⟧Terms ρ ≡ ⟦ terms ⟧Terms (⟦ Γ₁≼Γ₂ ⟧ ρ)

weaken-sound-terms ∅ ρ = refl
weaken-sound-terms (t • terms) ρ =
  cong₂ _•_ (weaken-sound t ρ) (weaken-sound-terms terms ρ)

weaken-sound {Γ₁≼Γ₂ = Γ₁≼Γ₂} (var x) ρ = weakenVar-sound Γ₁≼Γ₂ x ρ
weaken-sound (app s t) ρ = weaken-sound s ρ ⟨$⟩ weaken-sound t ρ
weaken-sound (abs t) ρ = ext (λ v → weaken-sound t (v • ρ))
weaken-sound {Γ₁} {Γ₂} {Γ₁≼Γ₂ = Γ₁≼Γ₂} (const {Σ} {τ} c args) ρ =
  cong ⟦ c ⟧Const (weaken-sound-terms args ρ)


Simplified two proofs.

Simplified two proofs.

Ignore-this: d8fd5428625a1fa253d896b6e6b7f1a0

darcs-hash:20110805172720-3bd4e-b3562ca0bdde5411ed84b7d8effec24c86d5a044.gz

------------------------------------------------------------------------------
-- FOTC terms properties
------------------------------------------------------------------------------

module FOTC.Base.PropertiesI where

open import FOTC.Base

open import FOTC.Relation.Binary.EqReasoning

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

succInjective : ∀ {d e} → succ d ≡ succ e → d ≡ e
succInjective {d} {e} h =
  begin
    d              ≡⟨ sym (pred-S d) ⟩
    pred (succ d)  ≡⟨ cong pred h ⟩
    pred (succ e)  ≡⟨ pred-S e ⟩
    e
  ∎

∷-injective : ∀ {x y xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y ∧ xs ≡ ys
∷-injective {x} {y} {xs} {ys} h = x≡y , xs≡ys
  where
  x≡y : x ≡ y
  x≡y =
    begin
      x              ≡⟨ sym (head-∷ x xs) ⟩
      head (x ∷ xs)  ≡⟨ cong head h ⟩
      head (y ∷ ys)  ≡⟨ head-∷ y ys ⟩
      y
    ∎

  xs≡ys : xs ≡ ys
  xs≡ys =
    begin
      xs             ≡⟨ sym (tail-∷ x xs) ⟩
      tail (x ∷ xs)  ≡⟨ cong tail h ⟩
      tail (y ∷ ys)  ≡⟨ tail-∷ y ys ⟩
      ys
    ∎

------------------------------------------------------------------------------
-- FOTC terms properties
------------------------------------------------------------------------------

module FOTC.Base.PropertiesI where

open import FOTC.Base

open import FOTC.Relation.Binary.EqReasoning

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

succInjective : ∀ {d e} → succ d ≡ succ e → d ≡ e
succInjective {d} {e} Sd≡Se =
  begin
    d              ≡⟨ sym (pred-S d) ⟩
    pred (succ d)  ≡⟨ subst (λ t → pred (succ d) ≡ pred t)
                            Sd≡Se
                            refl
                   ⟩
    pred (succ e)  ≡⟨ pred-S e ⟩
    e
  ∎

∷-injective : ∀ {x y xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y ∧ xs ≡ ys
∷-injective {x} {y} {xs} {ys} x∷xs≡y∷ys = x≡y , xs≡ys
  where
  x≡y : x ≡ y
  x≡y =
    begin
      x              ≡⟨ sym (head-∷ x xs) ⟩
      head (x ∷ xs)  ≡⟨ subst (λ t → head (x ∷ xs) ≡ head t)
                              x∷xs≡y∷ys
                              refl
                     ⟩
      head (y ∷ ys)  ≡⟨ head-∷ y ys ⟩
      y
    ∎

  xs≡ys : xs ≡ ys
  xs≡ys =
    begin
      xs             ≡⟨ sym (tail-∷ x xs) ⟩
      tail (x ∷ xs)  ≡⟨ subst (λ t → tail (x ∷ xs) ≡ tail t)
                              x∷xs≡y∷ys
                              refl
                     ⟩
      tail (y ∷ ys)  ≡⟨ tail-∷ y ys ⟩
      ys
    ∎


Drop non-CBPV caching semantics & update comments

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality

module Structure where
  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit
  open import Level

  -- Defining a caching semantics for Term proves to be hard, requiring to
  -- insert and remove caches where we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  open import Parametric.Syntax.MType as MType
  open MType.Structure Base
  open import Parametric.Syntax.MTerm as MTerm
  open MTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

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

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType

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

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

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

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

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

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

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

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

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality

module Structure where
  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Sum hiding (map)
  open import Data.Unit
  open import Level

  -- Type semantics for this scenario.
  ⟦_⟧TypeHidCache : (τ : Type) → Set₁
  ⟦ base ι ⟧TypeHidCache = Lift ⟦ base ι ⟧
  ⟦ σ ⇒ τ ⟧TypeHidCache = ⟦ σ ⟧TypeHidCache → (Σ[ τ₁ ∈ Set ] ⟦ τ ⟧TypeHidCache × τ₁ )

  -- Now, let us define a caching semantics for terms.

  -- This proves to be hard, because we need to insert and remove caches where
  -- we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  --
  -- Inserting and removing caches --
  --

  -- Implementation note: The mutual recursion looks like a fold on exponentials, where you need to define the function and the inverse at the same time.
  -- Indeed, both functions seem structurally recursive on τ.
  dropCache : ∀ {τ} → ⟦ τ ⟧TypeHidCache → ⟦ τ ⟧
  extend : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧TypeHidCache

  dropCache {base ι} v = lower v
  dropCache {σ ⇒ τ} v x = dropCache (proj₁ (proj₂ (v (extend x))))

  extend {base ι} v = lift v
  extend {σ ⇒ τ} v = λ x → , (extend (v (dropCache x)) , tt)

  ⟦_⟧CtxHidCache : (Γ : Context) → Set₁
  ⟦_⟧CtxHidCache = DependentList ⟦_⟧TypeHidCache

  -- It's questionable that this is not polymorphic enough.
  ⟦_⟧VarHidCache : ∀ {Γ τ} → Var Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦ this ⟧VarHidCache (v • ρ) = v
  ⟦ that x ⟧VarHidCache (v • ρ) = ⟦ x ⟧VarHidCache ρ

  -- OK, this version is syntax-directed, luckily enough, except on primitives
  -- (as expected). This reveals a bug of ours on higher-order primitives.
  --
  -- Moreover, we can somewhat safely assume that each call to extend and to
  -- dropCache is bad: then we see that the handling of constants is bad. That's
  -- correct, because constants will not return intermediate results in this
  -- schema :-(.
  ⟦_⟧TermCache : ∀ {τ Γ} → Term Γ τ → ⟦ Γ ⟧CtxHidCache → ⟦ τ ⟧TypeHidCache
  ⟦_⟧TermCache (const c args) ρ = extend (⟦ const c args ⟧ (map dropCache ρ))
  ⟦_⟧TermCache (var x) ρ = ⟦ x ⟧VarHidCache ρ

  -- It seems odd (a probable bug?) that the result of t needn't be stripped of
  -- its cache.
  ⟦_⟧TermCache (app s t) ρ = proj₁ (proj₂ ((⟦ s ⟧TermCache ρ) (⟦ t ⟧TermCache ρ)))

  -- Provide an empty cache!
  ⟦_⟧TermCache (abs t) ρ x = , (⟦ t ⟧TermCache (x • ρ) , tt)

  open import Parametric.Syntax.MType as MType
  open MType.Structure Base
  open import Parametric.Syntax.MTerm as MTerm
  open MTerm.Structure Const

  open import Function hiding (const)

  ⟦_⟧ValType : (τ : ValType) → Set
  ⟦_⟧CompType : (τ : CompType) → Set

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

  ⟦ F τ ⟧CompType = ⟦ τ ⟧ValType
  ⟦ σ ⇛ τ ⟧CompType = ⟦ σ ⟧ValType → ⟦ τ ⟧CompType

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

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

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

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

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

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

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

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

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVar)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ

  -- The real deal, finally.
  open import UNDEFINED
  -- XXX constants are still a slight mess because I'm abusing CBPV...
  -- (Actually, I just forgot the difference, and believe I had too little clue
  -- when I wrote these constructors... but some of them did make sense).
  ⟦_⟧CompTermCache (cConst c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV c args) ρ = reveal UNDEFINED
  ⟦_⟧CompTermCache (cConstV2 c args) ρ = reveal UNDEFINED

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ x = ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)


Cosmetic change.

Cosmetic change.

Ignore-this: c0ac3d6b1eb5edebf6be7139a698a541

darcs-hash:20110919015938-3bd4e-1c475cd3e1a7d2fdb71d05033e334b1a57666e58.gz

module Draft.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → N i → P i → P (succ i)
    ih {i} Ni Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : ∀ x →
                N (zero + x) →
                (∀ {n} → N n → N (n + x) → N (succ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
{-# ATP prove +-N₂ indN #-}

module Draft.FOTC.Data.Nat.AddTotality where

open import FOTC.Base
open import FOTC.Data.Nat

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → N i → P i → P (succ i)
    ih {i} Ni Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : (x : D) →
                N (zero + x) →
                (∀ {n} → N n → N (n + x) → N (succ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
{-# ATP prove +-N₂ indN #-}


IDesc stratified model: GOT IT! The proof type-checks with no fancy color: the embedded IDescl is isomorph to the host IDesc. Fully stratified, on any universe you want my Lord.

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

module IDesc where

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

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

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

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

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

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

{-# BUILTIN LEVELMAX max #-}

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

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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

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

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

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

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

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

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

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

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

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

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

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

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

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

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

IDescl0 : {l : Level}(I : Set l) -> Unit -> Set (suc l)
IDescl0 I = IMu (\_ -> descD I)

IDescl : {l : Level}(I : Set l) -> Set (suc l)
IDescl I = IDescl0 I Void

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

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

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

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

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

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

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

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

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

psi : {l : Level}{I : Set l} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set l} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

proof-psi-phi : {l : Level}(I : Set l) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> descD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
                where P : Sigma Unit (IMu (\ x -> descD I)) -> Set (suc x)
                      P ( Void , D ) = psi (phi D) == D
                      proof-psi-phi-cases : (i : Unit)
                                            (xs : desc (descD I) (IDescl0 I))
                                            (hs : desc (box (descD I) (IDescl0 I) xs) P)
                                            -> P (i , con xs)
                      proof-psi-phi-cases Void (lvar , i) hs = cong (\t -> con (lvar' , t))
                                                                    (proof-lift-unlift-eq i)
                      proof-psi-phi-cases Void (lconst , x) hs = refl
                      proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
                      proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\T -> con (lpi {l = suc x} , ( S , T ) ))
                                                                           (trans (reflFun (λ s → psi (phi (T (lifter (unlift s)))))
                                                                                (λ s → psi (phi (T (s))))
                                                                                (\s -> cong (λ s → psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                                (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))
                      proof-psi-phi-cases Void (lsigma , ( S , T )) hs = cong (\T -> con (lsigma {l = suc x} , ( S , T ) ))
                                                                              (trans (reflFun (λ s → psi (phi (T (lifter (unlift s)))))
                                                                                (λ s → psi (phi (T (s))))
                                                                                (\s -> cong (λ s → psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                                (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))

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

module IDesc where

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

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

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

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

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

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

{-# BUILTIN LEVELMAX max #-}

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

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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

IDescl0 : {l : Level}(I : Set l) -> Unit -> Set (suc l)
IDescl0 I = IMu (\_ -> descD I)

IDescl : {l : Level}(I : Set l) -> Set (suc l)
IDescl I = IDescl0 I Void

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

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

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

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

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

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

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

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

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

psi : {l : Level}{I : Set l} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set l} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

proof-psi-phi : {l : Level}(I : Set l) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> descD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
                where P : Sigma Unit (IMu (\ x -> descD I)) -> Set (suc x)
                      P ( Void , D ) = psi (phi D) == D
                      lvar' : DescDConst {l = suc x}
                      lvar' = lvar
                      lpi' : DescDConst {l = suc x}
                      lpi' = lpi
                      lsigma' : DescDConst {l = suc x}
                      lsigma' = lsigma
                      proof-psi-phi-cases : (i : Unit)
                                            (xs : desc (descD I) (IDescl0 I))
                                            (hs : desc (box (descD I) (IDescl0 I) xs) P)
                                            -> P (i , con xs)
                      proof-psi-phi-cases Void (lvar , i) hs = cong (\t -> con (lvar' , t))
                                                                    (proof-lift-unlift-eq i)
                      proof-psi-phi-cases Void (lconst , x) hs = refl
                      proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
                      proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\t ->  con ((lpi' , ((S , \ s -> t s)))))
                                                                          (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs)
                      proof-psi-phi-cases Void (lsigma , ( S , T )) hs = {!!} {- cong (\t -> con (lsigma' , ( S , \s -> t (unlift s) )))
                                                                              (reflFun (\s -> psi (phi (T (lifter s))))
                                                                                (\s -> T (lifter s))
                                                                                (\s -> hs (lifter s))) -}