Convert Base.Change.Algebra to Agda 2.4.2

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} ℓ {A : Set a} (P : A → Set p): Set (suc ℓ ⊔ p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra ℓ (P x)

  {-
  instance
    change-algebra-extractor : ∀ {x} → ChangeAlgebra ℓ (P x)
    change-algebra-extractor {x} = change-algebra x
  -}
  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

-- XXX not clear this is ever used
instance
  change-algebra-family-inst = change-algebra₍_₎

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

Derivative : ∀ {a b c d} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra c A}} →
  {{CB : ChangeAlgebra d B}} →
  (f : A → B) →
  (df : (a : A) (da : Δ a) → Δ (f a)) →
  Set (a ⊔ b ⊔ c)
Derivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of Derivative for change algebra families.
Derivative₍_,_₎ : ∀ {a b p q c d} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily c P}} →
  {{CQ : ChangeAlgebraFamily d Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : (px : P x) (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)) →
  Set (p ⊔ q ⊔ c)
Derivative₍ x , y ₎ f df = Derivative {{change-algebra₍ _ ₎}} {{change-algebra₍ _ ₎}} f df where
  CPx = change-algebra₍ x ₎
  CQy = change-algebra₍ y ₎

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebra : ChangeAlgebra a A
    changeAlgebra = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} {c} {d} (A : Set a) (B : Set b) {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b ⊔ c ⊔ d) where
      constructor
        cons
      field
        -- Definition 2.6a
        apply : (a : A) (da : Δ a) →
          Δ (f a)

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g ((a ⊞ da) ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }
    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)
    funNil = λ f → funDiff f f

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      instance
        changeAlgebra : ChangeAlgebra (a ⊔ b ⊔ c ⊔ d) (A → B)

      changeAlgebra = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ nil a) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper.
    nil-is-derivative : ∀ (f : A → B) →
      Derivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {c} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily c P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ (Δ₍ _ ₎) pxs → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞₍ x ₎ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ (Δ₍ _ ₎) pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟₍ _ ₎ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff₍ _ ₎ px′ px) (update-diff-all pxs′ pxs)

    instance
      changeAlgebra : ChangeAlgebraFamily (c ⊔ a) (All P)

    changeAlgebra = record
      { change-algebra = λ xs → record
        { Change = All′ Δ₍ _ ₎
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change Structures.
--
-- This module defines the notion of change structures,
-- as well as change structures for groups, functions and lists.
--
-- This module corresponds to Section 2 of the PLDI paper.
------------------------------------------------------------------------

module Base.Change.Algebra where

open import Relation.Binary.PropositionalEquality
open import Level

-- Change Algebras
-- ===============
--
-- In the paper, change algebras are called "change structures"
-- and they are described in Section 2.1. We follow the design of
-- the Agda standard library and define change algebras as two
-- records, so Definition 2.1 from the PLDI paper maps to the
-- records IsChangeAlgebra and ChangeAlgebra.
--
-- A value of type (IsChangeAlgebra Change update diff) proves that
-- Change, update and diff together form a change algebra.
--
-- A value of type (ChangeAlgebra Carrier) contains the necessary
-- ingredients to create a change algebra for a carrier set.
--
-- In the paper, Carrier is called V (Def. 2.1a),
-- Change is called Δ (Def. 2.1b),
-- update is written as infix ⊕ (Def. 2.1c),
-- diff is written as infix ⊝ (Def. 2.1d),
-- and update-diff is specified in Def. 2.1e.

record IsChangeAlgebra
    {c} {d}
    {Carrier : Set c}
    (Change : Carrier → Set d)
    (update : (v : Carrier) (dv : Change v) → Carrier)
    (diff : (u v : Carrier) → Change v)
    (nil : (u : Carrier) → Change u) : Set (c ⊔ d) where
  field
    update-diff : ∀ u v → update v (diff u v) ≡ u
    -- This corresponds to Lemma 2.3 from the paper.
    update-nil : ∀ v → update v (nil v) ≡ v

  -- abbreviations
  before : ∀ {v} → Change v → Carrier
  before {v} _ = v

  after : ∀ {v} → Change v → Carrier
  after {v} dv = update v dv

record ChangeAlgebra {c} ℓ
    (Carrier : Set c) : Set (c ⊔ suc ℓ) where
  field
    Change : Carrier → Set ℓ
    update : (v : Carrier) (dv : Change v) → Carrier
    diff : (u v : Carrier) → Change v

    -- This generalizes Def. 2.2. from the paper.
    nil : (u : Carrier) → Change u

    isChangeAlgebra : IsChangeAlgebra Change update diff nil

  infixl 6 update diff

  open IsChangeAlgebra isChangeAlgebra public

-- The following open ... public statement lets us use infix ⊞
-- and ⊟ for update and diff. In the paper, we use infix ⊕ and
-- ⊝.

open ChangeAlgebra {{...}} public
  using
    ( update-diff
    ; update-nil
    ; nil
    ; before
    ; after
    )
  renaming
    ( Change to Δ
    ; update to _⊞_
    ; diff to _⊟_
    )

-- Families of Change Algebras
-- ===========================
--
-- This is some Agda machinery to allow subscripting change
-- algebra operations to avoid ambiguity. In the paper,
-- we simply write (in the paragraph after Def. 2.1):
--
--   We overload operators ∆, ⊝ and ⊕ to refer to the
--   corresponding operations of different change structures; we
--   will subscript these symbols when needed to prevent
--   ambiguity.
--
-- The following definitions implement this idea formally.

record ChangeAlgebraFamily {a p} ℓ {A : Set a} (P : A → Set p): Set (suc ℓ ⊔ p ⊔ a) where
  constructor
    family
  field
    change-algebra : ∀ x → ChangeAlgebra ℓ (P x)

  module _ x where
    open ChangeAlgebra (change-algebra x) public

module Family = ChangeAlgebraFamily {{...}}

open Family public
  using
    (
    )
  renaming
    ( Change to Δ₍_₎
    ; nil to nil₍_₎
    ; update-diff to update-diff₍_₎
    ; update-nil to update-nil₍_₎
    ; change-algebra to change-algebra₍_₎
    ; before to before₍_₎
    ; after to after₍_₎
    )

infixl 6 update′ diff′

update′ = Family.update
syntax update′ x v dv = v ⊞₍ x ₎ dv

diff′ = Family.diff
syntax diff′ x u v = u ⊟₍ x ₎ v

-- Derivatives
-- ===========
--
-- This corresponds to Def. 2.4 in the paper.

Derivative : ∀ {a b c d} {A : Set a} {B : Set b} →
  {{CA : ChangeAlgebra c A}} →
  {{CB : ChangeAlgebra d B}} →
  (f : A → B) →
  (df : (a : A) (da : Δ a) → Δ (f a)) →
  Set (a ⊔ b ⊔ c)
Derivative f df = ∀ a da → f a ⊞ df a da ≡ f (a ⊞ da)

-- This is a variant of Derivative for change algebra families.
Derivative₍_,_₎ : ∀ {a b p q c d} {A : Set a} {B : Set b} {P : A → Set p} {Q : B → Set q} →
  {{CP : ChangeAlgebraFamily c P}} →
  {{CQ : ChangeAlgebraFamily d Q}} →
  (x : A) →
  (y : B) →
  (f : P x → Q y) →
  (df : (px : P x) (dpx : Δ₍ x ₎ px) → Δ₍ y ₎ (f px)) →
  Set (p ⊔ q ⊔ c)
Derivative₍ x , y ₎ f df = Derivative f df where
  CPx = change-algebra₍ x ₎
  CQy = change-algebra₍ y ₎

-- Lemma 2.5 appears in Base.Change.Equivalence.

-- Abelian Groups Induce Change Algebras
-- =====================================
--
-- In the paper, as the first example for change structures after
-- Def. 2.1, we mention that "each abelian group ... induces a
-- change structure". This is the formalization of this result.
--
-- The module GroupChanges below takes a proof that A forms an
-- abelian group and provides a changeAlgebra for A. The proof of
-- Def 2.1e is by equational reasoning using the group axioms, in
-- the definition of changeAlgebra.isChangeAlgebra.update-diff.

open import Algebra.Structures
open import Data.Product
open import Function

module GroupChanges
    {a} (A : Set a) {_⊕_} {ε} {_⁻¹}
    {{isAbelianGroup : IsAbelianGroup {A = A} _≡_ _⊕_ ε _⁻¹}}
  where
    open IsAbelianGroup isAbelianGroup
      hiding
        ( refl
        )
      renaming
        ( _-_ to _⊝_
        ; ∙-cong to _⟨⊕⟩_
        )

    open ≡-Reasoning

    changeAlgebra : ChangeAlgebra a A
    changeAlgebra = record
      { Change = const A
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = const ε
      ; isChangeAlgebra = record
        { update-diff = λ u v →
            begin
              v ⊕ (u ⊝ v)
            ≡⟨ comm _ _ ⟩
              (u ⊝ v ) ⊕ v
            ≡⟨⟩
              (u ⊕ (v ⁻¹)) ⊕ v
            ≡⟨ assoc _ _ _ ⟩
              u ⊕ ((v ⁻¹) ⊕ v)
            ≡⟨  refl ⟨⊕⟩ proj₁ inverse v  ⟩
              u ⊕ ε
            ≡⟨  proj₂ identity u ⟩
              u
            ∎
        ; update-nil = proj₂ identity
        }
      }

-- Function Changes
-- ================
--
-- This is one of our most important results: Change structures
-- can be lifted to function spaces. We formalize this as a module
-- FunctionChanges that takes the change algebras for A and B as
-- arguments, and provides a changeAlgebra for (A → B). The proofs
-- are by equational reasoning using 2.1e for A and B.

module FunctionChanges
    {a} {b} {c} {d} (A : Set a) (B : Set b) {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}}
  where
    -- This corresponds to Definition 2.6 in the paper.
    record FunctionChange (f : A → B) : Set (a ⊔ b ⊔ c ⊔ d) where
      constructor
        cons
      field
        -- Definition 2.6a
        apply : (a : A) (da : Δ a) →
          Δ (f a)

        -- Definition 2.6b.
        -- (for some reason, the version in the paper has the arguments of ≡
        -- flipped. Since ≡ is symmetric, this doesn't matter).
        correct : (a : A) (da : Δ a) →
          f (a ⊞ da) ⊞ apply (a ⊞ da) (nil (a ⊞ da)) ≡ f a ⊞ apply a da

    open FunctionChange public
    open ≡-Reasoning
    open import Postulate.Extensionality

    funDiff : (g f : A → B) → FunctionChange f
    funDiff = λ g f → record
        { apply = λ a da → g (a ⊞ da) ⊟ f a
          -- the proof of correct is the first half of what we
          -- have to prove for Theorem 2.7.
        ; correct = λ a da →
          begin
            f (a ⊞ da) ⊞ (g ((a ⊞ da) ⊞ nil (a ⊞ da)) ⊟ f (a ⊞ da))
          ≡⟨ cong (λ □ → f (a ⊞ da) ⊞ (g □ ⊟ f (a ⊞ da)))
               (update-nil (a ⊞ da)) ⟩
            f (a ⊞ da) ⊞ (g (a ⊞ da) ⊟ f (a ⊞ da))
          ≡⟨ update-diff (g (a ⊞ da)) (f (a ⊞ da)) ⟩
            g (a ⊞ da)
          ≡⟨ sym (update-diff (g (a ⊞ da)) (f a)) ⟩
            f a ⊞ (g (a ⊞ da) ⊟ f a)
          ∎
        }
    funUpdate : ∀ (f : A → B) (df : FunctionChange f) → A → B
    funUpdate = λ f df a → f a ⊞ apply df a (nil a)
    funNil = λ f → funDiff f f

    mutual
      -- I have to write the type of funUpdateDiff without using changeAlgebra,
      -- so I just use the underlying implementations.
      funUpdateDiff : ∀ u v → funUpdate v (funDiff u v) ≡ u
      changeAlgebra : ChangeAlgebra (a ⊔ b ⊔ c ⊔ d) (A → B)

      changeAlgebra = record
        { Change = FunctionChange
          -- in the paper, update and diff below are in Def. 2.7
        ; update = funUpdate
        ; diff = funDiff
        ; nil = funNil
        ; isChangeAlgebra = record
            -- the proof of update-diff is the second half of what
            -- we have to prove for Theorem 2.8.
          { update-diff = funUpdateDiff
          ; update-nil = λ v → funUpdateDiff v v
          }
        }
      -- XXX remove mutual recursion by inlining the algebra in here?
      funUpdateDiff = λ g f → ext (λ a →
        begin
          f a ⊞ (g (a ⊞ nil a) ⊟ f a)
        ≡⟨ cong (λ □ → f a ⊞ (g □ ⊟ f a)) (update-nil a) ⟩
          f a ⊞ (g a ⊟ f a)
        ≡⟨ update-diff (g a) (f a) ⟩
          g a
        ∎)

    -- This is Theorem 2.9 in the paper.
    incrementalization : ∀ (f : A → B) df a da →
      (f ⊞ df) (a ⊞ da) ≡ f a ⊞ apply df a da
    incrementalization f df a da = correct df a da

    -- This is Theorem 2.10 in the paper.
    nil-is-derivative : ∀ (f : A → B) →
      Derivative f (apply (nil f))
    nil-is-derivative f a da =
      begin
        f a ⊞ apply (nil f) a da
      ≡⟨ sym (incrementalization f (nil f) a da) ⟩
        (f ⊞ nil f) (a ⊞ da)
      ≡⟨ cong (λ □ → □ (a ⊞ da))
           (update-nil f) ⟩
        f (a ⊞ da)
      ∎

-- List (== Environment) Changes
-- =============================
--
-- Here, we define a change structure on environments, given a
-- change structure on the values in the environments. In the
-- paper, we describe this in Definition 3.5. But note that this
-- Agda formalization uses de Bruijn indices instead of names, so
-- environments are just lists. Therefore, when we use Definition
-- 3.5 in the paper, in this formalization, we use the list-like
-- change structure defined here.

open import Data.List
open import Data.List.All

data All′ {a p q} {A : Set a}
    {P : A → Set p}
    (Q : {x : A} → P x → Set q)
  : {xs : List A} (pxs : All P xs) → Set (p ⊔ q ⊔ a) where
    []  : All′ Q []
    _∷_ : ∀ {x xs} {px : P x} {pxs : All P xs} (qx : Q px) (qxs : All′ Q pxs) → All′ Q (px ∷ pxs)

module ListChanges
    {a} {c} {A : Set a} (P : A → Set) {{C : ChangeAlgebraFamily c P}}
  where
    update-all : ∀ {xs} → (pxs : All P xs) → All′ (Δ₍ _ ₎) pxs → All P xs
    update-all {[]} [] [] = []
    update-all {x ∷ xs} (px ∷ pxs) (dpx ∷ dpxs) = (px ⊞₍ x ₎ dpx) ∷ update-all pxs dpxs

    diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → All′ (Δ₍ _ ₎) pxs
    diff-all [] [] = []
    diff-all (px′ ∷ pxs′) (px ∷ pxs) = (px′ ⊟₍ _ ₎ px) ∷ diff-all pxs′ pxs

    update-diff-all : ∀ {xs} → (pxs′ pxs : All P xs) → update-all pxs (diff-all pxs′ pxs) ≡ pxs′
    update-diff-all [] [] = refl
    update-diff-all (px′ ∷ pxs′) (px ∷ pxs) = cong₂ _∷_ (update-diff₍ _ ₎ px′ px) (update-diff-all pxs′ pxs)

    changeAlgebra : ChangeAlgebraFamily (c ⊔ a) (All P)
    changeAlgebra = record
      { change-algebra = λ xs → record
        { Change = All′ Δ₍ _ ₎
        ; update = update-all
        ; diff = diff-all
        ; nil = λ xs → diff-all xs xs
        ; isChangeAlgebra = record
          { update-diff = update-diff-all
          ; update-nil = λ xs₁ → update-diff-all xs₁ xs₁
          }
        }
      }


Removing subst from Conat→N.

Removing subst from Conat→N.

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

module FOT.FOTC.Data.Conat.PropertiesI where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Conat.PropertiesI
open import FOTC.Data.Nat

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

-- 09 January 2014. Doesn't type check with --without-K.
--
{-# NO_TERMINATION_CHECK #-}
Conat→N : ∀ {n} → Conat n → N n
Conat→N Cn with Conat-out Cn
... | inj₁ prf               = subst N (sym prf) nzero
... | inj₂ (n' , refl , Cn') = nsucc (Conat→N Cn')

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

module FOT.FOTC.Data.Conat.PropertiesI where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Conat.PropertiesI
open import FOTC.Data.Nat

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

{-# NO_TERMINATION_CHECK #-}
Conat→N : ∀ {n} → Conat n → N n
Conat→N Cn with Conat-out Cn
... | inj₁ prf              = subst N (sym prf) nzero
... | inj₂ (n' , prf , Cn') = subst N (sym prf) (nsucc (Conat→N Cn'))


Minor changes.

Minor changes.

------------------------------------------------------------------------------
-- The FOTC types without using data, i.e. using Agda as a logical framework
------------------------------------------------------------------------------

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

module Predicates where

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

------------------------------------------------------------------------------
-- The existential proyections.

∃-proj₁ : ∀ {A} → ∃ A → D
∃-proj₁ (x , _) = x

∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
∃-proj₂ (_ , Ax) = Ax

------------------------------------------------------------------------------
-- The inductive FOTC types using postulates.

module Pure where

  -- The FOTC natural numbers type.
  postulate
    N     : D → Set
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- Example.
  [1] : D
  [1] = succ₁ zero

  1-N : N [1]
  1-N = nsucc nzero

  -- The FOTC lists type.
  postulate
    List  : D → Set
    lnil  : List []
    lcons : ∀ x {xs} → List xs → List (x ∷ xs)

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

  -- The FOTC list of natural numbers type.
  postulate
    ListN  : D → Set
    lnnil  : ListN []
    lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

  -- Example.
  ln : ListN (zero ∷ [1] ∷ [])
  ln = lncons nzero (lncons 1-N lnnil)

------------------------------------------------------------------------------
-- The inductive FOTC types using data.

module Inductive where

  -- The FOTC natural numbers type.
  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- Example.
  [1] : D
  [1] = succ₁ zero

  1-N : N [1]
  1-N = nsucc nzero

  -- The FOTC lists type.
  data List : D → Set where
    lnil  : List []
    lcons : ∀ x {xs} → List xs → List (x ∷ xs)

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

  -- The FOTC list of natural numbers type.
  data ListN : D → Set where
    lnnil  : ListN []
    lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

  -- Example.
  ln : ListN (zero ∷ [1] ∷ [])
  ln = lncons nzero (lncons 1-N lnnil)

------------------------------------------------------------------------------
-- The least fixed-point operator.

module LFP where

  postulate
    -- Least fixed-points correspond to inductively defined types.
    --
    -- N.B. We cannot write μ in first-order logic. We should use an
    -- instance instead.
    μ : ((D → Set) → D → Set) → D → Set

    -- In FOTC, we cannot use the equality on predicates, i.e. we
    -- cannot write
    --
    -- (f : (D → Set) → D → Set) → f (μ f) ≡ μ f  (1)
    --
    -- because the type of the equality is
    --
    -- _≡_ : D → D → Set,
    --
    -- therefore we postulate both directions of the conversion rule (1).

    -- LFP₁ : (f : (D → Set) → D → Set)(d : D) → μ f d → f (μ f) d
    μ-in : (f : (D → Set) → D → Set)(d : D) → f (μ f) d → μ f d

------------------------------------------------------------------------------
-- The greatest fixed-point operator.

-- N.B. At the moment, the definitions of μ and ν are the same.

module GFP where

  postulate
    -- Greatest fixed-points correspond to co-inductively defined
    -- types.

    ν : ((D → Set) → D → Set) → D → Set

    ν-out : (f : (D → Set) → D → Set)(d : D) → ν f d → f (ν f) d
    GFP₂  : (f : (D → Set) → D → Set)(d : D) → f (ν f) d → ν f d

------------------------------------------------------------------------------
-- The FOTC natural numbers type as the least fixed-point of a
-- functor.

module NLFP where

  open LFP

  -- Functor for the FOTC natural numbers type.

  -- From Peter: NatF if D was an inductive type.
  --
  -- NatF : (D → Set) → D → Set
  -- NatF X zero      = ⊤
  -- NatF X (succ₁ n) = X n

  -- From Peter: NatF in pure predicate logic.
  NatF : (D → Set) → D → Set
  NatF X n = n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ X n')

  -- The FOTC natural numbers type using μ.
  N : D → Set
  N = μ NatF

  -- The data constructors of N.
  nzero : N zero
  nzero = μ-in NatF zero (inj₁ refl)

  nsucc : {n : D} → N n → N (succ₁ n)
  nsucc {n} Nn = μ-in NatF (succ₁ n) (inj₂ (n , refl , Nn))

  -- Example.
  [1] : D
  [1] = succ₁ zero

  1-N : N [1]
  1-N = nsucc nzero

------------------------------------------------------------------------------
-- The FOTC list type as the least fixed-point of a functor.

module ListLFT where

  open LFP

  -- Functor for the FOTC lists type.
  ListF : (D → Set) → D → Set
  ListF X xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ X xs')

  -- The FOTC list type using μ.
  List : D → Set
  List = μ ListF

  -- The data constructors of List.
  lnil : List []
  lnil = μ-in ListF [] (inj₁ refl)

  lcons : ∀ x {xs} → List xs → List (x ∷ xs)
  lcons x {xs} Lxs = μ-in ListF (x ∷ xs) (inj₂ (x , xs , refl , Lxs))

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

------------------------------------------------------------------------------
-- The FOTC list of natural numbers type as the least fixed-point of a
-- functor.

module ListNLFT where

  open LFP
  open NLFP

  -- Functor for the FOTC list of natural numbers type.
  ListNF : (D → Set) → D → Set
  ListNF X ns = ns ≡ [] ∨ (∃[ n' ] ∃[ ns' ] ns ≡ n' ∷ ns' ∧ N n' ∧ X ns')

  -- The FOTC list type using μ.
  ListN : D → Set
  ListN = μ ListNF

  -- The data constructors of ListN.
  lnnil : ListN []
  lnnil = μ-in ListNF [] (inj₁ refl)

  lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)
  lncons {n} {ns} Nn LNns =
    μ-in ListNF (n ∷ ns) (inj₂ (n , ns , refl , Nn , LNns))

  -- Example.
  ln : ListN (zero ∷ [1] ∷ [])
  ln = lncons nzero (lncons 1-N lnnil)

------------------------------------------------------------------------------
-- The FOTC Colist type as the greatest fixed-point of a functor.

module CoList where

  open GFP

  -- Functor for the FOTC Colists type (the same functor that for the
  -- List type).
  ColistF : (D → Set) → D → Set
  ColistF X xs = xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ X xs')

  -- The FOTC Colist type using ν.
  Colist : D → Set
  Colist = ν ColistF

  -- The data constructors of Colist.
  nilCL : Colist []
  nilCL = GFP₂ ColistF [] (inj₁ refl)

  consCL : ∀ x xs → Colist xs → Colist (x ∷ xs)
  consCL x xs CLxs = GFP₂ ColistF (x ∷ xs) (inj₂ (x , xs , refl , CLxs))

  -- Example (finite colist).
  l : Colist (zero ∷ true ∷ [])
  l = consCL zero (true ∷ []) (consCL true [] nilCL)

  -- TODO: Example (infinite colist).
  -- zerosCL : Colist {!!}
  -- zerosCL = consCL zero {!!} zerosCL

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X xs = ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ X xs'

  -- The FOTC Stream type using ν.
  Stream : D → Set
  Stream = ν StreamF

  -- The data constructor of Stream.
  consS : ∀ x {xs} → Stream xs → Stream (x ∷ xs)
  consS x {xs} Sxs = GFP₂ StreamF (x ∷ xs) (x , xs , refl , Sxs)

  -- TODO: Example
  -- zerosS : Stream {!!}
  -- zerosS = consS zero {!!} zerosS

  headS : ∀ {x xs} → Stream (x ∷ xs) → D
  headS {x} _ = x

  tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
  tailS {x} {xs} Sx∷xs = Sxs
    where
    unfoldS : StreamF (ν StreamF) (x ∷ xs)
    unfoldS = ν-out StreamF (x ∷ xs) Sx∷xs

    e : D
    e = ∃-proj₁ unfoldS

    Pe : ∃ λ es → x ∷ xs ≡ e ∷ es ∧ ν StreamF es
    Pe = ∃-proj₂ unfoldS

    es : D
    es = ∃-proj₁ Pe

    Pes : x ∷ xs ≡ e ∷ es ∧ ν StreamF es
    Pes = ∃-proj₂ Pe

    xs≡es : xs ≡ es
    xs≡es = ∧-proj₂ (∷-injective (∧-proj₁ Pes))

    Sxs : ν StreamF xs
    Sxs = subst (ν StreamF) (sym xs≡es) (∧-proj₂ Pes)

------------------------------------------------------------------------------
-- The FOTC types without use data, i.e. using Agda as a logical framework
------------------------------------------------------------------------------

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

module Predicates where

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

------------------------------------------------------------------------------
-- The existential proyections.
∃-proj₁ : ∀ {A} → ∃ A → D
∃-proj₁ (x , _) = x

∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
∃-proj₂ (_ , Ax) = Ax

------------------------------------------------------------------------------
-- The inductive FOTC types using postulates.

module Pure where

  -- The FOTC natural numbers type.
  postulate
    N     : D → Set
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- Example.
  [1] : D
  [1] = succ₁ zero

  1-N : N [1]
  1-N = nsucc nzero

  -- The FOTC lists type.
  postulate
    List  : D → Set
    lnil  : List []
    lcons : ∀ x {xs} → List xs → List (x ∷ xs)

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

  -- The FOTC list of natural numbers type.
  postulate
    ListN  : D → Set
    lnnil  : ListN []
    lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

  -- Example.
  ln : ListN (zero ∷ [1] ∷ [])
  ln = lncons nzero (lncons 1-N lnnil)

------------------------------------------------------------------------------
-- The inductive FOTC types using data.

module Inductive where

  -- The FOTC natural numbers type.
  data N : D → Set where
    nzero : N zero
    nsucc : ∀ {n} → N n → N (succ₁ n)

  -- Example.
  [1] : D
  [1] = succ₁ zero

  1-N : N [1]
  1-N = nsucc nzero

  -- The FOTC lists type.
  data List : D → Set where
    lnil  :                      List []
    lcons : ∀ x {xs} → List xs → List (x ∷ xs)

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

  -- The FOTC list of natural numbers type.
  data ListN : D → Set where
    lnnil  :                             ListN []
    lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)

  -- Example.
  ln : ListN (zero ∷ [1] ∷ [])
  ln = lncons nzero (lncons 1-N lnnil)

------------------------------------------------------------------------------
-- The least fixed-point operator.

module LFP where

  postulate
    -- Least fixed-points correspond to inductively defined types.
    --
    -- N.B. We cannot write LFP in first-order logic. We should use an
    -- instance instead.
    LFP : ((D → Set) → D → Set) → D → Set

    -- In FOTC, we cannot use the equality on predicates, i.e. we
    -- cannot write
    --
    -- (f : (D → Set) → D → Set) → f (LFP f) ≡ LFP f  (1)
    --
    -- because the type of the equality is
    --
    -- _≡_ : D → D → Set,
    --
    -- therefore we postulate both directions of the conversion rule (1).

    LFP₁ : (f : (D → Set) → D → Set)(d : D) → LFP f d → f (LFP f) d
    LFP₂ : (f : (D → Set) → D → Set)(d : D) → f (LFP f) d → LFP f d

------------------------------------------------------------------------------
-- The greatest fixed-point operator.

-- N.B. At the moment, the definitions of LFP and GFP are the same.

module GFP where

  postulate
    -- Greatest fixed-points correspond to co-inductively defined
    -- types.

    GFP : ((D → Set) → D → Set) → D → Set

    GFP₁ : (f : (D → Set) → D → Set)(d : D) → GFP f d → f (GFP f) d
    GFP₂ : (f : (D → Set) → D → Set)(d : D) → f (GFP f) d → GFP f d

------------------------------------------------------------------------------
-- The FOTC natural numbers type as the least fixed-point of a
-- functor.

module NLFP where

  open LFP

  -- Functor for the FOTC natural numbers type.

  -- From Peter: NatF if D was an inductive type
  -- NatF : (D → Set) → D → Set
  -- NatF X zero      = ⊤
  -- NatF X (succ₁ n) = X n

  -- From Peter: NatF in pure predicate logic.
  NatF : (D → Set) → D → Set
  NatF X n = n ≡ zero ∨ (∃ λ m → n ≡ succ₁ m ∧ X m)

  -- The FOTC natural numbers type using LFP.
  N : D → Set
  N = LFP NatF

  -- The data constructors of N.
  nzero : N zero
  nzero = LFP₂ NatF zero (inj₁ refl)

  nsucc : {n : D} → N n → N (succ₁ n)
  nsucc {n} Nn = LFP₂ NatF (succ₁ n) (inj₂ (n , (refl , Nn)))

  -- Example.
  [1] : D
  [1] = succ₁ zero

  1-N : N [1]
  1-N = nsucc nzero

------------------------------------------------------------------------------
-- The FOTC list type as the least fixed-point of a functor.

module ListLFT where

  open LFP

  -- Functor for the FOTC lists type.
  ListF : (D → Set) → D → Set
  ListF X ds = ds ≡ [] ∨ (∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ X es)

  -- The FOTC list type using LFP.
  List : D → Set
  List = LFP ListF

  -- The data constructors of List.
  lnil : List []
  lnil = LFP₂ ListF [] (inj₁ refl)

  lcons : ∀ x {xs} → List xs → List (x ∷ xs)
  lcons x {xs} Lxs = LFP₂ ListF (x ∷ xs) (inj₂ (x , xs , refl , Lxs))

  -- Example.
  l : List (zero ∷ true ∷ [])
  l = lcons zero (lcons true lnil)

------------------------------------------------------------------------------
-- The FOTC list of natural numbers type as the least fixed-point of a
-- functor.

module ListNLFT where

  open LFP
  open NLFP

  -- Functor for the FOTC list of natural numbers type.
  ListNF : (D → Set) → D → Set
  ListNF X ds = ds ≡ [] ∨ (∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ N e ∧ X es)

  -- The FOTC list type using LFP.
  ListN : D → Set
  ListN = LFP ListNF

  -- The data constructors of ListN.
  lnnil : ListN []
  lnnil = LFP₂ ListNF [] (inj₁ refl)

  lncons : ∀ {n ns} → N n → ListN ns → ListN (n ∷ ns)
  lncons {n} {ns} Nn LNns =
    LFP₂ ListNF (n ∷ ns) (inj₂ (n , ns , refl , Nn , LNns))

  -- Example.
  ln : ListN (zero ∷ [1] ∷ [])
  ln = lncons nzero (lncons 1-N lnnil)

------------------------------------------------------------------------------
-- The FOTC Colist type as the greatest fixed-point of a functor.

module CoList where

  open GFP

  -- Functor for the FOTC Colists type (the same functor that for the
  -- List type).
  ColistF : (D → Set) → D → Set
  ColistF X ds = ds ≡ [] ∨ (∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ X es)

  -- The FOTC Colist type using GFP.
  Colist : D → Set
  Colist = GFP ColistF

  -- The data constructors of Colist.
  nilCL : Colist []
  nilCL = GFP₂ ColistF [] (inj₁ refl)

  consCL : ∀ x xs → Colist xs → Colist (x ∷ xs)
  consCL x xs CLxs = GFP₂ ColistF (x ∷ xs) (inj₂ (x , xs , refl , CLxs))

  -- Example (finite colist).
  l : Colist (zero ∷ true ∷ [])
  l = consCL zero (true ∷ []) (consCL true [] nilCL)

  -- TODO: Example (infinite colist).
  -- zerosCL : Colist {!!}
  -- zerosCL = consCL zero {!!} zerosCL

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream₁ where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X ds = ∃ λ e → X ds

  -- The FOTC Stream type using GFP.
  Stream : D → Set
  Stream = GFP StreamF

  -- The data constructor of Stream.
  -- Using StreamF we cannot define this data constructor
  -- consS : ∀ x xs → Stream xs → Stream (x ∷ xs)
  -- consS x xs Sxs = GFP₂ StreamF (x ∷ xs) {!!}

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream₂ where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X ds = ∃ λ e → ∃ λ es → X es

  -- The FOTC Stream type using GFP.
  Stream : D → Set
  Stream = GFP StreamF

  -- The data constructor of Stream.
  -- TODO: To use implicit arguments.
  consS : ∀ x xs → Stream xs → Stream (x ∷ xs)
  consS x xs Sxs = GFP₂ StreamF (x ∷ xs) (x , xs , Sxs)

  -- TODO: Example
  -- zerosS : Stream {!!}
  -- zerosS = consS zero {!!} zerosS

  headS : ∀ {x xs} → Stream (x ∷ xs) → D
  headS {x} _ = x

  tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
  tailS {x} {xs} S = GFP₂ StreamF xs (x , x ∷ xs , S)

  -- The functor StreamF does not link together the parts of the
  -- stream, so I can get a stream from any stream.
  bad : ∀ {xs ys} → Stream xs → Stream ys
  bad {xs} {ys} S = GFP₂ StreamF ys (ys , xs , S)

------------------------------------------------------------------------------
-- The FOTC Stream type as the greatest fixed-point of a functor.

module Stream₃ where

  open GFP

  -- Functor for the FOTC Stream type.
  StreamF : (D → Set) → D → Set
  StreamF X ds = ∃ λ e → ∃ λ es → ds ≡ e ∷ es ∧ X es

  -- The FOTC Stream type using GFP.
  Stream : D → Set
  Stream = GFP StreamF

  -- The data constructor of Stream.
  -- TODO: To use implicit arguments.
  consS : ∀ x xs → Stream xs → Stream (x ∷ xs)
  consS x xs Sxs = GFP₂ StreamF (x ∷ xs) (x , xs , refl , Sxs)

  -- TODO: Example
  -- zerosS : Stream {!!}
  -- zerosS = consS zero {!!} zerosS

  headS : ∀ {x xs} → Stream (x ∷ xs) → D
  headS {x} _ = x

  tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
  tailS {x} {xs} Sx∷xs = Sxs
    where
    unfoldS : StreamF (GFP StreamF) (x ∷ xs)
    unfoldS = GFP₁ StreamF (x ∷ xs) Sx∷xs

    e : D
    e = ∃-proj₁ unfoldS

    Pe : ∃ λ es → x ∷ xs ≡ e ∷ es ∧ GFP StreamF es
    Pe = ∃-proj₂ unfoldS

    es : D
    es = ∃-proj₁ Pe

    Pes : x ∷ xs ≡ e ∷ es ∧ GFP StreamF es
    Pes = ∃-proj₂ Pe

    xs≡es : xs ≡ es
    xs≡es = ∧-proj₂ (∷-injective (∧-proj₁ Pes))

    Sxs : GFP StreamF xs
    Sxs = subst (GFP StreamF) (sym xs≡es) (∧-proj₂ Pes)


Agda: refactor proof of embed (#62)

Agda: refactor proof of embed (#62)

This refactoring makes the code of embed readable to humans (say, me).
(One should remember that programming should be about communicating with
humans).

Old-commit-hash: bf8e0402fab99cc5be02c0d14d407dd6c8123e06

module Embed62 where

open import TaggedDeltaTypes
open import ExplicitNil using (ext³)
open import Relation.Binary.PropositionalEquality
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Unit using (⊤ ; tt)
open import Data.Nat

natPairVisitor : Type
natPairVisitor = nats ⇒ nats ⇒ nats

Δ-Type : Type → Type
Δ-Type nats = natPairVisitor ⇒ nats -- Church pairs
Δ-Type bags = bags
Δ-Type (σ ⇒ τ) = σ ⇒ Δ-Type σ ⇒ Δ-Type τ

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

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

weak : ∀ {τ Γ} → Term Γ τ → Term (Δ-Context Γ) τ
weak = weaken Γ≼ΔΓ

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

absurd! : ∀ {A B : Set} → A → A → B → B
absurd! _ _ b = b

fst : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
snd = abs (abs (var this))

oldFrom newFrom : ∀ {Γ} → Term Γ (Δ-Type nats) → Term Γ nats
oldFrom d = app d fst
newFrom d = app d snd

difff : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
apply : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ

apply {nats} dt t = app dt snd
apply {bags} dt t = union t dt
apply {σ ⇒ τ} dt t = abs (apply
  (app (app (weaken (drop _ • Γ≼Γ) dt)
    (var this)) (difff (var this) (var this)))
  (app (weaken (drop _ • Γ≼Γ) t) (var this)))

difff {nats} s t = abs (app (app (var this)
  (weaken (drop _ • Γ≼Γ) s)) (weaken (drop _ • Γ≼Γ) t))
difff {bags} s t = diff s t
difff {σ ⇒ τ} s t = abs (abs (difff
  (app (weaken (drop _ • drop _ • Γ≼Γ) s)
    (apply (var this) (var (that this))))
  (app (weaken (drop _ • drop _ • Γ≼Γ) t) (var (that this)))))

natPair : ∀ {Γ} → (old new : Term (natPairVisitor • Γ) nats) → Term Γ (Δ-Type nats)
natPair old new = abs (app (app (var this) old) new)

embed : ∀ {τ Γ} → ΔTerm Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
embed (Δnat old new) = natPair (nat old) (nat new)
embed (Δbag db) = bag db
embed (Δvar x) = var (deriveVar x)
embed (Δabs dt) = abs (abs (embed dt))
embed (Δapp ds t dt) = app (app (embed ds) (weak t)) (embed dt)
embed (Δadd ds dt) = natPair
  (add (oldFrom (embedWeaken ds))
       (oldFrom (embedWeaken dt)))
  (add (newFrom (embedWeaken ds))
       (newFrom (embedWeaken dt)))
  where
    embedWeaken : ∀ {Γ τ} → (d : ΔTerm Γ nats) →
      Term (τ • Δ-Context Γ) (natPairVisitor ⇒ nats)
    embedWeaken d = (weaken (drop _ • Γ≼Γ) (embed d))
embed (Δmap₀ s ds t dt) = diff
  (map (apply (embed ds) (weak s)) (apply (embed dt) (weak t)))
  (weak (map s t))
embed (Δmap₁ s dt) = map (weak s) (embed dt)
embed (Δunion ds dt) = union (embed ds) (embed dt)
embed (Δdiff ds dt) = diff (embed ds) (embed dt)

⟦fst⟧ : ∀ {A : Set} → A → A → A
⟦fst⟧ a b = a
⟦snd⟧ : ∀ {A : Set} → A → A → A
⟦snd⟧ a b = b

_≈_ : ∀ {τ} → ΔVal τ → ⟦ Δ-Type τ ⟧ → Set
_≈_ {nats} (old , new) v = old ≡ v ⟦fst⟧ × new ≡ v ⟦snd⟧
_≈_ {bags} u v = u ≡ v
_≈_ {σ ⇒ τ} u v =
  (w : ⟦ σ ⟧) (dw : ΔVal σ) (dw′ : ⟦ Δ-Type σ ⟧)
  (R[w,dw] : valid w dw) (eq : dw ≈ dw′) →
  u w dw R[w,dw] ≈ v w dw′

infix 4 _≈_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ Δ-Context Γ ⟧ → Set
compatible {∅} ∅ ∅ = EmptySet
compatible {τ • Γ} (cons v dv _ ρ) (dv′ • v′ • ρ′) =
  triple (v ≡ v′) (dv ≈ dv′) (compatible ρ ρ′)

deriveVar-correct : ∀ {τ Γ} {x : Var Γ τ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ x ⟧ΔVar ρ ≈ ⟦ deriveVar x ⟧ ρ′

deriveVar-correct {x = this} -- pattern-matching on ρ, ρ′ NOT optional
  {cons _ _ _ _} {_ • _ • _} {cons _ dv≈dv′ _ _} = dv≈dv′
deriveVar-correct {x = that y}
  {cons _ _ _ ρ} {_ • _ • ρ′} {cons _ _ C _} =
  deriveVar-correct {x = y} {ρ} {ρ′} {C}

weak-id : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
weak-id {∅} {∅} = refl
weak-id {τ • Γ} {v • ρ} = cong₂ _•_ {x = v} refl (weak-id {Γ} {ρ})

weak-eq : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′

weak-eq {∅} {∅} {∅} _ = refl
weak-eq {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′} (cons v≡v′ _ C _) =
  cong₂ _•_ v≡v′ (weak-eq C)

weak-eq-term : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ′

weak-eq-term t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (weak-eq C)) (sym (weaken-sound t ρ′))

weaken-once : ∀ {τ Γ σ} {t : Term Γ τ} {v : ⟦ σ ⟧} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ≡ ⟦ weaken (drop σ • Γ≼Γ) t ⟧ (v • ρ)

weaken-once {t = t} {v} {ρ} = trans
  (cong ⟦ t ⟧ (sym weak-id))
  (sym (weaken-sound t (v • ρ)))

embed-correct : ∀ {τ Γ}
  {dt : ΔTerm Γ τ}
  {ρ : ΔEnv Γ} {V : dt is-valid-for ρ}
  {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ dt ⟧Δ ρ V ≈ ⟦ embed dt ⟧ ρ′

embed-correct {dt = Δnat old new} = refl , refl

embed-correct {dt = Δbag db} = refl

embed-correct {dt = Δvar x} {ρ} {ρ′ = ρ′} {C} =
  deriveVar-correct {x = x} {ρ} {ρ′} {C}

embed-correct {dt = Δadd ds dt} {ρ} {V} {ρ′} {C} =
  let
    s00 , s01 = ⟦ ds ⟧Δ ρ (car V)
    t00 , t01 = ⟦ dt ⟧Δ ρ (cadr V)
    s10 = ⟦ embed ds ⟧ ρ′ ⟦fst⟧
    s11 = ⟦ embed ds ⟧ ρ′ ⟦snd⟧
    t10 = ⟦ embed dt ⟧ ρ′ ⟦fst⟧
    t11 = ⟦ embed dt ⟧ ρ′ ⟦snd⟧
    rec-s = embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
    rec-t = embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C}
  in

    (begin
      s00 + t00
    ≡⟨ cong₂ _+_ (proj₁ rec-s) (proj₁ rec-t) ⟩
      s10 + t10
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦fst⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦fst⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed ds) (⟦fst⟧ • ρ′))))
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed dt) (⟦fst⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧
    ∎)
    ,
    (begin
      s01 + t01
    ≡⟨ cong₂ _+_ (proj₂ rec-s) (proj₂ rec-t) ⟩
      s11 + t11
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦snd⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦snd⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed ds) (⟦snd⟧ • ρ′))))
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed dt) (⟦snd⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧
    ∎)
  where open ≡-Reasoning

