Updated setoid note.

Updated setoid note.

Ignore-this: e3efd15c1aa4c5d0d3b13ce3c8b9d2c0

darcs-hash:20120514124154-3bd4e-4a0539c4fe3ebec97983e47f466c258e4221a3a0.gz

------------------------------------------------------------------------------
-- Using setoids for formalizing the FOTC
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- Tested with the development version of Agda on 14 May 2012.

{-

From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For =: The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.

-}

module FOTC where

-- References:
--
-- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
--   type theory. Journal of Functional Programming, 13(2):261–293,
--   2003.

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

module Setoid where

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- The setoid equality.
  data _≐_ : D → D → Set where
    refl  : ∀ x →                                       x ≐ x
    sym   : ∀ {x y} → x ≐ y →                           y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≐ x
    Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

  -- 14 May 2012. We cannot define the identity elimination using the
  -- setoid equality.
  --
  -- subst : (A : D → Set) → ∀ x y → x ≐ y → A x → A y

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

  -- 14 May 2012: Using the inductive structure we cannot prove
  --
  -- K · x · y ≡ x,
  --
  -- we need the setoid equality.
  -- K-eq : ∀ {x y} → (K · x · y) ≡ x

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

module LeibnizEquality where

  infix 7 _≡_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- Using the Leibniz equality (adapted from
  -- Agda/examples/lib/Logic/Leibniz.agda)

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} h A Ay = h (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z h₁ h₂ A Ax = h₂ A (h₁ A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- and the congruency

  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  cong {x₁} {x₂} {y₁} {y₂} h₁ h₂ A Ax₁x₂ =
    h₂ (λ z → A (x₂ · z)) (h₁ (λ z → A (z · y₁)) Ax₁x₂)

------------------------------------------------------------------------------
-- Using setoids for formalizing the FOTC
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- Tested with the development version of Agda on 13 May 2012.

{-

From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For =: The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.

-}

module FOTC where

-- References:
--
-- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
--   type theory. Journal of Functional Programming, 13(2):261–293,
--   2003.

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

module Setoid where

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.
  infix 7  _≐_

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- The setoid equality
  data _≐_ : D → D → Set where
    refl  : ∀ x →                                       x ≐ x
    sym   : ∀ {x y} → x ≐ y →                           y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≐ x
    Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

  -- 13 May 2012. It seems we cannot define the identity elimination
  -- using the setoid equality.
  --
  -- subst : (A : D → Set) → ∀ x y → x ≐ y → A x → A y

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

  -- 13 May 2012: Using the inductive structure we cannot prove
  --
  -- K · x · y ≡ x,
  --
  -- we need the setoid equality.
  -- K-eq : ∀ {x y} → (K · x · y) ≡ x

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

module LeibnizEquality where

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- Using the Leibniz equality
  -- (Adapted from Agda/examples/lib/Logic/Leibniz.agda)

  infix 7 _≡_

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} h A Ay = h (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z h₁ h₂ A Ax = h₂ A (h₁ A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- and the congruency

  cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  cong {x₁} {x₂} {y₁} {y₂} h₁ h₂ A Ax₁x₂ =
    h₂ (λ z → A (x₂ · z)) (h₁ (λ z → A (z · y₁)) Ax₁x₂)


Rename ΔEnv-Entry to ValidChange.

Rename ΔEnv-Entry to ValidChange.

Also rename operations related to ΔEnv-Entry.

Old-commit-hash: 35ab981b89bab6eced9a7b20753bb140f6caf7a8

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

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    ΔVal-base : Base → Set
    valid-base : ∀ {ι} → ⟦ ι ⟧Base → ΔVal-base ι → Set
    apply-ΔVal-base : ∀ ι → ⟦ ι ⟧Base → ΔVal-base ι → ⟦ ι ⟧Base
    diff-ΔVal-base : ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → ΔVal-base ι
    R[v,u-v]-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → valid-base {ι} v (diff-ΔVal-base ι u v)
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-ΔVal-base ι v (diff-ΔVal-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  ΔVal : Type → Set
  valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set

  apply-ΔVal : ∀ τ → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
  diff-ΔVal : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ

  infixl 6 apply-ΔVal diff-ΔVal -- as with + - in GHC.Num
  syntax apply-ΔVal τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-ΔVal τ u v = u ⊟₍ τ ₎ v

  -- Lemma diff-is-valid
  R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟₍ τ ₎ v)

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (ΔVal τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (ΔVal (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- ΔVal τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
  -- ΔVal : Type → Set
  ΔVal (base ι) = ΔVal-base ι
  ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
  n ⊞₍ base ι ₎ Δn = apply-ΔVal-base ι n Δn
  f ⊞₍ σ ⇒ τ ₎ Δf = λ v → f v ⊞₍ τ ₎ Δf v (v ⊟₍ σ ₎ v) (R[v,u-v] {σ})

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
  m ⊟₍ base ι ₎ n = diff-ΔVal-base ι m n
  g ⊟₍ σ ⇒ τ ₎ f = λ v Δv R[v,Δv] → g (v ⊞₍ σ ₎ Δv) ⊟₍ τ ₎ f v

  -- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
  valid {base ι} n Δn = valid-base {ι} n Δn
  valid {σ ⇒ τ} f Δf =
    ∀ (v : ⟦ σ ⟧) (Δv : ΔVal σ) (R[v,Δv] : valid v Δv)
    → valid {τ} (f v) (Δf v Δv R[v,Δv])
    -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
    × (f ⊞₍ σ ⇒ τ ₎ Δf) (v ⊞₍ σ ₎ Δv) ≡ f v ⊞₍ τ ₎ Δf v Δv R[v,Δv]

  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  R[v,u-v] {base ι} {u} {v} = R[v,u-v]-base {ι} {u} {v}
  R[v,u-v] {σ ⇒ τ} {u} {v} = λ w Δw R[w,Δw] →
    let
      w′ = w ⊞₍ σ ₎ Δw
    in
      R[v,u-v] {τ}
      ,
      (begin
        (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w′
      ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
        u w′
      ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v w}) ⟩
        v w ⊞₍ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v) w Δw R[w,Δw]
      ∎) where open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  ValidChange : Type → Set
  ValidChange τ = Triple
    ⟦ τ ⟧
    (λ _ → ΔVal τ)
    (λ v dv → valid {τ} v dv)

  ΔEnv : Context → Set
  ΔEnv = DependentList ValidChange

  ignore-valid-change : ValidChange ⊆ ⟦_⟧
  ignore-valid-change (cons v _ _) = v

  update-valid-change : ValidChange ⊆ ⟦_⟧
  update-valid-change {τ} (cons v dv R[v,dv]) = v ⊞₍ τ ₎ dv

  ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  ignore = map (λ {τ} → ignore-valid-change {τ})

  update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  update = map (λ {τ} → update-valid-change {τ})

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

module Parametric.Change.Validity
    {Base : Type.Structure}
    (⟦_⟧Base : Value.Structure Base)
  where

open Type.Structure Base
open Value.Structure Base ⟦_⟧Base

-- Changes for Calculus Popl14
--
-- Contents
-- - Mutually recursive concepts: ΔVal, validity.
--     Under module Syntax, the corresponding concepts of
--     ΔType and ΔContext reside in separate files.
--     Now they have to be together due to mutual recursiveness.
-- - `diff` and `apply` on semantic values of changes:
--     they have to be here as well because they are mutually
--     recursive with validity.
-- - The lemma diff-is-valid: it has to be here because it is
--     mutually recursive with `apply`
-- - The lemma apply-diff: it is mutually recursive with `apply`
--     and `diff`

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality
open import Data.Product hiding (map)

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

record Structure : Set₁ where
  ----------------
  -- Parameters --
  ----------------

  field
    ΔVal-base : Base → Set
    valid-base : ∀ {ι} → ⟦ ι ⟧Base → ΔVal-base ι → Set
    apply-ΔVal-base : ∀ ι → ⟦ ι ⟧Base → ΔVal-base ι → ⟦ ι ⟧Base
    diff-ΔVal-base : ∀ ι → ⟦ ι ⟧Base → ⟦ ι ⟧Base → ΔVal-base ι
    R[v,u-v]-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → valid-base {ι} v (diff-ΔVal-base ι u v)
    v+[u-v]=u-base : ∀ {ι} {u v : ⟦ ι ⟧Base} → apply-ΔVal-base ι v (diff-ΔVal-base ι u v) ≡ u

  ---------------
  -- Interface --
  ---------------

  ΔVal : Type → Set
  valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set

  apply-ΔVal : ∀ τ → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
  diff-ΔVal : ∀ τ → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ

  infixl 6 apply-ΔVal diff-ΔVal -- as with + - in GHC.Num
  syntax apply-ΔVal τ v dv = v ⊞₍ τ ₎ dv
  syntax diff-ΔVal τ u v = u ⊟₍ τ ₎ v

  -- Lemma diff-is-valid
  R[v,u-v] : ∀ {τ : Type} {u v : ⟦ τ ⟧} → valid {τ} v (u ⊟₍ τ ₎ v)

  -- Lemma apply-diff
  v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    v ⊞₍ τ ₎ (u ⊟₍ τ ₎ v) ≡ u

  --------------------
  -- Implementation --
  --------------------

  -- (ΔVal τ) is the set of changes of type τ. This set is
  -- strictly smaller than ⟦ ΔType τ⟧ if τ is a function type. In
  -- particular, (ΔVal (σ ⇒ τ)) is a function that accepts only
  -- valid changes, while ⟦ ΔType (σ ⇒ τ) ⟧ accepts also invalid
  -- changes.
  --
  -- ΔVal τ is the target of the denotational specification ⟦_⟧Δ.
  -- Detailed motivation:
  --
  -- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
  -- ΔVal : Type → Set
  ΔVal (base ι) = ΔVal-base ι
  ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

  -- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
  n ⊞₍ base ι ₎ Δn = apply-ΔVal-base ι n Δn
  f ⊞₍ σ ⇒ τ ₎ Δf = λ v → f v ⊞₍ τ ₎ Δf v (v ⊟₍ σ ₎ v) (R[v,u-v] {σ})

  -- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
  m ⊟₍ base ι ₎ n = diff-ΔVal-base ι m n
  g ⊟₍ σ ⇒ τ ₎ f = λ v Δv R[v,Δv] → g (v ⊞₍ σ ₎ Δv) ⊟₍ τ ₎ f v

  -- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
  valid {base ι} n Δn = valid-base {ι} n Δn
  valid {σ ⇒ τ} f Δf =
    ∀ (v : ⟦ σ ⟧) (Δv : ΔVal σ) (R[v,Δv] : valid v Δv)
    → valid {τ} (f v) (Δf v Δv R[v,Δv])
    -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
    × (f ⊞₍ σ ⇒ τ ₎ Δf) (v ⊞₍ σ ₎ Δv) ≡ f v ⊞₍ τ ₎ Δf v Δv R[v,Δv]

  -- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
  v+[u-v]=u {base ι} {u} {v} = v+[u-v]=u-base {ι} {u} {v}
  v+[u-v]=u {σ ⇒ τ} {u} {v} =
      ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
        begin
          (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w
        ≡⟨ refl ⟩
          v w ⊞₍ τ ₎ (u (w ⊞₍ σ ₎ (w ⊟₍ σ ₎ w)) ⊟₍ τ ₎ v w)
        ≡⟨ cong (λ hole → v w ⊞₍ τ ₎ (u hole ⊟₍ τ ₎ v w)) (v+[u-v]=u {σ}) ⟩
          v w ⊞₍ τ ₎ (u w ⊟₍ τ ₎ v w)
        ≡⟨ v+[u-v]=u {τ} ⟩
          u w
        ∎) where
        open ≡-Reasoning

  R[v,u-v] {base ι} {u} {v} = R[v,u-v]-base {ι} {u} {v}
  R[v,u-v] {σ ⇒ τ} {u} {v} = λ w Δw R[w,Δw] →
    let
      w′ = w ⊞₍ σ ₎ Δw
    in
      R[v,u-v] {τ}
      ,
      (begin
        (v ⊞₍ σ ⇒ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v)) w′
      ≡⟨ cong (λ hole → hole w′) (v+[u-v]=u {σ ⇒ τ} {u} {v}) ⟩
        u w′
      ≡⟨ sym (v+[u-v]=u {τ} {u w′} {v w}) ⟩
        v w ⊞₍ τ ₎ (u ⊟₍ σ ⇒ τ ₎ v) w Δw R[w,Δw]
      ∎) where open ≡-Reasoning

  -- syntactic sugar for implicit indices
  infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num

  _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
  _⊞_ {τ} v dv = v ⊞₍ τ ₎ dv

  _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
  _⊟_ {τ} u v = u ⊟₍ τ ₎ v

  ------------------
  -- Environments --
  ------------------

  open DependentList public using (∅; _•_)
  open Tuples public using (cons)

  ΔEnv-Entry : Type → Set
  ΔEnv-Entry τ = Triple
    ⟦ τ ⟧
    (λ _ → ΔVal τ)
    (λ v dv → valid {τ} v dv)

  ΔEnv : Context → Set
  ΔEnv = DependentList ΔEnv-Entry

  ignore-entry : ΔEnv-Entry ⊆ ⟦_⟧
  ignore-entry (cons v _ _) = v

  update-entry : ΔEnv-Entry ⊆ ⟦_⟧
  update-entry {τ} (cons v dv R[v,dv]) = v ⊞₍ τ ₎ dv

  ignore : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  ignore = map (λ {τ} → ignore-entry {τ})

  update : ∀ {Γ : Context} → (ρ : ΔEnv Γ) → ⟦ Γ ⟧
  update = map (λ {τ} → update-entry {τ})


module Explore.Summable where

open import Type
open import Function.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_ ; _≗_ ; _≗₂_)
open import Explore.Type
open import Explore.Product
open import Data.Product
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Bool.NP renaming (Bool to 𝟚; true to 1b; false to 0b; toℕ to 𝟚▹ℕ)
open Data.Bool.NP.Indexed

module FromSum {A : ★} (sum : Sum A) where
  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (𝟚▹ℕ ∘ f)

module FromSumInd {A : ★}
                  {sum : Sum A}
                  (sum-ind : SumInd sum) where
  open FromSum sum public

  sum-ext : SumExt sum
  sum-ext = sum-ind (λ s → s _ ≡ s _) (≡.cong₂ _+_)

  sum-zero : SumZero sum
  sum-zero = sum-ind (λ s → s (const 0) ≡ 0) (≡.cong₂ _+_) (λ _ → ≡.refl)

  sum-hom : SumHom sum
  sum-hom f g = sum-ind (λ s → s (f +° g) ≡ s f + s g)
                        (λ {s₀} {s₁} p₀ p₁ → ≡.trans (≡.cong₂ _+_ p₀ p₁) (+-interchange (s₀ _) (s₀ _) _ _))
                        (λ _ → ≡.refl)

  sum-mono : SumMono sum
  sum-mono = sum-ind (λ s → s _ ≤ s _) _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.cong₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  module _ (f g : A → ℕ) where
    open ≡.≡-Reasoning

    sum-⊓-∸ : sum f ≡ sum (f ⊓° g) + sum (f ∸° g)
    sum-⊓-∸ = sum f                          ≡⟨ sum-ext (f ⟨ a≡a⊓b+a∸b ⟩° g) ⟩
              sum ((f ⊓° g) +° (f ∸° g))     ≡⟨ sum-hom (f ⊓° g) (f ∸° g) ⟩
              sum (f ⊓° g) + sum (f ∸° g) ∎

    sum-⊔-⊓ : sum f + sum g ≡ sum (f ⊔° g) + sum (f ⊓° g)
    sum-⊔-⊓ = sum f + sum g               ≡⟨ ≡.sym (sum-hom f g) ⟩
              sum (f +° g)                ≡⟨ sum-ext (f ⟨ a+b≡a⊔b+a⊓b ⟩° g) ⟩
              sum (f ⊔° g +° f ⊓° g)      ≡⟨ sum-hom (f ⊔° g) (f ⊓° g) ⟩
              sum (f ⊔° g) + sum (f ⊓° g) ∎

    sum-⊔ : sum (f ⊔° g) ≤ sum f + sum g
    sum-⊔ = ℕ≤.trans (sum-mono (f ⟨ ⊔≤+ ⟩° g)) (ℕ≤.reflexive (sum-hom f g))

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong 𝟚▹ℕ ∘ f≗g)

  sum-const : ∀ k → sum (const k) ≡ Card * k
  sum-const k
      rewrite ℕ°.*-comm Card k
            | ≡.sym (sum-lin (const 1) k)
            | proj₂ ℕ°.*-identity k = ≡.refl

  module _ f g where
    count-∧-not : count f ≡ count (f ∧° g) + count (f ∧° not° g)
    count-∧-not rewrite sum-⊓-∸ (𝟚▹ℕ ∘ f) (𝟚▹ℕ ∘ g)
                      | sum-ext (f ⟨ toℕ-⊓ ⟩° g)
                      | sum-ext (f ⟨ toℕ-∸ ⟩° g)
                      = ≡.refl

    count-∨-∧ : count f + count g ≡ count (f ∨° g) + count (f ∧° g)
    count-∨-∧ rewrite sum-⊔-⊓ (𝟚▹ℕ ∘ f) (𝟚▹ℕ ∘ g)
                    | sum-ext (f ⟨ toℕ-⊔ ⟩° g)
                    | sum-ext (f ⟨ toℕ-⊓ ⟩° g)
                    = ≡.refl

    count-∨≤+ : count (f ∨° g) ≤ count f + count g
    count-∨≤+ = ℕ≤.trans (ℕ≤.reflexive (sum-ext (≡.sym ∘ (f ⟨ toℕ-⊔ ⟩° g))))
                         (sum-⊔ (𝟚▹ℕ ∘ f) (𝟚▹ℕ ∘ g))

module FromSum×
         {A B}
         {sumᴬ     : Sum A}
         (sum-indᴬ : SumInd sumᴬ)
         {sumᴮ     : Sum B}
         (sum-indᴮ : SumInd sumᴮ) where

  module |A| = FromSumInd sum-indᴬ
  module |B| = FromSumInd sum-indᴮ
  open Operators

  sumᴬᴮ = sumᴬ ×ˢ sumᴮ

  sum-∘proj₁≡Card* : ∀ f → sumᴬᴮ (f ∘ proj₁) ≡ |B|.Card * sumᴬ f
  sum-∘proj₁≡Card* f
      rewrite |A|.sum-ext (|B|.sum-const ∘ f)
            = |A|.sum-lin f |B|.Card

  sum-∘proj₂≡Card* : ∀ f → sumᴬᴮ (f ∘ proj₂) ≡ |A|.Card * sumᴮ f
  sum-∘proj₂≡Card* = |A|.sum-const ∘ sumᴮ

  sum-∘proj₁ : ∀ {f} {g} → sumᴬ f ≡ sumᴬ g → sumᴬᴮ (f ∘ proj₁) ≡ sumᴬᴮ (g ∘ proj₁)
  sum-∘proj₁ {f} {g} sumf≡sumg
      rewrite sum-∘proj₁≡Card* f
            | sum-∘proj₁≡Card* g
            | sumf≡sumg = ≡.refl

  sum-∘proj₂ : ∀ {f} {g} → sumᴮ f ≡ sumᴮ g → sumᴬᴮ (f ∘ proj₂) ≡ sumᴬᴮ (g ∘ proj₂)
  sum-∘proj₂ sumf≡sumg = |A|.sum-ext (const sumf≡sumg)

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


update linear solver with isomorphisms

update linear solver with isomorphisms

module linear-solver where

open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as F using (Fin)
import Data.Fin.Props as FP

module Syntax {a} (A : Set a)(_x_ : A → A → A)(T : A)
  (R' : A → A → Set)
  (id' : ∀ {A} → R' A A)
  (_∻'_ : ∀ {A B C} → R' A B → R' B C → R' A C)
  (<id,tt>' : ∀ {A} → R' (A x T) A)
  (<id,tt>⁻¹' : ∀ {A} → R' A (A x T))
  (<tt,id>' : ∀ {A} → R' (T x A) A)
  (<tt,id>⁻¹' : ∀ {A} → R' A (T x A))
  (⟨_×'_⟩   : ∀ {A B C D} → R' A C → R' B D → R' (A x B) (C x D))
  (first'    : ∀ {A B C} → R' A B → R' (A x C) (B x C))
  (second'   : ∀ {A B C} → R' B C → R' (A x B) (A x C))
  (assoc'   : ∀ {A B C} → R' (A x (B x C)) ((A x B) x C))
  (assoc⁻¹' : ∀ {A B C} → R' ((A x B) x C) (A x (B x C)))
  (swap'    : ∀ {A B}   → R' (A x B) (B x A))
  nrVars (!_ : Fin nrVars → A) where

  Var = Fin nrVars

  open import Relation.Nullary using (yes ; no)
  open import Relation.Nullary.Decidable

  data Syn : Set where
   var : Var → Syn
   tt  : Syn
   _,_ : Syn → Syn → Syn

  #_ : ∀ m {m<n : True (ℕ.suc m ℕ.≤? nrVars)} → Syn
  #_ m {p} = var (F.#_ m {nrVars} {p})

  eval : Syn → A
  eval (var x) = ! x
  eval tt = T
  eval (s , s₁) = eval s x eval s₁

  data R : Syn → Syn → Set where
    _∻''_ : ∀ {A B C} → R A B → R B C → R A C
    <id,tt> : ∀ {A} → R (A , tt) A
    <tt,id> : ∀ {A} → R (tt , A) A
    <tt,id>⁻¹ : ∀ {A} → R A (tt , A)
    <id,tt>⁻¹ : ∀ {A} → R A (A , tt)
    ⟨_×''_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
    assoc : ∀ {A B C} → R (A , (B , C)) ((A , B) , C)
    assoc⁻¹ : ∀ {A B C} → R ((A , B) , C) (A , (B , C))
    id : ∀ {A} → R A A
    swap : ∀ {A B} → R (A , B) (B , A)

  ⟨_×_⟩ : ∀ {A B C D} → R A C → R B D → R (A , B) (C , D)
  ⟨ id × id ⟩ = id
  ⟨ r₁ × r₂ ⟩ = ⟨ r₁ ×'' r₂ ⟩

  _∻_ : ∀ {A B C} → R A B → R B C → R A C
  id ∻ r₂ = r₂
  r₁ ∻ id = r₁
  <tt,id>⁻¹ ∻ <tt,id> = id
  <id,tt>⁻¹ ∻ <id,tt> = id
  <tt,id> ∻ <tt,id>⁻¹ = id
  <id,tt> ∻ <id,tt>⁻¹ = id
  swap ∻ <id,tt> = <tt,id>
  swap ∻ <tt,id> = <id,tt>
  <id,tt>⁻¹ ∻ swap = <tt,id>⁻¹
  <tt,id>⁻¹ ∻ swap = <id,tt>⁻¹
  assoc ∻ assoc⁻¹ = id
  assoc ∻ (assoc⁻¹ ∻'' r) = r
  assoc⁻¹ ∻ assoc = id
  assoc⁻¹ ∻ (assoc ∻'' r) = r
  swap ∻ swap = id
  swap ∻ (swap ∻'' r) = r
  (r₁ ∻'' r₂) ∻ r₃ = r₁ ∻ (r₂ ∻ r₃)
  ⟨ r₁ ×'' r₂ ⟩ ∻ ⟨ r₃ ×'' r₄ ⟩ = ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ⟨ r₁ ×'' r₂ ⟩ ∻ (⟨ r₃ ×'' r₄ ⟩ ∻'' r₅) with ⟨ r₁ ∻ r₃ × r₂ ∻ r₄ ⟩
  ... | id = r₅
  ... | r₆ = r₆ ∻'' r₅
  r₁ ∻ r₂ = r₁ ∻'' r₂

  sym : ∀ {S S'} → R S S' → R S' S
  sym (r ∻'' r₁) = sym r₁ ∻ sym r
  sym <id,tt> = <id,tt>⁻¹
  sym <tt,id> = <tt,id>⁻¹
  sym <id,tt>⁻¹ = <id,tt>
  sym <tt,id>⁻¹ = <tt,id>
  sym ⟨ r ×'' r₁ ⟩ = ⟨ sym r × sym r₁ ⟩
  sym assoc = assoc⁻¹
  sym assoc⁻¹ = assoc
  sym id = id
  sym swap = swap

  proof₁ : ∀ {S S'} → R S S' → R' (eval S) (eval S')
  proof₁ (r ∻'' r₁) = proof₁ r ∻' proof₁ r₁
  proof₁ <id,tt> = <id,tt>'
  proof₁ <tt,id> = <tt,id>'
  proof₁ <id,tt>⁻¹ = <id,tt>⁻¹'
  proof₁ <tt,id>⁻¹ = <tt,id>⁻¹'
  proof₁ ⟨ id ×'' r ⟩ = second' (proof₁ r)
  proof₁ ⟨ r ×'' id ⟩ = first'  (proof₁ r)
  proof₁ ⟨ r ×'' r₁ ⟩ = ⟨ proof₁ r ×' proof₁ r₁ ⟩
  proof₁ assoc = assoc'
  proof₁ assoc⁻¹ = assoc⁻¹'
  proof₁ id = id'
  proof₁ swap = swap'

  proof₂ : ∀ {S S'} → R S S' → R' (eval S') (eval S)
  proof₂ r = proof₁ (sym r)

  data NF : Syn → Set where
    tt : NF tt
    var : (x : Var) → NF (var x)
    var_::_ : ∀ {S}(i : Var) → NF S → NF (var i , S)

  record NFP S : Set where
    constructor _⊢_
    field
      {S'} : Syn
      term : NF S'
      proof : R S' S

  merge : ∀ {S S'} → NF S → NF S' → NFP (S , S')
  merge tt n2 = n2 ⊢ <tt,id>⁻¹
  merge (var i) n2 = (var i :: n2) ⊢ id
  merge (var i :: n1) n2 with merge n1 n2
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ assoc)

  norm : (x : Syn) → NFP x
  norm (var x) = (var x) ⊢ id
  norm tt = tt ⊢ id
  norm (x , x₁) with norm x | norm x₁
  ... | t1 ⊢ p1 | t2 ⊢ p2 with merge t1 t2
  ... | t3 ⊢ p3 = t3 ⊢ (p3 ∻ ⟨ p1 × p2 ⟩)

  insert : ∀ {S} → (x : Var) → NF S → NFP (var x , S)
  insert y tt = (var y) ⊢ <id,tt>⁻¹
  insert y (var i) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: var i) ⊢ id
  ... | no  _ = (var i :: var y) ⊢ swap
  insert y (var i :: n1) with (F.toℕ y) ℕ.≤? (F.toℕ i)
  ... | yes _ = (var y :: (var i :: n1)) ⊢ id
  ... | no  _ with insert y n1
  ... | t ⊢ p = (var i :: t) ⊢ (⟨ id × p ⟩ ∻ (assoc ∻ (⟨ swap × id ⟩ ∻ assoc⁻¹)))

  sort : ∀ {x : Syn} → NF x → NFP x
  sort tt = tt ⊢ id
  sort (var i) = var i ⊢ id
  sort (var i :: n1) with sort n1
  ... | t1 ⊢ p1 with insert i t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ ⟨ id × p1 ⟩)

  normal : (x : Syn) → NFP x
  normal x with norm x
  ... | t1 ⊢ p1 with sort t1
  ... | t2 ⊢ p2 = t2 ⊢ (p2 ∻ p1)

  open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
  open import Relation.Nullary

  import Data.Unit
  import Data.Empty

  id≡ : ∀ {S S'} → S ≡ S' → R S S'
  id≡ refl = id

  _≢_ : ∀ {A : Set} → A → A → Set
  x ≢ y = x ≡ y → Data.Empty.⊥

  ≢-cong : ∀ {A B}{x y : A}(f : A → B) → f x ≢ f y → x ≢ y
  ≢-cong f fr refl = fr refl

  var-inj : ∀ {i j : Fin nrVars} → i ≢ j → Syn.var i ≢ var j
  var-inj p refl = p refl

  ,-inj₁ : ∀ {x y a b} → x ≢ y → (x Syn., a) ≢ (y , b)
  ,-inj₁ p refl = p refl

  ,-inj₂ : ∀ {x y a b} → a ≢ b → (x Syn., a) ≢ (y , b)
  ,-inj₂ p refl = p refl

  _≟_ : (x y : Syn) → Dec (x ≡ y)
  var x ≟ var x₁ with x FP.≟ x₁
  var .x₁ ≟ var x₁ | yes refl = yes refl
  ... | no  p    = no (var-inj p)
  var x ≟ tt = no (λ ())
  var x ≟ (y , y₁) = no (λ ())
  tt ≟ var x = no (λ ())
  tt ≟ tt = yes refl
  tt ≟ (y , y₁) = no (λ ())
  (x , x₁) ≟ var x₂ = no (λ ())
  (x , x₁) ≟ tt = no (λ ())
  (x , x₁) ≟ (y , y₁) with x ≟ y | x₁ ≟ y₁
  (x , x₁) ≟ (.x , .x₁) | yes refl | yes refl = yes refl
  (x , x₁) ≟ (y , y₁) | yes p | no ¬p = no (,-inj₂ ¬p)
  (x , x₁) ≟ (y , y₁) | no ¬p | q = no (,-inj₁ ¬p)

  CHECK : Syn → Syn → Set
  CHECK s1 s2 with s1 ≟ s2
  ... | yes p = Data.Unit.⊤
  ... | no  p = Data.Empty.⊥

  rewire : (S₁ S₂ : Syn) → CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire s₁ s₂ eq with NFP.S' (normal s₁) ≟ NFP.S' (normal s₂)
  ... | yes p = proof₁
                  ((sym (NFP.proof (normal s₁)) ∻ id≡ p) ∻ NFP.proof (normal s₂))
  rewire _ _ () | no _
    -- proof₂ (NFP.proof (normal s₁)) ∻' (eq ∻' proof₁ (NFP.proof (normal s₂)))

  infix 4 _⇛_

  record Eq : Set where
    constructor _⇛_
    field
      LHS RHS : Syn

  open import Data.Vec.N-ary using (N-ary ; _$ⁿ_)
  open import Data.Vec using (allFin) renaming (map to vmap)

  rewire' : (f : N-ary nrVars Syn Eq) → let (S₁ ⇛ S₂) = f $ⁿ (vmap Syn.var (allFin nrVars))
          in CHECK (NFP.S' (normal S₁)) (NFP.S' (normal S₂)) → R' (eval S₁) (eval S₂)
  rewire' f eq = let S ⇛ S' = f $ⁿ vmap Syn.var (allFin  nrVars)
         in rewire S S' eq

module example where

  open import Data.Vec

  open import Data.Product
  open import Data.Unit

  open import Function

  -- need to etaexpand this because otherwise we get an error
  module STest n M = Syntax Set _×_ ⊤ (λ x x₁ → x → x₁) (λ x → x)
         (λ x x₁ x₂ → x₁ (x x₂)) (λ x → proj₁ x) (λ x → x , tt)
         (λ x → proj₂ x) (λ x → tt , x) (λ x x₁ x₂ → (x (proj₁ x₂)) , (x₁ (proj₂ x₂)))
         (λ x x₁ → (x (proj₁ x₁)) , (proj₂ x₁)) (λ x x₁ → (proj₁ x₁) , (x (proj₂ x₁)))
         (λ x → ((proj₁ x) , (proj₁ (proj₂ x))) , (proj₂ (proj₂ x)))
         (λ x → (proj₁ (proj₁ x)) , ((proj₂ (proj₁ x)) , (proj₂ x)))
         (λ x → (proj₂ x) , (proj₁ x)) n M

  test : (A B C : Set) → (A × B) × C → (B × A) × C
  test A B C = rewire LHS RHS _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

    LHS = (# 0 , # 1) , # 2
    RHS = (# 1 , # 0) , # 2

  test2 : (A B C : Set) → (A × B) × C → (B × A) × C
  test2 A B C = rewire' (λ a b c → (a , b) , c ⇛ (b , a) , c) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₂ where

  open import Data.Vec

  data Ty : Set where
    _×_ : Ty → Ty → Ty
    ⊤ : Ty

  infix 4 _⟶_

  data _⟶_ : Ty → Ty → Set where
    id' : ∀ {A} → A ⟶ A
    _∻'_ : ∀ {A B C} → A ⟶ B → B ⟶ C → A ⟶ C
    <id,tt>' : ∀ {A} → (A × ⊤) ⟶ A
    <id,tt>⁻¹' : ∀ {A} → A ⟶ (A × ⊤)
    <tt,id>' : ∀ {A} → (⊤ × A) ⟶ A
    <tt,id>⁻¹' : ∀ {A} → A ⟶ (⊤ × A)
    ⟨_×'_⟩   : ∀ {A B C D} → A ⟶ C → B ⟶ D → (A × B) ⟶ (C × D)
    first    : ∀ {A B C} → A ⟶ B → A × C ⟶ B × C
    second   : ∀ {A B C} → B ⟶ C → A × B ⟶ A × C
    assoc'   : ∀ {A B C} → (A × (B × C)) ⟶ ((A × B) × C)
    assoc⁻¹' : ∀ {A B C} → ((A × B) × C) ⟶ (A × (B × C))
    swap'    : ∀ {A B}   → (A × B) ⟶ (B × A)

  module STest n M = Syntax Ty _×_ ⊤ _⟶_ id' _∻'_ <id,tt>' <id,tt>⁻¹' <tt,id>' <tt,id>⁻¹' ⟨_×'_⟩ first second assoc' assoc⁻¹' swap' n M

  test2 : (A B C : Ty) → (A × B) × C ⟶  (B × A) × C
  test2 A B C = rewire ((# 0 , # 1) , # 2) ((# 1 , # 0) , # 2) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))

module example₃ where

  open import Data.Unit
  open import Data.Product
  open import Data.Vec

  open import Function using (flip ; const)

  open import Function.Inverse
  open import Function.Related.TypeIsomorphisms.NP

  open ×-CMon using () renaming (∙-cong to ×-cong ; assoc to ×-assoc)

  module STest n M = Syntax Set _×_ ⊤ _↔_ id (flip _∘_) A×⊤↔A (sym A×⊤↔A) (A×⊤↔A ∘ swap-iso) (swap-iso ∘ sym A×⊤↔A)
                            ×-cong first-iso (λ x → second-iso (const x))
                            (sym (×-assoc _ _ _)) (×-assoc _ _ _) swap-iso n M

  test : ∀ A B C → ((A × B) × C) ↔ (C × (B × A))
  test A B C = rewire ((# 0 , # 1) , # 2) (# 2 , (# 1 , # 0)) _ where
    open STest 3 (λ i → lookup i (A ∷ B ∷ C ∷ []))


Cosmetic change.

Cosmetic change.

Ignore-this: 56f256a7d0c9d89dea0c836aed175f19

darcs-hash:20120303031914-3bd4e-94a323682a68c7fa19333fcfea1528dc4853b741.gz

------------------------------------------------------------------------------
-- First-order Peano arithmetic (PA)
------------------------------------------------------------------------------

module PA.README where

-- Two formalizations of first-order Peano aritmetic using:

-- • Agda postulates for the non-logical constants and the Peano's
--   axioms, using axioms based on the propositional equality (see, for
--   example, [Machover, 1996, p. 263], [Hájek and Pudlák, 1998, p. 28]).

-- • Agda data types and primitive recursive functions for addition and
--   multiplication.

-- References;

-- Moshé Machover. Set theory, logic and their limitations. Cambridge
-- University Press, 1996.

-- Petr Hájek and Pavel Pudlák. Metamathematics of First-Order
-- Arithmetic. Springer, 1998. 2nd printing.

------------------------------------------------------------------------------
-- Axiomatic PA

-- The axioms
open import PA.Axiomatic.Standard.Base

-- Some properties
open import PA.Axiomatic.Standard.PropertiesATP
open import PA.Axiomatic.Standard.PropertiesI

------------------------------------------------------------------------------
-- Inductive PA

-- Inductive definitions
open import PA.Inductive.Base

-- Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI

------------------------------------------------------------------------------
-- First-order Peano arithmetic (PA)
------------------------------------------------------------------------------

module PA.README where

-- Two formalizations of first-order Peano aritmetic using:

-- * Agda postulates for the non-logical constants and the Peano's
--   axioms, using axioms based on the propositional equality (see, for
--   example, [Machover, 1996, p. 263], [Hájek and Pudlák, 1998, p. 28]).

-- * Agda data types and primitive recursive functions for addition and
--   multiplication.

-- References;

-- Moshé Machover. Set theory, logic and their limitations. Cambridge
-- University Press, 1996.

-- Petr Hájek and Pavel Pudlák. Metamathematics of First-Order
-- Arithmetic. Springer, 1998. 2nd printing.

------------------------------------------------------------------------------
-- Axiomatic PA

-- The axioms
open import PA.Axiomatic.Standard.Base

-- Some properties
open import PA.Axiomatic.Standard.PropertiesATP
open import PA.Axiomatic.Standard.PropertiesI

------------------------------------------------------------------------------
-- Inductive PA

-- Inductive definitions
open import PA.Inductive.Base

-- Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI


Syntactic sugar for replacement pairs

Syntactic sugar for replacement pairs

Old-commit-hash: 930ad8e0b6ee020c54d0c8372373e433fb184bad

{-

Checklist of stuff to add when adding syntactic constructs

- derive (symbolic derivation; most important!)
- weaken
- ⟦_⟧Term
- weaken-sound
- validity-of-derive
- correctness-of-derive

-}

module Extension-00 where

open import Data.Product
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤)

open import Relation.Binary.PropositionalEquality

open import Level using
  (zero ; Level ; suc)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)

postulate extensionality : Extensionality zero zero

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

infixr 5 _⇒_

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

infixr 9 _•_

⟨∅⟩ : ∅ ≡ ∅
⟨∅⟩ = refl

_⟨•⟩_ : ∀ {τ₁ τ₂ Γ₁ Γ₂} → τ₁ ≡ τ₂ → Γ₁ ≡ Γ₂ → τ₁ • Γ₁ ≡ τ₂ • Γ₂
_⟨•⟩_ = cong₂ _•_

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

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

  -- ad-hoc extensions
  foldNat : ∀ {Γ τ} → (n : Term Γ nats) →
                      (f : Term Γ (τ ⇒ τ)) → (z : Term Γ τ)
                    → Term Γ τ

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

≼-reflexivity : Reflexive _≼_
≼-reflexivity {∅} = ∅≼∅
≼-reflexivity {τ • x} = keep τ • ≼-reflexivity

≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
≼-reflexive refl = ≼-reflexivity

Γ≼Γ : ∀ {Γ} → Γ ≼ Γ
Γ≼Γ = ≼-reflexive refl

≼-transitive : Transitive _≼_
≼-transitive ∅≼∅ rel1 = rel1
≼-transitive (keep τ • rel0) (keep .τ • rel1) =
  keep τ • ≼-transitive rel0 rel1
≼-transitive (keep τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (keep τ • rel0) rel1
≼-transitive (drop τ • rel0) (keep .τ • rel1) =
  drop τ • ≼-transitive rel0 rel1
≼-transitive (drop τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (drop τ • rel0) rel1

≼-isPreorder : IsPreorder _≡_ _≼_
≼-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive = ≼-reflexive
  ; trans = ≼-transitive
  }

≼-preorder : Preorder _ _ _
≼-preorder = record
  { Carrier = Context
  ; _≈_ = _≡_
  ; isPreorder = ≼-isPreorder
  }

module ≼-reasoning where
  open import Relation.Binary.PreorderReasoning ≼-preorder public
    renaming
      ( _≈⟨_⟩_ to _≡⟨_⟩_
      ; _∼⟨_⟩_ to _≼⟨_⟩_
      ; _≈⟨⟩_ to _≡⟨⟩_
      )

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x

weaken subctx (foldNat n f z) = {!!}

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

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

⟦ foldNat n f z ⟧Term ρ = {!!}

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = cong₂ (λ x y → x y)

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = ≡-app (weaken-sound t₁ ρ) (weaken-sound t₂ ρ)
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (foldNat n f z) ρ = {!!}

-- Changes to ℕ are replacement Church pairs. The only arguments
-- of conern are `fst` and `snd`, so the Church pairs don't have
-- to be polymorphic.

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

-- Combination as type-indexed family of terms
-- _⊕_ : ∀ {τ Γ} →  TODO: IMPLEMENT ME!! {!!}

-- Replacement-pairs on all types as syntactic sugar

replace_by_ : ∀ {τ Γ} → (old : Term Γ τ) (new : Term Γ τ)
                      → Term Γ (Δ-Type τ)

-- replace n by m = λ f . f n m
-- replace f by g = λ x . λ dx . replace (f x) by (g (x ⊕ dx))
--
-- Remark. Amazingly, weakening is identical to arbitrary
-- legal adjustment of de-Bruijn indices.
replace_by_ {nats} {Γ} old new =
  abs (app (app (var this) (weaken drop-f old)) (weaken drop-f new))
  where drop-f = drop _ • Γ≼Γ
-- Think: the new must compute upon changes...
replace_by_ {τ₁ ⇒ τ₂} old new =
  abs (abs (replace (app (weaken drop! old) (var (that this)))
                 by (app (weaken drop! new) {!!})))
  where drop! = drop (Δ-Type τ₁) • drop τ₁ • Γ≼Γ

-- It is clear that ⟦⊝⟧ exists on the semantic level:
-- there exists an Agda value to describe the change between any
-- two Agda values denoted by terms. If we have (not dependently-
-- typed) arrays, no term denotes the change between two arrays
-- of different lengths. Thus no full abstraction.

⟦derive⟧ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

infixl 6 _⟦⊕⟧_
infixl 6 _⟦⊝⟧_

⟦fst⟧ : ℕ → ℕ → ℕ
⟦snd⟧ : ℕ → ℕ → ℕ

⟦derive⟧ {τ₁ ⇒ τ₂} f = λ v dv → f (v ⟦⊕⟧ dv) ⟦⊝⟧ f v
⟦derive⟧ {nats} n = λ f → f n n

_⟦⊝⟧_ {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → f₁ (v ⟦⊕⟧ dv) ⟦⊝⟧ f₂ v
_⟦⊝⟧_ {nats} m n = λ f → f n m
-- m ⟦⊝⟧ n ::= replace n by m

_⟦⊕⟧_ {τ₁ ⇒ τ₂} f df = λ v → f v ⟦⊕⟧ df v (⟦derive⟧ v)
_⟦⊕⟧_ {nats} n dn = dn ⟦snd⟧

⟦fst⟧ m n = m
⟦snd⟧ m n = n

-- Strong validity!
data ⟦ValidΔ⟧ : {τ : Type} → (v : ⟦ τ ⟧) → (dv : ⟦ Δ-Type τ ⟧) → Set where
  -- Following Pierce's case names `T-Var`, `T-Abs`, `T-App`
  -- with Agda's capitalization convention
  -- generalized to the semantic (value) domain
  v-nat : (n : ℕ) → (dn : (ℕ → ℕ → ℕ) → ℕ) →
          n ≡ dn ⟦fst⟧ →
          ⟦ValidΔ⟧ n dn

  v-fun : {τ₁ τ₂ : Type} →
          (f : ⟦ τ₁ ⇒ τ₂ ⟧) → (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) →
          -- A strong antecedent: f and df map invalid changes to
          -- valid changes! So long as invalid changes exist,
          -- this is NOT satisfied by
          --
          --      f = ⟦ λ x. x ⟧     = identity
          --     df = ⟦ λ x dx. dx ⟧ = ⟦snd⟧,
          --
          -- negating any hope of ⟦ValidΔ⟧ ⟦ t ⟧ ⟦ derive t ⟧.
          (∀ {s ds} → {-ValidΔ s ds →-} ⟦ValidΔ⟧ (f s) (df s ds)) →
          (∀ {s ds} → (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ (f s ⟦⊕⟧ df s ds)) →
          ⟦ValidΔ⟧ f df

absurdity-of-0=1 : 0 ≡ 1 → (∀ {A : Set} → A)
absurdity-of-0=1 ()

it-is-absurd-that : ⟦ValidΔ⟧ {nats} 0 (λ f → f 1 1) → (∀ {A : Set} → A)
it-is-absurd-that (v-nat .0 .(λ f → f 1 1) 0=1) = absurdity-of-0=1 0=1

-- If (λ x dx → dx) is a ⟦ValidΔ⟧ to (λ x → x),
-- then impossible is nothing.
no-way : ⟦ValidΔ⟧ {nats ⇒ nats} (λ x → x) (λ x dx → dx) →
         (∀ {A : Set} → A)
no-way (v-fun .(λ x → x) .(λ x dx → dx) validity correctness) =
  it-is-absurd-that (validity {0} {λ f → f 1 1})

-- Cool lemmas

f⟦⊝⟧f=⟦deriv⟧f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊝⟧ f ≡ ⟦derive⟧ f
f⟦⊝⟧f=⟦deriv⟧f {nats} f = refl
f⟦⊝⟧f=⟦deriv⟧f {τ₁ ⇒ τ₂} f = refl

f⊕[g⊝f]=g : ∀ {τ : Type} (f g : ⟦ τ ⟧) → f ⟦⊕⟧ (g ⟦⊝⟧ f) ≡ g

f⊕Δf=f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊕⟧ (⟦derive⟧ f) ≡ f

f⊕[g⊝f]=g {nats} m n = refl
f⊕[g⊝f]=g {τ₁ ⇒ τ₂} f g = extensionality (λ x →
    begin
      (f ⟦⊕⟧ (g ⟦⊝⟧ f)) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (g (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong₂ _⟦⊕⟧_
            {x = f x} {y = f x} refl
            (cong₂ _⟦⊝⟧_ (cong g (f⊕Δf=f x)) refl) ⟩
      f x ⟦⊕⟧ (g x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (g x) ⟩
      g x
    ∎
  ) where open ≡-Reasoning

f⊕Δf=f {nats} n = refl
f⊕Δf=f {τ₁ ⇒ τ₂} f = extensionality (λ x →
    begin
      (f ⟦⊕⟧ ⟦derive⟧ f) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (f (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong (λ hole → f x ⟦⊕⟧ (f hole ⟦⊝⟧ f x)) (f⊕Δf=f x) ⟩
      f x ⟦⊕⟧ (f x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (f x) ⟩
      f x
    ∎
  ) where open ≡-Reasoning

valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {nats} n dn = n ≡ dn ⟦fst⟧
valid-Δ {τ₁ ⇒ τ₂} f df =
  ∀ (s : ⟦ τ₁ ⟧) (ds : ⟦ Δ-Type τ₁ ⟧) (R[s,ds] : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×              -- (valid-Δ:1)
    (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ f s ⟦⊕⟧ df s ds -- (valid-Δ:2)

R[f,g⊝f] : ∀ {τ} (f g : ⟦ τ ⟧) → valid-Δ {τ} f (g ⟦⊝⟧ f)
R[f,g⊝f] {nats} m n = refl
R[f,g⊝f] {τ₁ ⇒ τ₂} f g = λ x dx R[x,dx] →
  R[f,g⊝f] {τ₂} (f x) (g (x ⟦⊕⟧ dx)) -- (valid-Δ:1)
  , -- tuple constructor
  (begin
    (f ⟦⊕⟧ (g ⟦⊝⟧ f)) (x ⟦⊕⟧ dx)
  ≡⟨ refl ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧
      (g ((x ⟦⊕⟧ dx) ⟦⊕⟧ ⟦derive⟧ (x ⟦⊕⟧ dx)) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ cong (λ hole → f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g hole ⟦⊝⟧ f (x ⟦⊕⟧ dx)))
          (f⊕Δf=f (x ⟦⊕⟧ dx)) ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g (x ⟦⊕⟧ dx) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ f⊕[g⊝f]=g (f (x ⟦⊕⟧ dx)) (g (x ⟦⊕⟧ dx)) ⟩
    g (x ⟦⊕⟧ dx)
  ≡⟨ sym (f⊕[g⊝f]=g (f x) (g (x ⟦⊕⟧ dx))) ⟩
      f x ⟦⊕⟧ (g ⟦⊝⟧ f) x dx
  ∎)
  where open ≡-Reasoning

R[f,Δf] : ∀ {τ} (f : ⟦ τ ⟧) → valid-Δ {τ} f (⟦derive⟧ f)
R[f,Δf] f rewrite sym (f⟦⊝⟧f=⟦deriv⟧f f) = R[f,g⊝f] f f

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ -- push τ, then push Δτ.

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • (keep τ • Γ≼ΔΓ)

-- Data type to hold proofs that environments are valid
data Valid-Δenv : {Γ : Context} (ρ : ⟦ Γ ⟧) (Δρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is its own valid Δ-environment.
  ρ=∅ : Valid-Δenv {∅} ∅ ∅
  -- Induction case: the change introduced therein should be valid,
  -- and the smaller Δ-environment should be valid as well.
  ρ=v•ρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
            {Γ₀ : Context} {ρ₀ : ⟦ Γ₀ ⟧} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
            valid-Δ v dv → Valid-Δenv ρ₀ dρ₀ →
            Valid-Δenv {τ • Γ₀} (v • ρ₀) (dv • v • dρ₀)

-- Data type to hold proofs that a Δ-env is consistent with self
data Consistent-Δenv : {Γ : Context} (dρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is consistent with itself
  dρ=∅ : Consistent-Δenv {∅} ∅
  -- Induction case: the change introduced at top level
  -- should be valid.
  dρ=dv•v•dρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
                 {Γ₀ : Context} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
                 valid-Δ v dv → Consistent-Δenv dρ₀ →
                 Consistent-Δenv {τ • Γ₀} (dv • v • dρ₀)

-- If a Δ-environment is valid for some other environment,
-- then it is also consistent with itself.

valid-Δenv-is-consistent :
   ∀ {Γ : Context} {ρ : ⟦ Γ ⟧} {dρ : ⟦ Δ-Context Γ ⟧} →
    Valid-Δenv ρ dρ → Consistent-Δenv dρ

valid-Δenv-is-consistent ρ=∅ = dρ=∅
valid-Δenv-is-consistent (ρ=v•ρ₀ valid[v,dv] valid[ρ₀,dρ₀]) =
  dρ=dv•v•dρ₀ valid[v,dv] (valid-Δenv-is-consistent valid[ρ₀,dρ₀])

-- finally, update and ignore

update : ∀ {Γ} → (dρ : ⟦ Δ-Context Γ ⟧) → {_ : Consistent-Δenv dρ} → ⟦ Γ ⟧
update {∅} ∅ {dρ=∅} = ∅
update {τ • Γ} (dv • v • dρ) {dρ=dv•v•dρ₀ valid[v,dv] consistent[dρ₀]} =
  (v ⟦⊕⟧ dv) • update dρ {consistent[dρ₀]}

-- Ignorance is bliss (don't have to pass consistency proofs around :D)

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore = ⟦ Γ≼ΔΓ ⟧ -- Using a proof to describe computation

-- Naming scheme follows weakenVar/weaken

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

derive : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

-- derive(n) = λf. f n n
derive (nat n) = abs (app (app (var this) (nat n)) (nat n))

-- derive(x) = dx
derive (var x) = var (deriveVar x)

-- derive(λx. t) = λx. λdx. derive(t)
derive (abs t) = abs (abs (derive t))

-- derive(f s) = derive(f) s derive(s)
derive (app f s) = app (app (derive f) (weaken Γ≼ΔΓ s)) (derive s)

-- derive (foldNat n f z) = ?
derive (foldNat n f z) =  {!!}

-- Extensional equivalence for changes
data as-Δ_is_ext-equiv-to_ :
  ∀ (τ : Type) → (df : ⟦ Δ-Type τ ⟧) → (dg : ⟦ Δ-Type τ ⟧) → Set where
  ext-Δ : ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
          (∀ (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg →
             (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)) →
          as-Δ τ is df ext-equiv-to dg

infix 3 as-Δ_is_ext-equiv-to_

-- Extractor for extensional-equivalence-as-changes:
-- Given a value of the data type holding the proof,
-- returns the proof in applicable form.
--
-- It would not be necessary if such
-- proof-holding types were defined as a function in
-- the first place, say in the manner of `valid-Δ`.
--
extract-Δequiv :
  ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
    as-Δ τ is df ext-equiv-to dg →
    (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg → (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)

extract-Δequiv (ext-Δ proof-method) = proof-method

-- Distribution lemmas of validity over ⟦⊝⟧ and ⟦⊕⟧

application-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v) ≡ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
application-over-⊕-and-⊝ f g df v =
  begin
    f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v
  ≡⟨ cong₂ _⟦⊝⟧_
       (cong₂ _⟦⊕⟧_
         (cong f ((sym (f⊕Δf=f v))))
         (cong₂ df
           (sym (f⊕Δf=f v))
           (cong ⟦derive⟧ (sym (f⊕Δf=f v)))))
       refl ⟩
    f (v ⟦⊕⟧ ⟦derive⟧ v)
    ⟦⊕⟧ df (v ⟦⊕⟧ ⟦derive⟧ v) (⟦derive⟧ (v ⟦⊕⟧ ⟦derive⟧ v))
    ⟦⊝⟧ f v
  ≡⟨ refl ⟩
   (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
  ∎ where open ≡-Reasoning

validity-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    valid-Δ g (f ⟦⊕⟧ df ⟦⊝⟧ f) →
    valid-Δ (g v) (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
validity-over-⊕-and-⊝ f g df v R[g,f⊕df]
  rewrite application-over-⊕-and-⊝ f g df v =
    proj₁ (R[g,f⊕df] v (⟦derive⟧ v) (R[f,Δf] v))

-- diff-apply
df=f⊕df⊝f :
  ∀ {τ} (f : ⟦ τ ⟧) (df : ⟦ Δ-Type τ ⟧) →
    valid-Δ f df → as-Δ τ is df ext-equiv-to f ⟦⊕⟧ df ⟦⊝⟧ f

-- Case nat: this REFL is more obvious to Agda than to a human.
df=f⊕df⊝f {nats} n dn valid-f-df =
  ext-Δ (λ m valid-m-dn valid-rhs → refl)

df=f⊕df⊝f {τ₁ ⇒ τ₂} f df R[f,df] = ext-Δ (
  λ g R[g,df] R[g,f⊕df⊝f] →
    extensionality (λ v →
      begin
        g v ⟦⊕⟧ df v (⟦derive⟧ v)
      ≡⟨ extract-Δequiv
           (df=f⊕df⊝f
             (f v) (df v (⟦derive⟧ v))
             (proj₁ (R[f,df] v (⟦derive⟧ v) (R[f,Δf] v))))
           (g v)
           (proj₁ (R[g,df] v (⟦derive⟧ v) (R[f,Δf] v)))
           (validity-over-⊕-and-⊝ f g df v R[g,f⊕df⊝f]) ⟩
        g v ⟦⊕⟧ (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
      ≡⟨ cong₂ _⟦⊕⟧_
           {x = g v} {y = g v} refl
           (application-over-⊕-and-⊝ f g df v) ⟩
        g v ⟦⊕⟧ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
      ∎
    )
  )
  where open ≡-Reasoning

correctness-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  as-Δ τ is
  ⟦ deriveVar x ⟧ ρ
  ext-equiv-to
  ⟦ x ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ x ⟧ (ignore ρ)

correctness-of-deriveVar {τ • Γ₀} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  this = df=f⊕df⊝f {τ} v dv R[v,dv]

correctness-of-deriveVar {τ₀ • Γ₀} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ₀} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  (that x) = correctness-of-deriveVar ρ x

correctness-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  as-Δ τ is
  ⟦ derive t ⟧ ρ
  ext-equiv-to
  ⟦ t ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ t ⟧ (ignore ρ)

-- Mutually recursive lemma: derivatives are valid
validity-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  valid-Δ (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

validity-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  valid-Δ (⟦ x ⟧ (ignore ρ)) (⟦ deriveVar x ⟧ ρ)

validity-of-deriveVar {τ • Γ} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  this = R[v,dv]

validity-of-deriveVar {τ₀ • Γ} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  (that x) = validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ {consistency} (var x) =
  validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ (nat n) = refl

validity-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs t) = λ v dv R[v,dv] →
    validity-of-derive (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency} t
    , -- tuple constructor
      (begin
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          ⟦ derive t ⟧ (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
      ≡⟨ extract-Δequiv
           (correctness-of-derive
             (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
             {dρ=dv•v•dρ₀ (R[f,Δf] (v ⟦⊕⟧ dv)) consistency}
             t)
           (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
           (validity-of-derive
             (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
             {dρ=dv•v•dρ₀ (R[f,Δf] (v ⟦⊕⟧ dv)) consistency}
             t)
           ((R[f,g⊝f] (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
                     (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                       update ρ {consistency})))) ⟩
         ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                  update ρ {consistency})
           ⟦⊝⟧
           ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
      ≡⟨ f⊕[g⊝f]=g (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
                   (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                          update ρ {consistency})) ⟩
        ⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                  update ρ {consistency})
      ≡⟨ cong ⟦ t ⟧ (cong₂ _•_ (f⊕Δf=f (v ⟦⊕⟧ dv)) refl) ⟩
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})
      ≡⟨ sym (f⊕[g⊝f]=g (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
                        (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency}))) ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})
           ⟦⊝⟧
           ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
      ≡⟨ sym (extract-Δequiv
           (correctness-of-derive
             ((dv • v • ρ))
             {dρ=dv•v•dρ₀ R[v,dv] consistency}
             t)
           (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
           (validity-of-derive
             (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
             t)
           (R[f,g⊝f] (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
                     (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})))) ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧ ⟦ derive t ⟧ (dv • v • ρ)
      ∎)
  where open ≡-Reasoning

validity-of-derive ρ {consistency} (app {τ₁} {τ₂} t₁ t₂)
  = R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧]
  where
    open ≡-Reasoning
    v₁ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁ = ⟦ t₁ ⟧ (ignore ρ)
    v₂ : ⟦ τ₁ ⟧
    v₂ = ⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ

    dv₁ : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    dv₁ = ⟦ derive t₁ ⟧ ρ
    dv₂ : ⟦ Δ-Type τ₁ ⟧
    dv₂ = ⟦ derive t₂ ⟧ ρ

    v₁′ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁′ = ⟦ t₁ ⟧ (update ρ {consistency})
    v₂′ : ⟦ τ₁ ⟧
    v₂′ = ⟦ t₂ ⟧ (update ρ {consistency})

    v₂=old-v₂ : v₂ ≡ ⟦ t₂ ⟧ (ignore ρ)
    v₂=old-v₂ = weaken-sound {subctx = Γ≼ΔΓ} t₂ ρ

    valid-dv₁ : valid-Δ v₁ dv₁
    valid-dv₁ = validity-of-derive ρ {consistency} t₁

    valid-dv₂ : valid-Δ v₂ dv₂
    valid-dv₂ rewrite v₂=old-v₂ =
      validity-of-derive ρ {consistency} t₂

    R[v₁v₂,dv₁v₂dv₂] : valid-Δ (v₁ v₂) (dv₁ v₂ dv₂)
    R[v₁v₂,dv₁v₂dv₂] = proj₁ (valid-dv₁ v₂ dv₂ valid-dv₂)

    ⟦t₁t₂⟧=v₁v₂ : ⟦ app t₁ t₂ ⟧ (ignore ρ) ≡ v₁ v₂
    ⟦t₁t₂⟧=v₁v₂ rewrite (sym v₂=old-v₂) = refl

    ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ : ⟦ derive (app t₁ t₂) ⟧ ρ ≡ dv₁ v₂ dv₂
    ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ = refl

    R[⟦t₁t₂⟧,dv₁v₂dv₂] : valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (dv₁ v₂ dv₂)
    R[⟦t₁t₂⟧,dv₁v₂dv₂] rewrite ⟦t₁t₂⟧=v₁v₂ = R[v₁v₂,dv₁v₂dv₂]

    -- What I want to write:
    {-
        R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] :
          valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (⟦ derive (app t₁ t₂) ⟧ ρ)
        R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] rewrite ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ = R[⟦t₁t₂⟧,dv₁v₂dv₂]
    -}

    -- What I have to write:

    R : {τ : Type} → {v : ⟦ τ ⟧} → {dv₁ dv₂ : ⟦ Δ-Type τ ⟧} →
        dv₁ ≡ dv₂ → valid-Δ v dv₁ → valid-Δ v dv₂

    R {nats} dv₁=dv₂ refl = cong₂ (λ f x → f x) dv₁=dv₂ refl

    --R {τ₁ ⇒ τ₂} dv₁=dv₂ valid-dv₁ rewrite dv₁=dv₂ = {!valid-dv₁!}
    R {τ₁ ⇒ τ₂} {v} {dv₁} {dv₂} dv₁=dv₂ valid-dv₁ =
      λ s ds R[s,ds] →
        R {τ₂} {v s} {dv₁ s ds} {dv₂ s ds}
           (cong₂ (λ f x → f x)
                  (cong₂ (λ f x → f x) dv₁=dv₂ refl) refl)
           (proj₁ (valid-dv₁ s ds R[s,ds]))
        ,
        (begin
          v (s ⟦⊕⟧ ds) ⟦⊕⟧ dv₂ (s ⟦⊕⟧ ds) (⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ cong₂ _⟦⊕⟧_
                 {x = v (s ⟦⊕⟧ ds)} refl
                 (cong₂ (λ f x → f x)
                        (cong₂ (λ f x → f x) (sym dv₁=dv₂) refl) refl) ⟩
          v (s ⟦⊕⟧ ds) ⟦⊕⟧ dv₁ (s ⟦⊕⟧ ds) (⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ sym (proj₂ (valid-dv₁
               (s ⟦⊕⟧ ds)
               (⟦derive⟧ (s ⟦⊕⟧ ds))
               (R[f,Δf] (s ⟦⊕⟧ ds)))) ⟩
          (v ⟦⊕⟧ dv₁) (s ⟦⊕⟧ ds ⟦⊕⟧ ⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ cong (v ⟦⊕⟧ dv₁) (f⊕Δf=f (s ⟦⊕⟧ ds)) ⟩
          (v ⟦⊕⟧ dv₁) (s ⟦⊕⟧ ds)
        ≡⟨ proj₂ (valid-dv₁ s ds R[s,ds]) ⟩
          v s ⟦⊕⟧ dv₁ s ds
        ≡⟨ cong₂ _⟦⊕⟧_
                 {x = v s} refl
                 (cong₂ (λ f x → f x)
                        (cong₂ (λ f x → f x) dv₁=dv₂ refl) refl) ⟩
          v s ⟦⊕⟧ dv₂ s ds
        ∎) where open ≡-Reasoning

    R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] :
      valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (⟦ derive (app t₁ t₂) ⟧ ρ)
    R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] = R ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ R[⟦t₁t₂⟧,dv₁v₂dv₂]

validity-of-derive ρ {consistency} (foldNat n f z) = {!!}

correctness-of-derive ρ (var x) = correctness-of-deriveVar ρ x

correctness-of-derive ρ (nat n) = ext-Δ (λ _ _ _ → refl)

correctness-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs {.τ₁} {.τ₂} t) =
  ext-Δ {τ₁ ⇒ τ₂}
    (λ f R[f,Δt] R[f,t′⊝t] →
      extensionality {⟦ τ₁ ⟧} {λ _ → ⟦ τ₂ ⟧} (λ x →
        begin
          f x ⟦⊕⟧ ⟦ derive t ⟧ (⟦derive⟧ x • x • ρ)
        ≡⟨ extract-Δequiv
            (correctness-of-derive {τ₁ • Γ} {τ₂}
               (⟦derive⟧ x • x • ρ)
               {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency}
               t)
            (f x)
            (proj₁ (R[f,Δt] x (⟦derive⟧ x) (R[f,Δf] x)))
            (proj₁ (R[f,t′⊝t] x (⟦derive⟧ x) (R[f,Δf] x))) ⟩
          f x
          ⟦⊕⟧
          (⟦ t ⟧ (update (⟦derive⟧ x • x • ρ)
                {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency})
          ⟦⊝⟧ ⟦ t ⟧ (x • ⟦ Γ≼ΔΓ ⟧ ρ))
        ∎
  )) where open ≡-Reasoning

correctness-of-derive ρ {consistency} (app {τ₁} {τ₂} {Γ} t₁ t₂) =
  ext-Δ {τ₂}
  (λ f R[f,Δt] R[f,t′⊝t] →
    begin
      f ⟦⊕⟧ ⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ)
    ≡⟨ extract-Δequiv ext-Δ[t₁t₂] f R[f,Δt] R[f,t′⊝t] ⟩
      f ⟦⊕⟧
        (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ))
         ⟦⊝⟧
         ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ)))
    ∎)
  where
    open ≡-Reasoning

    v₁ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁ = ⟦ t₁ ⟧ (ignore ρ)
    v₂ : ⟦ τ₁ ⟧
    v₂ = ⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ

    dv₁ : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    dv₁ = ⟦ derive t₁ ⟧ ρ
    dv₂ : ⟦ Δ-Type τ₁ ⟧
    dv₂ = ⟦ derive t₂ ⟧ ρ

    v₁′ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁′ = ⟦ t₁ ⟧ (update ρ {consistency})
    v₂′ : ⟦ τ₁ ⟧
    v₂′ = ⟦ t₂ ⟧ (update ρ {consistency})

    v₂=old-v₂ : v₂ ≡ ⟦ t₂ ⟧ (ignore ρ)
    v₂=old-v₂ = weaken-sound {subctx = Γ≼ΔΓ} t₂ ρ

    valid-dv₁ : valid-Δ v₁ dv₁
    valid-dv₁ = validity-of-derive ρ {consistency} t₁

    valid-dv₂ : valid-Δ v₂ dv₂
    valid-dv₂ rewrite v₂=old-v₂ =
      validity-of-derive ρ {consistency} t₂

    v₁⊕dv₁=v₁′ : v₁ ⟦⊕⟧ dv₁ ≡ v₁′
    v₁⊕dv₁=v₁′ =
      begin
        v₁ ⟦⊕⟧ dv₁
      ≡⟨ extract-Δequiv
           (correctness-of-derive ρ {consistency} t₁)
           v₁ valid-dv₁ (R[f,g⊝f] v₁ v₁′) ⟩
        v₁ ⟦⊕⟧ (v₁′ ⟦⊝⟧ v₁)
      ≡⟨ f⊕[g⊝f]=g v₁ v₁′ ⟩
        v₁′
      ∎

    -- TODO: remove code duplication.
    v₂⊕dv₂=v₂′ : v₂ ⟦⊕⟧ dv₂ ≡ v₂′
    v₂⊕dv₂=v₂′ rewrite v₂=old-v₂ =
      begin
        old-v₂ ⟦⊕⟧ dv₂
      ≡⟨ extract-Δequiv
           (correctness-of-derive ρ {consistency} t₂)
           old-v₂
           (validity-of-derive ρ {consistency} t₂)
           (R[f,g⊝f] old-v₂ v₂′) ⟩
        old-v₂ ⟦⊕⟧ (v₂′ ⟦⊝⟧ old-v₂)
      ≡⟨ f⊕[g⊝f]=g old-v₂ v₂′ ⟩
        v₂′
      ∎
      where old-v₂ = ⟦ t₂ ⟧ (ignore ρ)

    v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] : v₁′ v₂′ ≡ (v₁ ⟦⊕⟧ dv₁) (v₂ ⟦⊕⟧ dv₂)
    v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] = sym (cong₂ (λ f x → f x) v₁⊕dv₁=v₁′ v₂⊕dv₂=v₂′)

    [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂ :
      (v₁ ⟦⊕⟧ dv₁) (v₂ ⟦⊕⟧ dv₂) ≡ v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂
    [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂ = proj₂ (valid-dv₁ v₂ dv₂ valid-dv₂)

    v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ :
      v₁′ v₂′ ⟦⊝⟧ v₁ v₂ ≡ v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂ ⟦⊝⟧ v₁ v₂
    v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      cong₂ _⟦⊝⟧_
        (trans v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂)
        refl

    R[v₁v₂,dv₁v₂dv₂] : valid-Δ (v₁ v₂) (dv₁ v₂ dv₂)
    R[v₁v₂,dv₁v₂dv₂] = proj₁ (valid-dv₁ v₂ dv₂ valid-dv₂)

    dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ :
      as-Δ τ₂ is dv₁ v₂ dv₂ ext-equiv-to v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂ ⟦⊝⟧ v₁ v₂
    dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      df=f⊕df⊝f (v₁ v₂) (dv₁ v₂ dv₂) R[v₁v₂,dv₁v₂dv₂]

    dv₁v₂dv₂=v₁′v₂′⊝v₁v₂ : as-Δ τ₂ is dv₁ v₂ dv₂ ext-equiv-to v₁′ v₂′ ⟦⊝⟧ v₁ v₂
    dv₁v₂dv₂=v₁′v₂′⊝v₁v₂ rewrite v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂

    ext-Δ[t₁t₂] :
      as-Δ τ₂ is
      ⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ)
      ext-equiv-to
      ⟦ t₁ ⟧ (update ρ {consistency}) (⟦ t₂ ⟧ (update ρ {consistency}))
      ⟦⊝⟧ ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ))
    ext-Δ[t₁t₂] rewrite sym v₂=old-v₂ = dv₁v₂dv₂=v₁′v₂′⊝v₁v₂

correctness-of-derive {Γ} {τ}
  ρ {consistency} (foldNat n f z) = {!!}

correctness-on-closed-terms : ∀ {τ₁ τ₂} →
  ∀ (f : Term ∅ (τ₁ ⇒ τ₂)) →
  ∀ (s : Term ∅ τ₁) (ds : Term ∅ (Δ-Type τ₁))
    {R[v,dv] : valid-Δ (⟦ s ⟧ ∅) (⟦ ds ⟧ ∅)} →
    ⟦ f ⟧ ∅ (⟦ s ⟧ ∅ ⟦⊕⟧ ⟦ ds ⟧ ∅)
    ≡
    ⟦ f ⟧ ∅ (⟦ s ⟧ ∅) ⟦⊕⟧ ⟦ derive f ⟧ ∅ (⟦ s ⟧ ∅) (⟦ ds ⟧ ∅)

correctness-on-closed-terms {τ₁} {τ₂} f s ds {R[v,dv]} =
  begin
    h (v ⟦⊕⟧ dv)
  ≡⟨ cong₂ (λ f x → f x)
           (sym (f⊕[g⊝f]=g h h))
           refl ⟩
    (h ⟦⊕⟧ (h ⟦⊝⟧ h)) (v ⟦⊕⟧ dv)
  ≡⟨ cong₂ (λ f x → f x)
      (sym (extract-Δequiv
        (correctness-of-derive ∅ f)
        h
        (validity-of-derive ∅ {dρ=∅} f)
        (R[f,g⊝f] h h)))
      refl ⟩
    (h ⟦⊕⟧ Δh) (v ⟦⊕⟧ dv)
  ≡⟨ proj₂ (validity-of-derive ∅ {dρ=∅} f v dv R[v,dv]) ⟩
    h v ⟦⊕⟧ Δh v dv
  ∎
  where
    open ≡-Reasoning
    h : ⟦ τ₁ ⇒ τ₂ ⟧
    h = ⟦ f ⟧ ∅
    Δh : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    Δh = ⟦ derive f ⟧ ∅
    v : ⟦ τ₁ ⟧
    v = ⟦ s ⟧ ∅
    dv : ⟦ Δ-Type τ₁ ⟧
    dv = ⟦ ds ⟧ ∅

{-

Checklist of stuff to add when adding syntactic constructs

- derive (symbolic derivation; most important!)
- weaken
- ⟦_⟧Term
- weaken-sound
- validity-of-derive
- correctness-of-derive

-}

module Extension-00 where

open import Data.Product
open import Data.Nat using (ℕ)
open import Data.Unit using (⊤)

open import Relation.Binary.PropositionalEquality

open import Level using
  (zero ; Level ; suc)
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)

postulate extensionality : Extensionality zero zero

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

infixr 5 _⇒_

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

infixr 9 _•_

⟨∅⟩ : ∅ ≡ ∅
⟨∅⟩ = refl

_⟨•⟩_ : ∀ {τ₁ τ₂ Γ₁ Γ₂} → τ₁ ≡ τ₂ → Γ₁ ≡ Γ₂ → τ₁ • Γ₁ ≡ τ₂ • Γ₂
_⟨•⟩_ = cong₂ _•_

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

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

  -- ad-hoc extensions
  foldNat : ∀ {Γ τ} → (n : Term Γ nats) →
                      (f : Term Γ (τ ⇒ τ)) → (z : Term Γ τ)
                    → Term Γ τ

  -- Change to nats = replacement Church pairs
  -- 3 -> 5 ::= λf. f 3 5

infix 8 _≼_

data _≼_ : (Γ₁ Γ₂ : Context) → Set where
  ∅≼∅ : ∅ ≼ ∅
  keep_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → τ • Γ₁ ≼ τ • Γ₂
  drop_•_ : ∀ {Γ₁ Γ₂} → (τ : Type) → Γ₁ ≼ Γ₂ → Γ₁ ≼ τ • Γ₂

≼-reflexivity : Reflexive _≼_
≼-reflexivity {∅} = ∅≼∅
≼-reflexivity {τ • x} = keep τ • ≼-reflexivity

≼-reflexive : ∀ {Γ₁ Γ₂} → Γ₁ ≡ Γ₂ → Γ₁ ≼ Γ₂
≼-reflexive refl = ≼-reflexivity

≼-transitive : Transitive _≼_
≼-transitive ∅≼∅ rel1 = rel1
≼-transitive (keep τ • rel0) (keep .τ • rel1) =
  keep τ • ≼-transitive rel0 rel1
≼-transitive (keep τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (keep τ • rel0) rel1
≼-transitive (drop τ • rel0) (keep .τ • rel1) =
  drop τ • ≼-transitive rel0 rel1
≼-transitive (drop τ • rel0) (drop τ₁ • rel1) =
  drop τ₁ • ≼-transitive (drop τ • rel0) rel1

≼-isPreorder : IsPreorder _≡_ _≼_
≼-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive = ≼-reflexive
  ; trans = ≼-transitive
  }

≼-preorder : Preorder _ _ _
≼-preorder = record
  { Carrier = Context
  ; _≈_ = _≡_
  ; isPreorder = ≼-isPreorder
  }

module ≼-reasoning where
  open import Relation.Binary.PreorderReasoning ≼-preorder public
    renaming
      ( _≈⟨_⟩_ to _≡⟨_⟩_
      ; _∼⟨_⟩_ to _≼⟨_⟩_
      ; _≈⟨⟩_ to _≡⟨⟩_
      )

weakenVar : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Var Γ₁ τ → Var Γ₂ τ
weakenVar ∅≼∅ x = x
weakenVar (keep τ₁ • subctx) this = this
weakenVar (keep τ₁ • subctx) (that y) = that (weakenVar subctx y)
weakenVar (drop τ₁ • subctx) x = that (weakenVar subctx x)

weaken : ∀ {Γ₁ Γ₂ τ} → (subctx : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken subctx (abs {τ} t) = abs (weaken (keep τ • subctx) t)
weaken subctx (app t₁ t₂) = app (weaken subctx t₁) (weaken subctx t₂)
weaken subctx (var x) = var (weakenVar subctx x)
weaken subctx (nat x) = nat x

weaken subctx (foldNat n f z) = {!!}

record Meaning (Syntax : Set) {ℓ : Level} : Set (suc ℓ) where
  constructor
    meaning
  field
    {Semantics} : Set ℓ
    ⟨_⟩⟦_⟧ : Syntax → Semantics

open Meaning {{...}} public
  renaming (⟨_⟩⟦_⟧ to ⟦_⟧)

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

data EmptySet : Set where
  ∅ : EmptySet

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

⟦_⟧Context : Context → Set
⟦ ∅ ⟧Context = EmptySet
⟦ τ • Γ ⟧Context = Bind ⟦ τ ⟧ ⟦ Γ ⟧Context

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

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

meaningOfVar : ∀ {Γ τ} → Meaning (Var Γ τ)
meaningOfVar = meaning ⟦_⟧Var

⟦_⟧≼ : ∀ {Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → ⟦ Γ₂ ⟧ → ⟦ Γ₁ ⟧
⟦ ∅≼∅ ⟧≼ ∅ = ∅
⟦ keep τ • subctx ⟧≼ (v • ρ) = v • ⟦ subctx ⟧≼ ρ
⟦ drop τ • subctx ⟧≼ (v • ρ) = ⟦ subctx ⟧≼ ρ

meaningOf≼ : ∀ {Γ₁ Γ₂} → Meaning (Γ₁ ≼ Γ₂)
meaningOf≼ = meaning ⟦_⟧≼

weakenVar-sound : ∀ {Γ₁ Γ₂ τ} (subctx : Γ₁ ≼ Γ₂) (x : Var Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weakenVar subctx x ⟧ ρ ≡ ⟦ x ⟧ (⟦ subctx ⟧ ρ)
weakenVar-sound ∅≼∅ () ρ
weakenVar-sound (keep τ • subctx) this (v • ρ) = refl
weakenVar-sound (keep τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx x ρ
weakenVar-sound (drop τ • subctx) this (v • ρ) =
  weakenVar-sound subctx this ρ
weakenVar-sound (drop τ • subctx) (that x) (v • ρ) =
  weakenVar-sound subctx (that x) ρ

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

⟦ foldNat n f z ⟧Term ρ = {!!}

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = cong₂ (λ x y → x y)

weaken-sound : ∀ {Γ₁ Γ₂ τ} {subctx : Γ₁ ≼ Γ₂} (t : Term Γ₁ τ) →
  ∀ (ρ : ⟦ Γ₂ ⟧) → ⟦ weaken subctx t ⟧ ρ ≡ ⟦ t ⟧ (⟦ subctx ⟧ ρ)
weaken-sound (abs t) ρ = extensionality (λ v → weaken-sound t (v • ρ))
weaken-sound (app t₁ t₂) ρ = ≡-app (weaken-sound t₁ ρ) (weaken-sound t₂ ρ)
weaken-sound {subctx = subctx} (var x) ρ = weakenVar-sound subctx x ρ
weaken-sound (nat n) ρ = refl

weaken-sound (foldNat n f z) ρ = {!!}

-- Changes to ℕ are replacement Church pairs. The only arguments
-- of conern are `fst` and `snd`, so the Church pairs don't have
-- to be polymorphic.

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

-- It is clear that ⟦⊝⟧ exists on the semantic level:
-- there exists an Agda value to describe the change between any
-- two Agda values denoted by terms. If we have (not dependently-
-- typed) arrays, no term denotes the change between two arrays
-- of different lengths. Thus no full abstraction.

⟦derive⟧ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧

infixl 6 _⟦⊕⟧_
infixl 6 _⟦⊝⟧_

⟦fst⟧ : ℕ → ℕ → ℕ
⟦snd⟧ : ℕ → ℕ → ℕ

⟦derive⟧ {τ₁ ⇒ τ₂} f = λ v dv → f (v ⟦⊕⟧ dv) ⟦⊝⟧ f v
⟦derive⟧ {nats} n = λ f → f n n

_⟦⊝⟧_ {τ₁ ⇒ τ₂} f₁ f₂ = λ v dv → f₁ (v ⟦⊕⟧ dv) ⟦⊝⟧ f₂ v
_⟦⊝⟧_ {nats} m n = λ f → f n m
-- m ⟦⊝⟧ n ::= replace n by m

_⟦⊕⟧_ {τ₁ ⇒ τ₂} f df = λ v → f v ⟦⊕⟧ df v (⟦derive⟧ v)
_⟦⊕⟧_ {nats} n dn = dn ⟦snd⟧

⟦fst⟧ m n = m
⟦snd⟧ m n = n

-- Strong validity!
data ⟦ValidΔ⟧ : {τ : Type} → (v : ⟦ τ ⟧) → (dv : ⟦ Δ-Type τ ⟧) → Set where
  -- Following Pierce's case names `T-Var`, `T-Abs`, `T-App`
  -- with Agda's capitalization convention
  -- generalized to the semantic (value) domain
  v-nat : (n : ℕ) → (dn : (ℕ → ℕ → ℕ) → ℕ) →
          n ≡ dn ⟦fst⟧ →
          ⟦ValidΔ⟧ n dn

  v-fun : {τ₁ τ₂ : Type} →
          (f : ⟦ τ₁ ⇒ τ₂ ⟧) → (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) →
          -- A strong antecedent: f and df map invalid changes to
          -- valid changes! So long as invalid changes exist,
          -- this is NOT satisfied by
          --
          --      f = ⟦ λ x. x ⟧     = identity
          --     df = ⟦ λ x dx. dx ⟧ = ⟦snd⟧,
          --
          -- negating any hope of ⟦ValidΔ⟧ ⟦ t ⟧ ⟦ derive t ⟧.
          (∀ {s ds} → {-ValidΔ s ds →-} ⟦ValidΔ⟧ (f s) (df s ds)) →
          (∀ {s ds} → (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ (f s ⟦⊕⟧ df s ds)) →
          ⟦ValidΔ⟧ f df

absurdity-of-0=1 : 0 ≡ 1 → (∀ {A : Set} → A)
absurdity-of-0=1 ()

it-is-absurd-that : ⟦ValidΔ⟧ {nats} 0 (λ f → f 1 1) → (∀ {A : Set} → A)
it-is-absurd-that (v-nat .0 .(λ f → f 1 1) 0=1) = absurdity-of-0=1 0=1

-- If (λ x dx → dx) is a ⟦ValidΔ⟧ to (λ x → x),
-- then impossible is nothing.
no-way : ⟦ValidΔ⟧ {nats ⇒ nats} (λ x → x) (λ x dx → dx) →
         (∀ {A : Set} → A)
no-way (v-fun .(λ x → x) .(λ x dx → dx) validity correctness) =
  it-is-absurd-that (validity {0} {λ f → f 1 1})

-- Cool lemmas

f⟦⊝⟧f=⟦deriv⟧f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊝⟧ f ≡ ⟦derive⟧ f
f⟦⊝⟧f=⟦deriv⟧f {nats} f = refl
f⟦⊝⟧f=⟦deriv⟧f {τ₁ ⇒ τ₂} f = refl

f⊕[g⊝f]=g : ∀ {τ : Type} (f g : ⟦ τ ⟧) → f ⟦⊕⟧ (g ⟦⊝⟧ f) ≡ g

f⊕Δf=f : ∀ {τ : Type} (f : ⟦ τ ⟧) → f ⟦⊕⟧ (⟦derive⟧ f) ≡ f

f⊕[g⊝f]=g {nats} m n = refl
f⊕[g⊝f]=g {τ₁ ⇒ τ₂} f g = extensionality (λ x →
    begin
      (f ⟦⊕⟧ (g ⟦⊝⟧ f)) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (g (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong₂ _⟦⊕⟧_
            {x = f x} {y = f x} refl
            (cong₂ _⟦⊝⟧_ (cong g (f⊕Δf=f x)) refl) ⟩
      f x ⟦⊕⟧ (g x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (g x) ⟩
      g x
    ∎
  ) where open ≡-Reasoning

f⊕Δf=f {nats} n = refl
f⊕Δf=f {τ₁ ⇒ τ₂} f = extensionality (λ x →
    begin
      (f ⟦⊕⟧ ⟦derive⟧ f) x
    ≡⟨ refl ⟩
      f x ⟦⊕⟧ (f (x ⟦⊕⟧ ⟦derive⟧ x) ⟦⊝⟧ f x)
    ≡⟨ cong (λ hole → f x ⟦⊕⟧ (f hole ⟦⊝⟧ f x)) (f⊕Δf=f x) ⟩
      f x ⟦⊕⟧ (f x ⟦⊝⟧ f x)
    ≡⟨ f⊕[g⊝f]=g (f x) (f x) ⟩
      f x
    ∎
  ) where open ≡-Reasoning

valid-Δ : {τ : Type} → ⟦ τ ⟧ → ⟦ Δ-Type τ ⟧ → Set
valid-Δ {nats} n dn = n ≡ dn ⟦fst⟧
valid-Δ {τ₁ ⇒ τ₂} f df =
  ∀ (s : ⟦ τ₁ ⟧) (ds : ⟦ Δ-Type τ₁ ⟧) (R[s,ds] : valid-Δ s ds) →
    valid-Δ (f s) (df s ds) ×              -- (valid-Δ:1)
    (f ⟦⊕⟧ df) (s ⟦⊕⟧ ds) ≡ f s ⟦⊕⟧ df s ds -- (valid-Δ:2)

R[f,g⊝f] : ∀ {τ} (f g : ⟦ τ ⟧) → valid-Δ {τ} f (g ⟦⊝⟧ f)
R[f,g⊝f] {nats} m n = refl
R[f,g⊝f] {τ₁ ⇒ τ₂} f g = λ x dx R[x,dx] →
  R[f,g⊝f] {τ₂} (f x) (g (x ⟦⊕⟧ dx)) -- (valid-Δ:1)
  , -- tuple constructor
  (begin
    (f ⟦⊕⟧ (g ⟦⊝⟧ f)) (x ⟦⊕⟧ dx)
  ≡⟨ refl ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧
      (g ((x ⟦⊕⟧ dx) ⟦⊕⟧ ⟦derive⟧ (x ⟦⊕⟧ dx)) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ cong (λ hole → f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g hole ⟦⊝⟧ f (x ⟦⊕⟧ dx)))
          (f⊕Δf=f (x ⟦⊕⟧ dx)) ⟩
    f (x ⟦⊕⟧ dx) ⟦⊕⟧ (g (x ⟦⊕⟧ dx) ⟦⊝⟧ f (x ⟦⊕⟧ dx))
  ≡⟨ f⊕[g⊝f]=g (f (x ⟦⊕⟧ dx)) (g (x ⟦⊕⟧ dx)) ⟩
    g (x ⟦⊕⟧ dx)
  ≡⟨ sym (f⊕[g⊝f]=g (f x) (g (x ⟦⊕⟧ dx))) ⟩
      f x ⟦⊕⟧ (g ⟦⊝⟧ f) x dx
  ∎)
  where open ≡-Reasoning

R[f,Δf] : ∀ {τ} (f : ⟦ τ ⟧) → valid-Δ {τ} f (⟦derive⟧ f)
R[f,Δf] f rewrite sym (f⟦⊝⟧f=⟦deriv⟧f f) = R[f,g⊝f] f f

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • τ • Δ-Context Γ -- push τ, then push Δτ.

Γ≼ΔΓ : ∀ {Γ} → Γ ≼ Δ-Context Γ
Γ≼ΔΓ {∅} = ∅≼∅
Γ≼ΔΓ {τ • Γ} = drop Δ-Type τ • (keep τ • Γ≼ΔΓ)

-- Data type to hold proofs that environments are valid
data Valid-Δenv : {Γ : Context} (ρ : ⟦ Γ ⟧) (Δρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is its own valid Δ-environment.
  ρ=∅ : Valid-Δenv {∅} ∅ ∅
  -- Induction case: the change introduced therein should be valid,
  -- and the smaller Δ-environment should be valid as well.
  ρ=v•ρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
            {Γ₀ : Context} {ρ₀ : ⟦ Γ₀ ⟧} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
            valid-Δ v dv → Valid-Δenv ρ₀ dρ₀ →
            Valid-Δenv {τ • Γ₀} (v • ρ₀) (dv • v • dρ₀)

-- Data type to hold proofs that a Δ-env is consistent with self
data Consistent-Δenv : {Γ : Context} (dρ : ⟦ Δ-Context Γ ⟧) → Set
 where
  -- Base case: the empty environment is consistent with itself
  dρ=∅ : Consistent-Δenv {∅} ∅
  -- Induction case: the change introduced at top level
  -- should be valid.
  dρ=dv•v•dρ₀ : ∀ {τ : Type} {v : ⟦ τ ⟧} {dv : ⟦ Δ-Type τ ⟧}
                 {Γ₀ : Context} {dρ₀ : ⟦ Δ-Context Γ₀ ⟧} →
                 valid-Δ v dv → Consistent-Δenv dρ₀ →
                 Consistent-Δenv {τ • Γ₀} (dv • v • dρ₀)

-- If a Δ-environment is valid for some other environment,
-- then it is also consistent with itself.

valid-Δenv-is-consistent :
   ∀ {Γ : Context} {ρ : ⟦ Γ ⟧} {dρ : ⟦ Δ-Context Γ ⟧} →
    Valid-Δenv ρ dρ → Consistent-Δenv dρ

valid-Δenv-is-consistent ρ=∅ = dρ=∅
valid-Δenv-is-consistent (ρ=v•ρ₀ valid[v,dv] valid[ρ₀,dρ₀]) =
  dρ=dv•v•dρ₀ valid[v,dv] (valid-Δenv-is-consistent valid[ρ₀,dρ₀])

-- finally, update and ignore

update : ∀ {Γ} → (dρ : ⟦ Δ-Context Γ ⟧) → {_ : Consistent-Δenv dρ} → ⟦ Γ ⟧
update {∅} ∅ {dρ=∅} = ∅
update {τ • Γ} (dv • v • dρ) {dρ=dv•v•dρ₀ valid[v,dv] consistent[dρ₀]} =
  (v ⟦⊕⟧ dv) • update dρ {consistent[dρ₀]}

-- Ignorance is bliss (don't have to pass consistency proofs around :D)

ignore : ∀ {Γ} → ⟦ Δ-Context Γ ⟧ → ⟦ Γ ⟧
ignore = ⟦ Γ≼ΔΓ ⟧ -- Using a proof to describe computation

-- Naming scheme follows weakenVar/weaken

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

derive : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)

-- derive(n) = λf. f n n
derive (nat n) = abs (app (app (var this) (nat n)) (nat n))

-- derive(x) = dx
derive (var x) = var (deriveVar x)

-- derive(λx. t) = λx. λdx. derive(t)
derive (abs t) = abs (abs (derive t))

-- derive(f s) = derive(f) s derive(s)
derive (app f s) = app (app (derive f) (weaken Γ≼ΔΓ s)) (derive s)

-- derive (foldNat f n z) =
derive (foldNat f n z) =  {!!}

-- Extensional equivalence for changes
data as-Δ_is_ext-equiv-to_ :
  ∀ (τ : Type) → (df : ⟦ Δ-Type τ ⟧) → (dg : ⟦ Δ-Type τ ⟧) → Set where
  ext-Δ : ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
          (∀ (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg →
             (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)) →
          as-Δ τ is df ext-equiv-to dg

infix 3 as-Δ_is_ext-equiv-to_

-- Extractor for extensional-equivalence-as-changes:
-- Given a value of the data type holding the proof,
-- returns the proof in applicable form.
--
-- It would not be necessary if such
-- proof-holding types were defined as a function in
-- the first place, say in the manner of `valid-Δ`.
--
extract-Δequiv :
  ∀ {τ : Type} {df dg : ⟦ Δ-Type τ ⟧} →
    as-Δ τ is df ext-equiv-to dg →
    (f : ⟦ τ ⟧) → valid-Δ f df → valid-Δ f dg → (f ⟦⊕⟧ df) ≡ (f ⟦⊕⟧ dg)

extract-Δequiv (ext-Δ proof-method) = proof-method

-- Distribution lemmas of validity over ⟦⊝⟧ and ⟦⊕⟧

application-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v) ≡ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
application-over-⊕-and-⊝ f g df v =
  begin
    f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v
  ≡⟨ cong₂ _⟦⊝⟧_
       (cong₂ _⟦⊕⟧_
         (cong f ((sym (f⊕Δf=f v))))
         (cong₂ df
           (sym (f⊕Δf=f v))
           (cong ⟦derive⟧ (sym (f⊕Δf=f v)))))
       refl ⟩
    f (v ⟦⊕⟧ ⟦derive⟧ v)
    ⟦⊕⟧ df (v ⟦⊕⟧ ⟦derive⟧ v) (⟦derive⟧ (v ⟦⊕⟧ ⟦derive⟧ v))
    ⟦⊝⟧ f v
  ≡⟨ refl ⟩
   (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
  ∎ where open ≡-Reasoning

validity-over-⊕-and-⊝ :
  ∀ {τ₁ τ₂ : Type}
    (f g : ⟦ τ₁ ⇒ τ₂ ⟧) (df : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧) (v : ⟦ τ₁ ⟧) →
    valid-Δ g (f ⟦⊕⟧ df ⟦⊝⟧ f) →
    valid-Δ (g v) (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
validity-over-⊕-and-⊝ f g df v R[g,f⊕df]
  rewrite application-over-⊕-and-⊝ f g df v =
    proj₁ (R[g,f⊕df] v (⟦derive⟧ v) (R[f,Δf] v))

-- diff-apply
df=f⊕df⊝f :
  ∀ {τ} (f : ⟦ τ ⟧) (df : ⟦ Δ-Type τ ⟧) →
    valid-Δ f df → as-Δ τ is df ext-equiv-to f ⟦⊕⟧ df ⟦⊝⟧ f

-- Case nat: this REFL is more obvious to Agda than to a human.
df=f⊕df⊝f {nats} n dn valid-f-df =
  ext-Δ (λ m valid-m-dn valid-rhs → refl)

df=f⊕df⊝f {τ₁ ⇒ τ₂} f df R[f,df] = ext-Δ (
  λ g R[g,df] R[g,f⊕df⊝f] →
    extensionality (λ v →
      begin
        g v ⟦⊕⟧ df v (⟦derive⟧ v)
      ≡⟨ extract-Δequiv
           (df=f⊕df⊝f
             (f v) (df v (⟦derive⟧ v))
             (proj₁ (R[f,df] v (⟦derive⟧ v) (R[f,Δf] v))))
           (g v)
           (proj₁ (R[g,df] v (⟦derive⟧ v) (R[f,Δf] v)))
           (validity-over-⊕-and-⊝ f g df v R[g,f⊕df⊝f]) ⟩
        g v ⟦⊕⟧ (f v ⟦⊕⟧ df v (⟦derive⟧ v) ⟦⊝⟧ f v)
      ≡⟨ cong₂ _⟦⊕⟧_
           {x = g v} {y = g v} refl
           (application-over-⊕-and-⊝ f g df v) ⟩
        g v ⟦⊕⟧ (f ⟦⊕⟧ df ⟦⊝⟧ f) v (⟦derive⟧ v)
      ∎
    )
  )
  where open ≡-Reasoning

correctness-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  as-Δ τ is
  ⟦ deriveVar x ⟧ ρ
  ext-equiv-to
  ⟦ x ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ x ⟧ (ignore ρ)

correctness-of-deriveVar {τ • Γ₀} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  this = df=f⊕df⊝f {τ} v dv R[v,dv]

correctness-of-deriveVar {τ₀ • Γ₀} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ {.τ₀} {.v} {.dv} {.Γ₀} {.ρ} R[v,dv] _}
  (that x) = correctness-of-deriveVar ρ x

correctness-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  as-Δ τ is
  ⟦ derive t ⟧ ρ
  ext-equiv-to
  ⟦ t ⟧ (update ρ {consistency}) ⟦⊝⟧ ⟦ t ⟧ (ignore ρ)

-- Mutually recursive lemma: derivatives are valid
validity-of-derive : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (t : Term Γ τ) →
  valid-Δ (⟦ t ⟧ (ignore ρ)) (⟦ derive t ⟧ ρ)

validity-of-deriveVar : ∀ {Γ τ} →
  ∀ (ρ : ⟦ Δ-Context Γ ⟧) {consistency : Consistent-Δenv ρ} →
  ∀ (x : Var Γ τ) →
  valid-Δ (⟦ x ⟧ (ignore ρ)) (⟦ deriveVar x ⟧ ρ)

validity-of-deriveVar {τ • Γ} {.τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  this = R[v,dv]

validity-of-deriveVar {τ₀ • Γ} {τ}
  (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
  (that x) = validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ {consistency} (var x) =
  validity-of-deriveVar ρ {consistency} x

validity-of-derive ρ (nat n) = refl

validity-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs t) = λ v dv R[v,dv] →
    validity-of-derive (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency} t
    , -- tuple constructor
      (begin
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          ⟦ derive t ⟧ (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
      ≡⟨ extract-Δequiv
           (correctness-of-derive
             (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
             {dρ=dv•v•dρ₀ (R[f,Δf] (v ⟦⊕⟧ dv)) consistency}
             t)
           (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
           (validity-of-derive
             (⟦derive⟧ (v ⟦⊕⟧ dv) • (v ⟦⊕⟧ dv) • ρ)
             {dρ=dv•v•dρ₀ (R[f,Δf] (v ⟦⊕⟧ dv)) consistency}
             t)
           ((R[f,g⊝f] (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
                     (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                       update ρ {consistency})))) ⟩
         ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                  update ρ {consistency})
           ⟦⊝⟧
           ⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
      ≡⟨ f⊕[g⊝f]=g (⟦ t ⟧ ((v ⟦⊕⟧ dv) • ⟦ Γ≼ΔΓ ⟧ ρ))
                   (⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                          update ρ {consistency})) ⟩
        ⟦ t ⟧ ((v ⟦⊕⟧ dv ⟦⊕⟧ (⟦derive⟧ (v ⟦⊕⟧ dv))) •
                  update ρ {consistency})
      ≡⟨ cong ⟦ t ⟧ (cong₂ _•_ (f⊕Δf=f (v ⟦⊕⟧ dv)) refl) ⟩
        ⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})
      ≡⟨ sym (f⊕[g⊝f]=g (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
                        (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency}))) ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧
          (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})
           ⟦⊝⟧
           ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
      ≡⟨ sym (extract-Δequiv
           (correctness-of-derive
             ((dv • v • ρ))
             {dρ=dv•v•dρ₀ R[v,dv] consistency}
             t)
           (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
           (validity-of-derive
             (dv • v • ρ) {dρ=dv•v•dρ₀ R[v,dv] consistency}
             t)
           (R[f,g⊝f] (⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ))
                     (⟦ t ⟧ ((v ⟦⊕⟧ dv) • update ρ {consistency})))) ⟩
        ⟦ t ⟧ (v • ⟦ Γ≼ΔΓ ⟧ ρ) ⟦⊕⟧ ⟦ derive t ⟧ (dv • v • ρ)
      ∎)
  where open ≡-Reasoning

validity-of-derive ρ {consistency} (app {τ₁} {τ₂} t₁ t₂)
  = R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧]
  where
    open ≡-Reasoning
    v₁ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁ = ⟦ t₁ ⟧ (ignore ρ)
    v₂ : ⟦ τ₁ ⟧
    v₂ = ⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ

    dv₁ : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    dv₁ = ⟦ derive t₁ ⟧ ρ
    dv₂ : ⟦ Δ-Type τ₁ ⟧
    dv₂ = ⟦ derive t₂ ⟧ ρ

    v₁′ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁′ = ⟦ t₁ ⟧ (update ρ {consistency})
    v₂′ : ⟦ τ₁ ⟧
    v₂′ = ⟦ t₂ ⟧ (update ρ {consistency})

    v₂=old-v₂ : v₂ ≡ ⟦ t₂ ⟧ (ignore ρ)
    v₂=old-v₂ = weaken-sound {subctx = Γ≼ΔΓ} t₂ ρ

    valid-dv₁ : valid-Δ v₁ dv₁
    valid-dv₁ = validity-of-derive ρ {consistency} t₁

    valid-dv₂ : valid-Δ v₂ dv₂
    valid-dv₂ rewrite v₂=old-v₂ =
      validity-of-derive ρ {consistency} t₂

    R[v₁v₂,dv₁v₂dv₂] : valid-Δ (v₁ v₂) (dv₁ v₂ dv₂)
    R[v₁v₂,dv₁v₂dv₂] = proj₁ (valid-dv₁ v₂ dv₂ valid-dv₂)

    ⟦t₁t₂⟧=v₁v₂ : ⟦ app t₁ t₂ ⟧ (ignore ρ) ≡ v₁ v₂
    ⟦t₁t₂⟧=v₁v₂ rewrite (sym v₂=old-v₂) = refl

    ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ : ⟦ derive (app t₁ t₂) ⟧ ρ ≡ dv₁ v₂ dv₂
    ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ = refl

    R[⟦t₁t₂⟧,dv₁v₂dv₂] : valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (dv₁ v₂ dv₂)
    R[⟦t₁t₂⟧,dv₁v₂dv₂] rewrite ⟦t₁t₂⟧=v₁v₂ = R[v₁v₂,dv₁v₂dv₂]

    -- What I want to write:
    {-
        R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] :
          valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (⟦ derive (app t₁ t₂) ⟧ ρ)
        R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] rewrite ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ = R[⟦t₁t₂⟧,dv₁v₂dv₂]
    -}

    -- What I have to write:

    R : {τ : Type} → {v : ⟦ τ ⟧} → {dv₁ dv₂ : ⟦ Δ-Type τ ⟧} →
        dv₁ ≡ dv₂ → valid-Δ v dv₁ → valid-Δ v dv₂

    R {nats} dv₁=dv₂ refl = cong₂ (λ f x → f x) dv₁=dv₂ refl

    --R {τ₁ ⇒ τ₂} dv₁=dv₂ valid-dv₁ rewrite dv₁=dv₂ = {!valid-dv₁!}
    R {τ₁ ⇒ τ₂} {v} {dv₁} {dv₂} dv₁=dv₂ valid-dv₁ =
      λ s ds R[s,ds] →
        R {τ₂} {v s} {dv₁ s ds} {dv₂ s ds}
           (cong₂ (λ f x → f x)
                  (cong₂ (λ f x → f x) dv₁=dv₂ refl) refl)
           (proj₁ (valid-dv₁ s ds R[s,ds]))
        ,
        (begin
          v (s ⟦⊕⟧ ds) ⟦⊕⟧ dv₂ (s ⟦⊕⟧ ds) (⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ cong₂ _⟦⊕⟧_
                 {x = v (s ⟦⊕⟧ ds)} refl
                 (cong₂ (λ f x → f x)
                        (cong₂ (λ f x → f x) (sym dv₁=dv₂) refl) refl) ⟩
          v (s ⟦⊕⟧ ds) ⟦⊕⟧ dv₁ (s ⟦⊕⟧ ds) (⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ sym (proj₂ (valid-dv₁
               (s ⟦⊕⟧ ds)
               (⟦derive⟧ (s ⟦⊕⟧ ds))
               (R[f,Δf] (s ⟦⊕⟧ ds)))) ⟩
          (v ⟦⊕⟧ dv₁) (s ⟦⊕⟧ ds ⟦⊕⟧ ⟦derive⟧ (s ⟦⊕⟧ ds))
        ≡⟨ cong (v ⟦⊕⟧ dv₁) (f⊕Δf=f (s ⟦⊕⟧ ds)) ⟩
          (v ⟦⊕⟧ dv₁) (s ⟦⊕⟧ ds)
        ≡⟨ proj₂ (valid-dv₁ s ds R[s,ds]) ⟩
          v s ⟦⊕⟧ dv₁ s ds
        ≡⟨ cong₂ _⟦⊕⟧_
                 {x = v s} refl
                 (cong₂ (λ f x → f x)
                        (cong₂ (λ f x → f x) dv₁=dv₂ refl) refl) ⟩
          v s ⟦⊕⟧ dv₂ s ds
        ∎) where open ≡-Reasoning

    R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] :
      valid-Δ (⟦ app t₁ t₂ ⟧ (ignore ρ)) (⟦ derive (app t₁ t₂) ⟧ ρ)
    R[⟦t₁t₂⟧,⟦Δ[t₁t₂]⟧] = R ⟦Δ[t₁t₂]⟧=dv₁v₂dv₂ R[⟦t₁t₂⟧,dv₁v₂dv₂]

validity-of-derive ρ {consistency} (foldNat n f z) = {!!}

correctness-of-derive ρ (var x) = correctness-of-deriveVar ρ x

correctness-of-derive ρ (nat n) = ext-Δ (λ _ _ _ → refl)

correctness-of-derive {Γ} {τ₁ ⇒ τ₂}
  ρ {consistency} (abs {.τ₁} {.τ₂} t) =
  ext-Δ {τ₁ ⇒ τ₂}
    (λ f R[f,Δt] R[f,t′⊝t] →
      extensionality {⟦ τ₁ ⟧} {λ _ → ⟦ τ₂ ⟧} (λ x →
        begin
          f x ⟦⊕⟧ ⟦ derive t ⟧ (⟦derive⟧ x • x • ρ)
        ≡⟨ extract-Δequiv
            (correctness-of-derive {τ₁ • Γ} {τ₂}
               (⟦derive⟧ x • x • ρ)
               {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency}
               t)
            (f x)
            (proj₁ (R[f,Δt] x (⟦derive⟧ x) (R[f,Δf] x)))
            (proj₁ (R[f,t′⊝t] x (⟦derive⟧ x) (R[f,Δf] x))) ⟩
          f x
          ⟦⊕⟧
          (⟦ t ⟧ (update (⟦derive⟧ x • x • ρ)
                {dρ=dv•v•dρ₀ (R[f,Δf] x) consistency})
          ⟦⊝⟧ ⟦ t ⟧ (x • ⟦ Γ≼ΔΓ ⟧ ρ))
        ∎
  )) where open ≡-Reasoning

correctness-of-derive ρ {consistency} (app {τ₁} {τ₂} {Γ} t₁ t₂) =
  ext-Δ {τ₂}
  (λ f R[f,Δt] R[f,t′⊝t] →
    begin
      f ⟦⊕⟧ ⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ)
    ≡⟨ extract-Δequiv ext-Δ[t₁t₂] f R[f,Δt] R[f,t′⊝t] ⟩
      f ⟦⊕⟧
        (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ))
         ⟦⊝⟧
         ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ)))
    ∎)
  where
    open ≡-Reasoning

    v₁ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁ = ⟦ t₁ ⟧ (ignore ρ)
    v₂ : ⟦ τ₁ ⟧
    v₂ = ⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ

    dv₁ : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    dv₁ = ⟦ derive t₁ ⟧ ρ
    dv₂ : ⟦ Δ-Type τ₁ ⟧
    dv₂ = ⟦ derive t₂ ⟧ ρ

    v₁′ : ⟦ τ₁ ⇒ τ₂ ⟧
    v₁′ = ⟦ t₁ ⟧ (update ρ {consistency})
    v₂′ : ⟦ τ₁ ⟧
    v₂′ = ⟦ t₂ ⟧ (update ρ {consistency})

    v₂=old-v₂ : v₂ ≡ ⟦ t₂ ⟧ (ignore ρ)
    v₂=old-v₂ = weaken-sound {subctx = Γ≼ΔΓ} t₂ ρ

    valid-dv₁ : valid-Δ v₁ dv₁
    valid-dv₁ = validity-of-derive ρ {consistency} t₁

    valid-dv₂ : valid-Δ v₂ dv₂
    valid-dv₂ rewrite v₂=old-v₂ =
      validity-of-derive ρ {consistency} t₂

    v₁⊕dv₁=v₁′ : v₁ ⟦⊕⟧ dv₁ ≡ v₁′
    v₁⊕dv₁=v₁′ =
      begin
        v₁ ⟦⊕⟧ dv₁
      ≡⟨ extract-Δequiv
           (correctness-of-derive ρ {consistency} t₁)
           v₁ valid-dv₁ (R[f,g⊝f] v₁ v₁′) ⟩
        v₁ ⟦⊕⟧ (v₁′ ⟦⊝⟧ v₁)
      ≡⟨ f⊕[g⊝f]=g v₁ v₁′ ⟩
        v₁′
      ∎

    -- TODO: remove code duplication.
    v₂⊕dv₂=v₂′ : v₂ ⟦⊕⟧ dv₂ ≡ v₂′
    v₂⊕dv₂=v₂′ rewrite v₂=old-v₂ =
      begin
        old-v₂ ⟦⊕⟧ dv₂
      ≡⟨ extract-Δequiv
           (correctness-of-derive ρ {consistency} t₂)
           old-v₂
           (validity-of-derive ρ {consistency} t₂)
           (R[f,g⊝f] old-v₂ v₂′) ⟩
        old-v₂ ⟦⊕⟧ (v₂′ ⟦⊝⟧ old-v₂)
      ≡⟨ f⊕[g⊝f]=g old-v₂ v₂′ ⟩
        v₂′
      ∎
      where old-v₂ = ⟦ t₂ ⟧ (ignore ρ)

    v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] : v₁′ v₂′ ≡ (v₁ ⟦⊕⟧ dv₁) (v₂ ⟦⊕⟧ dv₂)
    v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] = sym (cong₂ (λ f x → f x) v₁⊕dv₁=v₁′ v₂⊕dv₂=v₂′)

    [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂ :
      (v₁ ⟦⊕⟧ dv₁) (v₂ ⟦⊕⟧ dv₂) ≡ v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂
    [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂ = proj₂ (valid-dv₁ v₂ dv₂ valid-dv₂)

    v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ :
      v₁′ v₂′ ⟦⊝⟧ v₁ v₂ ≡ v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂ ⟦⊝⟧ v₁ v₂
    v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      cong₂ _⟦⊝⟧_
        (trans v₁′v₂′=[v₁⊕dv₁][v₂⊕dv₂] [v₁⊕dv₁][v₂⊕dv₂]=v₁v₂⊕dv₁v₂dv₂)
        refl

    R[v₁v₂,dv₁v₂dv₂] : valid-Δ (v₁ v₂) (dv₁ v₂ dv₂)
    R[v₁v₂,dv₁v₂dv₂] = proj₁ (valid-dv₁ v₂ dv₂ valid-dv₂)

    dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ :
      as-Δ τ₂ is dv₁ v₂ dv₂ ext-equiv-to v₁ v₂ ⟦⊕⟧ dv₁ v₂ dv₂ ⟦⊝⟧ v₁ v₂
    dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      df=f⊕df⊝f (v₁ v₂) (dv₁ v₂ dv₂) R[v₁v₂,dv₁v₂dv₂]

    dv₁v₂dv₂=v₁′v₂′⊝v₁v₂ : as-Δ τ₂ is dv₁ v₂ dv₂ ext-equiv-to v₁′ v₂′ ⟦⊝⟧ v₁ v₂
    dv₁v₂dv₂=v₁′v₂′⊝v₁v₂ rewrite v₁′v₂′⊝v₁v₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂ =
      dv₁v₂dv₂=v₁v₂⊕dv₁v₂dv₂⊝v₁v₂

    ext-Δ[t₁t₂] :
      as-Δ τ₂ is
      ⟦ derive t₁ ⟧ ρ (⟦ weaken Γ≼ΔΓ t₂ ⟧ ρ) (⟦ derive t₂ ⟧ ρ)
      ext-equiv-to
      ⟦ t₁ ⟧ (update ρ {consistency}) (⟦ t₂ ⟧ (update ρ {consistency}))
      ⟦⊝⟧ ⟦ t₁ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ) (⟦ t₂ ⟧ (⟦ Γ≼ΔΓ ⟧ ρ))
    ext-Δ[t₁t₂] rewrite sym v₂=old-v₂ = dv₁v₂dv₂=v₁′v₂′⊝v₁v₂

correctness-of-derive {Γ} {τ}
  ρ {consistency} (foldNat n f z) = {!!}

correctness-on-closed-terms : ∀ {τ₁ τ₂} →
  ∀ (f : Term ∅ (τ₁ ⇒ τ₂)) →
  ∀ (s : Term ∅ τ₁) (ds : Term ∅ (Δ-Type τ₁))
    {R[v,dv] : valid-Δ (⟦ s ⟧ ∅) (⟦ ds ⟧ ∅)} →
    ⟦ f ⟧ ∅ (⟦ s ⟧ ∅ ⟦⊕⟧ ⟦ ds ⟧ ∅)
    ≡
    ⟦ f ⟧ ∅ (⟦ s ⟧ ∅) ⟦⊕⟧ ⟦ derive f ⟧ ∅ (⟦ s ⟧ ∅) (⟦ ds ⟧ ∅)

correctness-on-closed-terms {τ₁} {τ₂} f s ds {R[v,dv]} =
  begin
    h (v ⟦⊕⟧ dv)
  ≡⟨ cong₂ (λ f x → f x)
           (sym (f⊕[g⊝f]=g h h))
           refl ⟩
    (h ⟦⊕⟧ (h ⟦⊝⟧ h)) (v ⟦⊕⟧ dv)
  ≡⟨ cong₂ (λ f x → f x)
      (sym (extract-Δequiv
        (correctness-of-derive ∅ f)
        h
        (validity-of-derive ∅ {dρ=∅} f)
        (R[f,g⊝f] h h)))
      refl ⟩
    (h ⟦⊕⟧ Δh) (v ⟦⊕⟧ dv)
  ≡⟨ proj₂ (validity-of-derive ∅ {dρ=∅} f v dv R[v,dv]) ⟩
    h v ⟦⊕⟧ Δh v dv
  ∎
  where
    open ≡-Reasoning
    h : ⟦ τ₁ ⇒ τ₂ ⟧
    h = ⟦ f ⟧ ∅
    Δh : ⟦ Δ-Type (τ₁ ⇒ τ₂) ⟧
    Δh = ⟦ derive f ⟧ ∅
    v : ⟦ τ₁ ⟧
    v = ⟦ s ⟧ ∅
    dv : ⟦ Δ-Type τ₁ ⟧
    dv = ⟦ ds ⟧ ∅


Fixed doc.

Fixed doc.

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --schematic-propositional-functions #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Nat.AddTotality where

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

------------------------------------------------------------------------------
-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind A A0 is Nm
  where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (nsucc ih)

-- Interactive proof using an instance of the induction principle.
+-N-ind : ∀ {n} →
          N (zero + n) →
          (∀ {m} → N (m + n) → N (succ₁ m + n)) →
          ∀ {m} → N m → N (m + n)
+-N-ind {n} = N-ind (λ i → N (i + n))

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ {n = n} Nm Nn = +-N-ind prf₁ prf₂ Nm
  where
  prf₁ : N (zero + n)
  prf₁ = subst N (sym (+-0x n)) Nn

  prf₂ : ∀ {m} → N (m + n) → N (succ₁ m + n)
  prf₂ {m} ih = subst N (sym (+-Sx m n)) (nsucc ih)

-- Combined proof using an instance of the induction principle.
postulate +-N₂ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₂ +-N-ind #-}

-- Combined proof using the induction principle.

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

postulate +-N₃ : ∀ {m n} → N m → N n → N (m + n)
-- Because the ATPs don't handle induction, them cannot prove this
-- postulate.
-- {-# ATP prove +-N₃ N-ind #-}

------------------------------------------------------------------------------
-- Totality of natural numbers addition
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --schematic-propositional-functions #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Nat.AddTotality where

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

------------------------------------------------------------------------------
-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-ind A A0 is Nm
  where
    A : D → Set
    A i = N (i + n)

    A0 : A zero
    A0 = subst N (sym (+-0x n)) Nn

    is : ∀ {i} → A i → A (succ₁ i)
    is {i} ih = subst N (sym (+-Sx i n)) (nsucc ih)

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

+-N₁ : ∀ {m n} → N m → N n → N (m + n)
+-N₁ {n = n} Nm Nn = +-N-ind prf₁ prf₂ Nm
  where
  prf₁ : N (zero + n)
  prf₁ = subst N (sym (+-0x n)) Nn

  prf₂ : ∀ {m} → N (m + n) → N (succ₁ m + n)
  prf₂ {m} ih = subst N (sym (+-Sx m n)) (nsucc ih)

postulate +-N₂ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₂ +-N-ind #-}

-- Combined proof using the induction principle.

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

postulate +-N₃ : ∀ {m n} → N m → N n → N (m + n)
-- Because the ATPs don't handle induction, them cannot prove this
-- postulate.
-- {-# ATP prove +-N₃ N-ind #-}


Renamed a property.

Renamed a property.

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

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Base.List.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Congruence properties

∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
∷-leftCong refl = refl

∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
∷-rightCong refl = refl

∷-cong : ∀ {x y xs ys} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
∷-cong refl refl = refl

headCong : ∀ {xs ys} → xs ≡ ys → head₁ xs ≡ head₁ ys
headCong refl = refl

tailCong : ∀ {xs ys} → xs ≡ ys → tail₁ xs ≡ tail₁ ys
tailCong refl = refl

------------------------------------------------------------------------------
-- Injective properties

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

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

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

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Base.List.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- Congruence properties

∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
∷-leftCong refl = refl

∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
∷-rightCong refl = refl

∷-Cong : ∀ {x y xs ys} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
∷-Cong refl refl = refl

headCong : ∀ {xs ys} → xs ≡ ys → head₁ xs ≡ head₁ ys
headCong refl = refl

tailCong : ∀ {xs ys} → xs ≡ ys → tail₁ xs ≡ tail₁ ys
tailCong refl = refl

------------------------------------------------------------------------------
-- Injective properties

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

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