More refactorings before adding bang

More refactorings before adding bang

Inference becomes weaker for some reason.

-- 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
  -- succ : Const (int ⇒ int)

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

_⊕_ (closure {Γ} t ρ) (dclosure {Γ1} dt ρ₁ dρ) with Γ ≟Ctx Γ1
closure {Γ} t ρ ⊕ dclosure {.Γ} dt ρ₁ dρ | yes refl = closure t (ρ ⊕ρ dρ)
closure {Γ} t ρ ⊕ dclosure {Γ₁} dt ρ₁ 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

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
  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→⊕ (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 (σ ⇒ τ) (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
... | 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
  -- succ : Const (int ⇒ int)

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

_⊕_ (closure {Γ} t ρ) (dclosure {Γ1} dt ρ₁ dρ) with Γ ≟Ctx Γ1
closure {Γ} t ρ ⊕ dclosure {.Γ} dt ρ₁ dρ | yes refl = closure t (ρ ⊕ρ dρ)
closure {Γ} t ρ ⊕ dclosure {Γ₁} dt ρ₁ 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

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
  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→⊕ (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 (σ ⇒ τ) (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 ⟧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
... | 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) _ _ _ _ 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 _ _ _ _ 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


Forgotten an ATP pragma.

Forgotten an ATP pragma.

Ignore-this: 658d2892e85c2963744d89e294196d75

darcs-hash:20100513053134-3bd4e-59e8a25f6a0225ce10b842c45ffe0373292c06c6.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

open import Postulates using ( trans-LT )

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

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

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = ⊥-elim prf
  where
    postulate
      prf : ⊥
    {-# ATP prove prf x≥0 #-}

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 Sx≤0 = ⊥-elim prf
  where
    postulate
      -- The proof uses the axiom true≠false
      prf : ⊥
    {-# ATP prove prf #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
  postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
  {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
  postulate prf : ⊥
  {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
  postulate prf : ¬ (LT m m) → ⊥
  {-# ATP prove prf #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
  postulate prf : lt (m + n) m ≡ false →
                  lt (succ m + n) (succ m) ≡ false
  {-# ATP prove prf #-}

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
  postulate prf : lt (m - zero) (succ m) ≡ true
  {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
  postulate prf : lt (zero - succ n) (succ zero) ≡ true
  {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
  postulate prf : lt (m - n) (succ m) ≡ true →
                  lt (succ m - succ n) (succ (succ m)) ≡ true
  {-# ATP prove prf trans-LT minus-N x<Sx sN #-}

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
  postulate prf : (succ m - zero) + zero ≡ succ m
  {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
  postulate m>n : GT m n
  {-# ATP prove m>n #-}

  postulate prf : (m - n) + n ≡ m →
                  (succ m - succ n) + succ n ≡ succ m
  {-# ATP prove prf +-comm minus-N sN #-}

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
  postulate prf : (n - zero) + zero ≡ n
  {-# ATP prove prf +-rightIdentity minus-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y-x+x≡y Nm Nn m≤n )
  where
  postulate m≤n : LE m n
  {-# ATP prove m≤n #-}

  postulate prf : (n - m) + m ≡ n →
                  (succ n - succ m) + succ m ≡ succ n
  {-# ATP prove prf +-comm minus-N sN #-}

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

open import Postulates using ( trans-LT )

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

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

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = ⊥-elim prf
  where
    postulate
      prf : ⊥
    {-# ATP prove prf x≥0 #-}

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 Sx≤0 = ⊥-elim prf
  where
    postulate
      -- The proof uses the axiom true≠false
      prf : ⊥
    {-# ATP prove prf #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
  postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
  {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
  postulate prf : ⊥
  {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
  postulate prf : ¬ (LT m m) → ⊥
  {-# ATP prove prf #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
  postulate prf : lt (m + n) m ≡ false →
                  lt (succ m + n) (succ m) ≡ false

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
  postulate prf : lt (m - zero) (succ m) ≡ true
  {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
  postulate prf : lt (zero - succ n) (succ zero) ≡ true
  {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
  postulate prf : lt (m - n) (succ m) ≡ true →
                  lt (succ m - succ n) (succ (succ m)) ≡ true
  {-# ATP prove prf trans-LT minus-N x<Sx sN #-}

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
  postulate prf : (succ m - zero) + zero ≡ succ m
  {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
  postulate m>n : GT m n
  {-# ATP prove m>n #-}

  postulate prf : (m - n) + n ≡ m →
                  (succ m - succ n) + succ n ≡ succ m
  {-# ATP prove prf +-comm minus-N sN #-}

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
  postulate prf : (n - zero) + zero ≡ n
  {-# ATP prove prf +-rightIdentity minus-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y-x+x≡y Nm Nn m≤n )
  where
  postulate m≤n : LE m n
  {-# ATP prove m≤n #-}

  postulate prf : (n - m) + m ≡ n →
                  (succ n - succ m) + succ m ≡ succ n
  {-# ATP prove prf +-comm minus-N sN #-}


Changed a precedence.

Changed a precedence.

Ignore-this: 6ae16a5e6172de27107db32fe0fd9ed5

darcs-hash:20101102155828-3bd4e-dcc9de24ac92cdf8c53e21bab077d349d60fa7e0.gz

------------------------------------------------------------------------------
-- The LTC core
------------------------------------------------------------------------------
{-

LTC                              Agda
* Logical constants              * Curry-Howard isomorphism
* Equality                       * Identity type
* Term language                  * Postulates
* Inductive predicates           * Inductive families
-}

module LTC.Minimal where

infixl 6 _∙_
infixr 5 _∷_
infix  5 if_then_else_
infix  4 _≡_

------------------------------------------------------------------------------
-- The universal domain

-- N.B. The following module is exported by this module.
open import LTC.Minimal.Core public

------------------------------------------------------------------------------
-- The term language of LTC correspond to the PCF terms.

--   t ::= x    | t t    | \x → t
--      | true  | false  | if t then t else t
--      | 0     | succ t | pred t             | isZero t
--      | []    | _∷_    | head               | tail
--      | fix t
--      | error

postulate

  -- LTC partial booleans.
  true          : D
  false         : D
  if_then_else_ : D → D → D → D

  -- LTC partial natural numbers.
  zero   : D
  succ   : D → D
  pred   : D → D
  isZero : D → D

  -- LTC abstraction.
  lam : (D → D) → D

  -- LTC application.
  -- The Agda application has higher precedence level than LTC application.
  _∙_ : D → D → D

  -- LTC error.
  error : D

  -- LTC fixed point operator.
  fix : (D → D) → D
  -- fixFO  : D

  -- LTC lists.
  []   : D
  _∷_  : D → D → D
  head : D → D
  tail : D → D

------------------------------------------------------------------------------
-- The LTC equality is the propositional identity on 'D'.

-- The identity type on D.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- Identity properties

sym : {x y : D} → x ≡ y → y ≡ x
sym refl = refl

trans : {x y z : D} → x ≡ y → y ≡ z → x ≡ z
trans refl y≡z = y≡z

-- The substitution is defined in LTC.MinimalER.

------------------------------------------------------------------------------
-- Logical constants: Curry-Howard isomorphism

-- The LTC logical constants are the type theory logical constants via
-- the Curry-Howard isomorphism.  For the implication and the
-- universal quantifier we use the Agda (dependent) function type.

-- N.B. The following modules are exported by this module.
open import Lib.Data.Empty       public
open import Lib.Data.Product     public
open import Lib.Data.Sum         public
-- open import Lib.Data.Unit        public
open import Lib.Relation.Nullary public
open import LTC.Data.Product     public

------------------------------------------------------------------------------
-- Conversion rules

postulate
  -- Conversion rules for booleans.
  if-true  : (d₁ : D){d₂ : D} →  if true then d₁ else d₂ ≡ d₁
  if-false : {d₁ : D}(d₂ : D) → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom if-true #-}
{-# ATP axiom if-false #-}

postulate
  -- Conversion rules for pred.
  pred-0 :           pred zero     ≡ zero
  pred-S : (n : D) → pred (succ n) ≡ n
{-# ATP axiom pred-0 #-}
{-# ATP axiom pred-S #-}

postulate
  -- Conversion rules for isZero.
  isZero-0 :           isZero zero     ≡ true
  isZero-S : (n : D) → isZero (succ n) ≡ false
{-# ATP axiom isZero-0 #-}
{-# ATP axiom isZero-S #-}

postulate
  -- Conversion rule for the abstraction and the application.
  beta : (f : D → D) → (a : D) → (lam f) ∙ a ≡ f a
{-# ATP axiom beta #-}

postulate
  -- Conversion rule for the fixed pointed operator.
  fix-f : (f : D → D) → fix f ≡ f (fix  f)
  -- cFixFO : (f : D) → fixFO ∙ f  ≡ f ∙ (fixFO ∙ f)
{-# ATP axiom fix-f #-}

postulate
  -- Conversion rule for head.
  head-∷ : (x xs : D) → head (x ∷ xs) ≡ x
{-# ATP axiom head-∷ #-}

postulate
  -- Conversion rule for tail.
  tail-∷ : (x xs : D) → tail (x ∷ xs) ≡ xs
{-# ATP axiom tail-∷ #-}

------------------------------------------------------------------------------
-- Discrimination rules

postulate
  true≠false : ¬ (true ≡ false)
  0≠S        : {d : D} → ¬ (zero ≡ succ d)
{-# ATP axiom true≠false #-}
{-# ATP axiom 0≠S #-}

------------------------------------------------------------------------------
-- The LTC core
------------------------------------------------------------------------------
{-

LTC                              Agda
* Logical constants              * Curry-Howard isomorphism
* Equality                       * Identity type
* Term language                  * Postulates
* Inductive predicates           * Inductive families
-}

module LTC.Minimal where

infixl 6 _∙_
infixr 5 _∷_
infix  5 if_then_else_
infix  3 _≡_

------------------------------------------------------------------------------
-- The universal domain

-- N.B. The following module is exported by this module.
open import LTC.Minimal.Core public

------------------------------------------------------------------------------
-- The term language of LTC correspond to the PCF terms.

--   t ::= x    | t t    | \x → t
--      | true  | false  | if t then t else t
--      | 0     | succ t | pred t             | isZero t
--      | []    | _∷_    | head               | tail
--      | fix t
--      | error

postulate

  -- LTC partial booleans.
  true          : D
  false         : D
  if_then_else_ : D → D → D → D

  -- LTC partial natural numbers.
  zero   : D
  succ   : D → D
  pred   : D → D
  isZero : D → D

  -- LTC abstraction.
  lam : (D → D) → D

  -- LTC application.
  -- The Agda application has higher precedence level than LTC application.
  _∙_ : D → D → D

  -- LTC error.
  error : D

  -- LTC fixed point operator.
  fix : (D → D) → D
  -- fixFO  : D

  -- LTC lists.
  []   : D
  _∷_  : D → D → D
  head : D → D
  tail : D → D

------------------------------------------------------------------------------
-- The LTC equality is the propositional identity on 'D'.

-- The identity type on D.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- Identity properties

sym : {x y : D} → x ≡ y → y ≡ x
sym refl = refl

trans : {x y z : D} → x ≡ y → y ≡ z → x ≡ z
trans refl y≡z = y≡z

-- The substitution is defined in LTC.MinimalER.

------------------------------------------------------------------------------
-- Logical constants: Curry-Howard isomorphism

-- The LTC logical constants are the type theory logical constants via
-- the Curry-Howard isomorphism.  For the implication and the
-- universal quantifier we use the Agda (dependent) function type.

-- N.B. The following modules are exported by this module.
open import Lib.Data.Empty       public
open import Lib.Data.Product     public
open import Lib.Data.Sum         public
-- open import Lib.Data.Unit        public
open import Lib.Relation.Nullary public
open import LTC.Data.Product     public

------------------------------------------------------------------------------
-- Conversion rules

postulate
  -- Conversion rules for booleans.
  if-true  : (d₁ : D){d₂ : D} →  if true then d₁ else d₂ ≡ d₁
  if-false : {d₁ : D}(d₂ : D) → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom if-true #-}
{-# ATP axiom if-false #-}

postulate
  -- Conversion rules for pred.
  pred-0 :           pred zero     ≡ zero
  pred-S : (n : D) → pred (succ n) ≡ n
{-# ATP axiom pred-0 #-}
{-# ATP axiom pred-S #-}

postulate
  -- Conversion rules for isZero.
  isZero-0 :           isZero zero     ≡ true
  isZero-S : (n : D) → isZero (succ n) ≡ false
{-# ATP axiom isZero-0 #-}
{-# ATP axiom isZero-S #-}

postulate
  -- Conversion rule for the abstraction and the application.
  beta : (f : D → D) → (a : D) → (lam f) ∙ a ≡ f a
{-# ATP axiom beta #-}

postulate
  -- Conversion rule for the fixed pointed operator.
  fix-f : (f : D → D) → fix f ≡ f (fix  f)
  -- cFixFO : (f : D) → fixFO ∙ f  ≡ f ∙ (fixFO ∙ f)
{-# ATP axiom fix-f #-}

postulate
  -- Conversion rule for head.
  head-∷ : (x xs : D) → head (x ∷ xs) ≡ x
{-# ATP axiom head-∷ #-}

postulate
  -- Conversion rule for tail.
  tail-∷ : (x xs : D) → tail (x ∷ xs) ≡ xs
{-# ATP axiom tail-∷ #-}

------------------------------------------------------------------------------
-- Discrimination rules

postulate
  true≠false : ¬ (true ≡ false)
  0≠S        : {d : D} → ¬ (zero ≡ succ d)
{-# ATP axiom true≠false #-}
{-# ATP axiom 0≠S #-}


Small cleanups

Small cleanups

module Thesis.SIRelBigStep.FundamentalProperty where

open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.IlcSILR

rfundamentalV3v : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
rfundamentalV3v x n ρ1 dρ ρ2 ρρ = ⟦ x ⟧RelVar3 ρρ

rfundamental3constV : ∀ {τ} k (c : Const τ) →
  rrelV3 τ (eval-const c) (deval (derive-const c) ∅ ∅) (eval-const c) k
rfundamental3constV k (lit n) = refl

rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k

rfundamental3svv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelV3 τ (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k
rfundamental3svv k (var x) ρ1 dρ ρ2 ρρ = rfundamentalV3v x k ρ1 dρ ρ2 ρρ
rfundamental3svv k (cons sv1 sv2) ρ1 dρ ρ2 ρρ = rfundamental3svv k sv1 ρ1 dρ ρ2 ρρ , rfundamental3svv k sv2 ρ1 dρ ρ2 ρρ
rfundamental3svv k (const c) ρ1 dρ ρ2 ρρ rewrite deval-derive-const-inv c ρ1 dρ = rfundamental3constV k c
rfundamental3svv k (abs t) ρ1 dρ ρ2 ρρ = (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ j j<k v1 dv v2 vv →
    -- If we replace abs t by rec t, here we would need to invoke (by
    -- well-founded recursion) rfundamental3svv on (abs t) at a smaller j, as follows:
    --   rfundamental3svv j (abs t) ρ1 dρ ρ2 (rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)
    -- As you'd expect, Agda's termination checker does not accept that call directly.
      rfundamental3 j t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)

rfundamental3sv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelT3 (val sv) (dval (derive-dsval sv)) (val sv) ρ1 dρ ρ2 k
rfundamental3sv k sv ρ1 dρ ρ2 ρρ .(eval sv ρ1) .(eval sv ρ2) .0 j<k (val .sv) (val .sv) = deval (derive-dsval sv) ρ1 dρ , dval (derive-dsval sv) , rfundamental3svv k sv ρ1 dρ ρ2 ρρ

open import Theorem.Groups-Nehemiah
rfundamental3primv : ∀ {σ τ} k p →
  ∀ v1 dv v2 → (vv : rrelV3 σ v1 dv v2 k) →
  rrelV3 τ (eval-primitive p v1) (deval-primitive p v1 dv) (eval-primitive p v2) k
rfundamental3primv k succ (natV n₁) (bang .(natV n)) (natV n) refl = refl
rfundamental3primv k succ (natV n) (dnatV dn) (natV .(dn + n)) refl = +-suc dn n
rfundamental3primv k add (pairV (natV a1) (natV b1))
  (dpairV (dnatV da) (dnatV db))
  (pairV (natV .(da + a1)) (natV .(db + b1)))
  (refl , refl) = ℕ-mn·pq=mp·nq {da} {db} {a1} {b1}
rfundamental3primv k add (pairV a1 b1)
  (dpairV (dnatV da) (bang b2))
  (pairV a2 .b2) (aa , refl) rewrite rrelV3→⊕ a1 (dnatV da) a2 aa = refl
rfundamental3primv k add (pairV a1 b1)
  (dpairV (bang a2) db)
  (pairV .a2 b2) (refl , bb) rewrite rrelV3→⊕ b1 db b2 bb = refl
rfundamental3primv k add (pairV a1 b1) (bang p2) .p2 refl = refl

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 k (val sv) = rfundamental3sv k sv
rfundamental3 (suc k) (primapp p sv) ρ1 dρ ρ2 ρρ
  .(eval-primitive p (eval sv ρ1)) .(eval-primitive p (eval sv ρ2)) .1 (s≤s j<k) (primapp .p .sv) (primapp .p .sv) =
   deval-primitive p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) , dprimapp p sv (derive-dsval sv) ,
     rfundamental3primv k p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2)
       (rfundamental3svv k sv ρ1 dρ ρ2 (rrelρ3-mono k (suc k) (≤-step ≤-refl) _ ρ1 dρ ρ2 ρρ))

rfundamental3 (suc (suc k)) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s (s≤s j<k))
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app n₁ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3sv (suc (suc k)) vs ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3sv (suc (suc k)) 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 (rrelV3→⊕ vtv1 dtv vtv2 dtvv) =
        bang v2 , bangapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv (suc k) ≤-refl vtv1 dtv vtv2
           (rrelV3-mono (suc k) (suc (suc k)) (s≤s (≤-step ≤-refl)) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j (s≤s 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

module Thesis.SIRelBigStep.FundamentalProperty where

open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.IlcSILR

rfundamentalV3v : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
rfundamentalV3v x n ρ1 dρ ρ2 ρρ = ⟦ x ⟧RelVar3 ρρ

rfundamental3constV : ∀ {τ} k (c : Const τ) →
  rrelV3 τ (eval-const c) (deval (derive-const c) ∅ ∅) (eval-const c) k
rfundamental3constV k (lit n) = refl

rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k

rfundamental3svv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelV3 τ (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k
rfundamental3svv k (var x) ρ1 dρ ρ2 ρρ = rfundamentalV3v x k ρ1 dρ ρ2 ρρ
rfundamental3svv k (cons sv1 sv2) ρ1 dρ ρ2 ρρ = rfundamental3svv k sv1 ρ1 dρ ρ2 ρρ , rfundamental3svv k sv2 ρ1 dρ ρ2 ρρ
rfundamental3svv k (const c) ρ1 dρ ρ2 ρρ rewrite deval-derive-const-inv c ρ1 dρ = rfundamental3constV k c
rfundamental3svv k (abs t) ρ1 dρ ρ2 ρρ = (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ j j<k v1 dv v2 vv →
    -- If we replace abs t by rec t, here we would need to invoke (by
    -- well-founded recursion) rfundamental3svv on (abs t) at a smaller j, as follows:
    --   rfundamental3svv j (abs t) ρ1 dρ ρ2 (rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)
    -- As you'd expect, Agda's termination checker does not accept that call directly.
      rfundamental3 j t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)

rfundamental3sv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelT3 (val sv) (dval (derive-dsval sv)) (val sv) ρ1 dρ ρ2 k
rfundamental3sv k sv ρ1 dρ ρ2 ρρ .(eval sv ρ1) .(eval sv ρ2) .0 j<k (val .sv) (val .sv) = deval (derive-dsval sv) ρ1 dρ , dval (derive-dsval sv) , rfundamental3svv k sv ρ1 dρ ρ2 ρρ

open import Theorem.Groups-Nehemiah
rfundamental3primv : ∀ {σ τ} k p →
  ∀ v1 dv v2 → (vv : rrelV3 σ v1 dv v2 k) →
  rrelV3 τ (eval-primitive p v1) (deval-primitive p v1 dv) (eval-primitive p v2) k
rfundamental3primv k succ (natV n₁) (bang .(natV n)) (natV n) refl = refl
rfundamental3primv k succ (natV n) (dnatV dn) (natV .(dn + n)) refl = +-suc dn n
rfundamental3primv k add (pairV (natV a1) (natV b1))
  (dpairV (dnatV da) (dnatV db))
  (pairV (natV .(da + a1)) (natV .(db + b1)))
  (refl , refl) = ℕ-mn·pq=mp·nq {da} {db} {a1} {b1}
rfundamental3primv k add (pairV a1 b1)
  (dpairV (dnatV da) (bang b2))
  (pairV a2 .b2) (aa , refl) rewrite rrelV3→⊕ a1 (dnatV da) a2 aa = refl
rfundamental3primv k add (pairV a1 b1)
  (dpairV (bang a2) db)
  (pairV .a2 b2) (refl , bb) rewrite rrelV3→⊕ b1 db b2 bb = refl
rfundamental3primv k add (pairV a1 b1) (bang p2) .p2 refl = refl

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 k (val sv) = rfundamental3sv k sv
rfundamental3 (suc k) (primapp p sv) ρ1 dρ ρ2 ρρ
  .(eval-primitive p (eval sv ρ1)) .(eval-primitive p (eval sv ρ2)) .1 (s≤s j<k) (primapp .p .sv) (primapp .p .sv) =
   deval-primitive p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) , dprimapp p sv (derive-dsval sv) ,
     rfundamental3primv k p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2)
       (rfundamental3svv k sv ρ1 dρ ρ2 (rrelρ3-mono k (suc k) (≤-step ≤-refl) _ ρ1 dρ ρ2 ρρ))
-- (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k

rfundamental3 (suc (suc k)) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s (s≤s j<k))
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app n₁ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3 (suc (suc k)) (val vs) ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3 (suc (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 (rrelV3→⊕ vtv1 dtv vtv2 dtvv) =
        bang v2 , bangapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv (suc k) ≤-refl vtv1 dtv vtv2
           (rrelV3-mono (suc k) (suc (suc k)) (s≤s (≤-step ≤-refl)) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j (s≤s 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


Bring proof up to Eq. 1 in PLDI'14

Bring proof up to Eq. 1 in PLDI'14

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive
open import Data.Empty

[_]τ_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

-- This can't be a datatype, since it wouldn't be strictly positive as it
-- appears on the left of an arrow in the function case, which then can be
-- contained in nested "fromto-validity" proofs.
sumfromto : ∀ (σ τ : Type) → (dv : SumChange2 {A = ⟦ σ ⟧Type} {B = ⟦ τ ⟧Type}) → (v1 v2 : ⟦ sum σ τ ⟧Type) → Set
sumfromto σ τ (ch₁ da) (inj₁ a1) (inj₁ a2) = [ σ ]τ da from a1 to a2
-- These fallback equations unfortunately don't hold definitionally, they're
-- split on multiple cases, so the pattern match is a mess.
--
-- To "case split" on validity, I typically copy-paste the pattern match from
-- fromto→⊕ and change the function name :-(.
sumfromto σ τ (ch₁ da) _ _ = ⊥
sumfromto σ τ (ch₂ db) (inj₂ b1) (inj₂ b2) = [ τ ]τ db from b1 to b2
sumfromto σ τ (ch₂ db) _ _ = ⊥
sumfromto σ τ (rp (inj₂ b2)) (inj₁ a1) (inj₂ b2') = b2 ≡ b2'
sumfromto σ τ (rp (inj₁ a2)) (inj₂ b1) (inj₁ a2') = a2 ≡ a2'
sumfromto σ τ (rp s) _ _ = ⊥

[ σ ⇒ τ ]τ df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ]τ da from a1 to a2 → [ τ ]τ df a1 da from f1 a1 to f2 a2
[ int ]τ dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ]τ (da , db) from (a1 , b1) to (a2 , b2) = [ σ ]τ da from a1 to a2 × [ τ ]τ db from b1 to b2
[ sum σ τ ]τ dv from v1 to v2 = sumfromto σ τ (convert dv) v1 v2

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

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ]τ dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ]τ v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₁ a2) = ⊝-fromto a1 a2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₂ b2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₁ a2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₂ b2) = ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ]τ nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa rewrite fromto→⊕ da a1 a2 daa = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb rewrite fromto→⊕ db b1 b2 dbb = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveConst : ∀ {τ} c →
  [ τ ]τ ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst (lit n) = sym (right-id-int n)
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = daa
fromtoDeriveConst rinj db b1 b2 dbb = dbb
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa df f1 f2 dff dg g1 g2 dgg = dff da a1 a2 daa
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb df f1 f2 dff dg g1 g2 dgg = dgg db b1 b2 dbb
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

open import Postulate.Extensionality

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ]τ da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨ cong (λ □ → □ (a ⊕ da)) (fromto→⊕ df f1 f2 dff)⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ]τ da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ]τ df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ]τ da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da _ _ daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ]τ dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ]τ dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa = sv₁ a1 da (fromto→valid da a1 a2 daa)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb = sv₂ b1 db (fromto→valid db b1 b2 dbb)
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = svrp₂ b1 a2
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = svrp₁ a1 b2
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ]τ df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)
valid→fromto {sum σ τ} .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) = valid→fromto a da ada
valid→fromto {sum σ τ} .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) = valid→fromto b db bdb
valid→fromto {sum σ τ} .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) = refl
valid→fromto {sum σ τ} .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) = refl

correctDeriveOplus : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ t ⟧Term ρ1) ⊕ (⟦ t ⟧ΔTerm ρ1 dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplus τ t dρρ = fromto→⊕ _ _ _ (fromtoDerive τ t dρρ)

-- Getting to the original equation 1 from PLDI'14.

open import New.LangOps

correctDeriveOplusτ : ∀ {Γ} τ → (t : Term Γ τ)
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit t) (derive t) ⟧Term dρ) ≡ (⟦ t ⟧Term ρ2)
correctDeriveOplusτ τ t {dρ = dρ} {ρ1 = ρ1} dρρ
  rewrite oplusτ-equiv _ dρ _ (⟦ fit t ⟧Term dρ) (⟦ derive t ⟧Term dρ)
  | sym (fit-sound t dρρ)
  = correctDeriveOplus τ t dρρ

deriveGivesDerivative : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ)→
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app f a ⟧Term ρ1) ⊕ (⟦ app f a ⟧ΔTerm ρ1 dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative σ τ f a dρρ = correctDeriveOplus τ (app f a) dρρ

deriveGivesDerivative₂ : ∀ {Γ} σ τ → (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
     (⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) (derive a)) ⟧Term dρ) ≡ (⟦ app f a ⟧Term ρ2)
deriveGivesDerivative₂ σ τ f a dρρ = correctDeriveOplusτ τ (app f a) dρρ

-- Proof of the original equation 1 from PLDI'14.
eq1 : ∀ {Γ} σ τ →
  {nilρ : eCh Γ} {ρ : ⟦ Γ ⟧Context} → [ Γ ]Γ nilρ from ρ to ρ →
  ∀ (f : Term Γ (σ ⇒ τ)) (a : Term Γ σ) (da : Term (ΔΓ Γ) (Δt σ)) →
  (daa : [ σ ]τ (⟦ da ⟧Term nilρ) from (⟦ a ⟧Term ρ) to (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ)) →
    ⟦ app₂ (oplusτo τ) (fit (app f a)) (app₂ (derive f) (fit a) da) ⟧Term nilρ ≡ ⟦ app (fit f) (app₂ (oplusτo σ) (fit a) da) ⟧Term nilρ
eq1 σ τ {nilρ} {ρ} dρρ f a da daa
  rewrite
    oplusτ-equiv _ nilρ _ (⟦ fit (app f a) ⟧Term nilρ) (⟦ (app₂ (derive f) (fit a) da) ⟧Term nilρ)
  | sym (fit-sound f dρρ)
  | oplusτ-equiv _ nilρ _ (⟦ fit a ⟧Term nilρ) (⟦ da ⟧Term nilρ)
  | sym (fit-sound a dρρ)
  = fromto→⊕ (⟦ f ⟧ΔTerm ρ nilρ (⟦ a ⟧Term ρ) (⟦ da ⟧Term nilρ)) _ _
    (fromtoDerive _ f dρρ (⟦ da ⟧Term nilρ) (⟦ a ⟧Term ρ)
      (⟦ a ⟧Term ρ ⊕ ⟦ da ⟧Term nilρ) daa)


Update a bit README.agda (#41)

Update a bit README.agda (#41)

README.agda was not up-to-date. Remaining issues are described inline.

Old-commit-hash: 93469332bbc849a2a13486a1bfae7d21dc9eb399

module README where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--
-- XXX: fill in again other details.

-- 41e0f95d7fda7244a258b67f8a4255e4128a42c3 declares that the main theorems are
-- in these files:

open import Denotation.Derive.Canon-Popl14
open import Denotation.Derive.Optimized-Popl14

-- TODO: this file is intended to load all maintained Agda code; otherwise, a
-- better solution to issue #41 should be found.
--
-- Moreover, arguably it would be good if this file would list all relevant
-- imports, to highlight the structure of the development, as it did previously.
-- But I'm not sure what's the best structure.

module README where

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

-- The formalization is split across the following files.
-- TODO: document them more.

-- Note that we postulate function extensionality (in
-- `Denotational.ExtensionalityPostulate`), known to be consistent
-- with intensional type theory.

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.ChangeTypes.ChangesAreDerivatives
open import Syntactic.ChangeContexts
open import Syntactic.Terms.Total
open import Syntactic.Changes

open import Denotational.Notation
open import Denotational.Values
open import Denotational.ExtensionalityPostulate
open import Denotational.EqualityLemmas
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total
open import Denotational.Changes
open import Denotational.Equivalence
open import Denotational.ValidChanges
open import Denotational.WeakValidChanges

open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- This finishes the correctness proof of the above work.
open import total

-- EXAMPLES

open import Examples.Examples1

-- NATURAL semantics

open import Syntactic.Closures
open import Denotational.Closures

open import Natural.Lookup
open import Natural.Evaluation

open import Natural.Soundness

-- Other calculi

open import partial
open import lambda


Implement 'Δ-term' for variables.

Implement 'Δ-term' for variables.

Old-commit-hash: dd0c2916cc4b7472353b0073fa6538f60e7325f5

module incremental where

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

-- Semantics

Dom⟦_⟧ : Type -> Set
Dom⟦ τ₁ ⇒ τ₂ ⟧ = Dom⟦ τ₁ ⟧ → Dom⟦ τ₂ ⟧

-- TYPING CONTEXTS

-- Syntax

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

infixr 9 _•_

-- Semantics

data Empty : Set where
  ∅ : Empty

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

Env⟦_⟧ : Context → Set
Env⟦ ∅ ⟧ = Empty
Env⟦ τ • Γ ⟧ = Bind Dom⟦ τ ⟧ Env⟦ Γ ⟧

-- VARIABLES

-- Syntax

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

-- Semantics

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

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

-- Semantics

eval⟦_⟧ : ∀ {Γ τ} → Term Γ τ → Env⟦ Γ ⟧ → Dom⟦ τ ⟧
eval⟦ abs t ⟧ ρ = λ v → eval⟦ t ⟧ (v • ρ)
eval⟦ app t₁ t₂ ⟧ ρ = (eval⟦ t₁ ⟧ ρ) (eval⟦ t₂ ⟧ ρ)
eval⟦ var x ⟧ ρ = lookup⟦ x ⟧ ρ

-- WEAKENING

-- Extend a context to a super context

infixr 10 _⋎_

_⋎_ : (Γ₁ Γ₁ : Context) → Context
∅ ⋎ Γ₂ = Γ₂
(τ • Γ₁) ⋎ Γ₂ = τ • Γ₁ ⋎ Γ₂

-- Lift a variable to a super context

lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
lift {∅} {∅} x = x
lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
lift {τ • Γ₁} {Γ₂} this = this
lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- Weaken a term to a super context

weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app compose (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )

nil : ∀ {τ Γ} → Term Γ (Δ-Type τ)
nil {τ₁ ⇒ τ₂} =
    abs nil
 -- λx. nil

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

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

-- CHANGE VARIABLES

-- changes 'x' to 'dx'

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

-- changes 'x' to 'nil' (if internally bound) or 'dx' (if externally bound)

Δ-var : ∀ {Γ₁ Γ₂ τ} → Var (Γ₁ ⋎ Γ₂) τ → Term (Δ-Context Γ₂) (Δ-Type τ)
Δ-var {∅} x = var (rename x)
Δ-var {τ • Γ} this = nil
Δ-var {τ • Γ} (that x) = Δ-var {Γ} x

-- CHANGE TERMS

Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)
Δ-term {Γ} (app t₁ t₂) = {!!}
Δ-term {Γ} (var x) = weaken {∅} {Γ} (Δ-var {Γ} x)

module incremental where

-- SIMPLE TYPES

-- Syntax

data Type : Set where
  _⇒_ : (τ₁ τ₂ : Type) → Type

infixr 5 _⇒_

-- Semantics

Dom⟦_⟧ : Type -> Set
Dom⟦ τ₁ ⇒ τ₂ ⟧ = Dom⟦ τ₁ ⟧ → Dom⟦ τ₂ ⟧

-- TYPING CONTEXTS

-- Syntax

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

infixr 9 _•_

-- Semantics

data Empty : Set where
  ∅ : Empty

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

Env⟦_⟧ : Context → Set
Env⟦ ∅ ⟧ = Empty
Env⟦ τ • Γ ⟧ = Bind Dom⟦ τ ⟧ Env⟦ Γ ⟧

-- VARIABLES

-- Syntax

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

-- Semantics

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

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

-- Semantics

eval⟦_⟧ : ∀ {Γ τ} → Term Γ τ → Env⟦ Γ ⟧ → Dom⟦ τ ⟧
eval⟦ abs t ⟧ ρ = λ v → eval⟦ t ⟧ (v • ρ)
eval⟦ app t₁ t₂ ⟧ ρ = (eval⟦ t₁ ⟧ ρ) (eval⟦ t₂ ⟧ ρ)
eval⟦ var x ⟧ ρ = lookup⟦ x ⟧ ρ

-- WEAKENING

-- Extend a context to a super context

infixr 10 _⋎_

_⋎_ : (Γ₁ Γ₁ : Context) → Context
∅ ⋎ Γ₂ = Γ₂
(τ • Γ₁) ⋎ Γ₂ = τ • Γ₁ ⋎ Γ₂

-- Lift a variable to a super context

lift : ∀ {Γ₁ Γ₂ Γ₃ τ} → Var (Γ₁ ⋎ Γ₃) τ → Var (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
lift {∅} {∅} x = x
lift {∅} {τ • Γ₂} x = that (lift {∅} {Γ₂} x)
lift {τ • Γ₁} {Γ₂} this = this
lift {τ • Γ₁} {Γ₂} (that x) = that (lift {Γ₁} {Γ₂} x)

-- Weaken a term to a super context

weaken : ∀ {Γ₁ Γ₂ Γ₃ τ} → Term (Γ₁ ⋎ Γ₃) τ → Term (Γ₁ ⋎ Γ₂ ⋎ Γ₃) τ
weaken {Γ₁} {Γ₂} (abs  {τ₁ = τ} t) = abs (weaken {τ • Γ₁} {Γ₂} t)
weaken {Γ₁} {Γ₂} (app t₁ t₂) = app (weaken {Γ₁} {Γ₂} t₁) (weaken {Γ₁} {Γ₂} t₂)
weaken {Γ₁} {Γ₂} (var x) = var (lift {Γ₁} {Γ₂} x)

-- CHANGE TYPES

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₂

apply : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app apply (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x        )  (     f                 x        )

compose : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ Δ-Type τ ⇒ Δ-Type τ)
compose {τ₁ ⇒ τ₂} =
    abs (abs (abs (app (app compose (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λdg. λx.           compose (     df                       x         ) (     dg                x      )

nil : ∀ {τ Γ} → Term Γ (Δ-Type τ)
nil {τ₁ ⇒ τ₂} =
    abs nil
 -- λx. nil

-- Hey, apply is α-equivalent to compose, what's going on?
-- Oh, and `Δ-Type` is the identity function?

-- CHANGE CONTEXTS

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

-- CHANGING TERMS WHEN THE ENVIRONMENT CHANGES

Δ-term : ∀ {Γ₁ Γ₂ τ} → Term (Γ₁ ⋎ Γ₂) τ → Term (Γ₁ ⋎ Δ-Context Γ₂) (Δ-Type τ)
Δ-term {Γ} (abs {τ₁ = τ} t) = abs (Δ-term {τ • Γ} t)
Δ-term {Γ} (app t₁ t₂) = {!!}
Δ-term {Γ} (var x) = {!!}


a better go with clearer holes

a better go with clearer holes

{-# OPTIONS --type-in-type --no-termination-check --no-positivity-check
 #-}

module Data1 where

_-_ : {A : Set}{B : A -> Set}{C : (a : A) -> B a -> Set} ->
      ({a : A}(b : B a) -> C a b) -> (f : (a : A) -> B a) ->
      (a : A) -> C a (f a)
f - g = \ x -> f (g x)

id : {X : Set} -> X -> X
id x = x

konst : {S : Set}{T : S -> Set} -> ({x : S} -> T x) -> (x : S) -> T x
konst c x = c

data Zero : Set where
record One : Set where

record Sig (S : Set)(T : S -> Set) : Set where
  field
    fst : S
    snd : T fst

open module Sig' {S : Set}{T : S -> Set} = Sig {S}{T}

_,_ : forall {S T}(s : S) -> T s -> Sig S T
s , t = record {fst = s; snd = t}

infixr 40 _,_

_*_ : Set -> Set -> Set
S * T = Sig S \ _ -> T

sig : forall {S T}{P : Sig S T -> Set} ->
      ((s : S)(t : T s) -> P (s , t)) -> (st : Sig S T) -> P st
sig f st = f (fst st) (snd st)

data Cx : Set where
  E : Cx
  _/_ : Cx -> Set -> Cx

data _:>_ : Cx -> Set -> Set where
  ze : {G : Cx}{S : Set} -> (G / S) :> S
  su : {G : Cx}{S T : Set} -> G :> T -> (G / S) :> T

data PROP : Set where
  Absu : PROP
  Triv : PROP
  _/\_ : PROP -> PROP -> PROP
  All : (S : Set) -> (S -> PROP) -> PROP

Prf : PROP -> Set
Prf Absu = Zero
Prf Triv = One
Prf (P /\ Q) = Prf P * Prf Q
Prf (All S P) = (x : S) -> Prf (P x)

data CON (G : Cx) : Set where
  ?? : {S : Set} -> G :> S -> S -> CON G
  PrfC : PROP -> CON G
  _*C_ : CON G -> CON G -> CON G
  PiC : (S : Set) -> (S -> CON G) -> CON G
  SiC : (S : Set) -> (S -> CON G) -> CON G
  MuC : (O : Set) -> (O -> CON (G / O)) -> O -> CON G
  NuC : (O : Set) -> (O -> CON (G / O)) -> O -> CON G

Box : (G : Cx) -> ((S : Set) -> (G :> S) -> Set) -> Set
Box E F = One
Box (G / S) F = Box G (\ S n -> F S (su n)) * F S ze

pr : {G : Cx}{S : Set}{F : (S : Set) -> (G :> S) -> Set} -> Box G F -> (n : G :> S) -> F S n
pr fsf ze = snd fsf
pr fsf (su n) = pr (fst fsf) n

Pay : Cx -> Set
Pay G = Box G (\ I _ -> I -> Set)

Arr : (G : Cx) -> Pay G -> Pay G -> Set
Arr G X Y = Box G (\ S n -> (s : S) -> pr X n s -> pr Y n s)

mutual
  [|_|] : {G : Cx} -> CON G -> Pay G -> Set
  [| ?? n i |]     X = pr X n i
  [| PrfC P |]     X = Prf P
  [| C *C D |]     X = [| C |] X * [| D |] X
  [| PiC S C |]    X = (s : S) -> [| C s |] X
  [| SiC S C |]    X = Sig S \ s -> [| C s |] X
  [| MuC O C o |]  X = Mu C X o
  [| NuC O C o |]  X = Nu C X o

  data Mu {G : Cx}{O : Set}(C : O -> CON (G / O))(X : Pay G)(o : O) : Set where
    con : [| C o |] ( X , Mu C X ) -> Mu C X o
  codata Nu {G : Cx}{O : Set}(C : O -> CON (G / O))(X : Pay G)(o : O) : Set where
    con : [| C o |] ( X , Nu C X ) -> Nu C X o

noc :  {G : Cx}{O : Set}{C : O -> CON (G / O)}{X : Pay G}{o : O} ->
       Nu C X o -> [| C o |] ( X , Nu C X )
noc (con xs) = xs

mutual
  map : {G : Cx}{X Y : Pay G} -> (C : CON G) ->
        Arr G X Y ->
        [| C |] X -> [| C |] Y
  map (?? n i)     f = pr f n i
  map (PrfC P)     f = id
  map (C *C D)     f = sig \ c d -> map C f c , map D f d
  map (PiC S C)    f = \ c s -> map (C s) f (c s)
  map (SiC S C)    f = sig \ s c -> s , map (C s) f c
  map (MuC O C o)  f = foldMap C (Mu C _) f (\ o -> con) o
  map (NuC O C o)  f = unfoldMap C (Nu C _) f (\ o -> noc) o

  foldMap :  {G : Cx}{O : Set}(C : O -> CON (G / O)){X Y : Pay G}(Z : O -> Set) ->
          Arr G X Y ->
          ((o : O) -> [| C o |] ( Y , Z ) -> Z o) ->
          (o : O) -> Mu C X o -> Z o
  foldMap C Z f alg o (con xs) = alg o (map (C o) (f , foldMap C Z f alg) xs)

  unfoldMap :  {G : Cx}{O : Set}(C : O -> CON (G / O)){X Y : Pay G}(Z : O -> Set) ->
            Arr G X Y ->
            ((o : O) -> Z o -> [| C o |] ( X , Z )) ->
            (o : O) -> Z o -> Nu C Y o
  unfoldMap C Z f coalg o y = con (map (C o) (f , unfoldMap C Z f coalg) (coalg o y))

ida : (G : Cx) -> (X : Pay G) -> Arr G X X
ida E = id
ida (G / S) = sig \ Xs X -> ida G Xs , \ s x -> x

compa : (G : Cx) -> (X Y Z : Pay G) -> Arr G Y Z -> Arr G X Y -> Arr G X Z
compa E = \ _ _ _ _ _ -> _
compa (G / S) = sig \ Xs X -> sig \ Ys Y -> sig \ Zs Z -> sig \ fs f -> sig \ gs g ->
  compa G Xs Ys Zs fs gs , \ s x -> f s (g s x)

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

subst : {X : Set}{P : X -> Set}{x y : X} -> x == y -> P x -> P y
subst refl p = p

_=,=_ : {S : Set}{T : S -> Set}
        {s0 : S}{s1 : S} -> s0 == s1 ->
        {t0 : T s0}{t1 : T s1} -> t0 == t1 ->
        _==_ {Sig S T} (s0 , t0) {Sig S T} (s1 , t1)
refl =,= refl = refl

mylem :  (G : Cx) -> (X : Pay G) -> compa G X X X (ida G X) (ida G X) == ida G X
mylem E X = refl
mylem (G / S) X = mylem G (fst X) =,= refl

claim : (G : Cx){O : Set}(C : O -> CON (G / O))(X : Pay G)
        (P : (o : O) -> Mu C X o -> Set) -> (p : (o : O)(y : Mu C X o) -> P o y)
        (o : O) ->
        compa (G / O) (X , Mu C X) (X , (\ o -> Sig (Mu C X o) (P o))) (X , Mu C X)
         (ida G X , konst fst) (ida G X , (\ o y -> (y , p o y)))
        == ida (G / O) (X , Mu C X)
claim G C X P p o = mylem G X =,= refl

idLem : {G : Cx}{S : Set}{X : Pay G}(n : G :> S) ->
        pr (ida G X) n == (\ (s : S)(x : pr X n s) -> x)
idLem ze = refl
idLem (su y) = idLem y

_=$_ : {S : Set}{T : S -> Set}{f g : (s : S) -> T s} ->
        f == g -> (s : S) -> f s == g s
refl =$ s = refl

mutual  -- and too intensional
  mapId : {G : Cx}{X : Pay G} -> (C : CON G) -> (xs : [| C |] X) ->
          map C (ida G X) xs == xs
  mapId (?? y y') xs = (idLem y =$ y') =$ xs
  mapId (PrfC y) xs = refl
  mapId (y *C y') xs = mapId y (fst xs) =,= mapId y' (snd xs)
  mapId (PiC S y) xs = {!!} -- no chance
  mapId (SiC S y) xs = refl =,= mapId (y (fst xs)) (snd xs)
  mapId (MuC O y y') xs = foldMapId y y' xs
  mapId (NuC O y y') xs = {!!}

  foldMapId : {G : Cx}{O : Set}(C : O -> CON (G / O)){X : Pay G}
              (o : O)(z : Mu C X o) ->
              foldMap C (Mu C X) (ida G X) (\ o -> con) o z == z
  foldMapId C o (con xzs) = {!!} -- close but no banana

mapComp :  {G : Cx}{X Y Z : Pay G} (f : Arr G Y Z)(g : Arr G X Y)
           (C : CON G) -> (xs : [| C |] X) ->
           map C f (map C g xs) == map C (compa G X Y Z f g) xs
mapComp = {!!}

_-=-_ : {X : Set}{x y z : X} -> x == y -> y == z -> x == z
refl -=- refl = refl

induction : {G : Cx}{O : Set}(C : O -> CON (G / O)){X : Pay G}
            (P : (o : O) -> Mu C X o -> Set) ->
            ((o : O)(xyps : [| C o |] (X , (\ o -> Sig (Mu C X o) (P o)))) ->
             P o (con (map (C o) (ida G X , konst fst) xyps))) ->
            (o : O)(y : Mu C X o) -> P o y
induction {G} C {X} P p o (con xys) =
  subst {P = \ xys -> P o (con xys)}{y = xys}
    ((mapComp
     (ida G X , konst fst) (ida G X , (\ o y -> (y , induction C P p o y))) (C o) xys
     -=- {!!})
      -=- mapId (C o) xys)
    (p o (map (C o) (ida G X , (\ o y -> (y , induction C P p o y))) xys))

{-# OPTIONS --type-in-type --no-termination-check --no-positivity-check
 #-}

module Data1 where

_-_ : {A : Set}{B : A -> Set}{C : (a : A) -> B a -> Set} ->
      ({a : A}(b : B a) -> C a b) -> (f : (a : A) -> B a) ->
      (a : A) -> C a (f a)
f - g = \ x -> f (g x)

id : {X : Set} -> X -> X
id x = x

konst : {S : Set}{T : S -> Set} -> ({x : S} -> T x) -> (x : S) -> T x
konst c x = c

data Zero : Set where
record One : Set where

record Sig (S : Set)(T : S -> Set) : Set where
  field
    fst : S
    snd : T fst

open module Sig' {S : Set}{T : S -> Set} = Sig {S}{T}

_,_ : forall {S T}(s : S) -> T s -> Sig S T
s , t = record {fst = s; snd = t}

infixr 40 _,_

_*_ : Set -> Set -> Set
S * T = Sig S \ _ -> T

sig : forall {S T}{P : Sig S T -> Set} ->
      ((s : S)(t : T s) -> P (s , t)) -> (st : Sig S T) -> P st
sig f st = f (fst st) (snd st)

data Cx : Set where
  E : Cx
  _/_ : Cx -> Set -> Cx

data _:>_ : Cx -> Set -> Set where
  ze : {G : Cx}{S : Set} -> (G / S) :> S
  su : {G : Cx}{S T : Set} -> G :> T -> (G / S) :> T

data PROP : Set where
  Absu : PROP
  Triv : PROP
  _/\_ : PROP -> PROP -> PROP
  All : (S : Set) -> (S -> PROP) -> PROP

Prf : PROP -> Set
Prf Absu = Zero
Prf Triv = One
Prf (P /\ Q) = Prf P * Prf Q
Prf (All S P) = (x : S) -> Prf (P x)

data CON (G : Cx) : Set where
  ?? : {S : Set} -> G :> S -> S -> CON G
  PrfC : PROP -> CON G
  _*C_ : CON G -> CON G -> CON G
  PiC : (S : Set) -> (S -> CON G) -> CON G
  SiC : (S : Set) -> (S -> CON G) -> CON G
  MuC : (O : Set) -> (O -> CON (G / O)) -> O -> CON G
  NuC : (O : Set) -> (O -> CON (G / O)) -> O -> CON G

Box : (G : Cx) -> ((S : Set) -> (G :> S) -> Set) -> Set
Box E F = One
Box (G / S) F = Box G (\ S n -> F S (su n)) * F S ze

pr : {G : Cx}{S : Set}{F : (S : Set) -> (G :> S) -> Set} -> Box G F -> (n : G :> S) -> F S n
pr fsf ze = snd fsf
pr fsf (su n) = pr (fst fsf) n

Pay : Cx -> Set
Pay G = Box G (\ I _ -> I -> Set)

Arr : (G : Cx) -> Pay G -> Pay G -> Set
Arr G X Y = Box G (\ S n -> (s : S) -> pr X n s -> pr Y n s)

mutual
  [|_|] : {G : Cx} -> CON G -> Pay G -> Set
  [| ?? n i |]     X = pr X n i
  [| PrfC P |]     X = Prf P
  [| C *C D |]     X = [| C |] X * [| D |] X
  [| PiC S C |]    X = (s : S) -> [| C s |] X
  [| SiC S C |]    X = Sig S \ s -> [| C s |] X
  [| MuC O C o |]  X = Mu C X o
  [| NuC O C o |]  X = Nu C X o

  data Mu {G : Cx}{O : Set}(C : O -> CON (G / O))(X : Pay G)(o : O) : Set where
    con : [| C o |] ( X , Mu C X ) -> Mu C X o
  codata Nu {G : Cx}{O : Set}(C : O -> CON (G / O))(X : Pay G)(o : O) : Set where
    con : [| C o |] ( X , Nu C X ) -> Nu C X o

noc :  {G : Cx}{O : Set}{C : O -> CON (G / O)}{X : Pay G}{o : O} ->
       Nu C X o -> [| C o |] ( X , Nu C X )
noc (con xs) = xs

mutual
  map : {G : Cx}{X Y : Pay G} -> (C : CON G) ->
        Arr G X Y ->
        [| C |] X -> [| C |] Y
  map (?? n i)     f = pr f n i
  map (PrfC P)     f = id
  map (C *C D)     f = sig \ c d -> map C f c , map D f d
  map (PiC S C)    f = \ c s -> map (C s) f (c s)
  map (SiC S C)    f = sig \ s c -> s , map (C s) f c
  map (MuC O C o)  f = foldMap C (Mu C _) f (\ o -> con) o
  map (NuC O C o)  f = unfoldMap C (Nu C _) f (\ o -> noc) o

  foldMap :  {G : Cx}{O : Set}(C : O -> CON (G / O)){X Y : Pay G}(Z : O -> Set) ->
          Arr G X Y ->
          ((o : O) -> [| C o |] ( Y , Z ) -> Z o) ->
          (o : O) -> Mu C X o -> Z o
  foldMap C Z f alg o (con xs) = alg o (map (C o) (f , foldMap C Z f alg) xs)

  unfoldMap :  {G : Cx}{O : Set}(C : O -> CON (G / O)){X Y : Pay G}(Z : O -> Set) ->
            Arr G X Y ->
            ((o : O) -> Z o -> [| C o |] ( X , Z )) ->
            (o : O) -> Z o -> Nu C Y o
  unfoldMap C Z f coalg o y = con (map (C o) (f , unfoldMap C Z f coalg) (coalg o y))

ida : (G : Cx) -> (X : Pay G) -> Arr G X X
ida E = id
ida (G / S) = sig \ Xs X -> ida G Xs , \ s x -> x

compa : (G : Cx) -> (X Y Z : Pay G) -> Arr G Y Z -> Arr G X Y -> Arr G X Z
compa E = \ _ _ _ _ _ -> _
compa (G / S) = sig \ Xs X -> sig \ Ys Y -> sig \ Zs Z -> sig \ fs f -> sig \ gs g ->
  compa G Xs Ys Zs fs gs , \ s x -> f s (g s x)

induction : {G : Cx}{O : Set}(C : O -> CON (G / O)){X : Pay G}
            (P : (o : O) -> Mu C X o -> Set) ->
            ((o : O)(xyps : [| C o |] (X , (\ o -> Sig (Mu C X o) (P o)))) ->
             P o (con (map (C o) (ida G X , konst fst) xyps))) ->
            (o : O)(y : Mu C X o) -> P o y
induction {G} C {X} P p o (con xys) =
  p o (map (C o) (ida G X , (\ o y -> (y , induction C P p o y))) xys)