embed-correct {dt = Δunion ds dt} {ρ} {V} {ρ′} {C} = cong₂ _++_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δdiff ds dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δmap₁ s dt} {ρ} {V} {ρ′} {C} = cong₂ mapBag
  (weak-eq-term s C)
  (embed-correct {dt = dt} {ρ} {car V} {ρ′} {C})

embed-correct {dt = Δmap₀ s ds t dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (cong₂ mapBag
    (extensionality (λ v →
    begin
      proj₂ (⟦ ds ⟧Δ ρ (car V) v (v , v) refl)
    ≡⟨ proj₂ (embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
        v (v , v) (λ f → f v v) refl (refl , refl)) ⟩
      ⟦ embed ds ⟧ ρ′ v (λ f → f v v) ⟦snd⟧
    ≡⟨ cong (λ hole → hole v (λ f → f v v) ⟦snd⟧)
        (weaken-once {t = embed ds} {v} {ρ′}) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (v • ρ′) v (λ f → f v v) ⟦snd⟧
    ∎))
    (cong₂ _++_
      (weak-eq-term t C)
      (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})))
  (cong₂ mapBag (weak-eq-term s C) (weak-eq-term t C))
  where open ≡-Reasoning

embed-correct {dt = Δapp ds t dt} {ρ} {cons vds vdt R[t,dt] _} {ρ′} {C}
  rewrite sym (weak-eq-term t C) =
  embed-correct {dt = ds} {ρ} {vds} {ρ′} {C}
    (⟦ t ⟧Term (ignore ρ)) (⟦ dt ⟧Δ ρ vdt) (⟦ embed dt ⟧Term ρ′)
    R[t,dt] (embed-correct {dt = dt} {ρ} {vdt} {ρ′} {C})

