open import Function
open import Data.Nat using (ℕ ; suc ; zero)
open import Data.Fin using (Fin)
open import Data.Vec
open import Data.Vec.N-ary.NP
open import Relation.Binary.PropositionalEquality

module liftVec where
module single (A : Set)(_+_ : A → A → A)where

  data Tm : Set where
    var : Tm
    cst : A → Tm
    fun : Tm → Tm → Tm

  eval : Tm → A → A
  eval var x = x
  eval (cst c) x = c
  eval (fun tm tm') x = eval tm x + eval tm' x

  veval : {m : ℕ} → Tm → Vec A m → Vec A m
  veval var xs = xs
  veval (cst x) xs = replicate x
  veval (fun tm tm') xs = zipWith _+_ (veval tm xs) (veval tm' xs)

  record Fm : Set where
    constructor _=='_
    field
      lhs : Tm
      rhs : Tm

  s[_] : Fm → Set
  s[ lhs ==' rhs ] = (x : A) → eval lhs x ≡ eval rhs x

  v[_] : Fm → Set
  v[ lhs ==' rhs ] = {m : ℕ}(xs : Vec A m) → veval lhs xs ≡ veval rhs xs

  lemma1 : (t : Tm) → veval t [] ≡ []
  lemma1 var = refl
  lemma1 (cst x) = refl
  lemma1 (fun t t') rewrite lemma1 t | lemma1 t' = refl

  lemma2 : {m : ℕ}(x : A)(xs : Vec A m)(t : Tm) → veval t (x ∷ xs) ≡ eval t x ∷ veval t xs
  lemma2 _ _ var = refl
  lemma2 _ _ (cst c) = refl
  lemma2 x xs (fun t t') rewrite lemma2 x xs t | lemma2 x xs t' = refl

  prf : (t : Fm) → s[ t ] → v[ t ]
  prf (lhs ==' rhs) pr [] rewrite lemma1 lhs | lemma1 rhs = refl
  prf (l ==' r) pr (x ∷ xs) rewrite lemma2 x xs l | lemma2 x xs r = cong₂ (_∷_) (pr x) (prf (l ==' r) pr xs)

module MultiDataType {A : Set} {nrVar : ℕ} where
  data Tm : Set where
    var : Fin nrVar → Tm
    cst : A → Tm
    fun : Tm → Tm → Tm

  infixl 6 _+'_
  _+'_ : Tm → Tm → Tm
  _+'_ = fun

  infix 4 _≡'_
  record TmEq : Set where
    constructor _≡'_
    field
      lhs rhs : Tm

module multi (A : Set)(_+_ : A → A → A)(nrVar : ℕ) where
  open MultiDataType {A} {nrVar} public

  sEnv : Set
  sEnv = Vec A nrVar

  vEnv : ℕ → Set
  vEnv m = Vec (Vec A m) nrVar

  Var : Set
  Var = Fin nrVar

  _!_ : {X : Set} → Vec X nrVar → Var → X
  E ! v = lookup v E

  eval : Tm → sEnv → A
  eval (var x) G = G ! x
  eval (cst c) G = c
  eval (fun t t') G = eval t G + eval t' G

  veval : {m : ℕ} → Tm → vEnv m → Vec A m
  veval (var x) G = G ! x
  veval (cst c) G = replicate c
  veval (fun t t') G = zipWith _+_ (veval t G) (veval t' G)

  lemma1 : {xs : Vec (Vec A 0) nrVar} (t : Tm) → veval t xs ≡ []
  lemma1 {xs} (var x) with xs ! x
  ... | [] = refl
  lemma1 (cst x) = refl
  lemma1 {xs} (fun t t') rewrite lemma1 {xs} t | lemma1 {xs} t' = refl

  lemVar : {m n : ℕ}(G : Vec (Vec A (suc m)) n)(i : Fin n) → lookup i G ≡ lookup i (map head G) ∷ lookup i (map tail G)
  lemVar [] ()
  lemVar ((x ∷ G) ∷ G₁) Data.Fin.zero = refl
  lemVar (G ∷ G') (Data.Fin.suc i) = lemVar G' i

  lemma2 : {n : ℕ}(xs : vEnv (suc n))(t : Tm) → veval t xs ≡ eval t (map head xs) ∷ veval t (map tail xs)
  lemma2 G (var x) = lemVar G x
  lemma2 _ (cst x) = refl
  lemma2 G (fun t t') rewrite lemma2 G t | lemma2 G t' = refl

  s[_==_] : Tm → Tm → Set
  s[ l == r ] = (G : Vec A nrVar) → eval l G ≡ eval r G

  v[_==_] : Tm → Tm → Set
  v[ l == r ] = {m : ℕ}(G : Vec (Vec A m) nrVar) → veval l G ≡ veval r G

  prf : (l r : Tm) → s[ l == r ] → v[ l == r ]
  prf l r pr {zero} G rewrite lemma1 {G} l | lemma1 {G} r = refl
  prf l r pr {suc m} G rewrite lemma2 G l | lemma2 G r
     = cong₂ _∷_ (pr (replicate head ⊛ G)) (prf l r pr (map tail G))

module Full (A : Set)(_+_ : A → A → A) (m : ℕ) n where
  open multi A _+_ n public

  solve : ∀ (l r : Tm) → ∀ⁿ n (curryⁿ′ (λ G → eval l G ≡ eval r G))
         → ∀ⁿ n (curryⁿ′ (λ G → veval {m} l G ≡ veval r G))
  solve l r x = curryⁿ {n} {A = Vec A m} {B = curryⁿ′ f}
        (λ xs → subst id (sym (curry-$ⁿ′ f xs))
                   (prf l r (λ G → subst id (curry-$ⁿ′ g G) (x $ⁿ G)) xs))
    where f = λ G → veval {m} l G ≡ veval r G
          g = λ G → eval l G ≡ eval r G

  mkTm : N-ary n Tm TmEq → TmEq
  mkTm = go (tabulate id) where
    go : {m : ℕ} -> Vec (Fin n) m → N-ary m Tm TmEq → TmEq
    go [] f         = f
    go (x ∷ args) f = go args (f (var x))

  prove :  ∀ (t : N-ary n Tm TmEq) →
           let
             l = TmEq.lhs (mkTm t)
             r = TmEq.rhs (mkTm t)
           in ∀ⁿ n (curryⁿ′ (λ G → eval l G ≡ eval r G))
         → ∀ⁿ n (curryⁿ′ (λ G → veval {m} l G ≡ veval r G))
  prove t x = solve (TmEq.lhs (mkTm t)) (TmEq.rhs (mkTm t)) x

open import Data.Bool

module example where

  open import Data.Fin
  open import Data.Bool.NP
  open import Data.Product using (Σ ; proj₁)

  module VecBoolXorProps {m} = Full Bool _xor_ m
  open MultiDataType

  coolTheorem : {m : ℕ} → (xs ys : Vec Bool m) → zipWith _xor_ xs ys ≡ zipWith _xor_ ys xs
  coolTheorem = VecBoolXorProps.prove 2 (λ x y → x +' y ≡' y +' x) Xor°.+-comm

  coolTheorem2 : {m : ℕ} → (xs : Vec Bool m) → _
  coolTheorem2 = VecBoolXorProps.prove 1 (λ x → (x +' x) ≡' (cst false)) (proj₁ Xor°.-‿inverse)

test = example.coolTheorem (true ∷ false ∷ []) (false ∷ false ∷ [])

open import Function
open import Data.Nat using (ℕ ; suc ; zero)
open import Data.Fin using (Fin)
open import Data.Vec
open import Data.Vec.N-ary.NP
open import Relation.Binary.PropositionalEquality

module liftVec where
module single (A : Set)(_+_ : A → A → A)where

  data Tm : Set where
    var : Tm
    cst : A → Tm
    fun : Tm → Tm → Tm

  eval : Tm → A → A
  eval var x = x
  eval (cst c) x = c
  eval (fun tm tm') x = eval tm x + eval tm' x

  veval : {m : ℕ} → Tm → Vec A m → Vec A m
  veval var xs = xs
  veval (cst x) xs = replicate x
  veval (fun tm tm') xs = zipWith _+_ (veval tm xs) (veval tm' xs)

  record Fm : Set where
    constructor _=='_
    field
      lhs : Tm
      rhs : Tm

  s[_] : Fm → Set
  s[ lhs ==' rhs ] = (x : A) → eval lhs x ≡ eval rhs x

  v[_] : Fm → Set
  v[ lhs ==' rhs ] = {m : ℕ}(xs : Vec A m) → veval lhs xs ≡ veval rhs xs

  lemma1 : (t : Tm) → veval t [] ≡ []
  lemma1 var = refl
  lemma1 (cst x) = refl
  lemma1 (fun t t') rewrite lemma1 t | lemma1 t' = refl

  lemma2 : {m : ℕ}(x : A)(xs : Vec A m)(t : Tm) → veval t (x ∷ xs) ≡ eval t x ∷ veval t xs
  lemma2 _ _ var = refl
  lemma2 _ _ (cst c) = refl
  lemma2 x xs (fun t t') rewrite lemma2 x xs t | lemma2 x xs t' = refl

  prf : (t : Fm) → s[ t ] → v[ t ]
  prf (lhs ==' rhs) pr [] rewrite lemma1 lhs | lemma1 rhs = refl
  prf (l ==' r) pr (x ∷ xs) rewrite lemma2 x xs l | lemma2 x xs r = cong₂ (_∷_) (pr x) (prf (l ==' r) pr xs)

module MultiDataType {A : Set} {nrVar : ℕ} where
  data Tm : Set where
    var : Fin nrVar → Tm
    cst : A → Tm
    fun : Tm → Tm → Tm

  infixl 6 _+'_
  _+'_ : Tm → Tm → Tm
  _+'_ = fun

  infix 4 _≡'_
  record TmEq : Set where
    constructor _≡'_
    field
      lhs rhs : Tm

module multi (A : Set)(_+_ : A → A → A)(nrVar : ℕ) where
  open MultiDataType {A} {nrVar} public

  sEnv : Set
  sEnv = Vec A nrVar

  vEnv : ℕ → Set
  vEnv m = Vec (Vec A m) nrVar

  Var : Set
  Var = Fin nrVar

  _!_ : {X : Set} → Vec X nrVar → Var → X
  E ! v = lookup v E

  eval : Tm → sEnv → A
  eval (var x) G = G ! x
  eval (cst c) G = c
  eval (fun t t') G = eval t G + eval t' G

  veval : {m : ℕ} → Tm → vEnv m → Vec A m
  veval (var x) G = G ! x
  veval (cst c) G = replicate c
  veval (fun t t') G = zipWith _+_ (veval t G) (veval t' G)

  lemma1 : {xs : Vec (Vec A 0) nrVar} (t : Tm) → veval t xs ≡ []
  lemma1 {xs} (var x) with xs ! x
  ... | [] = refl
  lemma1 (cst x) = refl
  lemma1 {xs} (fun t t') rewrite lemma1 {xs} t | lemma1 {xs} t' = refl

  lemVar : {m n : ℕ}(G : Vec (Vec A (suc m)) n)(i : Fin n) → lookup i G ≡ lookup i (map head G) ∷ lookup i (map tail G)
  lemVar [] ()
  lemVar ((x ∷ G) ∷ G₁) Data.Fin.zero = refl
  lemVar (G ∷ G') (Data.Fin.suc i) = lemVar G' i

  lemma2 : {n : ℕ}(xs : vEnv (suc n))(t : Tm) → veval t xs ≡ eval t (map head xs) ∷ veval t (map tail xs)
  lemma2 G (var x) = lemVar G x
  lemma2 _ (cst x) = refl
  lemma2 G (fun t t') rewrite lemma2 G t | lemma2 G t' = refl

  s[_==_] : Tm → Tm → Set
  s[ l == r ] = (G : Vec A nrVar) → eval l G ≡ eval r G

  v[_==_] : Tm → Tm → Set
  v[ l == r ] = {m : ℕ}(G : Vec (Vec A m) nrVar) → veval l G ≡ veval r G

  prf : (l r : Tm) → s[ l == r ] → v[ l == r ]
  prf l r pr {zero} G rewrite lemma1 {G} l | lemma1 {G} r = refl
  prf l r pr {suc m} G rewrite lemma2 G l | lemma2 G r
     = cong₂ _∷_ (pr (replicate head ⊛ G)) (prf l r pr (map tail G))

module Full (A : Set)(_+_ : A → A → A) (m : ℕ) n where
  open multi A _+_ n public

  solve : ∀ (l r : Tm) → ∀ⁿ n (curryⁿ′ (λ G → eval l G ≡ eval r G))
         → ∀ⁿ n (curryⁿ′ (λ G → veval {m} l G ≡ veval r G))
  solve l r x = curryⁿ {n} {A = Vec A m} {B = curryⁿ′ f}
        (λ xs → subst id (sym (curry-$ⁿ′ f xs))
                   (prf l r (λ G → subst id (curry-$ⁿ′ g G) (x $ⁿ G)) xs))
    where f = λ G → veval {m} l G ≡ veval r G
          g = λ G → eval l G ≡ eval r G

  mkTm : N-ary n Tm TmEq → TmEq
  mkTm = go (tabulate id) where
    go : {m : ℕ} -> Vec (Fin n) m → N-ary m Tm TmEq → TmEq
    go [] f         = f
    go (x ∷ args) f = go args (f (var x))

  prove :  ∀ (t : N-ary n Tm TmEq) →
           let
             l = TmEq.lhs (mkTm t)
             r = TmEq.rhs (mkTm t)
           in ∀ⁿ n (curryⁿ′ (λ G → eval l G ≡ eval r G))
         → ∀ⁿ n (curryⁿ′ (λ G → veval {m} l G ≡ veval r G))
  prove t x = solve (TmEq.lhs (mkTm t)) (TmEq.rhs (mkTm t)) x

open import Data.Two

module example where

  open import Data.Fin
  open import Data.Product using (Σ ; proj₁)

  module VecBoolXorProps {m} = Full 𝟚 _xor_ m
  open MultiDataType

  coolTheorem : {m : ℕ} → (xs ys : Vec 𝟚 m) → zipWith _xor_ xs ys ≡ zipWith _xor_ ys xs
  coolTheorem = VecBoolXorProps.prove 2 (λ x y → x +' y ≡' y +' x) Xor°.+-comm

  coolTheorem2 : {m : ℕ} → (xs : Vec 𝟚 m) → _
  coolTheorem2 = VecBoolXorProps.prove 1 (λ x → (x +' x) ≡' (cst 0₂)) (proj₁ Xor°.-‿inverse)

test = example.coolTheorem (1₂ ∷ 0₂ ∷ []) (0₂ ∷ 0₂ ∷ [])

Upgrade to Data.Two

Upgrade to Data.Two


module Base.Change.Context
    {Type : Set}
    (ΔType : Type → Type) where

-- Transform a context of values into a context of values and
-- changes.

open import Base.Syntax.Context Type

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

-- like ΔContext, but ΔType τ and τ are swapped
ΔContext′ : Context → Context
ΔContext′ ∅ = ∅
ΔContext′ (τ • Γ) = τ • ΔType τ • ΔContext′ Γ

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

module Base.Change.Context
    {Type : Set}
    (ΔType : Type → Type) where

open import Base.Syntax.Context Type

-- Transform a context of values into a context of values and
-- changes.

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

-- like ΔContext, but ΔType τ and τ are swapped
ΔContext′ : Context → Context
ΔContext′ ∅ = ∅
ΔContext′ (τ • Γ) = τ • ΔType τ • ΔContext′ Γ

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

Move function-specific comment right before function

Currently, this seems a comment about the whole module.

Old-commit-hash: c25e918e712496981adfe4c74f94a8d80e8e5052


module Denotation.Change.Popl14 where

-- 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 Popl14.Denotation.Value
open import Theorem.Groups-Popl14
open import Postulate.Extensionality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14

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

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

infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num
-- apply Δv v ::= v ⊞ Δv
_⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
--   diff u v ::= u ⊟ v
_⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ

-- 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 intended to be the semantic domain for changes of values
-- of type τ.
--
-- Δ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 int = ℤ
ΔVal bag = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

-- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊞_ {int} n Δn = n + Δn
_⊞_ {bag} b Δb = b ++ Δb
_⊞_ {σ ⇒ τ} f Δf = λ v → f v ⊞ Δf v (v ⊟ v) (R[v,u-v] {σ})

-- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
_⊟_ {int} m n = m - n
_⊟_ {bag} d b = d \\ b
_⊟_ {σ ⇒ τ} g f = λ v Δv R[v,Δv] → g (v ⊞ Δv) ⊟ f v

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {int} n Δn = ⊤
valid {bag} b Δb = ⊤
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]

-- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
v+[u-v]=u {int} {u} {v} = n+[m-n]=m {v} {u}
v+[u-v]=u {bag} {u} {v} = a++[b\\a]=b {v} {u}
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] {int} {u} {v} = tt
R[v,u-v] {bag} {u} {v} = tt
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 = u} {v}) ⟩
      u w′
    ≡⟨ sym (v+[u-v]=u {u = u w′} {v w}) ⟩
      v w ⊞ (u ⊟ v) w Δw R[w,Δw]
    ∎) where open ≡-Reasoning

-- `diff` and `apply`, without validity proofs
infixl 6 _⟦⊕⟧_ _⟦⊝⟧_
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧

_⟦⊕⟧_ {int}  n Δn = n +  Δn
_⟦⊕⟧_ {bag}  b Δb = b ++ Δb
_⟦⊕⟧_ {σ ⇒ τ} f Δf = λ v → f v ⟦⊕⟧ Δf v (v ⟦⊝⟧ v)

_⟦⊝⟧_ {int}  m n = m -  n
_⟦⊝⟧_ {bag}  a b = a \\ b
_⟦⊝⟧_ {σ ⇒ τ} g f = λ v Δv → g (v ⟦⊕⟧ Δv) ⟦⊝⟧ f v

module Denotation.Change.Popl14 where

-- 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 Popl14.Denotation.Value
open import Theorem.Groups-Popl14
open import Postulate.Extensionality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14

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

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

infixl 6 _⊞_ _⊟_ -- as with + - in GHC.Num
-- apply Δv v ::= v ⊞ Δv
_⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
--   diff u v ::= u ⊟ v
_⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ

-- 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 : ⟦ τ ⟧} →
  let
    _+_ = _⊞_ {τ}
    _-_ = _⊟_ {τ}
  in
  v + (u - v) ≡ u

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

-- ΔVal τ is intended to be the semantic domain for changes of values
-- of type τ.
--
-- Δ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 base-int) = ℤ
ΔVal (base base-bag) = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

-- _⊞_ : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → ⟦ τ ⟧
_⊞_ {base base-int} n Δn = n + Δn
_⊞_ {base base-bag} b Δb = b ++ Δb
_⊞_ {σ ⇒ τ} f Δf = λ v → f v ⊞ Δf v (v ⊟ v) (R[v,u-v] {σ})

-- _⊟_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ΔVal τ
_⊟_ {base base-int} m n = m - n
_⊟_ {base base-bag} d b = d \\ b
_⊟_ {σ ⇒ τ} g f = λ v Δv R[v,Δv] → g (v ⊞ Δv) ⊟ f v

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {base base-int} n Δn = ⊤
valid {base base-bag} b Δb = ⊤
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 base-int} {u} {v} = n+[m-n]=m {v} {u}
v+[u-v]=u {base base-bag} {u} {v} = a++[b\\a]=b {v} {u}
v+[u-v]=u {σ ⇒ τ} {u} {v} =
  let
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₀_ = _⊞_ {σ}
    _-₀_ = _⊟_ {σ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    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 base-int} {u} {v} = tt
R[v,u-v] {base base-bag} {u} {v} = tt
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

-- `diff` and `apply`, without validity proofs
infixl 6 _⟦⊕⟧_ _⟦⊝⟧_
_⟦⊕⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ ΔType τ ⟧ → ⟦ τ ⟧
_⟦⊝⟧_ : ∀ {τ} → ⟦ τ ⟧ → ⟦ τ ⟧ → ⟦ ΔType τ ⟧

_⟦⊕⟧_ {base base-int}  n Δn = n +  Δn
_⟦⊕⟧_ {base base-bag}  b Δb = b ++ Δb
_⟦⊕⟧_ {σ ⇒ τ} f Δf = λ v →
  let
    _-₀_ = _⟦⊝⟧_ {σ}
    _+₁_ = _⟦⊕⟧_ {τ}
  in
    f v +₁ Δf v (v -₀ v)

_⟦⊝⟧_ {base base-int}  m n = m -  n
_⟦⊝⟧_ {base base-bag}  a b = a \\ b
_⟦⊝⟧_ {σ ⇒ τ} g f = λ v Δv → _⟦⊝⟧_ {τ} (g (_⟦⊕⟧_ {σ} v Δv)) (f v)

[WIP] add type annotations to Denotation.Change.Popl14

Old-commit-hash: 90b06722aecf9d0b5c6c69547217cb2c522912be


module lambda where

open import Relation.Binary.PropositionalEquality

open import Denotational.Notation

-- SIMPLE TYPES

-- Syntax

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

infixr 5 _⇒_

-- Denotational Semantics

data Bool : Set where
  true false : Bool

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

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import Syntactic.Contexts Type public
open import Denotational.Environments Type ⟦_⟧Type public

-- TERMS

-- Syntax

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

  true false : ∀ {Γ} → Term Γ bool
  cond : ∀ {Γ τ} → (e₁ : Term Γ bool) (e₂ e₃ : Term Γ τ) → Term Γ τ

-- Denotational Semantics

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

⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ cond t₁ t₂ t₃ ⟧Term ρ with ⟦ t₁ ⟧Term ρ
... | true = ⟦ t₂ ⟧Term ρ
... | false = ⟦ t₃ ⟧Term ρ

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

-- NATURAL SEMANTICS

-- Syntax

data Env : Context → Set
data Val : Type → Set

data Val where
  ⟨abs_,_⟩ : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) (ρ : Env Γ) → Val (τ₁ ⇒ τ₂)
  true : Val bool
  false : Val bool

data Env where
  ∅ : Env ∅
  _•_ : ∀ {Γ τ} → Val τ → Env Γ → Env (τ • Γ)

-- Lookup

infixr 8 _⊢_↓_ _⊢_↦_

data _⊢_↦_ : ∀ {Γ τ} → Env Γ → Var Γ τ → Val τ → Set where
  this : ∀ {Γ τ} {ρ : Env Γ} {v : Val τ} →
    v • ρ ⊢ this ↦ v
  that : ∀ {Γ τ₁ τ₂ x} {ρ : Env Γ} {v₁ : Val τ₁} {v₂ : Val τ₂} →
    ρ ⊢ x ↦ v₂ →
    v₁ • ρ ⊢ that x ↦ v₂

-- Reduction

data _⊢_↓_ : ∀ {Γ τ} → Env Γ → Term Γ τ → Val τ → Set where
  abs : ∀ {Γ τ₁ τ₂ ρ} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ ⟨abs t , ρ ⟩
  app : ∀ {Γ Γ′ τ₁ τ₂ ρ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ ⟨abs t′ , ρ′ ⟩ →
    ρ ⊢ t₂ ↓ v₂ →
    v₂ • ρ′ ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {Γ τ x} {ρ : Env Γ} {v : Val τ}→
    ρ ⊢ x ↦ v →
    ρ ⊢ var x ↓ v
  cond-true : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₂ : Val τ} →
    ρ ⊢ t₁ ↓ true →
    ρ ⊢ t₂ ↓ v₂ →
    ρ ⊢ cond t₁ t₂ t₃ ↓ v₂
  cond-false : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₃ : Val τ} →
    ρ ⊢ t₁ ↓ false →
    ρ ⊢ t₃ ↓ v₃ →
    ρ ⊢ cond t₁ t₂ t₃ ↓ v₃

-- SOUNDNESS of natural semantics

⟦_⟧Env : ∀ {Γ} → Env Γ → ⟦ Γ ⟧
⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧

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

⟦ ⟨abs t , ρ ⟩ ⟧Val = λ v → ⟦ t ⟧ (v • ⟦ ρ ⟧Env)
⟦ true ⟧Val = true
⟦ false ⟧Val = false

meaningOfEnv : ∀ {Γ} → Meaning (Env Γ)
meaningOfEnv = meaning ⟦_⟧Env

meaningOfVal : ∀ {τ} → Meaning (Val τ)
meaningOfVal = meaning ⟦_⟧Val

↦-sound : ∀ {Γ τ ρ v} {x : Var Γ τ} →
  ρ ⊢ x ↦ v →
  ⟦ x ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↦-sound this = refl
↦-sound (that ↦) = ↦-sound ↦

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↓-sound abs = refl
↓-sound (app ↓₁ ↓₂ ↓′) = trans (cong₂ (λ x y → x y) (↓-sound ↓₁) (↓-sound ↓₂)) (↓-sound ↓′)
↓-sound (var ↦) = ↦-sound ↦
↓-sound (cond-true ↓₁ ↓₂) rewrite ↓-sound ↓₁ = ↓-sound ↓₂
↓-sound (cond-false ↓₁ ↓₃) rewrite ↓-sound ↓₁ = ↓-sound ↓₃

-- WEAKENING

-- Weaken a term to a super context

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

module lambda where

open import Relation.Binary.PropositionalEquality

open import Syntactic.Types public
open import Syntactic.Contexts Type public

open import Denotational.Notation
open import Denotational.Values public
open import Denotational.Environments Type ⟦_⟧Type public

-- TERMS

-- Syntax

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

  true false : ∀ {Γ} → Term Γ bool
  cond : ∀ {Γ τ} → (e₁ : Term Γ bool) (e₂ e₃ : Term Γ τ) → Term Γ τ

-- Denotational Semantics

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

⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ cond t₁ t₂ t₃ ⟧Term ρ with ⟦ t₁ ⟧Term ρ
... | true = ⟦ t₂ ⟧Term ρ
... | false = ⟦ t₃ ⟧Term ρ

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

-- NATURAL SEMANTICS

-- Syntax

data Env : Context → Set
data Val : Type → Set

data Val where
  ⟨abs_,_⟩ : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) (ρ : Env Γ) → Val (τ₁ ⇒ τ₂)
  true : Val bool
  false : Val bool

data Env where
  ∅ : Env ∅
  _•_ : ∀ {Γ τ} → Val τ → Env Γ → Env (τ • Γ)

-- Lookup

infixr 8 _⊢_↓_ _⊢_↦_

data _⊢_↦_ : ∀ {Γ τ} → Env Γ → Var Γ τ → Val τ → Set where
  this : ∀ {Γ τ} {ρ : Env Γ} {v : Val τ} →
    v • ρ ⊢ this ↦ v
  that : ∀ {Γ τ₁ τ₂ x} {ρ : Env Γ} {v₁ : Val τ₁} {v₂ : Val τ₂} →
    ρ ⊢ x ↦ v₂ →
    v₁ • ρ ⊢ that x ↦ v₂

-- Reduction

data _⊢_↓_ : ∀ {Γ τ} → Env Γ → Term Γ τ → Val τ → Set where
  abs : ∀ {Γ τ₁ τ₂ ρ} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ ⟨abs t , ρ ⟩
  app : ∀ {Γ Γ′ τ₁ τ₂ ρ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ ⟨abs t′ , ρ′ ⟩ →
    ρ ⊢ t₂ ↓ v₂ →
    v₂ • ρ′ ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {Γ τ x} {ρ : Env Γ} {v : Val τ}→
    ρ ⊢ x ↦ v →
    ρ ⊢ var x ↓ v
  cond-true : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₂ : Val τ} →
    ρ ⊢ t₁ ↓ true →
    ρ ⊢ t₂ ↓ v₂ →
    ρ ⊢ cond t₁ t₂ t₃ ↓ v₂
  cond-false : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₃ : Val τ} →
    ρ ⊢ t₁ ↓ false →
    ρ ⊢ t₃ ↓ v₃ →
    ρ ⊢ cond t₁ t₂ t₃ ↓ v₃

-- SOUNDNESS of natural semantics

⟦_⟧Env : ∀ {Γ} → Env Γ → ⟦ Γ ⟧
⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧

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

⟦ ⟨abs t , ρ ⟩ ⟧Val = λ v → ⟦ t ⟧ (v • ⟦ ρ ⟧Env)
⟦ true ⟧Val = true
⟦ false ⟧Val = false

meaningOfEnv : ∀ {Γ} → Meaning (Env Γ)
meaningOfEnv = meaning ⟦_⟧Env

meaningOfVal : ∀ {τ} → Meaning (Val τ)
meaningOfVal = meaning ⟦_⟧Val

↦-sound : ∀ {Γ τ ρ v} {x : Var Γ τ} →
  ρ ⊢ x ↦ v →
  ⟦ x ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↦-sound this = refl
↦-sound (that ↦) = ↦-sound ↦

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↓-sound abs = refl
↓-sound (app ↓₁ ↓₂ ↓′) = trans (cong₂ (λ x y → x y) (↓-sound ↓₁) (↓-sound ↓₂)) (↓-sound ↓′)
↓-sound (var ↦) = ↦-sound ↦
↓-sound (cond-true ↓₁ ↓₂) rewrite ↓-sound ↓₁ = ↓-sound ↓₂
↓-sound (cond-false ↓₁ ↓₃) rewrite ↓-sound ↓₁ = ↓-sound ↓₃

-- WEAKENING

-- Weaken a term to a super context

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

Improve reuse (see #28).

Improve reuse (see #28).

Old-commit-hash: 7da11aabf971e192ab71542164b98c80cbe26325


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

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

-- Terms that operate on changes

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

open import Data.Product

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

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

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

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

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

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    let
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
      _⊝σ_ = λ {Γ} s t  → app₂ (diffσ {Γ}) s t
      _⊝τ_ = λ {Γ} s t  → app₂ (diffτ {Γ}) s t
      _⊕σ_ = λ {Γ} t Δt → app₂ (applyσ {Γ}) Δt t
      _⊕τ_ = λ {Γ} t Δt → app₂ (applyτ {Γ}) Δt t
    in
      abs₄ (λ g f x Δx → app f (x ⊕σ Δx) ⊝τ app g x)
      ,
      abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y))

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

  lift-diff = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

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

  lift-apply = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})

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

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

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

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

-- Terms that operate on changes

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

open import Data.Product

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

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

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

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

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

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    let
      -- syntactic sugars
      diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
      diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
      applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
      applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
      _⊝σ_ = λ {Γ} s t  → app₂ (diffσ {Γ}) s t
      _⊝τ_ = λ {Γ} s t  → app₂ (diffτ {Γ}) s t
      _⊕σ_ = λ {Γ} t Δt → app₂ (applyσ {Γ}) Δt t
      _⊕τ_ = λ {Γ} t Δt → app₂ (applyτ {Γ}) Δt t
    in
      abs₄ (λ g f x Δx → app f (x ⊕σ Δx) ⊝τ app g x)
      ,
      abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y))

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

  diff-term = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

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

  lift-apply = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})

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

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

Rename lift-diff to diff-term.

Rename lift-diff to diff-term.

Old-commit-hash: 64cb73fbed07060d460e4d9ee85fcec48281d13a


module Syntax.Term.Plotkin where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product
open import Syntax.Type.Plotkin
open import Syntax.Context

data Term
  {B : Set {- of base types -}}
  {C : Set {- of constants -}}
  {type-of : C → Type B}
  (Γ : Context {Type B}) :
  (τ : Type B) → Set
  where
  const : (c : C) → Term Γ (type-of c)
  var : ∀ {τ} → (x : Var Γ τ) → Term Γ τ
  app : ∀ {σ τ}
    (s : Term {B} {C} {type-of} Γ (σ ⇒ τ))
    (t : Term {B} {C} {type-of} Γ σ) → Term Γ τ
  abs : ∀ {σ τ}
    (t : Term {B} {C} {type-of} (σ • Γ) τ) → Term Γ (σ ⇒ τ)

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

lift-diff-apply : ∀ {B C type-of} {Δbase : B → Type B} →
  let
    Δtype = lift-Δtype Δbase
    term = Term {B} {C} {type-of}
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {B C type-of} {Δbase : B → Type B} →
  let
    Δtype = lift-Δtype Δbase
    term = Term {B} {C} {type-of}
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {B C type-of} {Δbase : B → Type B} →
  let
    Δtype = lift-Δtype Δbase
    term = Term {B} {C} {type-of}
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {B C ⊢ Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term {B} {C} {⊢} Γ₁ τ →
  Term {B} {C} {⊢} Γ₂ τ
weaken Γ₁≼Γ₂ (const c) = const c
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

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

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

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

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

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

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

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

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

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product
open import Syntax.Type.Plotkin
open import Syntax.Context

data Term
  {type-of : C → Type B}
  (Γ : Context {Type B}) :
  (τ : Type B) → Set
  where
  const : (c : C) → Term Γ (type-of c)
  var : ∀ {τ} → (x : Var Γ τ) → Term Γ τ
  app : ∀ {σ τ}
    (s : Term {type-of} Γ (σ ⇒ τ))
    (t : Term {type-of} Γ σ) → Term Γ τ
  abs : ∀ {σ τ}
    (t : Term {type-of} (σ • Γ) τ) → Term Γ (σ ⇒ τ)

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

lift-diff-apply : ∀ {type-of} {Δbase : B → Type B} →
  let
    Δtype = lift-Δtype Δbase
    term = Term {type-of}
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {type-of} {Δbase : B → Type B} →
  let
    Δtype = lift-Δtype Δbase
    term = Term {type-of}
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {type-of} {Δbase : B → Type B} →
  let
    Δtype = lift-Δtype Δbase
    term = Term {type-of}
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {⊢ Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term {⊢} Γ₁ τ →
  Term {⊢} Γ₂ τ
weaken Γ₁≼Γ₂ (const c) = const c
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

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

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

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

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

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

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

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

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

Move parameters to module level.

Move parameters to module level.

All definitions in this module depend on the parameters {B} and
{C} which never change inside this module. So it is easier to
parameterize the whole module instead of each separate
definition.

Old-commit-hash: 1303320f48d486d11152713c604275c2c7bcdc18


module Base.Change.Products where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra

open import Data.Product

-- Also try defining sectioned change structures on the positives halves of
-- groups? Or on arbitrary subsets?

-- Restriction: we pair sets on the same level (because right now everything
-- else would risk getting in the way).
module ProductChanges ℓ (A B : Set ℓ) {{CA : ChangeAlgebra ℓ A}} {{CB : ChangeAlgebra ℓ B}} where
  open ≡-Reasoning

  -- The simplest possible definition of changes for products.

  -- The following is probably bullshit:
  -- Does not handle products of functions - more accurately, writing the
  -- derivative of fst and snd for products of functions is hard: fst' p dp must return the change of fst p
  PChange : A × B → Set ℓ
  PChange (a , b) = Δ a × Δ b

  _⊕_ : (v : A × B) → PChange v → A × B
  _⊕_ (a , b) (da , db) = a ⊞ da , b ⊞ db
  _⊝_ : A × B → (v : A × B) → PChange v
  _⊝_ (aNew , bNew) (a , b) = aNew ⊟ a , bNew ⊟ b

  p-update-diff : (u v : A × B) → v ⊕ (u ⊝ v) ≡ u
  p-update-diff (ua , ub) (va , vb) =
    let u = (ua , ub)
        v = (va , vb)
    in
      begin
        v ⊕ (u ⊝ v)
      ≡⟨⟩
        (va ⊞ (ua ⊟ va) , vb ⊞ (ub ⊟ vb))
        --v ⊕ ((ua ⊟ va , ub ⊟ vb))
      ≡⟨ cong₂ _,_ (update-diff ua va) (update-diff ub vb)⟩
        (ua , ub)
      ≡⟨⟩
        u
      ∎

  changeAlgebra : ChangeAlgebra ℓ (A × B)
  changeAlgebra = record
    { Change = PChange
    ; update = _⊕_
    ; diff = _⊝_
    ; isChangeAlgebra = record
      { update-diff = p-update-diff
      }
    }

  proj₁′ : (v : A × B) → Δ v → Δ (proj₁ v)
  proj₁′ (a , b) (da , db) = da

  proj₁′Derivative : Derivative proj₁ proj₁′
  -- Implementation note: we do not need to pattern match on v and dv because
  -- they are records, hence Agda knows that pattern matching on records cannot
  -- fail. Technically, the required feature is the eta-rule on records.
  proj₁′Derivative v dv = refl

  -- An extended explanation.
  proj₁′Derivative₁ : Derivative proj₁ proj₁′
  proj₁′Derivative₁ (a , b) (da , db) =
    let v  = (a  , b)
        dv = (da , db)
    in
      begin
        proj₁ v ⊞ proj₁′ v dv
      ≡⟨⟩
        a ⊞ da
      ≡⟨⟩
        proj₁ (v ⊞ dv)
      ∎

  -- Same for the second extractor.
  proj₂′ : (v : A × B) → Δ v → Δ (proj₂ v)
  proj₂′ (a , b) (da , db) = db

  proj₂′Derivative : Derivative proj₂ proj₂′
  proj₂′Derivative v dv = refl

  -- We should do the same for uncurry instead.

  -- What one could wrongly expect to be the derivative of the constructor:
  _,_′ : (a : A) → (da : Δ a) → (b : B) → (db : Δ b) → Δ (a , b)
  _,_′ a da b db = da , db

  -- That has the correct behavior, in a sense, and it would be in the
  -- subset-based formalization in the paper.
  --
  -- But the above is not even a change, because it does not contain a proof of its own validity, and because after application it does not contain a proof

  -- As a consequence, proving that's a derivative seems too insanely hard. We
  -- might want to provide a proof schema for curried functions at once,
  -- starting from the right correctness equation.

  B→A×B = FunctionChanges.changeAlgebra {c = ℓ} {d = ℓ} B (A × B)
  A→B→A×B = FunctionChanges.changeAlgebra {c = ℓ} {d = ℓ} A (B → A × B) {{CA}} {{B→A×B}}
  module ΔBA×B = FunctionChanges B (A × B) {{CB}} {{changeAlgebra}}
  module ΔA→B→A×B = FunctionChanges A (B → A × B) {{CA}} {{B→A×B}}

  _,_′-real : Δ _,_
  _,_′-real = nil _,_
  _,_′-real-Derivative : Derivative {{CA}} {{B→A×B}} _,_ (ΔA→B→A×B.apply _,_′-real)
  _,_′-real-Derivative =
    FunctionChanges.nil-is-derivative A (B → A × B) {{CA}} {{B→A×B}} _,_

  _,_′′ :  (a : A) → Δ a →
      Δ {{B→A×B}} (λ b → (a , b))
  _,_′′ a da = record
    { apply = _,_′ a da
    ; correct = λ b db →
      begin
        (a , b ⊞ db) ⊞ (_,_′ a da) (b ⊞ db) (nil (b ⊞ db))
      ≡⟨⟩
        a ⊞ da , b ⊞ db ⊞ (nil (b ⊞ db))
      ≡⟨ cong (λ □ →  a ⊞ da , □) (update-nil (b ⊞ db)) ⟩
        a ⊞ da , b ⊞ db
      ≡⟨⟩
        (a , b) ⊞ (_,_′ a da) b db
      ∎
    }

  _,_′′′ : Δ {{A→B→A×B}} _,_
  _,_′′′ = record
    { apply = _,_′′
    ; correct = λ a da →
      begin
        update
        (_,_ (a ⊞ da))
        (_,_′′ (a ⊞ da) (nil (a ⊞ da)))
      ≡⟨ {!!} ⟩
        update (_,_ a) (_,_′′ a da)
      ∎
    }
    where
      -- This is needed to use update above.
      -- Passing the change structure seems hard with the given operators; maybe I'm just using them wrongly.
      open ChangeAlgebra B→A×B hiding (nil)
{-
  {!
      begin
        (_,_ (a ⊞ da)) ⊞ _,_′′ (a ⊞ da) (nil (a ⊞ da))
      {- ≡⟨⟩
        a ⊞ da , b ⊞ db ⊞ (nil (b ⊞ db)) -}
      ≡⟨ ? ⟩
        {-a ⊞ da , b ⊞ db
      ≡⟨⟩-}
       (_,_ a) ⊞ (_,_′′ a da)
      ∎!}
    }
-}
  open import Postulate.Extensionality

  _,_′Derivative :
    Derivative {{CA}} {{B→A×B}} _,_  _,_′′
  _,_′Derivative a da =
    begin
      _⊞_ {{B→A×B}} (_,_ a) (_,_′′ a da)
    ≡⟨⟩
      (λ b → (a , b) ⊞ ΔBA×B.apply (_,_′′ a da) b (nil b))
    --ext (λ b → cong (λ □ →  (a , b) ⊞ □) (update-nil {{?}} b))
    ≡⟨ {!!} ⟩
      (λ b → (a , b) ⊞ ΔBA×B.apply (_,_′′ a da) b (nil b))
    ≡⟨ sym {!ΔA→B→A×B.incrementalization _,_ _,_′′′ a da!} ⟩
  --FunctionChanges.incrementalization A (B → A × B) {{CA}} {{{!B→A×B!}}} _,_ {!!} {!!} {!!}
       _,_ (a ⊞ da)
    ∎

module Base.Change.Products where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra

open import Data.Product

-- Also try defining sectioned change structures on the positives halves of
-- groups? Or on arbitrary subsets?

-- Restriction: we pair sets on the same level (because right now everything
-- else would risk getting in the way).
module ProductChanges ℓ (A B : Set ℓ) {{CA : ChangeAlgebra ℓ A}} {{CB : ChangeAlgebra ℓ B}} where
  open ≡-Reasoning

  -- The simplest possible definition of changes for products.

  -- The following is probably bullshit:
  -- Does not handle products of functions - more accurately, writing the
  -- derivative of fst and snd for products of functions is hard: fst' p dp must return the change of fst p
  PChange : A × B → Set ℓ
  PChange (a , b) = Δ a × Δ b

  _⊕_ : (v : A × B) → PChange v → A × B
  _⊕_ (a , b) (da , db) = a ⊞ da , b ⊞ db
  _⊝_ : A × B → (v : A × B) → PChange v
  _⊝_ (aNew , bNew) (a , b) = aNew ⊟ a , bNew ⊟ b

  p-update-diff : (u v : A × B) → v ⊕ (u ⊝ v) ≡ u
  p-update-diff (ua , ub) (va , vb) =
    let u = (ua , ub)
        v = (va , vb)
    in
      begin
        v ⊕ (u ⊝ v)
      ≡⟨⟩
        (va ⊞ (ua ⊟ va) , vb ⊞ (ub ⊟ vb))
        --v ⊕ ((ua ⊟ va , ub ⊟ vb))
      ≡⟨ cong₂ _,_ (update-diff ua va) (update-diff ub vb)⟩
        (ua , ub)
      ≡⟨⟩
        u
      ∎

  changeAlgebra : ChangeAlgebra ℓ (A × B)
  changeAlgebra = record
    { Change = PChange
    ; update = _⊕_
    ; diff = _⊝_
    ; isChangeAlgebra = record
      { update-diff = p-update-diff
      }
    }

  proj₁′ : (v : A × B) → Δ v → Δ (proj₁ v)
  proj₁′ (a , b) (da , db) = da

  proj₁′Derivative : Derivative proj₁ proj₁′
  -- Implementation note: we do not need to pattern match on v and dv because
  -- they are records, hence Agda knows that pattern matching on records cannot
  -- fail. Technically, the required feature is the eta-rule on records.
  proj₁′Derivative v dv = refl

  -- An extended explanation.
  proj₁′Derivative₁ : Derivative proj₁ proj₁′
  proj₁′Derivative₁ (a , b) (da , db) =
    let v  = (a  , b)
        dv = (da , db)
    in
      begin
        proj₁ v ⊞ proj₁′ v dv
      ≡⟨⟩
        a ⊞ da
      ≡⟨⟩
        proj₁ (v ⊞ dv)
      ∎

  -- Same for the second extractor.
  proj₂′ : (v : A × B) → Δ v → Δ (proj₂ v)
  proj₂′ (a , b) (da , db) = db

  proj₂′Derivative : Derivative proj₂ proj₂′
  proj₂′Derivative v dv = refl

  -- We should do the same for uncurry instead.

  -- What one could wrongly expect to be the derivative of the constructor:
  _,_′ : (a : A) → (da : Δ a) → (b : B) → (db : Δ b) → Δ (a , b)
  _,_′ a da b db = da , db

  -- That has the correct behavior, in a sense, and it would be in the
  -- subset-based formalization in the paper.
  --
  -- But the above is not even a change, because it does not contain a proof of its own validity, and because after application it does not contain a proof

  -- As a consequence, proving that's a derivative seems too insanely hard. We
  -- might want to provide a proof schema for curried functions at once,
  -- starting from the right correctness equation.

  B→A×B = FunctionChanges.changeAlgebra {c = ℓ} {d = ℓ} B (A × B)
  A→B→A×B = FunctionChanges.changeAlgebra {c = ℓ} {d = ℓ} A (B → A × B) {{CA}} {{B→A×B}}
  module ΔBA×B = FunctionChanges B (A × B) {{CB}} {{changeAlgebra}}
  module ΔA→B→A×B = FunctionChanges A (B → A × B) {{CA}} {{B→A×B}}

  _,_′-real : Δ _,_
  _,_′-real = nil _,_
  _,_′-real-Derivative : Derivative {{CA}} {{B→A×B}} _,_ (ΔA→B→A×B.apply _,_′-real)
  _,_′-real-Derivative =
    FunctionChanges.nil-is-derivative A (B → A × B) {{CA}} {{B→A×B}} _,_

  _,_′′ :  (a : A) → Δ a →
      Δ {{B→A×B}} (λ b → (a , b))
  _,_′′ a da = record
    { apply = _,_′ a da
    ; correct = λ b db →
      begin
        (a , b ⊞ db) ⊞ (_,_′ a da) (b ⊞ db) (nil (b ⊞ db))
      ≡⟨⟩
        a ⊞ da , b ⊞ db ⊞ (nil (b ⊞ db))
      ≡⟨ cong (λ □ →  a ⊞ da , □) (update-nil (b ⊞ db)) ⟩
        a ⊞ da , b ⊞ db
      ≡⟨⟩
        (a , b) ⊞ (_,_′ a da) b db
      ∎
    }
{-
  _,_′′′ : Δ {{A→B→A×B}} _,_
  _,_′′′ = record
    { apply = _,_′′
    ; correct = λ a da →
      begin
        update
        (_,_ (a ⊞ da))
        (_,_′′ (a ⊞ da) (nil (a ⊞ da)))
      ≡⟨ {!!} ⟩
        update (_,_ a) (_,_′′ a da)
      ∎
    }
    where
      -- This is needed to use update above.
      -- Passing the change structure seems hard with the given operators; maybe I'm just using them wrongly.
      open ChangeAlgebra B→A×B hiding (nil)
{-
  {!
      begin
        (_,_ (a ⊞ da)) ⊞ _,_′′ (a ⊞ da) (nil (a ⊞ da))
      {- ≡⟨⟩
        a ⊞ da , b ⊞ db ⊞ (nil (b ⊞ db)) -}
      ≡⟨ ? ⟩
        {-a ⊞ da , b ⊞ db
      ≡⟨⟩-}
       (_,_ a) ⊞ (_,_′′ a da)
      ∎!}
    }
-}
  open import Postulate.Extensionality

  _,_′Derivative :
    Derivative {{CA}} {{B→A×B}} _,_  _,_′′
  _,_′Derivative a da =
    begin
      _⊞_ {{B→A×B}} (_,_ a) (_,_′′ a da)
    ≡⟨⟩
      (λ b → (a , b) ⊞ ΔBA×B.apply (_,_′′ a da) b (nil b))
    --ext (λ b → cong (λ □ →  (a , b) ⊞ □) (update-nil {{?}} b))
    ≡⟨ {!!} ⟩
      (λ b → (a , b) ⊞ ΔBA×B.apply (_,_′′ a da) b (nil b))
    ≡⟨ sym {!ΔA→B→A×B.incrementalization _,_ _,_′′′ a da!} ⟩
  --FunctionChanges.incrementalization A (B → A × B) {{CA}} {{{!B→A×B!}}} _,_ {!!} {!!} {!!}
       _,_ (a ⊞ da)
    ∎
-}

Comment out holes to ensure Everything compiles again

Old-commit-hash: dfc28a00f9301015066e19d4be2c4179f8e0849b


{-# OPTIONS --without-K #-}
module Explore.Examples where

open import Type
open import Level.NP
open import Data.Maybe.NP
open import Data.List
open import Data.Two
open import Data.Product
open import Data.Sum.NP
open import Data.One
open import HoTT using (UA)
open import Function.Extensionality using (FunExt)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import Explore.Core
open import Explore.Explorable
open import Explore.Universe.Base
open import Explore.Monad {₀} ₀ public renaming (map to map-explore)
open import Explore.Two
open import Explore.Product
open Explore.Product.Operators

module E where
  open FromExplore public

module M {Msg Digest : ★}
         (_==_ : Digest → Digest → 𝟚)
         (H : Msg → Digest)
         (exploreMsg : ∀ {ℓ} → Explore ℓ Msg)
         (d : Digest) where

  module V1 where
    list-H⁻¹ : List Msg
    list-H⁻¹ = exploreMsg [] _++_ (λ m → [0: [] 1: [ m ] ] (H m == d))

  module ExploreMsg = FromExplore {A = Msg} exploreMsg

  module V2 where
    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = ExploreMsg.findKey (λ m → H m == d)

  module V3 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ ε _⊕_ f = exploreMsg ε _⊕_ (λ m → [0: ε 1: f m ] (H m == d))

  module V4 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ = exploreMsg >>= λ m → [0: empty-explore 1: point-explore m ] (H m == d)

  module V5 where

    explore-H⁻¹ : ∀ {ℓ} → Explore ℓ Msg
    explore-H⁻¹ = filter-explore (λ m → H m == d) exploreMsg

    list-H⁻¹ : List Msg
    list-H⁻¹ = E.list explore-H⁻¹

    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = E.first explore-H⁻¹

  module V6 where
    explore-H⁻¹ : ∀ {ℓ} → Explore ℓ Msg
    explore-H⁻¹ = explore-endo (filter-explore (λ m → H m == d) exploreMsg)

    list-H⁻¹ : List Msg
    list-H⁻¹ = E.list explore-H⁻¹

    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = E.first explore-H⁻¹

    last-H⁻¹ : Maybe Msg
    last-H⁻¹ = E.last explore-H⁻¹

Msg = 𝟚 × 𝟚
Digest = 𝟚
-- _==_ : Digest → Digest → 𝟚
H : Msg → Digest
H (x , y) = x xor y
Msgᵉ : ∀ {ℓ} → Explore ℓ Msg
Msgᵉ = 𝟚ᵉ ×ᵉ 𝟚ᵉ
module N5 = M.V5 _==_ H Msgᵉ
module N6 = M.V6 _==_ H Msgᵉ
test5 = N5.list-H⁻¹
test6-list : N6.list-H⁻¹ 0₂ ≡ (0₂ , 0₂) ∷ (1₂ , 1₂) ∷ []
test6-list = refl
test6-rev-list : E.list (E.backward (N6.explore-H⁻¹ 0₂)) ≡ (1₂ , 1₂) ∷ (0₂ , 0₂) ∷ []
test6-rev-list = refl
test6-first : N6.first-H⁻¹ 0₂ ≡ just (0₂ , 0₂)
test6-first = refl
test6-last : N6.last-H⁻¹ 0₂ ≡ just (1₂ , 1₂)
test6-last = refl
-- -}

{-
𝟛ᵁ : U
𝟛ᵁ = 𝟙ᵁ ⊎ᵁ 𝟚ᵁ

list22 = list (𝟚ᵁ →ᵁ 𝟚ᵁ)
list33 = list (𝟛ᵁ →ᵁ 𝟛ᵁ)
-}

{-
module _ {{_ : UA}}{{_ : FunExt}} where
  check22 : ∀ (f : 𝟚 → 𝟚) x → ✓ (f x == f (f (f x)))
  check22 f x = {!check! ((𝟚ᵁ →ᵁ 𝟚ᵁ) ×ᵁ 𝟚ᵁ) (λ { (f , x) → let f' = →ᵁ→→ 𝟚ᵁ 𝟚ᵁ f in f' x == f' (f' (f' x)) }) {{!!}} ((f 0₂ , f 1₂) , x)!}
-}

{-# OPTIONS --without-K #-}
module Explore.Examples where

open import Type
open import Level.NP
open import Data.Maybe.NP
open import Data.List
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Product
open import Data.Sum.NP
open import HoTT using (UA)
open import Function.NP
open import Function.Extensionality using (FunExt)
open import Relation.Binary.PropositionalEquality hiding ([_])

open import Explore.Core
open import Explore.Explorable
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base
open import Explore.Monad {₀} ₀ public renaming (map to map-explore)
open import Explore.Two
open import Explore.Product
open Explore.Product.Operators

module E where
  open FromExplore public

module M {Msg Digest : ★}
         (_==_ : Digest → Digest → 𝟚)
         (H : Msg → Digest)
         (exploreMsg : ∀ {ℓ} → Explore ℓ Msg)
         (d : Digest) where

  module V1 where
    list-H⁻¹ : List Msg
    list-H⁻¹ = exploreMsg [] _++_ (λ m → [0: [] 1: [ m ] ] (H m == d))

  module ExploreMsg = FromExplore {A = Msg} exploreMsg

  module V2 where
    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = ExploreMsg.findKey (λ m → H m == d)

  module V3 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ ε _⊕_ f = exploreMsg ε _⊕_ (λ m → [0: ε 1: f m ] (H m == d))

  module V4 where
    explore-H⁻¹ : Explore ₀ Msg
    explore-H⁻¹ = exploreMsg >>= λ m → [0: empty-explore 1: point-explore m ] (H m == d)

  module V5 where

    explore-H⁻¹ : ∀ {ℓ} → Explore ℓ Msg
    explore-H⁻¹ = filter-explore (λ m → H m == d) exploreMsg

    list-H⁻¹ : List Msg
    list-H⁻¹ = E.list explore-H⁻¹

    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = E.first explore-H⁻¹

  module V6 where
    explore-H⁻¹ : ∀ {ℓ} → Explore ℓ Msg
    explore-H⁻¹ = explore-endo (filter-explore (λ m → H m == d) exploreMsg)

    list-H⁻¹ : List Msg
    list-H⁻¹ = E.list explore-H⁻¹

    first-H⁻¹ : Maybe Msg
    first-H⁻¹ = E.first explore-H⁻¹

    last-H⁻¹ : Maybe Msg
    last-H⁻¹ = E.last explore-H⁻¹

Msg = 𝟚 × 𝟚
Digest = 𝟚
-- _==_ : Digest → Digest → 𝟚
H : Msg → Digest
H (x , y) = x xor y
Msgᵉ : ∀ {ℓ} → Explore ℓ Msg
Msgᵉ = 𝟚ᵉ ×ᵉ 𝟚ᵉ
module N5 = M.V5 _==_ H Msgᵉ
module N6 = M.V6 _==_ H Msgᵉ
test5 = N5.list-H⁻¹
test6-list : N6.list-H⁻¹ 0₂ ≡ (0₂ , 0₂) ∷ (1₂ , 1₂) ∷ []
test6-list = refl
test6-rev-list : E.list (E.backward (N6.explore-H⁻¹ 0₂)) ≡ (1₂ , 1₂) ∷ (0₂ , 0₂) ∷ []
test6-rev-list = refl
test6-first : N6.first-H⁻¹ 0₂ ≡ just (0₂ , 0₂)
test6-first = refl
test6-last : N6.last-H⁻¹ 0₂ ≡ just (1₂ , 1₂)
test6-last = refl
-- -}

𝟛ᵁ : U
𝟛ᵁ = 𝟙ᵁ ⊎ᵁ 𝟚ᵁ

prop-∧-comm : 𝟚 × 𝟚 → 𝟚
prop-∧-comm (x , y) = x ∧ y == y ∧ x

module _ {{_ : UA}}{{_ : FunExt}} where
  check-∧-comm : ∀ x y → ✓ (x ∧ y == y ∧ x)
  check-∧-comm x y = check! (𝟚ᵁ ×ᵁ 𝟚ᵁ) prop-∧-comm (x , y)

prop-∧-∨-distr : 𝟚 × 𝟚 × 𝟚 → 𝟚
prop-∧-∨-distr (x , y , z) = x ∧ (y ∨ z) == x ∧ y ∨ x ∧ z

module _ {{_ : UA}}{{_ : FunExt}} where
  check-∧-∨-distr : ∀ x y z → ✓ (x ∧ (y ∨ z) == x ∧ y ∨ x ∧ z)
  check-∧-∨-distr x y z =
    check! (𝟚ᵁ ×ᵁ 𝟚ᵁ ×ᵁ 𝟚ᵁ) prop-∧-∨-distr (x , y , z)

list22 = list (𝟚ᵁ →ᵁ 𝟚ᵁ)
list33 = list (𝟛ᵁ →ᵁ 𝟛ᵁ)

{-
module _ {{_ : UA}}{{_ : FunExt}} where
  module _ (fᵁ : El (𝟚ᵁ →ᵁ 𝟚ᵁ)) x where
    f = →ᵁ→→ 𝟚ᵁ 𝟚ᵁ fᵁ
    check22 : ✓ (f x == f (f (f x)))
    check22 = check! ((𝟚ᵁ →ᵁ 𝟚ᵁ) ×ᵁ 𝟚ᵁ) (λ { (f , x) → let f' = →ᵁ→→ 𝟚ᵁ 𝟚ᵁ f in f' x == f' (f' (f' x)) }) {{!!}} ((f 0₂ , f 1₂) , x)
  {-
  check22 : ∀ (f : 𝟚 → 𝟚) x → ✓ (f x == f (f (f x)))
  check22 f x = let k = check! ((𝟚ᵁ →ᵁ 𝟚ᵁ) ×ᵁ 𝟚ᵁ) (λ { (f , x) → let f' = →ᵁ→→ 𝟚ᵁ 𝟚ᵁ f in f' x == f' (f' (f' x)) }) {{!!}} ((f 0₂ , f 1₂) , x) in {!k!}
-- -}
-- -}
-- -}
-- -}

Update the Examples

Update the Examples


module Base.Change.Products where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra

open import Data.Product

-- Also try defining sectioned change structures on the positives halves of
-- groups? Or on arbitrary subsets?

-- Restriction: we pair sets on the same level (because right now everything
-- else would risk getting in the way).
module ProductChanges ℓ (A B : Set ℓ) {{CA : ChangeAlgebra ℓ A}} {{CB : ChangeAlgebra ℓ B}} where
  open ≡-Reasoning

  -- The simplest possible definition of changes for products.

  PChange : A × B → Set ℓ
  PChange (a , b) = Δ a × Δ b

  -- An interesting alternative definition allows omitting the nil change of a
  -- component when that nil change can be computed from the type. For instance, the nil change for integers is always the same.

  -- However, the nil change for function isn't always the same (unless we
  -- defunctionalize them first), so nil changes for functions can't be omitted.

  _⊕_ : (v : A × B) → PChange v → A × B
  _⊕_ (a , b) (da , db) = a ⊞ da , b ⊞ db
  _⊝_ : A × B → (v : A × B) → PChange v
  _⊝_ (aNew , bNew) (a , b) = aNew ⊟ a , bNew ⊟ b

  p-nil : (v : A × B) → PChange v
  p-nil (a , b) = (nil a , nil b)

  p-update-diff : (u v : A × B) → v ⊕ (u ⊝ v) ≡ u
  p-update-diff (ua , ub) (va , vb) =
    let u = (ua , ub)
        v = (va , vb)
    in
      begin
        v ⊕ (u ⊝ v)
      ≡⟨⟩
        (va ⊞ (ua ⊟ va) , vb ⊞ (ub ⊟ vb))
        --v ⊕ ((ua ⊟ va , ub ⊟ vb))
      ≡⟨ cong₂ _,_ (update-diff ua va) (update-diff ub vb)⟩
        (ua , ub)
      ≡⟨⟩
        u
      ∎

  p-update-nil : (v : A × B) → v ⊕ (p-nil v) ≡ v
  p-update-nil (a , b) =
    let v = (a , b)
    in
      begin
        v ⊕ (p-nil v)
      ≡⟨⟩
        (a ⊞ nil a , b ⊞ nil b)
      ≡⟨ cong₂ _,_ (update-nil a) (update-nil b)⟩
         (a , b)
      ≡⟨⟩
        v
      ∎

  changeAlgebra : ChangeAlgebra ℓ (A × B)
  changeAlgebra = record
    { Change = PChange
    ; update = _⊕_
    ; diff = _⊝_
    ; nil = p-nil
    ; isChangeAlgebra = record
      { update-diff = p-update-diff
      ; update-nil = p-update-nil
      }
    }

  proj₁′ : (v : A × B) → Δ v → Δ (proj₁ v)
  proj₁′ (a , b) (da , db) = da

  proj₁′Derivative : Derivative proj₁ proj₁′
  -- Implementation note: we do not need to pattern match on v and dv because
  -- they are records, hence Agda knows that pattern matching on records cannot
  -- fail. Technically, the required feature is the eta-rule on records.
  proj₁′Derivative v dv = refl

  -- An extended explanation.
  proj₁′Derivative₁ : Derivative proj₁ proj₁′
  proj₁′Derivative₁ (a , b) (da , db) =
    let v  = (a  , b)
        dv = (da , db)
    in
      begin
        proj₁ v ⊞ proj₁′ v dv
      ≡⟨⟩
        a ⊞ da
      ≡⟨⟩
        proj₁ (v ⊞ dv)
      ∎

  -- Same for the second extractor.
  proj₂′ : (v : A × B) → Δ v → Δ (proj₂ v)
  proj₂′ (a , b) (da , db) = db

  proj₂′Derivative : Derivative proj₂ proj₂′
  proj₂′Derivative v dv = refl

  B→A×B = FunctionChanges.changeAlgebra {c = ℓ} {d = ℓ} B (A × B)
  A→B→A×B = FunctionChanges.changeAlgebra {c = ℓ} {d = ℓ} A (B → A × B) {{CA}} {{B→A×B}}
  module ΔBA×B = FunctionChanges B (A × B) {{CB}} {{changeAlgebra}}
  module ΔA→B→A×B = FunctionChanges A (B → A × B) {{CA}} {{B→A×B}}

  -- Morally, the following is a change:
  -- What one could wrongly expect to be the derivative of the constructor:
  _,_′-realizer : (a : A) → (da : Δ a) → (b : B) → (db : Δ b) → Δ (a , b)
  _,_′-realizer a da b db = da , db

  -- That has the correct behavior, in a sense, and it would be in the
  -- subset-based formalization in the paper.
  --
  -- But the above is not even a change, because it does not contain a proof of
  -- its own validity, and because after application it does not contain a
  -- proof.
  --
  -- However, the above is (morally) a "realizer" of the actual change, since it
  -- only represents its computational behavior, not its proof manipulation.

  -- Hence, we need to do some additional work.

  _,_′-realizer-correct _,_′-realizer-correct-detailed :
    (a : A) → (da : Δ a) → (b : B) → (db : Δ b) →
      (a , b ⊞ db) ⊞ (_,_′-realizer a da (b ⊞ db) (nil (b ⊞ db))) ≡ (a , b) ⊞ (_,_′-realizer a da b db)
  _,_′-realizer-correct a da b db rewrite update-nil (b ⊞ db) = refl

  _,_′-realizer-correct-detailed a da b db =
    begin
      (a , b ⊞ db) ⊞ (_,_′-realizer a da) (b ⊞ db) (nil (b ⊞ db))
    ≡⟨⟩
      a ⊞ da , b ⊞ db ⊞ (nil (b ⊞ db))
    ≡⟨ cong (λ □ →  a ⊞ da , □) (update-nil (b ⊞ db)) ⟩
      a ⊞ da , b ⊞ db
    ≡⟨⟩
      (a , b) ⊞ (_,_′-realizer a da) b db
    ∎

  _,_′ : (a : A) → (da : Δ a) → Δ (_,_ a)
  _,_′ a da = record { apply = _,_′-realizer a da ; correct = λ b db → _,_′-realizer-correct a da b db }

  _,_′-Derivative : Derivative _,_ _,_′
  _,_′-Derivative a da = ext (λ b → cong (_,_ (a ⊞ da)) (update-nil b))
    where
      open import Postulate.Extensionality

  -- Define specialized variant of uncurry, and derive it.
  uncurry₀ : ∀ {C : Set ℓ} → (A → B → C) → A × B → C
  uncurry₀ f (a , b) = f a b

  module _ {C : Set ℓ} {{CC : ChangeAlgebra ℓ C}} where
    B→C : ChangeAlgebra ℓ (B → C)
    B→C = FunctionChanges.changeAlgebra B C
    A→B→C : ChangeAlgebra ℓ (A → B → C)
    A→B→C = FunctionChanges.changeAlgebra A (B → C)
    A×B→C : ChangeAlgebra ℓ (A × B → C)
    A×B→C = FunctionChanges.changeAlgebra (A × B) C
    module ΔB→C = FunctionChanges B C {{CB}} {{CC}}
    module ΔA→B→C = FunctionChanges A (B → C) {{CA}} {{B→C}}
    module ΔA×B→C = FunctionChanges (A × B) C {{changeAlgebra}} {{CC}}

    uncurry₀′-realizer : (f : A → B → C) → Δ f → (p : A × B) → Δ p → Δ (uncurry₀ f p)
    uncurry₀′-realizer f df (a , b) (da , db) = ΔB→C.apply (ΔA→B→C.apply df a da) b db

    uncurry₀′-realizer-correct uncurry₀′-realizer-correct-detailed :
      ∀ (f : A → B → C) (df : Δ f) (p : A × B) (dp : Δ p) →
        uncurry₀ f (p ⊕ dp) ⊞ uncurry₀′-realizer f df (p ⊕ dp) (nil (p ⊞ dp)) ≡ uncurry₀ f p ⊞ uncurry₀′-realizer f df p dp

    -- Hard to read
    uncurry₀′-realizer-correct f df (a , b) (da , db)
      rewrite sym (ΔB→C.incrementalization (f (a ⊞ da)) (ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db) (nil (b ⊞ db)))
      | update-nil (b ⊞ db)
      | {- cong (λ □ → □ (b ⊞ db)) -} (sym (ΔA→B→C.incrementalization f df (a ⊞ da) (nil (a ⊞ da))))
      | update-nil (a ⊞ da)
      | cong (λ □ → □ (b ⊞ db)) (ΔA→B→C.incrementalization f df a da)
      | ΔB→C.incrementalization (f a) (ΔA→B→C.apply df a da) b db
      = refl

    -- Verbose, but it shows all the intermediate steps.
    uncurry₀′-realizer-correct-detailed f df (a , b) (da , db) =
      begin
        uncurry₀ f (a ⊞ da , b ⊞ db) ⊞ uncurry₀′-realizer f df (a ⊞ da , b ⊞ db) (nil (a ⊞ da , b ⊞ db))
      ≡⟨⟩
        f (a ⊞ da) (b ⊞ db) ⊞ ΔB→C.apply (ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db) (nil (b ⊞ db))
      ≡⟨ sym (ΔB→C.incrementalization (f (a ⊞ da)) (ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db) (nil (b ⊞ db))) ⟩
        (f (a ⊞ da) ⊞ ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) ((b ⊞ db) ⊞ (nil (b ⊞ db)))
      ≡⟨ cong-lem₀ ⟩
        (f (a ⊞ da) ⊞ ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db)
      ≡⟨ sym cong-lem₂ ⟩
        ((f ⊞ df) ((a ⊞ da) ⊞ (nil (a ⊞ da)))) (b ⊞ db)
      ≡⟨ cong-lem₁ ⟩
        (f ⊞ df) (a ⊞ da) (b ⊞ db)
      ≡⟨ cong (λ □ → □ (b ⊞ db)) (ΔA→B→C.incrementalization f df a da) ⟩
        (f a ⊞ ΔA→B→C.apply df a da) (b ⊞ db)
      ≡⟨ ΔB→C.incrementalization (f a) (ΔA→B→C.apply df a da) b db ⟩
        f a b ⊞ ΔB→C.apply (ΔA→B→C.apply df a da) b db
      ≡⟨⟩
        uncurry₀ f (a , b) ⊞ uncurry₀′-realizer f df (a , b) (da ,  db)
      ∎
      where
        cong-lem₀ :
            (f (a ⊞ da) ⊞ ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) ((b ⊞ db) ⊞ (nil (b ⊞ db)))
            ≡
            (f (a ⊞ da) ⊞ ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db)
        cong-lem₀ rewrite update-nil (b ⊞ db) = refl

        cong-lem₁ :
                  ((f ⊞ df) ((a ⊞ da) ⊞ (nil (a ⊞ da)))) (b ⊞ db)
                  ≡
                  (f ⊞ df) (a ⊞ da) (b ⊞ db)
        cong-lem₁ rewrite update-nil (a ⊞ da) = refl

        cong-lem₂ :
                  ((f ⊞ df) ((a ⊞ da) ⊞ (nil (a ⊞ da)))) (b ⊞ db)
                  ≡
                  (f (a ⊞ da) ⊞ ΔA→B→C.apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db)
        cong-lem₂ = cong (λ □ → □ (b ⊞ db)) (ΔA→B→C.incrementalization f df (a ⊞ da) (nil (a ⊞ da)))

    uncurry₀′ : (f : A → B → C) → Δ f → Δ (uncurry f)
    uncurry₀′ f df = record
      { apply = uncurry₀′-realizer f df
      ; correct = uncurry₀′-realizer-correct f df }

    -- Now proving that uncurry₀′ is a derivative is trivial!
    uncurry₀′Derivative₀ : Derivative {{CB = A×B→C}} uncurry₀ uncurry₀′
    uncurry₀′Derivative₀ f df = refl

    -- If you wonder what's going on, here's the step-by-step proof, going purely by definitional equality.
    uncurry₀′Derivative : Derivative {{CB = A×B→C}} uncurry₀ uncurry₀′
    uncurry₀′Derivative f df =
      begin
        uncurry₀ f ⊞ uncurry₀′ f df
      ≡⟨⟩
        (λ {(a , b) → uncurry₀ f (a , b) ⊞ ΔA×B→C.apply (uncurry₀′ f df) (a , b) (nil (a , b))})
      ≡⟨⟩
        (λ {(a , b) → f a b ⊞ ΔB→C.apply (ΔA→B→C.apply df a (nil a)) b (nil b)})
      ≡⟨⟩
        (λ {(a , b) → (f a ⊞ ΔA→B→C.apply df a (nil a)) b})
      ≡⟨⟩
        (λ {(a , b) → (f ⊞ df) a b})
      ≡⟨⟩
        (λ {(a , b) → uncurry₀ (f ⊞ df) (a , b)})
      ≡⟨⟩
        uncurry₀ (f ⊞ df)
      ∎

module Base.Change.Products where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra

open import Data.Product

-- Also try defining sectioned change structures on the positives halves of
-- groups? Or on arbitrary subsets?

-- Restriction: we pair sets on the same level (because right now everything
-- else would risk getting in the way).
module ProductChanges ℓ (A B : Set ℓ) {{CA : ChangeAlgebra ℓ A}} {{CB : ChangeAlgebra ℓ B}} where
  open ≡-Reasoning

  -- The simplest possible definition of changes for products.

  PChange : A × B → Set ℓ
  PChange (a , b) = Δ a × Δ b

  -- An interesting alternative definition allows omitting the nil change of a
  -- component when that nil change can be computed from the type. For instance, the nil change for integers is always the same.

  -- However, the nil change for function isn't always the same (unless we
  -- defunctionalize them first), so nil changes for functions can't be omitted.

  _⊕_ : (v : A × B) → PChange v → A × B
  _⊕_ (a , b) (da , db) = a ⊞ da , b ⊞ db
  _⊝_ : A × B → (v : A × B) → PChange v
  _⊝_ (aNew , bNew) (a , b) = aNew ⊟ a , bNew ⊟ b

  p-nil : (v : A × B) → PChange v
  p-nil (a , b) = (nil a , nil b)

  p-update-diff : (u v : A × B) → v ⊕ (u ⊝ v) ≡ u
  p-update-diff (ua , ub) (va , vb) =
    let u = (ua , ub)
        v = (va , vb)
    in
      begin
        v ⊕ (u ⊝ v)
      ≡⟨⟩
        (va ⊞ (ua ⊟ va) , vb ⊞ (ub ⊟ vb))
        --v ⊕ ((ua ⊟ va , ub ⊟ vb))
      ≡⟨ cong₂ _,_ (update-diff ua va) (update-diff ub vb)⟩
        (ua , ub)
      ≡⟨⟩
        u
      ∎

  p-update-nil : (v : A × B) → v ⊕ (p-nil v) ≡ v
  p-update-nil (a , b) =
    let v = (a , b)
    in
      begin
        v ⊕ (p-nil v)
      ≡⟨⟩
        (a ⊞ nil a , b ⊞ nil b)
      ≡⟨ cong₂ _,_ (update-nil a) (update-nil b)⟩
         (a , b)
      ≡⟨⟩
        v
      ∎

  changeAlgebra : ChangeAlgebra ℓ (A × B)
  changeAlgebra = record
    { Change = PChange
    ; update = _⊕_
    ; diff = _⊝_
    ; nil = p-nil
    ; isChangeAlgebra = record
      { update-diff = p-update-diff
      ; update-nil = p-update-nil
      }
    }

  proj₁′ : (v : A × B) → Δ v → Δ (proj₁ v)
  proj₁′ (a , b) (da , db) = da

  proj₁′Derivative : Derivative proj₁ proj₁′
  -- Implementation note: we do not need to pattern match on v and dv because
  -- they are records, hence Agda knows that pattern matching on records cannot
  -- fail. Technically, the required feature is the eta-rule on records.
  proj₁′Derivative v dv = refl

  -- An extended explanation.
  proj₁′Derivative₁ : Derivative proj₁ proj₁′
  proj₁′Derivative₁ (a , b) (da , db) =
    let v  = (a  , b)
        dv = (da , db)
    in
      begin
        proj₁ v ⊞ proj₁′ v dv
      ≡⟨⟩
        a ⊞ da
      ≡⟨⟩
        proj₁ (v ⊞ dv)
      ∎

  -- Same for the second extractor.
  proj₂′ : (v : A × B) → Δ v → Δ (proj₂ v)
  proj₂′ (a , b) (da , db) = db

  proj₂′Derivative : Derivative proj₂ proj₂′
  proj₂′Derivative v dv = refl

  B→A×B = FunctionChanges.changeAlgebra B (A × B)
  A→B→A×B = FunctionChanges.changeAlgebra A (B → A × B) {{CA}} {{B→A×B}}

  -- Morally, the following is a change:
  -- What one could wrongly expect to be the derivative of the constructor:
  _,_′-realizer : (a : A) → (da : Δ a) → (b : B) → (db : Δ b) → Δ (a , b)
  _,_′-realizer a da b db = da , db

  -- That has the correct behavior, in a sense, and it would be in the
  -- subset-based formalization in the paper.
  --
  -- But the above is not even a change, because it does not contain a proof of
  -- its own validity, and because after application it does not contain a
  -- proof.
  --
  -- However, the above is (morally) a "realizer" of the actual change, since it
  -- only represents its computational behavior, not its proof manipulation.

  -- Hence, we need to do some additional work.

  _,_′-realizer-correct _,_′-realizer-correct-detailed :
    (a : A) → (da : Δ a) → (b : B) → (db : Δ b) →
      (a , b ⊞ db) ⊞ (_,_′-realizer a da (b ⊞ db) (nil (b ⊞ db))) ≡ (a , b) ⊞ (_,_′-realizer a da b db)
  _,_′-realizer-correct a da b db rewrite update-nil (b ⊞ db) = refl

  _,_′-realizer-correct-detailed a da b db =
    begin
      (a , b ⊞ db) ⊞ (_,_′-realizer a da) (b ⊞ db) (nil (b ⊞ db))
    ≡⟨⟩
      a ⊞ da , b ⊞ db ⊞ (nil (b ⊞ db))
    ≡⟨ cong (λ □ →  a ⊞ da , □) (update-nil (b ⊞ db)) ⟩
      a ⊞ da , b ⊞ db
    ≡⟨⟩
      (a , b) ⊞ (_,_′-realizer a da) b db
    ∎

  _,_′ : (a : A) → (da : Δ a) → Δ (_,_ a)
  _,_′ a da = record { apply = _,_′-realizer a da ; correct = λ b db → _,_′-realizer-correct a da b db }

  _,_′-Derivative : Derivative _,_ _,_′
  _,_′-Derivative a da = ext (λ b → cong (_,_ (a ⊞ da)) (update-nil b))
    where
      open import Postulate.Extensionality

  -- Define specialized variant of uncurry, and derive it.
  uncurry₀ : ∀ {C : Set ℓ} → (A → B → C) → A × B → C
  uncurry₀ f (a , b) = f a b

  module _ {C : Set ℓ} {{CC : ChangeAlgebra ℓ C}} where
    B→C : ChangeAlgebra ℓ (B → C)
    B→C = FunctionChanges.changeAlgebra B C
    A→B→C : ChangeAlgebra ℓ (A → B → C)
    A→B→C = FunctionChanges.changeAlgebra A (B → C)
    A×B→C : ChangeAlgebra ℓ (A × B → C)
    A×B→C = FunctionChanges.changeAlgebra (A × B) C
    open FunctionChanges using (apply; correct)

    uncurry₀′-realizer : (f : A → B → C) → Δ f → (p : A × B) → Δ p → Δ (uncurry₀ f p)
    uncurry₀′-realizer f df (a , b) (da , db) = apply (apply df a da) b db

    uncurry₀′-realizer-correct uncurry₀′-realizer-correct-detailed :
      ∀ (f : A → B → C) (df : Δ f) (p : A × B) (dp : Δ p) →
        uncurry₀ f (p ⊕ dp) ⊞ uncurry₀′-realizer f df (p ⊕ dp) (nil (p ⊞ dp)) ≡ uncurry₀ f p ⊞ uncurry₀′-realizer f df p dp

    -- Hard to read
    uncurry₀′-realizer-correct f df (a , b) (da , db)
      rewrite sym (correct (apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db) (nil (b ⊞ db)))
      | update-nil (b ⊞ db)
      | {- cong (λ □ → □ (b ⊞ db)) -} (sym (correct df (a ⊞ da) (nil (a ⊞ da))))
      | update-nil (a ⊞ da)
      | cong (λ □ → □ (b ⊞ db)) (correct df a da)
      | correct (apply df a da) b db
      = refl

    -- Verbose, but it shows all the intermediate steps.
    uncurry₀′-realizer-correct-detailed f df (a , b) (da , db) =
      begin
        uncurry₀ f (a ⊞ da , b ⊞ db) ⊞ uncurry₀′-realizer f df (a ⊞ da , b ⊞ db) (nil (a ⊞ da , b ⊞ db))
      ≡⟨⟩
        f (a ⊞ da) (b ⊞ db) ⊞ apply (apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db) (nil (b ⊞ db))
      ≡⟨ sym (correct (apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db) (nil (b ⊞ db))) ⟩
        (f (a ⊞ da) ⊞ apply df (a ⊞ da) (nil (a ⊞ da))) ((b ⊞ db) ⊞ (nil (b ⊞ db)))
      ≡⟨ cong-lem₀ ⟩
        (f (a ⊞ da) ⊞ apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db)
      ≡⟨ sym cong-lem₂ ⟩
        ((f ⊞ df) ((a ⊞ da) ⊞ (nil (a ⊞ da)))) (b ⊞ db)
      ≡⟨ cong-lem₁ ⟩
        (f ⊞ df) (a ⊞ da) (b ⊞ db)
      ≡⟨ cong (λ □ → □ (b ⊞ db)) (correct df a da) ⟩
        (f a ⊞ apply df a da) (b ⊞ db)
      ≡⟨ correct (apply df a da) b db ⟩
        f a b ⊞ apply (apply df a da) b db
      ≡⟨⟩
        uncurry₀ f (a , b) ⊞ uncurry₀′-realizer f df (a , b) (da ,  db)
      ∎
      where
        cong-lem₀ :
            (f (a ⊞ da) ⊞ apply df (a ⊞ da) (nil (a ⊞ da))) ((b ⊞ db) ⊞ (nil (b ⊞ db)))
            ≡
            (f (a ⊞ da) ⊞ apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db)
        cong-lem₀ rewrite update-nil (b ⊞ db) = refl

        cong-lem₁ :
                  ((f ⊞ df) ((a ⊞ da) ⊞ (nil (a ⊞ da)))) (b ⊞ db)
                  ≡
                  (f ⊞ df) (a ⊞ da) (b ⊞ db)
        cong-lem₁ rewrite update-nil (a ⊞ da) = refl

        cong-lem₂ :
                  ((f ⊞ df) ((a ⊞ da) ⊞ (nil (a ⊞ da)))) (b ⊞ db)
                  ≡
                  (f (a ⊞ da) ⊞ apply df (a ⊞ da) (nil (a ⊞ da))) (b ⊞ db)
        cong-lem₂ = cong (λ □ → □ (b ⊞ db)) (correct df (a ⊞ da) (nil (a ⊞ da)))

    uncurry₀′ : (f : A → B → C) → Δ f → Δ (uncurry f)
    uncurry₀′ f df = record
      { apply = uncurry₀′-realizer f df
      ; correct = uncurry₀′-realizer-correct f df }

    -- Now proving that uncurry₀′ is a derivative is trivial!
    uncurry₀′Derivative₀ : Derivative {{CB = A×B→C}} uncurry₀ uncurry₀′
    uncurry₀′Derivative₀ f df = refl

    -- If you wonder what's going on, here's the step-by-step proof, going purely by definitional equality.
    uncurry₀′Derivative : Derivative {{CB = A×B→C}} uncurry₀ uncurry₀′
    uncurry₀′Derivative f df =
      begin
        uncurry₀ f ⊞ uncurry₀′ f df
      ≡⟨⟩
        (λ {(a , b) → uncurry₀ f (a , b) ⊞ apply (uncurry₀′ f df) (a , b) (nil (a , b))})
      ≡⟨⟩
        (λ {(a , b) → f a b ⊞ apply (apply df a (nil a)) b (nil b)})
      ≡⟨⟩
        (λ {(a , b) → (f a ⊞ apply df a (nil a)) b})
      ≡⟨⟩
        (λ {(a , b) → (f ⊞ df) a b})
      ≡⟨⟩
        (λ {(a , b) → uncurry₀ (f ⊞ df) (a , b)})
      ≡⟨⟩
        uncurry₀ (f ⊞ df)
      ∎

Simplify code

Base.Change.Products: Simplify code

These simplifications are inspired by Base.Change.Sums. But they're
still modest.


import Parametric.Syntax.Type as Type

module Parametric.Change.Type
  (Base : Type.Structure)
  where

open Type.Structure Base

Structure : Set
Structure = Base → Base

module Structure (ΔBase : Structure) where
  ΔType : Type → Type
  ΔType (base ι) = base (ΔBase ι)
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  open import Base.Change.Context ΔType public

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Simply-typed changes (Fig. 3 and Fig. 4d)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type

module Parametric.Change.Type
  (Base : Type.Structure)
  where

open Type.Structure Base

-- Extension point: Simply-typed changes of base types.
Structure : Set
Structure = Base → Base

module Structure (ΔBase : Structure) where
  -- We provide: Simply-typed changes on simple types.
  ΔType : Type → Type
  ΔType (base ι) = base (ΔBase ι)
  ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ

  -- And we also provide context merging.
  open import Base.Change.Context ΔType public

Document P.C.Type.

Document P.C.Type.

Old-commit-hash: 11e38d018843f21411d014020ce42181e1f77d32


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

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

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where
  import Base.Data.DependentList as DependentList
  open DependentList public using (∅ ; _•_)
  open DependentList

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives can only occur fully applied.
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
  FV-terms : ∀ {Σ Γ} → Terms Γ Σ → Vars Γ

  FV (const ι ts) = FV-terms ts
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  FV-terms ∅ = none
  FV-terms (t • ts) = FV t ∪ FV-terms ts

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

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

  weaken-terms : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr)
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τ = foldr _ (λ a b → a → b) (Term Γ τ) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τ [] = Term Γ τ
    --hoasArgType Γ τ (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τ τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τ = foldr _ _⇒_ τ

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τ} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τ τs) →
      Term Γ (hoasResType τ τs)

    -- A better type for absN but a mess to use due to the proofs (which aren't synthesized, even though maybe they should be?)
    -- absN : (n : ℕ) → {_ : n > 0} → absNType n
    -- XXX See "how to keep your neighbours in order" for tricks.

    -- Please the termination checker by keeping this case separate.
    absNBase : ∀ {τ₁} → absNType (τ₁ ∷ [])
    absNBase {τ₁} f = abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))
    -- Otherwise, the recursive step of absN would invoke absN twice, and the
    -- termination checker does not figure out that the calls are in fact
    -- terminating.

  open AbsNHelpers using (absNType; absNBase)

  -- XXX: could we be using the same trick as above to take the N implicit
  -- arguments individually, rather than in a vector? I can't figure out how,
  -- at least not without trying it. But it seems that's what's shown in Agda 2.4.0 release notes!
  absN : {n : ℕ} → (τs : Vec _ (suc n)) → absNType τs
  absN {zero}  (τ₁ ∷ []) = absNBase
  absN {suc n} (τ₁ ∷ τ₂ ∷ τs) f =
    absNBase (λ {_} {Γ≼Γ′} x₁ →
      absN {n} (τ₂ ∷ τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

  -- What I'd like to write, avoiding the need for absNBase, but can't because of the termination checker.
  {-
  absN {zero}  (τ₁ ∷ []) f = abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))
  absN {suc n} (τ₁ ∷ τ₂ ∷ τs) f =
    absN (τ₁ ∷ []) (λ {_} {Γ≼Γ′} x₁ →
      absN {n} (τ₂ ∷ τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
        f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))
  -}

  -- Declare abs₁ .. abs₆ wrappers for more convenient use, allowing implicit
  -- type arguments to be synthesized. Somehow, Agda does not manage to
  -- synthesize τs by unification.
  -- Implicit arguments are reversed when assembling the list, but that's no real problem.
  module _ {τ₁ : Type} where
    τs₁ =  τ₁ ∷ []
    abs₁ : absNType τs₁
    abs₁ = absN τs₁
    module _ {τ₂ : Type} where
      τs₂ = τ₂ ∷ τs₁
      abs₂ : absNType τs₂
      abs₂ = absN τs₂
      module _ {τ₃ : Type} where
        τs₃ = τ₃ ∷ τs₂
        abs₃ : absNType τs₃
        abs₃ = absN τs₃
        module _ {τ₄ : Type} where
          τs₄ = τ₄ ∷ τs₃
          abs₄ : absNType τs₄
          abs₄ = absN τs₄
          module _ {τ₅ : Type} where
            τs₅ = τ₅ ∷ τs₄
            abs₅ : absNType τs₅
            abs₅ = absN τs₅
            module _ {τ₆ : Type} where
              τs₆ = τ₆ ∷ τs₅
              abs₆ : absNType τs₆
              abs₆ = absN τs₆

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms (Fig. 1a and 1b).
------------------------------------------------------------------------

-- The syntax of terms depends on the syntax of simple types
-- (because terms are indexed by types in order to rule out
-- ill-typed terms). But we are in the Parametric.* hierarchy, so
-- we don't know the full syntax of types, only how to lift the
-- syntax of base types into the syntax of simple types. This
-- means that we have to be parametric in the syntax of base
-- types, too.
--
-- In such parametric modules that depend on other parametric
-- modules, we first import our dependencies under a more
-- convenient name.

import Parametric.Syntax.Type as Type

-- Then we start the module proper, with parameters for all
-- extension points of our dependencies. Note that here, the
-- "Structure" naming convenion makes some sense, because we can
-- say that we need some "Type.Structure" in order to define the
-- "Term.Structure".

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

-- Now inside the module, we can open our dependencies with the
-- parameters for their extension points. Again, here the name
-- "Structure" makes some sense, because we can say that we want
-- to access the "Type.Structure" that is induced by Base.

open Type.Structure Base

-- At this point, we have dealt with the extension points of our
-- dependencies, and we have all the definitions about simple
-- types, contexts, variables, and variable sets in scope that we
-- provided in Parametric.Syntax.Type. Now we can proceed to
-- define our own extension point, following the pattern
-- explained in Parametric.Syntax.Type.

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function using (_∘_)
open import Data.Unit
open import Data.Sum

-- Our extension point is a set of primitives, indexed by the
-- types of their arguments and their return type. In general, if
-- you're confused about what an extension point means, you might
-- want to open the corresponding module in the Nehemiah
-- hierarchy to see how it is implemented in the example
-- plugin. In this case, that would be the Nehemiah.Syntax.Term
-- module.

Structure : Set₁
Structure = Context → Type → Set

module Structure (Const : Structure) where
  import Base.Data.DependentList as DependentList
  open DependentList public using (∅ ; _•_)
  open DependentList

  -- Declarations of Term and Terms to enable mutual recursion.
  --
  -- Note that terms are indexed by contexts and types. In the
  -- paper, we define the abstract syntax of terms in Fig 1a and
  -- then define a type system in Fig 1b. All lemmas and theorems
  -- then explicitly specify that they only hold for well-typed
  -- terms. Here, we use the indices to define a type that can
  -- only hold well-typed terms in the first place.
  data Term
    (Γ : Context) :
    (τ : Type) → Set

  -- (Terms Γ Σ) represents a list of terms with types from Σ
  -- with free variables bound in Γ.
  Terms : Context → Context → Set
  Terms Γ = DependentList (Term Γ)

  -- (Term Γ τ) represents a term of type τ
  -- with free variables bound in Γ.
  data Term Γ where
    -- constants aka. primitives can only occur fully applied.
    const : ∀ {Σ τ} →
      (c : Const Σ τ) →
      (args : Terms Γ Σ) →
      Term Γ τ
    var : ∀ {τ} →
      (x : Var Γ τ) →
      Term Γ τ
    app : ∀ {σ τ}
      (s : Term Γ (σ ⇒ τ)) →
      (t : Term Γ σ) →
      Term Γ τ
    -- we use de Bruijn indicies, so we don't need binding occurrences.
    abs : ∀ {σ τ}
      (t : Term (σ • Γ) τ) →
      Term Γ (σ ⇒ τ)

  -- Free variables
  FV : ∀ {τ Γ} → Term Γ τ → Vars Γ
  FV-terms : ∀ {Σ Γ} → Terms Γ Σ → Vars Γ

  FV (const ι ts) = FV-terms ts
  FV (var x) = singleton x
  FV (abs t) = tail (FV t)
  FV (app s t) = FV s ∪ FV t

  FV-terms ∅ = none
  FV-terms (t • ts) = FV t ∪ FV-terms ts

  closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ none) ⊎ ⊤
  closed? t = empty? (FV t)

  -- Weakening

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

  weaken-terms : ∀ {Γ₁ Γ₂ Σ} →
    (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
    Terms Γ₁ Σ →
    Terms Γ₂ Σ

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  -- We could also write this:
  module NamespaceForBadAbs₁ where
    abs₁′ :
      ∀ {Γ τ₁ τ} →
        (Term (τ₁ • Γ) τ₁ → Term (τ₁ • Γ) τ) →
        (Term Γ (τ₁ ⇒ τ))
    abs₁′ {Γ} {τ₁} = λ f → abs (f (var this))

  -- However, this is less general, and it is harder to reuse. In particular,
  -- this cannot be used inside abs₂, ..., abs₆.

  -- Now, let's write other variants with a loop!
  open import Data.Vec using (_∷_; []; Vec; foldr; [_])
  open import Data.Nat
  module AbsNHelpers where
    open import Function
    hoasArgType : ∀ {n} → Context → Type → Vec Type n → Set
    hoasArgType Γ τ = foldr _ (λ a b → a → b) (Term Γ τ) ∘ Data.Vec.map (Term Γ)
    -- That is,
    --hoasArgType Γ τ [] = Term Γ τ
    --hoasArgType Γ τ (τ₀ ∷ τs) = Term Γ τ₀ → hoasArgType Γ τ τs

    hoasResType : ∀ {n} → Type → Vec Type n → Type
    hoasResType τ = foldr _ _⇒_ τ

    absNType : {n : ℕ} → Vec _ n → Set
    absNType τs = ∀ {Γ τ} →
      (f : ∀ {Γ′} → {Γ≼Γ′ : Γ ≼ Γ′} → hoasArgType Γ′ τ τs) →
      Term Γ (hoasResType τ τs)

    -- A better type for absN but a mess to use due to the proofs (which aren't synthesized, even though maybe they should be?)
    -- absN : (n : ℕ) → {_ : n > 0} → absNType n
    -- XXX See "how to keep your neighbours in order" for tricks.

    -- Please the termination checker by keeping this case separate.
    absNBase : ∀ {τ₁} → absNType [ τ₁ ]
    absNBase {τ₁} f = abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))
    -- Otherwise, the recursive step of absN would invoke absN twice, and the
    -- termination checker does not figure out that the calls are in fact
    -- terminating.

    -- What I'd like to write, avoiding the need for absNBase, but can't because of the termination checker.
    {-
    absN {zero}  (τ₁ ∷ []) f = abs (f {Γ≼Γ′ = drop τ₁ • ≼-refl} (var this))
    absN {suc n} (τ₁ ∷ τ₂ ∷ τs) f =
      absN (τ₁ ∷ []) (λ {_} {Γ≼Γ′} x₁ →
        absN {n} (τ₂ ∷ τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
          f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))
    -}
    --What I have to write instead:

    absN : {n : ℕ} → (τs : Vec _ (suc n)) → absNType τs
    absN {zero}  (τ₁ ∷ []) = absNBase
    absN {suc n} (τ₁ ∷ τ₂ ∷ τs) f =
      absNBase (λ {_} {Γ≼Γ′} x₁ →
        absN {n} (τ₂ ∷ τs) (λ {Γ′₁} {Γ′≼Γ′₁} →
          f {Γ≼Γ′ = ≼-trans Γ≼Γ′ Γ′≼Γ′₁} (weaken Γ′≼Γ′₁ x₁)))

    -- Using a similar trick, we can declare absV which takes the N implicit
    -- type arguments individually, collects them and passes them on to absN.
    -- This is inspired by what's shown in the Agda 2.4.0 release notes, and
    -- relies critically on support for varying arity. To collect them, we need
    -- to use an accumulator argument.

    absVType : ∀ n {m} (τs : Vec Type m) → Set
    absVType 0       τs = absNType τs
    absVType (suc n) τs = {τᵢ : Type} → absVType n (τᵢ ∷ τs)

    -- XXX
    absVAux : ∀ {m} → (τs : Vec Type m) → ∀ n → absVType (suc n) τs
    absVAux τs zero    {τᵢ} = absN (τᵢ ∷ τs)
    absVAux τs (suc n) {τᵢ} = absVAux (τᵢ ∷ τs) n

    absV = absVAux []

  open AbsNHelpers using (absV) public

  -- Declare abs₁ .. abs₆ wrappers for more convenient use, allowing implicit
  -- type arguments to be synthesized. Somehow, Agda does not manage to
  -- synthesize τs by unification.
  -- Implicit arguments are reversed when assembling the list, but that's no real problem.

  abs₁ = absV 0
  abs₂ = absV 1
  abs₃ = absV 2
  abs₄ = absV 3
  abs₅ = absV 4
  abs₆ = absV 5

{-
abs₁
Have: {τ₁ : Type} {Γ : Context} {τ : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} → Term Γ′ τ₁ → Term Γ′ τ) →
      Term Γ (τ₁ Type.Structure.⇒ τ)

abs₂
Have: {τ₁ : Type} {τ₁ = τ₂ : Type} {Γ : Context} {τ : Type} →
      ({Γ′ : Context} {Γ≼Γ′ : Γ ≼ Γ′} →
       Term Γ′ τ₂ → Term Γ′ τ₁ → Term Γ′ τ) →
      Term Γ (τ₂ Type.Structure.⇒ τ₁ Type.Structure.⇒ τ)

-}

Remove remaining duplication between abs₁ ... abs₆

This relies on Agda 2.4.0's varying arity in a more essential way.