Follow-up question to commit message 3367105

Old-commit-hash: d0b179f01726529fe06b0707c242472fce315998

module Data.NatBag.Properties where

import Data.Nat as ℕ
open import Relation.Binary.PropositionalEquality
open import Data.NatBag
open import Data.Integer
open import Data.Sum hiding (map)
open import Data.Product hiding (map)

-- This import is too slow.
-- It causes Agda 2.3.2 to use so much memory that cai's
-- computer with 4GB RAM begins to thresh.
--
-- open import Data.Integer.Properties using (n⊖n≡0)
n⊖n≡0 : ∀ n → n ⊖ n ≡ + 0
n⊖n≡0 ℕ.zero    = refl
n⊖n≡0 (ℕ.suc n) = n⊖n≡0 n

----------------
-- Statements --
----------------

-- Caution: Please convert all implicit bag argument to
-- instance bag argument in the next iteration so that
-- using the lemmas here incurs less typing overhead.
-- Leave the implicit arguments on multivariate lemmas,
-- though.
--
-- TODO: Convert bags from a sum to an ADT so that
-- constructor names give hints to the bag type,
-- and a set-theoretic development can write things
-- like ∀ {b} → ∅ ⊆ b.

b\\b=∅ : ∀ {b} → b \\ b ≡ empty

∅++b=b : ∀ {b} → empty ++ b ≡ b

b\\∅=b : ∀ {b} → b \\ empty ≡ b

b++∅=b : ∀ {{b}} → b ++ empty ≡ b

b++[d\\b]=d : ∀ {b d} → b ++ (d \\ b) ≡ d

[b++d]\\b=d : ∀ {b d} → (b ++ d) \\ b ≡ d

------------
-- Proofs --
------------

b++∅=b = {!!}

i-i=0 : ∀ {i : ℤ} → (i - i) ≡ (+ 0)
i-i=0 {+ ℕ.zero} = refl
i-i=0 {+ ℕ.suc n} = n⊖n≡0 n
i-i=0 { -[1+ n ]} = n⊖n≡0 n

-- Debug tool
-- Lets you try out inhabitance of any type anywhere
absurd! : ∀ {B C : Set} → 0 ≡ 1 → B → {x : B} → C
absurd! ()

-- Specialized absurdity needed to type check.
-- λ () hasn't enough information sometimes.
absurd : Nonzero (+ 0) → ∀ {A : Set} → A
absurd ()

-- Here to please the termination checker.
neb\\neb=∅ : ∀ {neb : NonemptyBag} → zipNonempty _-_ neb neb ≡ empty
neb\\neb=∅ {singleton i i≠0} with nonzero? (i - i)
... | inj₁ _ = refl
... | inj₂ 0≠0 rewrite i-i=0 {i} = absurd 0≠0
neb\\neb=∅ {i ∷ neb} with nonzero? (i - i)
... | inj₁ _ rewrite neb\\neb=∅ {neb} = refl
... | inj₂ 0≠0 rewrite neb\\neb=∅ {neb} | i-i=0 {i} = absurd 0≠0

b\\b=∅ {inj₁ ∅} = refl
b\\b=∅ {inj₂ neb} = neb\\neb=∅ {neb}

∅++b=b {b} = {!!}

b\\∅=b {b} = {!!}

negate : ∀ {i} → Nonzero i → Nonzero (- i)
negate (negative n) = positive n
negate (positive n) = negative n

negate′ : ∀ {i} → (i≠0 : Nonzero i) → Nonzero (+ 0 - i)
negate′ { -[1+ n ]} (negative .n) = positive n
negate′ {+ .(ℕ.suc n)} (positive n) = negative n

0-i=-i : ∀ {i} → + 0 - i ≡ - i
0-i=-i { -[1+ n ]} = refl -- cases are split, for arguments to
0-i=-i {+ ℕ.zero}  = refl -- refl are different.
0-i=-i {+ ℕ.suc n} = refl

rewrite-singleton :
  ∀ (i : ℤ) (0-i≠0 : Nonzero (+ 0 - i)) ( -i≠0 : Nonzero (- i)) →
    singleton (+ 0 - i) 0-i≠0 ≡ singleton (- i) -i≠0
rewrite-singleton (+ ℕ.zero) () ()
rewrite-singleton (+ ℕ.suc n) (negative .n) (negative .n) = refl
rewrite-singleton ( -[1+ n ]) (positive .n) (positive .n) = refl

negateSingleton : ∀ {i i≠0} →
  mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡
  inj₂ (singleton (- i) (negate i≠0))

-- Fun fact:
-- Pattern-match on implicit parameters in the first two
-- cases results in rejection by Agda.
negateSingleton {i} {i≠0} with nonzero? i | nonzero? (+ 0 - i)
negateSingleton | inj₂ (negative n) | inj₁ ()
negateSingleton | inj₂ (positive n) | inj₁ ()
negateSingleton {_} {i≠0} | inj₁ i=0 | _ rewrite i=0 = absurd i≠0
negateSingleton {i} {i≠0} | inj₂ _ | inj₂ 0-i≠0 =
  begin -- Reasoning done in 1 step. Included for clarity only.
    inj₂ (singleton (+ 0 + - i) 0-i≠0)
  ≡⟨ cong inj₂ (rewrite-singleton i 0-i≠0 (negate i≠0)) ⟩
    inj₂ (singleton (- i) (negate i≠0))
  ∎  where open ≡-Reasoning

absurd[i-i≠0] : ∀ {i} → Nonzero (i - i) → ∀ {A : Set} → A
absurd[i-i≠0] {+ ℕ.zero} = absurd
absurd[i-i≠0] {+ ℕ.suc n} = absurd[i-i≠0] { -[1+ n ]}
absurd[i-i≠0] { -[1+ ℕ.zero ]} = absurd
absurd[i-i≠0] { -[1+ ℕ.suc n ]} = absurd[i-i≠0] { -[1+ n ]}

annihilate : ∀ {i i≠0} →
  inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0)) ≡ inj₁ ∅

annihilate {i} with nonzero? (i - i)
... | inj₁ i-i=0 = λ {i≠0} → refl
... | inj₂ i-i≠0 = absurd[i-i≠0] {i} i-i≠0
{-
Follow-up question to
https://github.com/ps-mr/ilc/commit/978e3f94e70762904e077bb4d51d6b7b17695103#commitcomment-3367105

Mysterious error message when the case above is replaced by the one
below.

annihilate {i} with i - i
... | w = ?
-}

b++[∅\\b]=∅ : ∀ {b} → b ++ (empty \\ b) ≡ empty
b++[∅\\b]=∅ {inj₁ ∅} = refl
b++[∅\\b]=∅ {inj₂ (singleton i i≠0)} =
  begin
    inj₂ (singleton i i≠0) ++
      mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡⟨ cong₂ _++_ {x = inj₂ (singleton i i≠0)} refl
                (negateSingleton {i} {i≠0}) ⟩
    inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0))
  ≡⟨ annihilate {i} {i≠0} ⟩
    inj₁ ∅
  ∎ where open ≡-Reasoning

b++[∅\\b]=∅ {inj₂ (i ∷ y)} = ?

b++[d\\b]=d {inj₁ ∅} {d} rewrite b\\∅=b {d} | ∅++b=b {d} = refl
b++[d\\b]=d {b} {inj₁ ∅} = b++[∅\\b]=∅ {b}
b++[d\\b]=d {inj₂ b} {inj₂ d} = {!!}

[b++d]\\b=d = {!!}

module Data.NatBag.Properties where

import Data.Nat as ℕ
open import Relation.Binary.PropositionalEquality
open import Data.NatBag
open import Data.Integer
open import Data.Sum hiding (map)
open import Data.Product hiding (map)

-- This import is too slow.
-- It causes Agda 2.3.2 to use so much memory that cai's
-- computer with 4GB RAM begins to thresh.
--
-- open import Data.Integer.Properties using (n⊖n≡0)
n⊖n≡0 : ∀ n → n ⊖ n ≡ + 0
n⊖n≡0 ℕ.zero    = refl
n⊖n≡0 (ℕ.suc n) = n⊖n≡0 n

----------------
-- Statements --
----------------

b\\b=∅ : ∀ {b : Bag} → b \\ b ≡ empty

∅++b=b : ∀ {b : Bag} → empty ++ b ≡ b

b\\∅=b : ∀ {b : Bag} → b \\ empty ≡ b

∅\\b=-b : ∀ {b : Bag} → empty \\ b ≡ map₂ -_ b

b++[d\\b]=d : ∀ {b d : Bag} → b ++ (d \\ b) ≡ d

------------
-- Proofs --
------------

i-i=0 : ∀ {i : ℤ} → (i - i) ≡ (+ 0)
i-i=0 {+ ℕ.zero} = refl
i-i=0 {+ ℕ.suc n} = n⊖n≡0 n
i-i=0 { -[1+ n ]} = n⊖n≡0 n

-- Debug tool
-- Lets you try out inhabitance of any type anywhere
absurd! : ∀ {B C : Set} → 0 ≡ 1 → B → {x : B} → C
absurd! ()

-- Specialized absurdity needed to type check.
-- λ () hasn't enough information sometimes.
absurd : Nonzero (+ 0) → ∀ {A : Set} → A
absurd ()

-- Here to please the termination checker.
neb\\neb=∅ : ∀ {neb : NonemptyBag} → zipNonempty _-_ neb neb ≡ empty
neb\\neb=∅ {singleton i i≠0} with nonzero? (i - i)
... | inj₁ _ = refl
... | inj₂ 0≠0 rewrite i-i=0 {i} = absurd 0≠0
neb\\neb=∅ {i ∷ neb} with nonzero? (i - i)
... | inj₁ _ rewrite neb\\neb=∅ {neb} = refl
... | inj₂ 0≠0 rewrite neb\\neb=∅ {neb} | i-i=0 {i} = absurd 0≠0

b\\b=∅ {inj₁ ∅} = refl
b\\b=∅ {inj₂ neb} = neb\\neb=∅ {neb}

∅++b=b {b} = {!!}

b\\∅=b {b} = {!!}

∅\\b=-b {b} = {!!}

negate : ∀ {i} → Nonzero i → Nonzero (- i)
negate (negative n) = positive n
negate (positive n) = negative n

negate′ : ∀ {i} → (i≠0 : Nonzero i) → Nonzero (+ 0 - i)
negate′ { -[1+ n ]} (negative .n) = positive n
negate′ {+ .(ℕ.suc n)} (positive n) = negative n

0-i=-i : ∀ {i} → + 0 - i ≡ - i
0-i=-i { -[1+ n ]} = refl -- cases are split, for arguments to
0-i=-i {+ ℕ.zero}  = refl -- refl are different.
0-i=-i {+ ℕ.suc n} = refl

rewrite-singleton :
  ∀ (i : ℤ) (0-i≠0 : Nonzero (+ 0 - i)) ( -i≠0 : Nonzero (- i)) →
    singleton (+ 0 - i) 0-i≠0 ≡ singleton (- i) -i≠0
rewrite-singleton (+ ℕ.zero) () ()
rewrite-singleton (+ ℕ.suc n) (negative .n) (negative .n) = refl
rewrite-singleton ( -[1+ n ]) (positive .n) (positive .n) = refl

negateSingleton : ∀ {i i≠0} →
  mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡
  inj₂ (singleton (- i) (negate i≠0))