embed-correct {dt = Δabs dt} {ρ} {V} {ρ′} {C} = λ w dw dw′ R[w,dw] dw≈dw′ →
  embed-correct {dt = dt}
    {cons w dw R[w,dw] ρ} {V w dw R[w,dw]}
    {dw′ • w • ρ′} {cons refl dw≈dw′ C tt}

module Embed62 where

open import TaggedDeltaTypes
open import ExplicitNil using (ext³)
open import Relation.Binary.PropositionalEquality
open import Data.Product using (_×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Unit using (⊤ ; tt)
open import Data.Nat

Δ-Type : Type → Type
Δ-Type nats = (nats ⇒ nats ⇒ nats) ⇒ nats -- Church pairs
Δ-Type bags = bags
Δ-Type (σ ⇒ τ) = σ ⇒ Δ-Type σ ⇒ Δ-Type τ

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

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

weak : ∀ {τ Γ} → Term Γ τ → Term (Δ-Context Γ) τ
weak = weaken Γ≼ΔΓ

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

absurd! : ∀ {A B : Set} → A → A → B → B
absurd! _ _ b = b

fst : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
fst = abs (abs (var (that this)))
snd : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ τ)
snd = abs (abs (var this))

difff : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
apply : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ

apply {nats} dt t = app dt snd
apply {bags} dt t = union t dt
apply {σ ⇒ τ} dt t = abs (apply
  (app (app (weaken (drop _ • Γ≼Γ) dt)
    (var this)) (difff (var this) (var this)))
  (app (weaken (drop _ • Γ≼Γ) t) (var this)))