-- Fun fact:
-- Pattern-match on implicit parameters in the first two
-- cases results in rejection by Agda.
negateSingleton {i} {i≠0} with nonzero? i | nonzero? (+ 0 - i)
negateSingleton | inj₂ (negative n) | inj₁ ()
negateSingleton | inj₂ (positive n) | inj₁ ()
negateSingleton {_} {i≠0} | inj₁ i=0 | _ rewrite i=0 = absurd i≠0
negateSingleton {i} {i≠0} | inj₂ _ | inj₂ 0-i≠0 =
  begin -- Reasoning done in 1 step. Included for clarity only.
    inj₂ (singleton (+ 0 + - i) 0-i≠0)
  ≡⟨ cong inj₂ (rewrite-singleton i 0-i≠0 (negate i≠0)) ⟩
    inj₂ (singleton (- i) (negate i≠0))
  ∎  where open ≡-Reasoning

absurd[i-i≠0] : ∀ {i} → Nonzero (i - i) → ∀ {A : Set} → A
absurd[i-i≠0] {+ ℕ.zero} = absurd
absurd[i-i≠0] {+ ℕ.suc n} = absurd[i-i≠0] { -[1+ n ]}
absurd[i-i≠0] { -[1+ ℕ.zero ]} = absurd
absurd[i-i≠0] { -[1+ ℕ.suc n ]} = absurd[i-i≠0] { -[1+ n ]}

annihilate : ∀ {i i≠0} →
  inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0)) ≡ inj₁ ∅
annihilate {i} with nonzero? (i - i)
... | inj₁ i-i=0 = λ {i≠0} → refl
... | inj₂ i-i≠0 = absurd[i-i≠0] {i} i-i≠0

b++[∅\\b]=∅ : ∀ {b} → b ++ (empty \\ b) ≡ empty
b++[∅\\b]=∅ {inj₁ ∅} = refl
b++[∅\\b]=∅ {inj₂ (singleton i i≠0)} =
  begin
    inj₂ (singleton i i≠0) ++
      mapNonempty₂ (λ j → + 0 - j) (singleton i i≠0)
  ≡⟨ cong₂ _++_ {x = inj₂ (singleton i i≠0)} refl
                (negateSingleton {i} {i≠0}) ⟩
    inj₂ (singleton i i≠0) ++ inj₂ (singleton (- i) (negate i≠0))
  ≡⟨ annihilate {i} {i≠0} ⟩
    inj₁ ∅
  ∎ where open ≡-Reasoning
b++[∅\\b]=∅ {inj₂ (i ∷ y)} = {!!}

b++[d\\b]=d {inj₁ ∅} {d} rewrite b\\∅=b {d} | ∅++b=b {d} = refl
b++[d\\b]=d {b} {inj₁ ∅} = b++[∅\\b]=∅ {b}
b++[d\\b]=d {inj₂ b} {inj₂ d} = {!!}


StepIndexedRelBigStepTypedAnfIlcCorrect: Prove SOS sound

That's soundness wrt. denotational semantics. No completeness though, that would
be tricky (and `succ` violates it right now).

-- Step-indexed logical relations based on relational big-step semantics
-- for ILC-based incremental computation.

-- Goal: prove the fundamental lemma for a ternary logical relation (change
-- validity) across t1, dt and t2. The fundamnetal lemma relates t, derive t and
-- t. That is, we relate a term evaluated relative to an original environment,
-- its derivative evaluated relative to a valid environment change, and the
-- original term evaluated relative to an updated environment.
--
-- Missing goal: here ⊕ isn't defined and wouldn't yet agree with change
-- validity.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, including the choice of using ANF syntax
-- to simplify some step-indexing proofs.
--
-- In fact, this development is typed, hence some parts of the model are closer
-- to Ahmed (ESOP 2006), "Step-Indexed Syntactic Logical Relations for Recursive
-- and Quantified Types". But for many relevant aspects, the two papers are
-- very similar. In fact, I first defined similar logical relations
-- without types, but they require a trickier recursion scheme for well-founded
-- recursion, and I failed to do any proof in that setting.
--
-- The original inspiration came from Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but we ended up looking
-- at their source.
--
-- The main insight from the ISAC paper missing from the other one is how to
-- step-index a big-step semantics correctly: just ensure that the steps in the
-- big-step semantics agree with the ones in the small-step semantics. *Then*
-- everything just works with big-step semantics. Quite a few other details are
-- fiddly, but those are the same in small-step semantics.
--
-- The crucial novelty here is that we relate two computations on different
-- inputs. So we only conclude their results are related if both terminate; the
-- relation for computations does not prove that if the first computation
-- terminates, then the second terminates as well.
--
-- Instead, e1, de and e2 are related at k steps if, whenever e1 terminates in j
-- < k steps and e2 terminates with any step count, then de terminates (with any
-- step count) and their results are related at k - j steps.
--
-- Even when e1 terminates in j steps implies that e2 terminates, e2 gets no
-- bound. Similarly, we do not bound in how many steps de terminates, since on
-- big inputs it might take long.

module Thesis.StepIndexedRelBigStepTypedAnfIlcCorrect where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

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

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

-- Decidable equivalence for types and contexts. Needed later for ⊕ on closures.

⇒-inj : ∀ {τ1 τ2 τ3 τ4 : Type} → _≡_ {A = Type} (τ1 ⇒ τ2) (τ3 ⇒ τ4) → τ1 ≡ τ3 × τ2 ≡ τ4
⇒-inj refl = refl , refl

_≟Type_ : (τ1 τ2 : Type) → Dec (τ1 ≡ τ2)
(τ1 ⇒ τ2) ≟Type (τ3 ⇒ τ4) with τ1 ≟Type τ3 | τ2 ≟Type τ4
(τ1 ⇒ τ2) ≟Type (.τ1 ⇒ .τ2) | yes refl | yes refl = yes refl
(τ1 ⇒ τ2) ≟Type (.τ1 ⇒ τ4) | yes refl | no ¬q = no (λ x → ¬q (proj₂ (⇒-inj x)))
(τ1 ⇒ τ2) ≟Type (τ3 ⇒ τ4) | no ¬p | q = no (λ x → ¬p (proj₁ (⇒-inj x)))
(τ1 ⇒ τ2) ≟Type nat = no (λ ())
nat ≟Type (τ2 ⇒ τ3) = no (λ ())
nat ≟Type nat = yes refl

•-inj : ∀ {τ1 τ2 : Type} {Γ1 Γ2 : Context} → _≡_ {A = Context} (τ1 • Γ1) (τ2 • Γ2) → τ1 ≡ τ2 × Γ1 ≡ Γ2
•-inj refl = refl , refl

_≟Ctx_ : (Γ1 Γ2 : Context) → Dec (Γ1 ≡ Γ2)
∅ ≟Ctx ∅ = yes refl
∅ ≟Ctx (τ2 • Γ2) = no (λ ())
(τ1 • Γ1) ≟Ctx ∅ = no (λ ())
(τ1 • Γ1) ≟Ctx (τ2 • Γ2) with τ1 ≟Type τ2 | Γ1 ≟Ctx Γ2
(τ1 • Γ1) ≟Ctx (.τ1 • .Γ1) | yes refl | yes refl = yes refl
(τ1 • Γ1) ≟Ctx (.τ1 • Γ2) | yes refl | no ¬q = no (λ x → ¬q (proj₂ (•-inj x)))
(τ1 • Γ1) ≟Ctx (τ2 • Γ2) | no ¬p | q = no (λ x → ¬p (proj₁ (•-inj x)))

≟Ctx-refl : ∀ Γ → Γ ≟Ctx Γ ≡ yes refl
≟Ctx-refl Γ with Γ ≟Ctx Γ
≟Ctx-refl Γ | yes refl = refl
≟Ctx-refl Γ | no ¬p = ⊥-elim (¬p refl)

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- Adding this changes nothing without changes to the semantics.
  succ : Const (nat ⇒ nat)

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

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

data Val : Type → Set

import Base.Denotation.Environment
module Den = Base.Denotation.Environment Type ⟦_⟧Type
open Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

⟦_⟧Const : ∀ {τ} → Const τ → ⟦ τ ⟧Type
⟦ lit n ⟧Const = n
⟦ succ ⟧Const = suc

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → Den.⟦ Γ ⟧Context → ⟦ τ ⟧Type
⟦_⟧SVal : ∀ {Γ τ} → SVal Γ τ → Den.⟦ Γ ⟧Context → ⟦ τ ⟧Type
⟦ var x ⟧SVal ρ = Den.⟦ x ⟧Var ρ
⟦ abs t ⟧SVal ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ const c ⟧Term ρ = ⟦ c ⟧Const
⟦ val sv ⟧Term ρ = ⟦ sv ⟧SVal ρ
⟦ app s t ⟧Term ρ = ⟦ s ⟧SVal ρ (⟦ t ⟧SVal ρ)
⟦ lett s t ⟧Term ρ = ⟦ t ⟧Term ((⟦ s ⟧Term ρ) • ρ)

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

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ natV n ⟧Val = n

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

import Data.Integer as I
open I using (ℤ)

-- Yann's idea.
data HasIdx : Set where
  true : HasIdx
  false : HasIdx
data Idx : HasIdx → Set where
  i' : ℕ → Idx true
  no : Idx false

i : {hasIdx : HasIdx} → ℕ → Idx hasIdx
i {false} j = no
i {true} j = i' j

module _ {hasIdx : HasIdx} where
  data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : ∀ {τ} → Term Γ τ → Idx hasIdx → Val τ → Set where
    abs : ∀ {σ τ} {t : Term (σ • Γ) τ} →
      ρ ⊢ val (abs t) ↓[ i 1 ] closure t ρ
    var : ∀ {τ} (x : Var Γ τ) →
      ρ ⊢ val (var x) ↓[ i 1 ] (⟦ x ⟧Var ρ)
    app : ∀ n {Γ′ σ τ ρ′} vtv {v} {vs : SVal Γ (σ ⇒ τ)} {vt : SVal Γ σ} {t : Term (σ • Γ′) τ} →
      ρ ⊢ val vs ↓[ i 0 ] closure t ρ′ →
      ρ ⊢ val vt ↓[ i 0 ] vtv →
      (vtv • ρ′) ⊢ t ↓[ i n ] v →
      ρ ⊢ app vs vt ↓[ i (suc n) ] v
    lett :
      ∀ n1 n2 {σ τ} vsv {v} (s : Term Γ σ) (t : Term (σ • Γ) τ) →
      ρ ⊢ s ↓[ i n1 ] vsv →
      (vsv • ρ) ⊢ t ↓[ i n2 ] v →
      ρ ⊢ lett s t ↓[ i (suc n1 + n2) ] v
    lit : ∀ n →
      ρ ⊢ const (lit n) ↓[ i 1 ] natV n

↓-sound : ∀ {Γ τ ρ v hasIdx} {n : Idx hasIdx} {t : Term Γ τ} →
  ρ ⊢ t ↓[ n ] v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val
↓-sound abs = refl
↓-sound (app _ _ ↓₁ ↓₂ ↓′) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ | ↓-sound ↓′ = refl
↓-sound (var x) = ↦-sound _ x
↓-sound (lit n) = refl
↓-sound (lett n1 n2 vsv s t ↓ ↓₁) rewrite ↓-sound ↓ | ↓-sound ↓₁ = refl
-- ↓-sound (add ↓₁ ↓₂) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ = refl
-- ↓-sound (minus ↓₁ ↓₂) rewrite ↓-sound ↓₁ | ↓-sound ↓₂ = refl

-- No proof of completeness yet: the statement does not hold here.

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context DType as DC

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ nat = nat

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

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var (ΔΔ Δ) (Δτ τ)) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  -- constants aka. primitives
  dconst :
    (c : Const τ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ

derive-dsval : ∀ {Δ σ} → (t : SVal Δ σ) → DSVal Δ σ
derive-dsval (var x) = dvar (derive-dvar x)

derive-dsval (abs t) = dabs (derive-dterm t)

derive-dterm (val x) = dval (derive-dsval x)
derive-dterm (const c) = dconst c
derive-dterm (app vs vt) = dapp (derive-dsval vs) vt (derive-dsval vt)
derive-dterm (lett s t) = dlett s (derive-dterm s) (derive-dterm t)

-- Nontrivial because of unification problems in pattern matching. I wanted to
-- use it to define ⊕ on closures purely on terms of the closure change.

-- Instead, I decided to use decidable equality on contexts: that's a lot of
-- tedious boilerplate, but not too hard, but the proof that validity and ⊕
-- agree becomes easier.
-- -- Define a DVar and be done?
-- underive-dvar :  ∀ {Δ σ} → Var (ΔΔ Δ) (Δτ σ) → Var Δ σ
-- underive-dvar {∅} ()
-- underive-dvar {τ • Δ} x = {!!}

--underive-dvar {σ • Δ} (that x) = that (underive-dvar x)

data DVal : Type → Set
import Base.Denotation.Environment DType DVal as D

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

data DVal where
  bang : ∀ {τ} → Val τ → DVal τ
  dclosure : ∀ {Γ σ τ} → (dt : DTerm (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) →  (dρ : ChΔ Γ) → DVal (σ ⇒ τ)
  dnatV : ∀ (n : ℕ) → DVal nat

_⊕_ : ∀ {τ} → (v1 : Val τ) (dv : DVal τ) → Val τ

_⊕ρ_ : ∀ {Γ} → ⟦ Γ ⟧Context → ChΔ Γ → ⟦ Γ ⟧Context
∅ ⊕ρ ∅ = ∅
(v • ρ1) ⊕ρ (dv • dρ) = v ⊕ dv • ρ1 ⊕ρ dρ

v1 ⊕ bang v2 = v2
closure {Γ} t ρ ⊕ dclosure {Γ1} dt ρ₁ dρ with Γ ≟Ctx Γ1
closure {Γ} t ρ ⊕ dclosure {.Γ} dt ρ₁ dρ | yes refl = closure t (ρ ⊕ρ dρ)
... | no ¬p = closure t ρ
_⊕_ (natV n) (dnatV dn) = natV (n + dn)

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : ∀ {τ} → DTerm Γ τ → DVal τ → Set where
  dabs : ∀ {σ τ} {dt : DTerm (σ • Γ) τ} →
    ρ D dρ ⊢ dval (dabs dt) ↓ dclosure dt ρ dρ
  dvar : ∀ {τ} (x : DC.Var Γ τ) →
    ρ D dρ ⊢ dval (dvar (derive-dvar x)) ↓ D.⟦ x ⟧Var dρ
  dlit : ∀ n →
    ρ D dρ ⊢ dconst (lit n) ↓ dnatV 0
  dapp : ∀ {hasIdx} {n : Idx hasIdx}
    {Γ′ σ τ ρ′ dρ′}
    {dvs} {vt} {dvt}
    {vtv} {dvtv}
    {dt : DTerm (σ • Γ′) τ} {dv} →
    ρ D dρ ⊢ dval dvs ↓ dclosure dt ρ′ dρ′ →
    ρ ⊢ val vt ↓[ n ] vtv →
    ρ D dρ ⊢ dval dvt ↓ dvtv →
    (vtv • ρ′) D (dvtv • dρ′) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dapp dvs vt dvt ↓ dv
  dlett : ∀ {hasIdx} {n : Idx hasIdx}
    {σ τ} {s : Term Γ σ} {ds} {dt : DTerm (σ • Γ) τ}
    {vsv dvsv dv} →
    ρ ⊢ s ↓[ n ] vsv →
    ρ D dρ ⊢ ds ↓ dvsv →
    (vsv • ρ) D (dvsv • dρ) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dlett s ds dt ↓ dv
  bangapp : ∀ {hasIdx} {n1 n2 : Idx hasIdx}
    {Γ′ σ τ ρ′}
    {dvs} {vt} {dvt}
    {vtv2}
    {t : Term (σ • Γ′) τ} {v2} →
    ρ D dρ ⊢ dval dvs ↓ bang (closure t ρ′) →
    (ρ ⊕ρ dρ) ⊢ val vt ↓[ n1 ] vtv2 →
    (vtv2 • ρ′) ⊢ t ↓[ n2 ] v2 →
    ρ D dρ ⊢ dapp dvs vt dvt ↓ bang v2

mutual
  rrelT3 : ∀ {τ Γ} (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  rrelT3 {τ} t1 dt t2 ρ1 dρ ρ2 k =
    (v1 v2 : Val τ) →
    ∀ j (j<k : j < k) →
    (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t1 ↓[ i' j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t2 ↓[ no ] v2) →
    Σ[ dv ∈ DVal τ ]
    ρ1 D dρ ⊢ dt ↓ dv ×
    rrelV3 τ v1 dv v2 (k ∸ j)

  rrelV3 : ∀ τ (v1 : Val τ) (dv : DVal τ) (v2 : Val τ) → ℕ → Set
  -- Making this case first ensures rrelV3 splits on its second argument, hence
  -- that all its equations hold definitionally.
  rrelV3 τ v1 (bang v2) v2' n = v2 ≡ v2'
  rrelV3 nat (natV v1) (dnatV dv) (natV v2) n = dv + v1 ≡ v2
  rrelV3 (σ ⇒ τ) (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ dρ) (closure {Γ2} t2 ρ2) n =
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ρ1 ≡ ρ ×
        ρ1 ⊕ρ dρ ≡ ρ2 ×
        t1 ≡ t2 ×
        dt ≡ derive-dterm t1 ×
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        rrelV3 σ v1 dv v2 k →
        rrelT3
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
          k
      }

rrelV3→⊕ : ∀ {τ n} v1 dv v2 → rrelV3 τ v1 dv v2 n → v1 ⊕ dv ≡ v2
rrelV3→⊕ v1 (bang v2) v2' vv = vv
rrelV3→⊕ (closure {Γ} t ρ) (dclosure .(derive-dterm t) .ρ dρ) (closure .t .(ρ ⊕ρ dρ)) ((refl , refl) , refl , refl , refl , refl , dvv) with Γ ≟Ctx Γ | ≟Ctx-refl Γ
... | .(yes refl) | refl = refl
rrelV3→⊕ (natV n) (dnatV dn) (natV .(dn + n)) refl rewrite +-comm n dn = refl

rrelρ3 : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
rrelρ3 ∅ ∅ ∅ ∅ n = ⊤
rrelρ3 (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) n = rrelV3 τ v1 dv v2 n × rrelρ3 Γ ρ1 dρ ρ2 n

rrelρ3→⊕ : ∀ {Γ n} ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → ρ1 ⊕ρ dρ ≡ ρ2
rrelρ3→⊕ ∅ ∅ ∅ tt = refl
rrelρ3→⊕ (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) rewrite rrelV3→⊕ v1 dv v2 vv | rrelρ3→⊕ ρ1 dρ ρ2 ρρ = refl

rrelV3-mono : ∀ m n → m ≤ n → ∀ τ v1 dv v2 → rrelV3 τ v1 dv v2 n → rrelV3 τ v1 dv v2 m
rrelV3-mono m n m≤n τ v1 (bang v2) v2′ vv = vv
rrelV3-mono m n m≤n (σ ⇒ τ) (closure t ρ) (dclosure dt ρ₁ dρ) (closure t₁ ρ₂)
  -- Validity
  ((refl , refl) , refl , refl , refl , refl , vv) =
  (refl  , refl) , refl , refl , refl , refl , λ k k<m → vv k (≤-trans k<m m≤n)
rrelV3-mono m n m≤n nat (natV n₁) (dnatV n₂) (natV n₃) vv = vv

rrelρ3-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → rrelρ3 Γ ρ1 dρ ρ2 m
rrelρ3-mono m n m≤n ∅ ∅ ∅ ∅ tt = tt
rrelρ3-mono m n m≤n (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) = rrelV3-mono m n m≤n _ v1 dv v2 vv , rrelρ3-mono m n m≤n Γ ρ1 dρ ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

⟦_⟧RelVar3 : ∀ {Γ τ n} (x : Var Γ τ) {ρ1 dρ ρ2} →
  rrelρ3 Γ ρ1 dρ ρ2 n →
  rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
⟦ this ⟧RelVar3   {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = vv
⟦ that x ⟧RelVar3 {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = ⟦ x ⟧RelVar3 ρρ

m∸n≤m : ∀ m n → m ∸ n ≤ m
m∸n≤m m zero = ≤-refl
m∸n≤m zero (suc n) = z≤n
m∸n≤m (suc m) (suc n) = ≤-step (m∸n≤m m n)

rfundamentalV3 : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelT3 (val (var x)) (dval (dvar (derive-dvar x))) (val (var x)) ρ1 dρ ρ2 n
rfundamentalV3 x n ρ1 dρ ρ2 ρρ .(⟦ x ⟧Var ρ1) .(⟦ x ⟧Var ρ2) .1 j<n (var .x) (var .x) =
  D.⟦ x ⟧Var dρ , dvar x , rrelV3-mono (n ∸ 1) n (m∸n≤m n 1) _ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) (⟦ x ⟧RelVar3 ρρ)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

sub∸ : ∀ m n o → m + n ≤ o → n ≤ o ∸ m
sub∸ m n o n+m≤o rewrite +-comm m n | cong (_≤ o ∸ m) (sym (m+n∸n≡m n m)) = ∸-mono n+m≤o (≤-refl {m})

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k
rfundamental3 k (val (var x)) ρ1 dρ ρ2 ρρ = rfundamentalV3 x k ρ1 dρ ρ2 ρρ
rfundamental3 (suc k) (val (abs t)) ρ1 dρ ρ2 ρρ .(closure t ρ1) .(closure t ρ2) .1 (s≤s j<k) abs abs =
  dclosure (derive-dterm t) ρ1 dρ , dabs , (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ k₁ k<n v1 dv v2 vv v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 →
    rfundamental3 k₁ t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono k₁ (suc k) (≤-step (lt1 k<n)) _ _ _ _ ρρ) v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
rfundamental3 k (const .(lit n)) ρ1 dρ ρ2 ρρ (natV n) .(natV n) .1 j<k (lit .n) (lit .n) = dnatV 0 , dlit n , refl
rfundamental3 (suc k) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s j<k)
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app _ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc k) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3 (suc k) (val vt) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | bang f2 , vs↓dsv , refl | dtv , vt↓dvv , dtvv
      rewrite sym (rrelρ3→⊕ ρ1 dρ ρ2 ρρ) =
        bang v2 , bangapp vs↓dsv ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv k (s≤s ≤-refl) vtv1 dtv vtv2
           (rrelV3-mono k (suc k) (≤-step ≤-refl) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j j<k ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv =
      dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv
rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ v1 dv v2 dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl

-- Step-indexed logical relations based on relational big-step semantics
-- for ILC-based incremental computation.

-- Goal: prove the fundamental lemma for a ternary logical relation (change
-- validity) across t1, dt and t2. The fundamnetal lemma relates t, derive t and
-- t. That is, we relate a term evaluated relative to an original environment,
-- its derivative evaluated relative to a valid environment change, and the
-- original term evaluated relative to an updated environment.
--
-- Missing goal: here ⊕ isn't defined and wouldn't yet agree with change
-- validity.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, including the choice of using ANF syntax
-- to simplify some step-indexing proofs.
--
-- In fact, this development is typed, hence some parts of the model are closer
-- to Ahmed (ESOP 2006), "Step-Indexed Syntactic Logical Relations for Recursive
-- and Quantified Types". But for many relevant aspects, the two papers are
-- very similar. In fact, I first defined similar logical relations
-- without types, but they require a trickier recursion scheme for well-founded
-- recursion, and I failed to do any proof in that setting.
--
-- The original inspiration came from Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but we ended up looking
-- at their source.
--
-- The main insight from the ISAC paper missing from the other one is how to
-- step-index a big-step semantics correctly: just ensure that the steps in the
-- big-step semantics agree with the ones in the small-step semantics. *Then*
-- everything just works with big-step semantics. Quite a few other details are
-- fiddly, but those are the same in small-step semantics.
--
-- The crucial novelty here is that we relate two computations on different
-- inputs. So we only conclude their results are related if both terminate; the
-- relation for computations does not prove that if the first computation
-- terminates, then the second terminates as well.
--
-- Instead, e1, de and e2 are related at k steps if, whenever e1 terminates in j
-- < k steps and e2 terminates with any step count, then de terminates (with any
-- step count) and their results are related at k - j steps.
--
-- Even when e1 terminates in j steps implies that e2 terminates, e2 gets no
-- bound. Similarly, we do not bound in how many steps de terminates, since on
-- big inputs it might take long.

module Thesis.StepIndexedRelBigStepTypedAnfIlcCorrect where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl; trans to ≤-trans)

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

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

-- Decidable equivalence for types and contexts. Needed later for ⊕ on closures.

⇒-inj : ∀ {τ1 τ2 τ3 τ4 : Type} → _≡_ {A = Type} (τ1 ⇒ τ2) (τ3 ⇒ τ4) → τ1 ≡ τ3 × τ2 ≡ τ4
⇒-inj refl = refl , refl

_≟Type_ : (τ1 τ2 : Type) → Dec (τ1 ≡ τ2)
(τ1 ⇒ τ2) ≟Type (τ3 ⇒ τ4) with τ1 ≟Type τ3 | τ2 ≟Type τ4
(τ1 ⇒ τ2) ≟Type (.τ1 ⇒ .τ2) | yes refl | yes refl = yes refl
(τ1 ⇒ τ2) ≟Type (.τ1 ⇒ τ4) | yes refl | no ¬q = no (λ x → ¬q (proj₂ (⇒-inj x)))
(τ1 ⇒ τ2) ≟Type (τ3 ⇒ τ4) | no ¬p | q = no (λ x → ¬p (proj₁ (⇒-inj x)))
(τ1 ⇒ τ2) ≟Type nat = no (λ ())
nat ≟Type (τ2 ⇒ τ3) = no (λ ())
nat ≟Type nat = yes refl

•-inj : ∀ {τ1 τ2 : Type} {Γ1 Γ2 : Context} → _≡_ {A = Context} (τ1 • Γ1) (τ2 • Γ2) → τ1 ≡ τ2 × Γ1 ≡ Γ2
•-inj refl = refl , refl

_≟Ctx_ : (Γ1 Γ2 : Context) → Dec (Γ1 ≡ Γ2)
∅ ≟Ctx ∅ = yes refl
∅ ≟Ctx (τ2 • Γ2) = no (λ ())
(τ1 • Γ1) ≟Ctx ∅ = no (λ ())
(τ1 • Γ1) ≟Ctx (τ2 • Γ2) with τ1 ≟Type τ2 | Γ1 ≟Ctx Γ2
(τ1 • Γ1) ≟Ctx (.τ1 • .Γ1) | yes refl | yes refl = yes refl
(τ1 • Γ1) ≟Ctx (.τ1 • Γ2) | yes refl | no ¬q = no (λ x → ¬q (proj₂ (•-inj x)))
(τ1 • Γ1) ≟Ctx (τ2 • Γ2) | no ¬p | q = no (λ x → ¬p (proj₁ (•-inj x)))

≟Ctx-refl : ∀ Γ → Γ ≟Ctx Γ ≡ yes refl
≟Ctx-refl Γ with Γ ≟Ctx Γ
≟Ctx-refl Γ | yes refl = refl
≟Ctx-refl Γ | no ¬p = ⊥-elim (¬p refl)

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- Adding this changes nothing without changes to the semantics.
  succ : Const (nat ⇒ nat)

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

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

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

import Data.Integer as I
open I using (ℤ)

-- Yann's idea.
data HasIdx : Set where
  true : HasIdx
  false : HasIdx
data Idx : HasIdx → Set where
  i' : ℕ → Idx true
  no : Idx false

i : {hasIdx : HasIdx} → ℕ → Idx hasIdx
i {false} j = no
i {true} j = i' j

module _ {hasIdx : HasIdx} where
  data _⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : ∀ {τ} → Term Γ τ → Idx hasIdx → Val τ → Set where
    abs : ∀ {σ τ} {t : Term (σ • Γ) τ} →
      ρ ⊢ val (abs t) ↓[ i 1 ] closure t ρ
    var : ∀ {τ} (x : Var Γ τ) →
      ρ ⊢ val (var x) ↓[ i 1 ] (⟦ x ⟧Var ρ)
    app : ∀ n {Γ′ σ τ ρ′} vtv {v} {vs : SVal Γ (σ ⇒ τ)} {vt : SVal Γ σ} {t : Term (σ • Γ′) τ} →
      ρ ⊢ val vs ↓[ i 0 ] closure t ρ′ →
      ρ ⊢ val vt ↓[ i 0 ] vtv →
      (vtv • ρ′) ⊢ t ↓[ i n ] v →
      ρ ⊢ app vs vt ↓[ i (suc n) ] v
    lett :
      ∀ n1 n2 {σ τ} vsv {v} (s : Term Γ σ) (t : Term (σ • Γ) τ) →
      ρ ⊢ s ↓[ i n1 ] vsv →
      (vsv • ρ) ⊢ t ↓[ i n2 ] v →
      ρ ⊢ lett s t ↓[ i (suc n1 + n2) ] v
    lit : ∀ n →
      ρ ⊢ const (lit n) ↓[ i 1 ] natV n

-- data DType : Set where
--   _⇒_ : (σ τ : DType) → DType
--   int : DType
DType = Type

import Base.Syntax.Context DType as DC

Δτ : Type → DType
Δτ (σ ⇒ τ) = σ ⇒ Δτ σ ⇒ Δτ τ
Δτ nat = nat

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

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm (Δ : Context) (τ : DType) : Set
data DSVal (Δ : Context) : (τ : DType) → Set where
  dvar : ∀ {τ} →
    (x : Var (ΔΔ Δ) (Δτ τ)) →
    DSVal Δ τ
  dabs : ∀ {σ τ}
    (dt : DTerm (σ • Δ) τ) →
    DSVal Δ (σ ⇒ τ)

data DTerm (Δ : Context) (τ : DType) where
  dval :
    DSVal Δ τ →
    DTerm Δ τ
  -- constants aka. primitives
  dconst :
    (c : Const τ) →
    DTerm Δ τ
  dapp : ∀ {σ}
    (dvs : DSVal Δ (σ ⇒ τ)) →
    (vt : SVal Δ σ) →
    (dvt : DSVal Δ σ) →
    DTerm Δ τ
  dlett : ∀ {σ}
    (s : Term Δ σ) →
    (ds : DTerm Δ σ) →
    (dt : DTerm (σ • Δ) τ) →
    DTerm Δ τ

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ

derive-dsval : ∀ {Δ σ} → (t : SVal Δ σ) → DSVal Δ σ
derive-dsval (var x) = dvar (derive-dvar x)

derive-dsval (abs t) = dabs (derive-dterm t)

derive-dterm (val x) = dval (derive-dsval x)
derive-dterm (const c) = dconst c
derive-dterm (app vs vt) = dapp (derive-dsval vs) vt (derive-dsval vt)
derive-dterm (lett s t) = dlett s (derive-dterm s) (derive-dterm t)

-- Nontrivial because of unification problems in pattern matching. I wanted to
-- use it to define ⊕ on closures purely on terms of the closure change.

-- Instead, I decided to use decidable equality on contexts: that's a lot of
-- tedious boilerplate, but not too hard, but the proof that validity and ⊕
-- agree becomes easier.
-- -- Define a DVar and be done?
-- underive-dvar :  ∀ {Δ σ} → Var (ΔΔ Δ) (Δτ σ) → Var Δ σ
-- underive-dvar {∅} ()
-- underive-dvar {τ • Δ} x = {!!}

--underive-dvar {σ • Δ} (that x) = that (underive-dvar x)

data DVal : Type → Set
import Base.Denotation.Environment DType DVal as D

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

data DVal where
  bang : ∀ {τ} → Val τ → DVal τ
  dclosure : ∀ {Γ σ τ} → (dt : DTerm (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) →  (dρ : ChΔ Γ) → DVal (σ ⇒ τ)
  dnatV : ∀ (n : ℕ) → DVal nat

_⊕_ : ∀ {τ} → (v1 : Val τ) (dv : DVal τ) → Val τ

_⊕ρ_ : ∀ {Γ} → ⟦ Γ ⟧Context → ChΔ Γ → ⟦ Γ ⟧Context
∅ ⊕ρ ∅ = ∅
(v • ρ1) ⊕ρ (dv • dρ) = v ⊕ dv • ρ1 ⊕ρ dρ

v1 ⊕ bang v2 = v2
closure {Γ} t ρ ⊕ dclosure {Γ1} dt ρ₁ dρ with Γ ≟Ctx Γ1
closure {Γ} t ρ ⊕ dclosure {.Γ} dt ρ₁ dρ | yes refl = closure t (ρ ⊕ρ dρ)
... | no ¬p = closure t ρ
_⊕_ (natV n) (dnatV dn) = natV (n + dn)

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : ∀ {τ} → DTerm Γ τ → DVal τ → Set where
  dabs : ∀ {σ τ} {dt : DTerm (σ • Γ) τ} →
    ρ D dρ ⊢ dval (dabs dt) ↓ dclosure dt ρ dρ
  dvar : ∀ {τ} (x : DC.Var Γ τ) →
    ρ D dρ ⊢ dval (dvar (derive-dvar x)) ↓ D.⟦ x ⟧Var dρ
  dlit : ∀ n →
    ρ D dρ ⊢ dconst (lit n) ↓ dnatV 0
  dapp : ∀ {hasIdx} {n : Idx hasIdx}
    {Γ′ σ τ ρ′ dρ′}
    {dvs} {vt} {dvt}
    {vtv} {dvtv}
    {dt : DTerm (σ • Γ′) τ} {dv} →
    ρ D dρ ⊢ dval dvs ↓ dclosure dt ρ′ dρ′ →
    ρ ⊢ val vt ↓[ n ] vtv →
    ρ D dρ ⊢ dval dvt ↓ dvtv →
    (vtv • ρ′) D (dvtv • dρ′) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dapp dvs vt dvt ↓ dv
  dlett : ∀ {hasIdx} {n : Idx hasIdx}
    {σ τ} {s : Term Γ σ} {ds} {dt : DTerm (σ • Γ) τ}
    {vsv dvsv dv} →
    ρ ⊢ s ↓[ n ] vsv →
    ρ D dρ ⊢ ds ↓ dvsv →
    (vsv • ρ) D (dvsv • dρ) ⊢ dt ↓ dv →
    ρ D dρ ⊢ dlett s ds dt ↓ dv
  bangapp : ∀ {hasIdx} {n1 n2 : Idx hasIdx}
    {Γ′ σ τ ρ′}
    {dvs} {vt} {dvt}
    {vtv2}
    {t : Term (σ • Γ′) τ} {v2} →
    ρ D dρ ⊢ dval dvs ↓ bang (closure t ρ′) →
    (ρ ⊕ρ dρ) ⊢ val vt ↓[ n1 ] vtv2 →
    (vtv2 • ρ′) ⊢ t ↓[ n2 ] v2 →
    ρ D dρ ⊢ dapp dvs vt dvt ↓ bang v2

mutual
  rrelT3 : ∀ {τ Γ} (t1 : Term Γ τ) (dt : DTerm Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  rrelT3 {τ} t1 dt t2 ρ1 dρ ρ2 k =
    (v1 v2 : Val τ) →
    ∀ j (j<k : j < k) →
    (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t1 ↓[ i' j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t2 ↓[ no ] v2) →
    Σ[ dv ∈ DVal τ ]
    ρ1 D dρ ⊢ dt ↓ dv ×
    rrelV3 τ v1 dv v2 (k ∸ j)

  rrelV3 : ∀ τ (v1 : Val τ) (dv : DVal τ) (v2 : Val τ) → ℕ → Set
  -- Making this case first ensures rrelV3 splits on its second argument, hence
  -- that all its equations hold definitionally.
  rrelV3 τ v1 (bang v2) v2' n = v2 ≡ v2'
  rrelV3 nat (natV v1) (dnatV dv) (natV v2) n = dv + v1 ≡ v2
  rrelV3 (σ ⇒ τ) (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ dρ) (closure {Γ2} t2 ρ2) n =
      Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ρ1 ≡ ρ ×
        ρ1 ⊕ρ dρ ≡ ρ2 ×
        t1 ≡ t2 ×
        dt ≡ derive-dterm t1 ×
        ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
        rrelV3 σ v1 dv v2 k →
        rrelT3
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
          k
      }

rrelV3→⊕ : ∀ {τ n} v1 dv v2 → rrelV3 τ v1 dv v2 n → v1 ⊕ dv ≡ v2
rrelV3→⊕ v1 (bang v2) v2' vv = vv
rrelV3→⊕ (closure {Γ} t ρ) (dclosure .(derive-dterm t) .ρ dρ) (closure .t .(ρ ⊕ρ dρ)) ((refl , refl) , refl , refl , refl , refl , dvv) with Γ ≟Ctx Γ | ≟Ctx-refl Γ
... | .(yes refl) | refl = refl
rrelV3→⊕ (natV n) (dnatV dn) (natV .(dn + n)) refl rewrite +-comm n dn = refl

rrelρ3 : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
rrelρ3 ∅ ∅ ∅ ∅ n = ⊤
rrelρ3 (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) n = rrelV3 τ v1 dv v2 n × rrelρ3 Γ ρ1 dρ ρ2 n

rrelρ3→⊕ : ∀ {Γ n} ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → ρ1 ⊕ρ dρ ≡ ρ2
rrelρ3→⊕ ∅ ∅ ∅ tt = refl
rrelρ3→⊕ (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) rewrite rrelV3→⊕ v1 dv v2 vv | rrelρ3→⊕ ρ1 dρ ρ2 ρρ = refl

rrelV3-mono : ∀ m n → m ≤ n → ∀ τ v1 dv v2 → rrelV3 τ v1 dv v2 n → rrelV3 τ v1 dv v2 m
rrelV3-mono m n m≤n τ v1 (bang v2) v2′ vv = vv
rrelV3-mono m n m≤n (σ ⇒ τ) (closure t ρ) (dclosure dt ρ₁ dρ) (closure t₁ ρ₂)
  -- Validity
  ((refl , refl) , refl , refl , refl , refl , vv) =
  (refl  , refl) , refl , refl , refl , refl , λ k k<m → vv k (≤-trans k<m m≤n)
rrelV3-mono m n m≤n nat (natV n₁) (dnatV n₂) (natV n₃) vv = vv

rrelρ3-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 dρ ρ2 → rrelρ3 Γ ρ1 dρ ρ2 n → rrelρ3 Γ ρ1 dρ ρ2 m
rrelρ3-mono m n m≤n ∅ ∅ ∅ ∅ tt = tt
rrelρ3-mono m n m≤n (τ • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , ρρ) = rrelV3-mono m n m≤n _ v1 dv v2 vv , rrelρ3-mono m n m≤n Γ ρ1 dρ ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

⟦_⟧RelVar3 : ∀ {Γ τ n} (x : Var Γ τ) {ρ1 dρ ρ2} →
  rrelρ3 Γ ρ1 dρ ρ2 n →
  rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
⟦ this ⟧RelVar3   {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = vv
⟦ that x ⟧RelVar3 {v1 • ρ1} {dv • dρ} {v2 • ρ2} (vv , ρρ) = ⟦ x ⟧RelVar3 ρρ

m∸n≤m : ∀ m n → m ∸ n ≤ m
m∸n≤m m zero = ≤-refl
m∸n≤m zero (suc n) = z≤n
m∸n≤m (suc m) (suc n) = ≤-step (m∸n≤m m n)

rfundamentalV3 : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelT3 (val (var x)) (dval (dvar (derive-dvar x))) (val (var x)) ρ1 dρ ρ2 n
rfundamentalV3 x n ρ1 dρ ρ2 ρρ .(⟦ x ⟧Var ρ1) .(⟦ x ⟧Var ρ2) .1 j<n (var .x) (var .x) =
  D.⟦ x ⟧Var dρ , dvar x , rrelV3-mono (n ∸ 1) n (m∸n≤m n 1) _ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) (⟦ x ⟧RelVar3 ρρ)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

sub∸ : ∀ m n o → m + n ≤ o → n ≤ o ∸ m
sub∸ m n o n+m≤o rewrite +-comm m n | cong (_≤ o ∸ m) (sym (m+n∸n≡m n m)) = ∸-mono n+m≤o (≤-refl {m})

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k
rfundamental3 k (val (var x)) ρ1 dρ ρ2 ρρ = rfundamentalV3 x k ρ1 dρ ρ2 ρρ
rfundamental3 (suc k) (val (abs t)) ρ1 dρ ρ2 ρρ .(closure t ρ1) .(closure t ρ2) .1 (s≤s j<k) abs abs =
  dclosure (derive-dterm t) ρ1 dρ , dabs , (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ k₁ k<n v1 dv v2 vv v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 →
    rfundamental3 k₁ t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono k₁ (suc k) (≤-step (lt1 k<n)) _ _ _ _ ρρ) v3 v4 j j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
rfundamental3 k (const .(lit n)) ρ1 dρ ρ2 ρρ (natV n) .(natV n) .1 j<k (lit .n) (lit .n) = dnatV 0 , dlit n , refl
rfundamental3 (suc k) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s j<k)
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app _ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc k) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3 (suc k) (val vt) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | bang f2 , vs↓dsv , refl | dtv , vt↓dvv , dtvv
      rewrite sym (rrelρ3→⊕ ρ1 dρ ρ2 ρρ) =
        bang v2 , bangapp vs↓dsv ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv k (s≤s ≤-refl) vtv1 dtv vtv2
           (rrelV3-mono k (suc k) (≤-step ≤-refl) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j j<k ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv =
      dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv
rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ v1 dv v2 dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl


Document P.C.Term.

Document P.C.Term.

Old-commit-hash: 0263f48a6674e209dc10d253b3ffab2671e313cd

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Terms that operate on changes (Fig. 3).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

-- Extension point 1: A term for ⊝ on base types.
DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

-- Extension point 2: A term for ⊕ on base types.
ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

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

  -- We provide: terms for ⊕ and ⊝ on arbitrary types.
  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    (let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       abs₄ (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x))

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    (let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

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

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

  infixl 6 apply diff
  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_
  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = app₂ apply-term

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Const : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Const
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

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

  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    (let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       abs₄ (λ g f x Δx → app g (x ⊕σ Δx) ⊝τ app f x))

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    (let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

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

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

  infixl 6 apply diff
  syntax apply τ x Δx = Δx ⊕₍ τ ₎ x
  syntax diff τ x y = x ⊝₍ τ ₎ y

  infixl 6 _⊕_ _⊝_
  _⊝_ : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  _⊝_ {τ} = diff τ

  _⊕_ : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  _⊕_ {τ} = app₂ apply-term


Avoid "white smoke" warning for fallback cases that do not hold

{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.ANormalUntyped where

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

{- Typed deBruijn indexes for untyped languages. -}

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

record DType : Set where
  constructor DUni

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

import Base.Denotation.Environment DType DVal as D

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

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

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

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

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

data _F⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Fun Γ → ℕ → Val Uni → Set where
  abs : ∀ {t : Fun (Uni • Γ)} →
    ρ F⊢ abs t ↓[ 0 ] closure t ρ
  term : ∀ {v} n (t : Term Γ) →
    ρ ⊢ t ↓[ n ] v →
    ρ F⊢ term t ↓[ n ] v

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

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

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

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DTerm Γ → DVal DUni → Set

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

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

open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Relation.Binary hiding (_⇒_)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

suc∸suc : ∀ m n → n < m → suc (m ∸ suc n) ≡ m ∸ n
suc∸suc (suc m) zero (s≤s n<m) = refl
suc∸suc (suc m) (suc n) (s≤s n<m) = suc∸suc m n n<m

lemlt : ∀ j k → suc j < k → k ∸ suc j < k
lemlt j (suc k) (s≤s j<k) = s≤s (∸-mono {k} {k} {j} {0} ≤-refl z≤n)

lemlt′ : ∀ j k → suc j <′ k → k ∸ suc j <′ k
lemlt′ j k j<′k = ≤⇒≤′ (lemlt j k (≤′⇒≤ j<′k))

open import Induction.WellFounded
open import Induction.Nat
rrelT3-Type : ℕ → Set₁
rrelT3-Type n =
  ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
  (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set

rrelV3-Type : ℕ → Set₁
rrelV3-Type n = ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set

rrelTV3-Type : ℕ → Set₁
rrelTV3-Type n = rrelT3-Type n × rrelV3-Type n

-- The type of the function availalbe for recursive calls.
rrelTV3-recSubCallsT : ℕ → Set₁
rrelTV3-recSubCallsT n = (k : ℕ) → k < n → rrelTV3-Type k

mutual
  -- Assemble together
  rrelTV3-step : ∀ n → rrelTV3-recSubCallsT n → rrelTV3-Type n
  rrelTV3-step n rec-rrelTV3 =
    let rrelV3-n = rrelV3-step n rec-rrelTV3
    in rrelT3-step n rec-rrelTV3 rrelV3-n , rrelV3-n
  rrelTV3 =  <-rec rrelTV3-Type rrelTV3-step
  rrelT3 : ∀ n → rrelT3-Type n
  rrelT3 n =  proj₁ (rrelTV3 n)
  rrelV3 : ∀ n → rrelV3-Type n
  rrelV3 n =  proj₂ (rrelTV3 n)

  s-rrelV3 :
    ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
    ∀ j → j < k → rrelV3-Type (k ∸ j)
  s-rrelV3 k rec-rrelTV3 rrelV3-k 0 _ = rrelV3-k
  s-rrelV3 k rec-rrelTV3 rrelV3-k (suc j) sucj<k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt j k sucj<k))
  -- Have the same context for t1, dt and t2? Yeah, good, that's what we want in the end...
  -- Though we might want more flexibility till when we have replacement
  -- changes.
  rrelT3-step : ∀ k → rrelTV3-recSubCallsT k →
    rrelV3-Type k →
    -- rrelV3-Type n
    ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
      (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
  rrelT3-step k rec-rrelTV3 rrelV3-k =
    λ t1 dt t2 ρ1 dρ ρ2 →
    ∀ j (j<k : j < k) n2 →
    (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    s-rrelV3 k rec-rrelTV3 rrelV3-k j j<k v1 dv v2
    -- where
    --   s-rrelV3 : ∀ j → j <′ k → rrelV3-Type (k ∸ j)
    --   -- If j = 0, we can't do a recursive call on (k - j) because that's not
    --   -- well-founded. Luckily, we don't need to, just use relV as defined at
    --   -- the same level.
    --   -- Yet, this will be a pain in proofs.
    --   s-rrelV3 0 _ = rrelV3-k
    --   s-rrelV3 (suc j) sucj<′k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt′ j k sucj<′k))

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

open import Postulate.Extensionality
mutual
  rrelT3-equiv : ∀ k {Γ} {t1 : Fun Γ} {dt t2 ρ1 dρ ρ2} →
    rrelT3 k t1 dt t2 ρ1 dρ ρ2 ≡
    ∀ j (j<k : j < k) n2 →
    ∀ (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    rrelV3 j v1 dv v2
  rrelT3-equiv n = cong (λ □ → ∀ j → □ j) (ext (λ j → {!!}))

  rrelV3-equiv : ∀ n {Γ1 Γ2 ΔΓ t1 dt t2 ρ1 ρ' dρ ρ2} →
    rrelV3 n (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) ≡ Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 →
        rrelV3 k v1 dv v2 →
        rrelT3 k
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-equiv n = cong (λ □ → Σ (_ ≡ _ × _ ≡ _) □) (ext (λ { (eq1 , eq2) →
    cong
      (λ □ →
         (λ { (refl , refl)
                → ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 → □ k k<n v1 dv v2
            })
         eq1 eq2)
      (ext (λ x → ext {!!}))}))
  --
  -- cong (λ □ → ∀ k → (k<n : k <′ n) → □ k k<n)
  -- rrelV3-equiv k

rrelρ3 : ℕ → ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3 n ∅ ∅ ∅ ∅ = ⊤
rrelρ3 n (Uni • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) = rrelV3 n v1 dv v2 × rrelρ3 n Γ ρ1 dρ ρ2

--
rfundamental3 : ∀ {Γ} (t : Fun Γ) → ∀ k ρ1 dρ ρ2 → (ρρ : rrelρ3 k Γ ρ1 dρ ρ2) → rrelT3 k t (derive-dfun t) t ρ1 dρ ρ2
rfundamental3 (term x) k ρ1 dρ ρ2 ρρ j j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 = {!!}
rfundamental3 {Γ} (abs t) k ρ1 dρ ρ2 ρρ .0 j<k .0 (closure .t .ρ1) (closure .t .ρ2) abs abs = dclosure (derive-dfun t) ρ1 dρ , 0 , dabs , (refl , refl) , {!body !}
  where
    body1 : ∀ k₁ (k₁<k : k₁ <′ k) → (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → rrelV3 k₁ v1 dv v2 → rrelT3 k₁ t (derive-dfun t) t (v1 • ρ1) (dv • dρ) (v2 • ρ2)
    body1 = λ k₁ k₁<k v1 dv v2 x v3 v4 j n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
    rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
    !}
  -- λ
  -- { k₁ k<n v1 dv v2 vv v3 v4 0 n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- !}
  -- -- (Some.wfRec-builder rrelTV3-Type rrelTV3-step k₁
  --                     -- (<-well-founded′ k k₁ k<n))

  -- -- All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k k₁ k<n : rrelTV3-Type k₁
  -- --
  -- ; k₁ k<n v1 dv v2 vv v3 v4 (suc j) n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- !}
  -- -- rfundamental3 t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 {!suc j !} n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- }

  --   -- ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
  --   -- ∀ j → j <′ k → rrelV3-Type (k ∸ j)
  --   foo : s-rrelV3 k
  --     (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k)
  --     (rrelV3-step k (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k))
  --     j j<k v1 (dclosure (derive-dfun t) ρ1 dρ) v2
  --   foo with j
  --   ... | s = {!!}

{-# OPTIONS --allow-unsolved-metas #-}
module Thesis.ANormalUntyped where

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

{- Typed deBruijn indexes for untyped languages. -}

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

record DType : Set where
  constructor DUni

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

import Base.Denotation.Environment DType DVal as D

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

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

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

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

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

data _F⊢_↓[_]_ {Γ} (ρ : ⟦ Γ ⟧Context) : Fun Γ → ℕ → Val Uni → Set where
  abs : ∀ {t : Fun (Uni • Γ)} →
    ρ F⊢ abs t ↓[ 0 ] closure t ρ
  term : ∀ {v} n (t : Term Γ) →
    ρ ⊢ t ↓[ n ] v →
    ρ F⊢ term t ↓[ n ] v

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

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

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

data _D_⊢_↓_ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) : DTerm Γ → DVal DUni → Set

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

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

open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Relation.Binary hiding (_⇒_)

suc∸ : ∀ m n → n ≤ m → suc (m ∸ n) ≡ suc m ∸ n
suc∸ m zero z≤n = refl
suc∸ (suc m) (suc n) (s≤s n≤m) = suc∸ m n n≤m

suc∸suc : ∀ m n → n < m → suc (m ∸ suc n) ≡ m ∸ n
suc∸suc (suc m) zero (s≤s n<m) = refl
suc∸suc (suc m) (suc n) (s≤s n<m) = suc∸suc m n n<m

lemlt : ∀ j k → suc j < k → k ∸ suc j < k
lemlt j (suc k) (s≤s j<k) = s≤s (∸-mono {k} {k} {j} {0} ≤-refl z≤n)

lemlt′ : ∀ j k → suc j <′ k → k ∸ suc j <′ k
lemlt′ j k j<′k = ≤⇒≤′ (lemlt j k (≤′⇒≤ j<′k))

open import Induction.WellFounded
open import Induction.Nat
rrelT3-Type : ℕ → Set₁
rrelT3-Type n =
  ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
  (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set

rrelV3-Type : ℕ → Set₁
rrelV3-Type n = ∀ (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → Set

rrelTV3-Type : ℕ → Set₁
rrelTV3-Type n = rrelT3-Type n × rrelV3-Type n

-- The type of the function availalbe for recursive calls.
rrelTV3-recSubCallsT : ℕ → Set₁
rrelTV3-recSubCallsT n = (k : ℕ) → k < n → rrelTV3-Type k

mutual
  -- Assemble together
  rrelTV3-step : ∀ n → rrelTV3-recSubCallsT n → rrelTV3-Type n
  rrelTV3-step n rec-rrelTV3 =
    let rrelV3-n = rrelV3-step n rec-rrelTV3
    in rrelT3-step n rec-rrelTV3 rrelV3-n , rrelV3-n
  rrelTV3 =  <-rec rrelTV3-Type rrelTV3-step
  rrelT3 : ∀ n → rrelT3-Type n
  rrelT3 n =  proj₁ (rrelTV3 n)
  rrelV3 : ∀ n → rrelV3-Type n
  rrelV3 n =  proj₂ (rrelTV3 n)

  s-rrelV3 :
    ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
    ∀ j → j < k → rrelV3-Type (k ∸ j)
  s-rrelV3 k rec-rrelTV3 rrelV3-k 0 _ = rrelV3-k
  s-rrelV3 k rec-rrelTV3 rrelV3-k (suc j) sucj<k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt j k sucj<k))
  -- Have the same context for t1, dt and t2? Yeah, good, that's what we want in the end...
  -- Though we might want more flexibility till when we have replacement
  -- changes.
  rrelT3-step : ∀ k → rrelTV3-recSubCallsT k →
    rrelV3-Type k →
    -- rrelV3-Type n
    ∀ {Γ} → (t1 : Fun Γ) (dt : DFun Γ) (t2 : Fun Γ)
      (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
  rrelT3-step k rec-rrelTV3 rrelV3-k =
    λ t1 dt t2 ρ1 dρ ρ2 →
    ∀ j (j<k : j < k) n2 →
    (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    s-rrelV3 k rec-rrelTV3 rrelV3-k j j<k v1 dv v2
    -- where
    --   s-rrelV3 : ∀ j → j <′ k → rrelV3-Type (k ∸ j)
    --   -- If j = 0, we can't do a recursive call on (k - j) because that's not
    --   -- well-founded. Luckily, we don't need to, just use relV as defined at
    --   -- the same level.
    --   -- Yet, this will be a pain in proofs.
    --   s-rrelV3 0 _ = rrelV3-k
    --   s-rrelV3 (suc j) sucj<′k = proj₂ (rec-rrelTV3 (k ∸ suc j) (lemlt′ j k sucj<′k))

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

open import Postulate.Extensionality
mutual
  rrelT3-equiv : ∀ k {Γ} {t1 : Fun Γ} {dt t2 ρ1 dρ ρ2} →
    rrelT3 k t1 dt t2 ρ1 dρ ρ2 ≡
    ∀ j (j<k : j < k) n2 →
    ∀ (v1 v2 : Val Uni) →
    (ρ1⊢t1↓[j]v1 : ρ1 F⊢ t1 ↓[ j ] v1) →
    (ρ2⊢t2↓[n2]v2 : ρ2 F⊢ t2 ↓[ n2 ] v2) →
    Σ[ dv ∈ DVal DUni ] Σ[ dn ∈ ℕ ]
    ρ1 D dρ F⊢ dt ↓ dv ×
    rrelV3 j v1 dv v2
  rrelT3-equiv n = cong (λ □ → ∀ j → □ j) (ext (λ j → {!!}))

  rrelV3-equiv : ∀ n {Γ1 Γ2 ΔΓ t1 dt t2 ρ1 ρ' dρ ρ2} →
    rrelV3 n (closure {Γ1} t1 ρ1) (dclosure {ΔΓ} dt ρ' dρ) (closure {Γ2} t2 ρ2) ≡ Σ ((Γ1 ≡ Γ2) × (Γ1 ≡ ΔΓ)) λ { (refl , refl) →
        ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 →
        rrelV3 k v1 dv v2 →
        rrelT3 k
          t1
          dt
          t2
          (v1 • ρ1)
          (dv • dρ)
          (v2 • ρ2)
      }
  rrelV3-equiv n = cong (λ □ → Σ (_ ≡ _ × _ ≡ _) □) (ext (λ { (eq1 , eq2) →
    cong
      (λ □ →
         (λ { (refl , refl)
                → ∀ (k : ℕ) (k<n : k <′ n) v1 dv v2 → □ k k<n v1 dv v2
            })
         eq1 eq2)
      (ext (λ x → ext {!!}))}))
  --
  -- cong (λ □ → ∀ k → (k<n : k <′ n) → □ k k<n)
  -- rrelV3-equiv k

rrelρ3 : ℕ → ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3 n ∅ ∅ ∅ ∅ = ⊤
rrelρ3 n (Uni • Γ) (v1 • ρ1) (dv • dρ) (v2 • ρ2) = rrelV3 n v1 dv v2 × rrelρ3 n Γ ρ1 dρ ρ2

--
rfundamental3 : ∀ {Γ} (t : Fun Γ) → ∀ k ρ1 dρ ρ2 → (ρρ : rrelρ3 k Γ ρ1 dρ ρ2) → rrelT3 k t (derive-dfun t) t ρ1 dρ ρ2
rfundamental3 (term x) k ρ1 dρ ρ2 ρρ j j<k n2 v1 v2 ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 = {!!}
rfundamental3 {Γ} (abs t) k ρ1 dρ ρ2 ρρ .0 j<k .0 (closure .t .ρ1) (closure .t .ρ2) abs abs = dclosure (derive-dfun t) ρ1 dρ , 0 , dabs , (refl , refl) , {!body !}
  where
    body1 : ∀ k₁ (k₁<k : k₁ <′ k) → (v1 : Val Uni) (dv : DVal DUni) (v2 : Val Uni) → rrelV3 k₁ v1 dv v2 → rrelT3 k₁ t (derive-dfun t) t (v1 • ρ1) (dv • dρ) (v2 • ρ2)
    body1 = λ k₁ k₁<k v1 dv v2 x v3 v4 j n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
    rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
    !}
  -- λ
  -- { k₁ k<n v1 dv v2 vv v3 v4 0 n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- rfundamental3 {Uni • Γ} t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 0 n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- !}
  -- -- (Some.wfRec-builder rrelTV3-Type rrelTV3-step k₁
  --                     -- (<-well-founded′ k k₁ k<n))

  -- -- All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k k₁ k<n : rrelTV3-Type k₁
  -- --
  -- ; k₁ k<n v1 dv v2 vv v3 v4 (suc j) n2 j<k₁ ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2 → {!
  -- !}
  -- -- rfundamental3 t k₁ (v1 • ρ1) (dv • dρ) (v2 • ρ2) ({!vv!} , {!ρρ!}) v3 v4 {!suc j !} n2 {!j<k₁ !} {! ρ1⊢t1↓[j]v1 !} ρ2⊢t2↓[n2]v2
  -- }

  --   -- ∀ k → rrelTV3-recSubCallsT k → rrelV3-Type k →
  --   -- ∀ j → j <′ k → rrelV3-Type (k ∸ j)
  --   foo : s-rrelV3 k
  --     (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k)
  --     (rrelV3-step k (All.wfRec-builder <-well-founded _ rrelTV3-Type rrelTV3-step k))
  --     j j<k v1 (dclosure (derive-dfun t) ρ1 dρ) v2
  --   foo with j
  --   ... | s = {!!}


give the `Terms` parameter of `const` a default name `args` for induction

Old-commit-hash: 0657adc1ef2e2e51a3d863ac5d78085bd8913b08

import Parametric.Syntax.Type as Type

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)

open Type.Structure Base

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where

  -- Declarations of Term and Terms to enable mutual recursion
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  data Terms
    (Γ : Context) :
    (Σ : Context) → Set

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  data Terms Γ where
    ∅ : Terms Γ ∅
    _•_ : ∀ {τ Σ} →
      Term Γ τ →
      Terms Γ Σ →
      Terms Γ (τ • Σ)

  infixr 9 _•_

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ

  weakenAll : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

  weaken Γ₁≼Γ₂ (const c ts) = const c (weakenAll Γ₁≼Γ₂ ts)
  weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  weakenAll Γ₁≼Γ₂ ∅ = ∅
  weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ ts

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

  uncurriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → UncurriedTermConstructor Γ Σ τ
  uncurriedConst constant = const constant

  CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
  CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

  curryTermConstructor : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
  curryTermConstructor {∅} k = k ∅
  curryTermConstructor {τ • Σ} k = λ t → curryTermConstructor (λ ts → k (t • ts))

  curriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
  curriedConst constant = curryTermConstructor (uncurriedConst constant)

  -- HOAS-like smart constructors for lambdas, for different arities.

  abs₁ :
    ∀ {Γ τ₁ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → (x : Term Γ′ τ₁) → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ))
  abs₁ {Γ} {τ₁} =  λ f → abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))

  abs₂ :
    ∀ {Γ τ₁ τ₂ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ))
  abs₂ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₁ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₃ :
    ∀ {Γ τ₁ τ₂ τ₃ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ))
  abs₃ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₂ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₄ :
    ∀ {Γ τ₁ τ₂ τ₃ τ₄ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ₄ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ₄ ⇒ τ))
  abs₄ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₃ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₅ :
    ∀ {Γ τ₁ τ₂ τ₃ τ₄ τ₅ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ₄ → Term Γ′ τ₅ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ₄ ⇒ τ₅ ⇒ τ))
  abs₅ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₄ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₆ :
    ∀ {Γ τ₁ τ₂ τ₃ τ₄ τ₅ τ₆ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ₄ → Term Γ′ τ₅ → Term Γ′ τ₆ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ₄ ⇒ τ₅ ⇒ τ₆ ⇒ τ))
  abs₆ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₅ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