difff {nats} s t = abs (app (app (var this)
  (weaken (drop _ • Γ≼Γ) s)) (weaken (drop _ • Γ≼Γ) t))
difff {bags} s t = diff s t
difff {σ ⇒ τ} s t = abs (abs (difff
  (app (weaken (drop _ • drop _ • Γ≼Γ) s)
    (apply (var this) (var (that this))))
  (app (weaken (drop _ • drop _ • Γ≼Γ) t) (var (that this)))))

embed : ∀ {τ Γ} → ΔTerm Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
embed (Δnat old new) = abs (app (app (var this) (nat old)) (nat new))
embed (Δbag db) = bag db
embed (Δvar x) = var (deriveVar x)
embed (Δabs dt) = abs (abs (embed dt))
embed (Δapp ds t dt) = app (app (embed ds) (weak t)) (embed dt)
embed (Δadd ds dt) = abs (app (app (var this)
  (add (app (weaken (drop _ • Γ≼Γ) (embed ds)) fst)
       (app (weaken (drop _ • Γ≼Γ) (embed dt)) fst)))
  (add (app (weaken (drop _ • Γ≼Γ) (embed ds)) snd)
       (app (weaken (drop _ • Γ≼Γ) (embed dt)) snd)))
embed (Δmap₀ s ds t dt) = diff
  (map (apply (embed ds) (weak s)) (apply (embed dt) (weak t)))
  (weak (map s t))