import Parametric.Syntax.Type as Type

module Parametric.Syntax.Term
    (Base : Type.Structure)
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)

open Type.Structure Base

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where

  -- Declarations of Term and Terms to enable mutual recursion
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  data Terms
    (Γ : Context) :
    (Σ : Context) → Set

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      Terms Γ Σ →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  data Terms Γ where
    ∅ : Terms Γ ∅
    _•_ : ∀ {τ Σ} →
      Term Γ τ →
      Terms Γ Σ →
      Terms Γ (τ • Σ)

  infixr 9 _•_

  -- Weakening

  weaken : ∀ {Γ₁ Γ₂ τ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Term Γ₁ τ →
    Term Γ₂ τ

  weakenAll : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

  weaken Γ₁≼Γ₂ (const c ts) = const c (weakenAll Γ₁≼Γ₂ ts)
  weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
  weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
  weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

  weakenAll Γ₁≼Γ₂ ∅ = ∅
  weakenAll Γ₁≼Γ₂ (t • ts) = weaken Γ₁≼Γ₂ t • weakenAll Γ₁≼Γ₂ ts

  -- Specialized weakening
  weaken₁ : ∀ {Γ σ τ} →
    Term Γ τ → Term (σ • Γ) τ
  weaken₁ t = weaken (drop _ • ≼-refl) t

  weaken₂ : ∀ {Γ α β τ} →
    Term Γ τ → Term (α • β • Γ) τ
  weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

  weaken₃ : ∀ {Γ α β γ τ} →
    Term Γ τ → Term (α • β • γ • Γ) τ
  weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

  -- Shorthands for nested applications
  app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
  app₂ f x = app (app f x)

  app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
  app₃ f x = app₂ (app f x)

  app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
  app₄ f x = app₃ (app f x)

  app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
  app₅ f x = app₄ (app f x)

  app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
  app₆ f x = app₅ (app f x)

  UncurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  UncurriedTermConstructor Γ Σ τ = Terms Γ Σ → Term Γ τ

  uncurriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → UncurriedTermConstructor Γ Σ τ
  uncurriedConst constant = const constant

  CurriedTermConstructor : (Γ Σ : Context) (τ : Type) → Set
  CurriedTermConstructor Γ ∅ τ′ = Term Γ τ′
  CurriedTermConstructor Γ (τ • Σ) τ′ = Term Γ τ → CurriedTermConstructor Γ Σ τ′

  curryTermConstructor : ∀ {Σ Γ τ} → UncurriedTermConstructor Γ Σ τ → CurriedTermConstructor Γ Σ τ
  curryTermConstructor {∅} k = k ∅
  curryTermConstructor {τ • Σ} k = λ t → curryTermConstructor (λ ts → k (t • ts))

  curriedConst : ∀ {Σ τ} → Const Σ τ → ∀ {Γ} → CurriedTermConstructor Γ Σ τ
  curriedConst constant = curryTermConstructor (uncurriedConst constant)

  -- HOAS-like smart constructors for lambdas, for different arities.

  abs₁ :
    ∀ {Γ τ₁ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → (x : Term Γ′ τ₁) → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ))
  abs₁ {Γ} {τ₁} =  λ f → abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))

  abs₂ :
    ∀ {Γ τ₁ τ₂ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ))
  abs₂ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₁ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₃ :
    ∀ {Γ τ₁ τ₂ τ₃ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ))
  abs₃ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₂ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₄ :
    ∀ {Γ τ₁ τ₂ τ₃ τ₄ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ₄ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ₄ ⇒ τ))
  abs₄ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₃ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₅ :
    ∀ {Γ τ₁ τ₂ τ₃ τ₄ τ₅ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ₄ → Term Γ′ τ₅ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ₄ ⇒ τ₅ ⇒ τ))
  abs₅ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₄ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  abs₆ :
    ∀ {Γ τ₁ τ₂ τ₃ τ₄ τ₅ τ₆ τ} →
      (∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ₂ → Term Γ′ τ₃ → Term Γ′ τ₄ → Term Γ′ τ₅ → Term Γ′ τ₆ → Term Γ′ τ) →
      (Term Γ (τ₁ ⇒ τ₂ ⇒ τ₃ ⇒ τ₄ ⇒ τ₅ ⇒ τ₆ ⇒ τ))
  abs₆ f =
    abs₁ (λ {_} {Γ≼Γ′} x₁ →
      abs₅ (λ {_} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))


Compile fix

Compile fix

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of function types (Fig. 1a).
------------------------------------------------------------------------

module Parametric.Syntax.Type where

-- This is a module in the Parametric.* hierarchy, so it defines
-- an extension point for plugins. In this case, the plugin can
-- choose the syntax for data types. We always provide a binding
-- called "Structure" that defines the type of the value that has
-- to be provided by the plugin. In this case, the plugin has to
-- provide a type, so we say "Structure = Set".

Structure : Set₁
Structure = Set

-- Here is the parametric module that defines the syntax of
-- simply types in terms of the syntax of base types. In the
-- Parametric.* hierarchy, we always call these parametric
-- modules "Structure". Note that in Agda, there is a separate
-- namespace for module names and for other bindings, so this
-- doesn't clash with the "Structure" above.
--
-- The idea behind all these structures is that the parametric
-- module lifts some structure of the plugin to the corresponding
-- structure in the full language. In this case, we lift the
-- structure of base types to the structure of simple types.
-- Maybe not the best choice of names, but it seemed clever at
-- the time.

module Structure (Base : Structure) where
  infixr 5 _⇒_

  -- A simple type is either a base type or a function types.
  -- Note that we can use our module parameter "Base" here just
  -- like any other type.
  data Type : Set where
    base : (ι : Base) → Type
    _⇒_ : (σ : Type) → (τ : Type) → Type

  -- We also provide the definitions of contexts of the newly
  -- defined simple types, variables as de Bruijn indices
  -- pointing into such a context, and sets of bound variables.
  open import Base.Syntax.Context Type public
  open import Base.Syntax.Vars Type public

  -- Internalize a context to a type.
  --
  -- Is there a better name for this function?
  internalizeContext : (Σ : Context) (τ′ : Type) → Type
  internalizeContext ∅ τ′ = τ′
  internalizeContext (τ • Σ) τ′ = τ ⇒ internalizeContext Σ τ′

  mutual
    --  CBPV
    data ValType : Set where
      U : CompType → ValType
      B : Base → ValType
      Unit : ValType
      _×_ : ValType → ValType → ValType
      _⊹_ : ValType → ValType → ValType

    data CompType : Set where
      F : ValType → CompType
      _⇛_ : ValType → CompType → CompType
      _Π_ : CompType → CompType → CompType

  cbnToCompType : Type → CompType
  cbnToCompType (base ι) = F (B ι)
  cbnToCompType (σ ⇒ τ) = U (cbnToCompType σ) ⇛ cbnToCompType τ

  cbvToValType : Type → ValType
  cbvToValType (base ι) = B ι
  cbvToValType (σ ⇒ τ) = U (cbvToValType σ ⇛ F (cbvToValType τ))

  open import Base.Syntax.Context ValType public
    using ()
    renaming
      ( ∅ to ∅∅
      ; _•_ to _••_
      ; mapContext to mapValCtx
      ; Var to ValVar
      ; Context to ValContext
      ; this to vThis; that to vThat)

  cbnToValType : Type → ValType
  cbnToValType τ = U (cbnToCompType τ)

  cbvToCompType : Type → CompType
  cbvToCompType τ = F (cbvToValType τ)

  fromCBNCtx : Context → ValContext
  fromCBNCtx Γ = mapValCtx cbnToValType Γ

  fromCBVCtx : Context → ValContext
  fromCBVCtx Γ = mapValCtx cbvToValType Γ

  fromVar : ∀ {Γ τ} → (f : Type → ValType) → Var Γ τ → ValVar (mapValCtx f Γ) (f τ)
  fromVar {x • Γ} f this = vThis
  fromVar {x • Γ} f (that v) = vThat (fromVar f v)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of function types (Fig. 1a).