embed (Δmap₁ s dt) = map (weak s) (embed dt)
embed (Δunion ds dt) = union (embed ds) (embed dt)
embed (Δdiff ds dt) = diff (embed ds) (embed dt)

⟦fst⟧ : ∀ {A : Set} → A → A → A
⟦fst⟧ a b = a
⟦snd⟧ : ∀ {A : Set} → A → A → A
⟦snd⟧ a b = b

_≈_ : ∀ {τ} → ΔVal τ → ⟦ Δ-Type τ ⟧ → Set
_≈_ {nats} (old , new) v = old ≡ v ⟦fst⟧ × new ≡ v ⟦snd⟧
_≈_ {bags} u v = u ≡ v
_≈_ {σ ⇒ τ} u v =
  (w : ⟦ σ ⟧) (dw : ΔVal σ) (dw′ : ⟦ Δ-Type σ ⟧)
  (R[w,dw] : valid w dw) (eq : dw ≈ dw′) →
  u w dw R[w,dw] ≈ v w dw′

infix 4 _≈_

compatible : ∀ {Γ} → ΔEnv Γ → ⟦ Δ-Context Γ ⟧ → Set
compatible {∅} ∅ ∅ = EmptySet
compatible {τ • Γ} (cons v dv _ ρ) (dv′ • v′ • ρ′) =
  triple (v ≡ v′) (dv ≈ dv′) (compatible ρ ρ′)

deriveVar-correct : ∀ {τ Γ} {x : Var Γ τ}
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ x ⟧ΔVar ρ ≈ ⟦ deriveVar x ⟧ ρ′

deriveVar-correct {x = this} -- pattern-matching on ρ, ρ′ NOT optional
  {cons _ _ _ _} {_ • _ • _} {cons _ dv≈dv′ _ _} = dv≈dv′
deriveVar-correct {x = that y}
  {cons _ _ _ ρ} {_ • _ • ρ′} {cons _ _ C _} =
  deriveVar-correct {x = y} {ρ} {ρ′} {C}

weak-id : ∀ {Γ} {ρ : ⟦ Γ ⟧} → ⟦ Γ≼Γ {Γ} ⟧ ρ ≡ ρ
weak-id {∅} {∅} = refl
weak-id {τ • Γ} {v • ρ} = cong₂ _•_ {x = v} refl (weak-id {Γ} {ρ})

weak-eq : ∀ {Γ} {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧}
  (C : compatible ρ ρ′) → ignore ρ ≡ ⟦ Γ≼ΔΓ ⟧ ρ′

weak-eq {∅} {∅} {∅} _ = refl
weak-eq {τ • Γ} {cons v dv _ ρ} {dv′ • v′ • ρ′} (cons v≡v′ _ C _) =
  cong₂ _•_ v≡v′ (weak-eq C)