------------------------------------------------------------------------

module Parametric.Syntax.Type where

-- This is a module in the Parametric.* hierarchy, so it defines
-- an extension point for plugins. In this case, the plugin can
-- choose the syntax for data types. We always provide a binding
-- called "Structure" that defines the type of the value that has
-- to be provided by the plugin. In this case, the plugin has to
-- provide a type, so we say "Structure = Set".

Structure : Set₁
Structure = Set

-- Here is the parametric module that defines the syntax of
-- simply types in terms of the syntax of base types. In the
-- Parametric.* hierarchy, we always call these parametric
-- modules "Structure". Note that in Agda, there is a separate
-- namespace for module names and for other bindings, so this
-- doesn't clash with the "Structure" above.
--
-- The idea behind all these structures is that the parametric
-- module lifts some structure of the plugin to the corresponding
-- structure in the full language. In this case, we lift the
-- structure of base types to the structure of simple types.
-- Maybe not the best choice of names, but it seemed clever at
-- the time.

module Structure (Base : Structure) where
  infixr 5 _⇒_

  -- A simple type is either a base type or a function types.
  -- Note that we can use our module parameter "Base" here just
  -- like any other type.
  data Type : Set where
    base : (ι : Base) → Type
    _⇒_ : (σ : Type) → (τ : Type) → Type

  -- We also provide the definitions of contexts of the newly
  -- defined simple types, variables as de Bruijn indices
  -- pointing into such a context, and sets of bound variables.
  open import Base.Syntax.Context Type public
  open import Base.Syntax.Vars Type public

  -- Internalize a context to a type.
  --
  -- Is there a better name for this function?
  internalizeContext : (Σ : Context) (τ′ : Type) → Type
  internalizeContext ∅ τ′ = τ′
  internalizeContext (τ • Σ) τ′ = τ ⇒ internalizeContext Σ τ′

  mutual
    --  CBPV
    data ValType : Set where
      U : CompType → ValType
      B : Base → ValType
      Unit : ValType
      _×_ : ValType → ValType → ValType
      _+_ : ValType → ValType → ValType

    data CompType : Set where
      F : ValType → CompType
      _⇛_ : ValType → CompType → CompType
      _Π_ : CompType → CompType → CompType

  cbnToCompType : Type → CompType
  cbnToCompType (base ι) = F (B ι)
  cbnToCompType (σ ⇒ τ) = U (cbnToCompType σ) ⇛ cbnToCompType τ

  cbvToValType : Type → ValType
  cbvToValType (base ι) = B ι
  cbvToValType (σ ⇒ τ) = U (cbvToValType σ ⇛ F (cbvToValType τ))

  open import Base.Syntax.Context ValType public
    using ()
    renaming
      ( ∅ to ∅∅
      ; _•_ to _••_
      ; mapContext to mapValCtx
      ; Var to ValVar
      ; Context to ValContext
      ; this to vThis; that to vThat)

  cbnToValType : Type → ValType
  cbnToValType τ = U (cbnToCompType τ)

  cbvToCompType : Type → CompType
  cbvToCompType τ = F (cbvToValType τ)

  fromCBNCtx : Context → ValContext
  fromCBNCtx Γ = mapValCtx cbnToValType Γ

  fromCBVCtx : Context → ValContext
  fromCBVCtx Γ = mapValCtx cbvToValType Γ

  fromVar : ∀ {Γ τ} → (f : Type → ValType) → Var Γ τ → ValVar (mapValCtx f Γ) (f τ)
  fromVar {x • Γ} f this = vThis
  fromVar {x • Γ} f (that v) = vThat (fromVar f v)