weak-eq-term : ∀ {τ Γ} (t : Term Γ τ)
  {ρ : ΔEnv Γ} {ρ′ : ⟦ Δ-Context Γ ⟧} (C : compatible ρ ρ′) →
  ⟦ t ⟧ (ignore ρ) ≡ ⟦ weaken Γ≼ΔΓ t ⟧ ρ′

weak-eq-term t {ρ} {ρ′} C =
  trans (cong ⟦ t ⟧ (weak-eq C)) (sym (weaken-sound t ρ′))

weaken-once : ∀ {τ Γ σ} {t : Term Γ τ} {v : ⟦ σ ⟧} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ≡ ⟦ weaken (drop σ • Γ≼Γ) t ⟧ (v • ρ)

weaken-once {t = t} {v} {ρ} = trans
  (cong ⟦ t ⟧ (sym weak-id))
  (sym (weaken-sound t (v • ρ)))

embed-correct : ∀ {τ Γ}
  {dt : ΔTerm Γ τ}
  {ρ : ΔEnv Γ} {V : dt is-valid-for ρ}
  {ρ′ : ⟦ Δ-Context Γ ⟧} {C : compatible ρ ρ′} →
  ⟦ dt ⟧Δ ρ V ≈ ⟦ embed dt ⟧ ρ′

embed-correct {dt = Δnat old new} = refl , refl

embed-correct {dt = Δbag db} = refl

embed-correct {dt = Δvar x} {ρ} {ρ′ = ρ′} {C} =
  deriveVar-correct {x = x} {ρ} {ρ′} {C}

embed-correct {dt = Δadd ds dt} {ρ} {V} {ρ′} {C} =
  let
    s00 , s01 = ⟦ ds ⟧Δ ρ (car V)
    t00 , t01 = ⟦ dt ⟧Δ ρ (cadr V)
    s10 = ⟦ embed ds ⟧ ρ′ ⟦fst⟧
    s11 = ⟦ embed ds ⟧ ρ′ ⟦snd⟧
    t10 = ⟦ embed dt ⟧ ρ′ ⟦fst⟧
    t11 = ⟦ embed dt ⟧ ρ′ ⟦snd⟧
    rec-s = embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
    rec-t = embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C}
  in

    (begin
      s00 + t00
    ≡⟨ cong₂ _+_ (proj₁ rec-s) (proj₁ rec-t) ⟩
      s10 + t10
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦fst⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦fst⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦fst⟧ {ℕ} • ρ′)) ⟦fst⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed ds) (⟦fst⟧ • ρ′))))
      (cong (λ f → f ⟦fst⟧) (sym (weaken-sound (embed dt) (⟦fst⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦fst⟧ • ρ′) ⟦fst⟧
    ∎)
    ,
    (begin
      s01 + t01
    ≡⟨ cong₂ _+_ (proj₂ rec-s) (proj₂ rec-t) ⟩
      s11 + t11
    ≡⟨ cong₂ _+_
        (cong (λ x → ⟦ embed ds ⟧ x ⟦snd⟧) (sym weak-id))
        (cong (λ x → ⟦ embed dt ⟧ x ⟦snd⟧) (sym weak-id)) ⟩
      ⟦ embed ds ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧ +
      ⟦ embed dt ⟧ (⟦ drop _ • Γ≼Γ ⟧ (⟦snd⟧ {ℕ} • ρ′)) ⟦snd⟧
    ≡⟨ cong₂ _+_
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed ds) (⟦snd⟧ • ρ′))))
      (cong (λ f → f ⟦snd⟧) (sym (weaken-sound (embed dt) (⟦snd⟧ • ρ′)))) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧ +
      ⟦ weaken (drop _ • Γ≼Γ) (embed dt) ⟧ (⟦snd⟧ • ρ′) ⟦snd⟧
    ∎)
  where open ≡-Reasoning

embed-correct {dt = Δunion ds dt} {ρ} {V} {ρ′} {C} = cong₂ _++_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δdiff ds dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (embed-correct {dt = ds} {ρ} {car  V} {ρ′} {C})
  (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})

embed-correct {dt = Δmap₁ s dt} {ρ} {V} {ρ′} {C} = cong₂ mapBag
  (weak-eq-term s C)
  (embed-correct {dt = dt} {ρ} {car V} {ρ′} {C})

embed-correct {dt = Δmap₀ s ds t dt} {ρ} {V} {ρ′} {C} = cong₂ _\\_
  (cong₂ mapBag
    (extensionality (λ v →
    begin
      proj₂ (⟦ ds ⟧Δ ρ (car V) v (v , v) refl)
    ≡⟨ proj₂ (embed-correct {dt = ds} {ρ} {car V} {ρ′} {C}
        v (v , v) (λ f → f v v) refl (refl , refl)) ⟩
      ⟦ embed ds ⟧ ρ′ v (λ f → f v v) ⟦snd⟧
    ≡⟨ cong (λ hole → hole v (λ f → f v v) ⟦snd⟧)
        (weaken-once {t = embed ds} {v} {ρ′}) ⟩
      ⟦ weaken (drop _ • Γ≼Γ) (embed ds) ⟧ (v • ρ′) v (λ f → f v v) ⟦snd⟧
    ∎))
    (cong₂ _++_
      (weak-eq-term t C)
      (embed-correct {dt = dt} {ρ} {cadr V} {ρ′} {C})))
  (cong₂ mapBag (weak-eq-term s C) (weak-eq-term t C))
  where open ≡-Reasoning

embed-correct {dt = Δapp ds t dt} {ρ} {cons vds vdt R[t,dt] _} {ρ′} {C}
  rewrite sym (weak-eq-term t C) =
  embed-correct {dt = ds} {ρ} {vds} {ρ′} {C}
    (⟦ t ⟧Term (ignore ρ)) (⟦ dt ⟧Δ ρ vdt) (⟦ embed dt ⟧Term ρ′)
    R[t,dt] (embed-correct {dt = dt} {ρ} {vdt} {ρ′} {C})

embed-correct {dt = Δabs dt} {ρ} {V} {ρ′} {C} = λ w dw dw′ R[w,dw] dw≈dw′ →
  embed-correct {dt = dt}
    {cons w dw R[w,dw] ρ} {V w dw R[w,dw]}
    {dw′ • w • ρ′} {cons refl dw≈dw′ C tt}