Added numbers.

Added numbers.

Ignore-this: c59bc2222a766dd1e2d9419a5f29e709

darcs-hash:20110208163438-3bd4e-889aba18405b0b32701d88789d240233e5d75a80.gz

------------------------------------------------------------------------------
-- Some naturales numbers
------------------------------------------------------------------------------

module Draft.McCarthy91.Numbers where

open import LTC.Base

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

one    = succ zero
two    = succ one
three  = succ two
four   = succ three
five   = succ four
six    = succ five
seven  = succ six
eight  = succ seven
nine   = succ eight
ten    = succ nine

{-# ATP definition one #-}
{-# ATP definition two #-}
{-# ATP definition three #-}
{-# ATP definition four #-}
{-# ATP definition five #-}
{-# ATP definition six #-}
{-# ATP definition seven #-}
{-# ATP definition eight #-}
{-# ATP definition nine #-}
{-# ATP definition ten #-}

eleven    = succ ten
twelve    = succ eleven
thirteen  = succ twelve
fourteen  = succ thirteen
fifteen   = succ fourteen
sixteen   = succ fifteen
seventeen = succ sixteen
eighteen  = succ seventeen
nineteen  = succ eighteen
twenty    = succ nineteen

{-# ATP definition eleven #-}
{-# ATP definition twelve #-}
{-# ATP definition thirteen #-}
{-# ATP definition fourteen #-}
{-# ATP definition fifteen #-}
{-# ATP definition sixteen #-}
{-# ATP definition seventeen #-}
{-# ATP definition eighteen #-}
{-# ATP definition nineteen #-}
{-# ATP definition twenty #-}

twenty-one   = succ twenty
twenty-two   = succ twenty-one
twenty-three = succ twenty-two
twenty-four  = succ twenty-three
twenty-five  = succ twenty-four
twenty-six   = succ twenty-five
twenty-seven = succ twenty-six
twenty-eight = succ twenty-seven
twenty-nine  = succ twenty-eight
thirty       = succ twenty-nine

{-# ATP definition twenty-one #-}
{-# ATP definition twenty-two #-}
{-# ATP definition twenty-three #-}
{-# ATP definition twenty-four #-}
{-# ATP definition twenty-five #-}
{-# ATP definition twenty-six #-}
{-# ATP definition twenty-seven #-}
{-# ATP definition twenty-eight #-}
{-# ATP definition twenty-nine #-}
{-# ATP definition thirty #-}

thirty-one   = succ thirty
thirty-two   = succ thirty-one
thirty-three = succ thirty-two
thirty-four  = succ thirty-three
thirty-five  = succ thirty-four
thirty-six   = succ thirty-five
thirty-seven = succ thirty-six
thirty-eight = succ thirty-seven
thirty-nine  = succ thirty-eight
forty        = succ thirty-nine

{-# ATP definition thirty-one #-}
{-# ATP definition thirty-two #-}
{-# ATP definition thirty-three #-}
{-# ATP definition thirty-four #-}
{-# ATP definition thirty-five #-}
{-# ATP definition thirty-six #-}
{-# ATP definition thirty-seven #-}
{-# ATP definition thirty-eight #-}
{-# ATP definition thirty-nine #-}
{-# ATP definition forty #-}

forty-one   = succ forty
forty-two   = succ forty-one
forty-three = succ forty-two
forty-four  = succ forty-three
forty-five  = succ forty-four
forty-six   = succ forty-five
forty-seven = succ forty-six
forty-eight = succ forty-seven
forty-nine  = succ forty-eight
fifty       = succ forty-nine

{-# ATP definition forty-one #-}
{-# ATP definition forty-two #-}
{-# ATP definition forty-three #-}
{-# ATP definition forty-four #-}
{-# ATP definition forty-five #-}
{-# ATP definition forty-six #-}
{-# ATP definition forty-seven #-}
{-# ATP definition forty-eight #-}
{-# ATP definition forty-nine #-}
{-# ATP definition fifty #-}

fifty-one   = succ fifty
fifty-two   = succ fifty-one
fifty-three = succ fifty-two
fifty-four  = succ fifty-three
fifty-five  = succ fifty-four
fifty-six   = succ fifty-five
fifty-seven = succ fifty-six
fifty-eight = succ fifty-seven
fifty-nine  = succ fifty-eight
sixty       = succ fifty-nine

{-# ATP definition fifty-one #-}
{-# ATP definition fifty-two #-}
{-# ATP definition fifty-three #-}
{-# ATP definition fifty-four #-}
{-# ATP definition fifty-five #-}
{-# ATP definition fifty-six #-}
{-# ATP definition fifty-seven #-}
{-# ATP definition fifty-eight #-}
{-# ATP definition fifty-nine #-}
{-# ATP definition sixty #-}

sixty-one   = succ sixty
sixty-two   = succ sixty-one
sixty-three = succ sixty-two
sixty-four  = succ sixty-three
sixty-five  = succ sixty-four
sixty-six   = succ sixty-five
sixty-seven = succ sixty-six
sixty-eight = succ sixty-seven
sixty-nine  = succ sixty-eight
seventy     = succ sixty-nine

{-# ATP definition sixty-one #-}
{-# ATP definition sixty-two #-}
{-# ATP definition sixty-three #-}
{-# ATP definition sixty-four #-}
{-# ATP definition sixty-five #-}
{-# ATP definition sixty-six #-}
{-# ATP definition sixty-seven #-}
{-# ATP definition sixty-eight #-}
{-# ATP definition sixty-nine #-}
{-# ATP definition seventy #-}

seventy-one   = succ seventy
seventy-two   = succ seventy-one
seventy-three = succ seventy-two
seventy-four  = succ seventy-three
seventy-five  = succ seventy-four
seventy-six   = succ seventy-five
seventy-seven = succ seventy-six
seventy-eight = succ seventy-seven
seventy-nine  = succ seventy-eight
eighty       = succ seventy-nine

{-# ATP definition seventy-one #-}
{-# ATP definition seventy-two #-}
{-# ATP definition seventy-three #-}
{-# ATP definition seventy-four #-}
{-# ATP definition seventy-five #-}
{-# ATP definition seventy-six #-}
{-# ATP definition seventy-seven #-}
{-# ATP definition seventy-eight #-}
{-# ATP definition seventy-nine #-}
{-# ATP definition eighty #-}

eighty-one   = succ eighty
eighty-two   = succ eighty-one
eighty-three = succ eighty-two
eighty-four  = succ eighty-three
eighty-five  = succ eighty-four
eighty-six   = succ eighty-five
eighty-seven = succ eighty-six
eighty-eight = succ eighty-seven
eighty-nine  = succ eighty-eight
ninety       = succ eighty-nine

{-# ATP definition eighty-one #-}
{-# ATP definition eighty-two #-}
{-# ATP definition eighty-three #-}
{-# ATP definition eighty-four #-}
{-# ATP definition eighty-five #-}
{-# ATP definition eighty-six #-}
{-# ATP definition eighty-seven #-}
{-# ATP definition eighty-eight #-}
{-# ATP definition eighty-nine #-}
{-# ATP definition ninety #-}

ninety-one   = succ ninety
ninety-two   = succ ninety-one
ninety-three = succ ninety-two
ninety-four  = succ ninety-three
ninety-five  = succ ninety-four
ninety-six   = succ ninety-five
ninety-seven = succ ninety-six
ninety-eight = succ ninety-seven
ninety-nine  = succ ninety-eight
one-hundred  = succ ninety-nine

{-# ATP definition ninety-one #-}
{-# ATP definition ninety-two #-}
{-# ATP definition ninety-three #-}
{-# ATP definition ninety-four #-}
{-# ATP definition ninety-five #-}
{-# ATP definition ninety-six #-}
{-# ATP definition ninety-seven #-}
{-# ATP definition ninety-eight #-}
{-# ATP definition ninety-nine #-}
{-# ATP definition one-hundred #-}

hundred-one   = succ one-hundred
hundred-two   = succ hundred-one
hundred-three = succ hundred-two
hundred-four  = succ hundred-three
hundred-five  = succ hundred-four
hundred-six   = succ hundred-five
hundred-seven = succ hundred-six
hundred-eight = succ hundred-seven
hundred-nine  = succ hundred-eight
hundred-ten   = succ hundred-nine

{-# ATP definition hundred-one #-}
{-# ATP definition hundred-two #-}
{-# ATP definition hundred-three #-}
{-# ATP definition hundred-four #-}
{-# ATP definition hundred-five #-}
{-# ATP definition hundred-six #-}
{-# ATP definition hundred-seven #-}
{-# ATP definition hundred-eight #-}
{-# ATP definition hundred-nine #-}
{-# ATP definition hundred-ten #-}

hundred-eleven = succ hundred-ten
{-# ATP definition hundred-eleven #-}