{-
This file demonstrates a technique that simulates the ability to
pattern match against function calls rather than just variables
or constructors.

This technique is necessary to write certain kinds of tactics
as generic functions.
-}

module TacticsMatchingFunctionCalls where
open import Data.Bool hiding ( _≟_ )
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Product hiding ( map )
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function

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

{-
Zero is the right identity of addition on the natural numbers.
-}

plusrident : (n : ℕ) → n ≡ n + 0
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

{-
Arith is a universe of codes representing the natural numbers
along with a limited set of functions over them. We would like to write
tactics that pattern match against types indexed by applications of
these functions.
-}

data Arith : Set where
  `zero : Arith
  `suc : (a : Arith) → Arith
  _`+_ _`*_ : (a₁ a₂ : Arith) → Arith

eval : Arith → ℕ
eval `zero = zero
eval (`suc a) = suc (eval a)
eval (a₁ `+ a₂) = eval a₁ + eval a₂
eval (a₁ `* a₂) = eval a₁ * eval a₂

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

{-
An alternative to the Arith codes is to create a *view* of the
natural numbers along with a collection of functions over them.
-}

data ArithView : ℕ → Set where
  `nat : (n : ℕ) → ArithView n
  _`+_ : (n₁ n₂ : ℕ) → ArithView (n₁ + n₂)
  _`*_ : (n₁ n₂ : ℕ) → ArithView (n₁ * n₂)

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

{-
Φ (standing for *function*-indexed types)
represents an indexed type, but we *can* pattern
match on function calls in its index position.

A - The type of codes, including constructors and functions.
  i.e. Arith
A′ - The model underlying the codes.
  i.e. ℕ
el - The evaluation function from code values to model values.
  i.e. eval
B - The genuine indexed datatype that Φ represents.
  i.e. Fin
a - The index value as a code, which may be a function call and hence supports
    pattern matching.
  i.e. (a `+ `zero)
-}

data Φ (A A′ : Set) (el : A → A′) (B : A′ → Set) (a : A) : Set where
  φ : (b : B (el a)) → Φ A A′ el B a

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

{-
Alternatively, we can specialize Φ to our Arith universe. This may be
a good use of our ability to cheaply define new datatypes via Desc.
-}

data ΦArith (B : ℕ → Set) (a : Arith) : Set where
  φ : (b : B (eval a)) → ΦArith B a

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

{-
Going further, we could even specialize B in ΦArith to Fin.
-}

data Fin₂ (a : Arith) : Set where
  fin : (i : Fin (eval a)) → Fin₂ a

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

{-
Here is the ArithView specialized into the Fin type.
-}

data Fin₃ : ℕ → Set where
  fin : (n : ℕ) (i : Fin n) → Fin₃ n
  fin+ : (n₁ n₂ : ℕ) (i : Fin (n₁ + n₂)) → Fin₃ (n₁ + n₂)
  fin* : (n₁ n₂ : ℕ) (i : Fin (n₁ * n₂)) → Fin₃ (n₁ * n₂)

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

{-
A small universe of dependent types that is sufficient for the
examples given below.
-}

data Type : Set
⟦_⟧ : Type → Set

data Type where
  `Bool `ℕ `Arith : Type
  `ArithView `Fin : (n : ℕ) → Type
  `Φ : (A A′ : Type)
    (el : ⟦ A ⟧ → ⟦ A′ ⟧)
    (B : ⟦ A′ ⟧ → Type)
    (a : ⟦ A ⟧)
    → Type
  `ΦArith : (B : ℕ → Type) (a : Arith) → Type
  `Fin₂ : (a : Arith) → Type
  `Fin₃ : (n : ℕ) → Type
  `Π `Σ : (A : Type) (B : ⟦ A ⟧ → Type) → Type
  `Id : (A : Type) (x y : ⟦ A ⟧) → Type

⟦ `Bool ⟧ = Bool
⟦ `ℕ ⟧ = ℕ
⟦ `Arith ⟧ = Arith
⟦ `ArithView n ⟧ = ArithView n
⟦ `Fin n ⟧ = Fin n
⟦ `Φ A A′ el B a ⟧ = Φ ⟦ A ⟧ ⟦ A′ ⟧ el (λ a → ⟦ B a ⟧) a
⟦ `ΦArith B a ⟧ = ΦArith (λ x → ⟦ B x ⟧) a
⟦ `Fin₂ a ⟧ = Fin₂ a
⟦ `Fin₃ n ⟧ = Fin₃ n
⟦ `Π A B ⟧ = (a : ⟦ A ⟧) → ⟦ B a ⟧
⟦ `Σ A B ⟧ = Σ ⟦ A ⟧ (λ a → ⟦ B a ⟧)
⟦ `Id A x y ⟧ = x ≡ y

_`→_ : (A B : Type) → Type
A `→ B = `Π A (const B)

_`×_ : (A B : Type) → Type
A `× B = `Σ A (const B)

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

{-
Tactics are represented as generic functions taking a Dynamic value (of
any type), and returning a Dynamic value (at a possibly different type).
The convention is to behave like the identity function if the tactic
doesn't match the current value or fails.

In practice, the context will be a List of Dynamic values, and a tactic
will map a Context to a Context. For simplicity, the tactics I give below
only map a Dynamic to a Dynamic.
-}

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

{-
Here is an example of a tactic that only needs to pattern match on a
variable or constructor, but not a function. We don't encounter
any problems when writing this kind of a tactic.

The tactic below changes a `Fin n` value into a `Fin (n + 0)` value.
-}

add-plus0-Fin : Tactic
add-plus0-Fin (`Fin n , i) = `Fin (n + 0) , subst Fin (plusrident n) i
add-plus0-Fin x = x

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

{-
In contrast, it is not straightforward to write tactics that need
to pattern match on function calls.
For example, below is ideally what we want to write to change
a value of `Fin (n + 0)` to a value of `Fin n`.
-}

-- rm-plus0-Fin : Tactic
-- rm-plus0-Fin (`Fin (n + 0) , i) = `Fin n , subst Fin (sym (plusrident n)) i
-- rm-plus0-Fin x = x

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

{-
Instead of matching directly on `Fin, we can match on a `Φ that
represents `Fin. This allows us to match on the the `+ function call
in the index position.

Because we cannot match against the function `el` (we would like to match
it against `eval`), we add to our return type that proves the
extentional equality between `el` and `eval`.

Also note that the tactic below can be used for any type indexed by
ℕ, not just Fin.
-}

rm-plus0 : Tactic
rm-plus0 (`Φ `Arith `ℕ el B (a `+ `zero) , φ b) =
  `Π `Arith (λ x → `Id `ℕ (el x) (eval x))
  `→
  `Φ `Arith `ℕ el B a
  ,
  λ f → φ
  (subst (λ x → ⟦ B x ⟧)
         (sym (f a))
         (subst (λ x → ⟦ B x ⟧)
                (sym (plusrident (eval a)))
                (subst (λ x → ⟦ B x ⟧)
                       (f (a `+ `zero))
                       b)))
rm-plus0 x = x

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

{-
Now it is possible to apply the generic tactic to a specific
value and have the desired behavior occur. Notice that the generated
extentional equality premise is trivially provable because
eval is always equal to eval.
-}

eg-rm-plus0 : (a : Arith)
  → ⟦ `Φ `Arith `ℕ eval `Fin (a `+ `zero) ⟧
  → ⟦ `Φ `Arith `ℕ eval `Fin a ⟧
eg-rm-plus0 a (φ i) = proj₂
  (rm-plus0 (`Φ `Arith `ℕ eval `Fin (a `+ `zero) , φ i))
  (λ _ → refl)

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

{-
Here is the same tactic but using the specialized ΦArith type.
-}

rm-plus0-Arith : Tactic
rm-plus0-Arith (`ΦArith B (a `+ `zero) , φ i) =
  `ΦArith B a
  ,
  φ (subst (λ x → ⟦ B x ⟧) (sym (plusrident (eval a))) i)
rm-plus0-Arith x = x

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

{-
And the same example usage, this time without needing to prove a premise.
-}

eg-rm-plus0-Arith : (a : Arith)
  → ⟦ `ΦArith `Fin (a `+ `zero) ⟧
  → ⟦ `ΦArith `Fin a ⟧
eg-rm-plus0-Arith a (φ i) = proj₂
  (rm-plus0-Arith (`ΦArith `Fin (a `+ `zero) , φ i))

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

{-
Finally, here is the same tactic but using the even more
specialized Fin₂ type.
-}

rm-plus0-Fin₂ : Tactic
rm-plus0-Fin₂ (`Fin₂ (a `+ `zero) , fin i) =
  `Fin₂ a
  ,
  fin (subst (λ x → ⟦ `Fin x ⟧) (sym (plusrident (eval a))) i)
rm-plus0-Fin₂ x = x

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

eg-rm-plus0-Fin₂ : (a : Arith)
  → ⟦ `Fin₂ (a `+ `zero) ⟧
  → ⟦ `Fin₂ a ⟧
eg-rm-plus0-Fin₂ a (fin i) = proj₂
  (rm-plus0-Fin₂ (`Fin₂ (a `+ `zero) , fin i))

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

{-
A tactic that simplifies an ArithView index.
To target Fin, ideally you want to match on something like:
`Σ `ℕ (λ n → `ArithView n `× Fin n)
But this requires matching on a λ, and a non-linear occurrence
of n.

The example after this one accomplishes the same thing via the
specialized Fin₃ type instead.
-}

rm-plus0-ArithView : Tactic
rm-plus0-ArithView (`ArithView .(n + 0) , (n `+ 0)) =
  `ArithView n , `nat n
rm-plus0-ArithView x = x

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

{-
A tactic to simplify to simplify the "view"-based Fin type Fin₃.
This is most similar to rm-plus0-Fin₂, except Fin₃ is view-based
while Fin₂ is universe-based (where the universe is the codes of
possible operations).

On one hand this Fin₃ approach is simpler than Fin₂, because you do
not need to write an eval function or tell it to reduce definitional
equalities explicitly (like you would to get Arith to compute).

On the other hand, the Fin₂ approach is more powerful because it
allows you to control when things reduce. This is more like Coq
tactics, where you might not want something to reduce and you use
"simpl" explicitly when you do. The "simpl" tactic is defined below
via the eval₂ function.
-}

rm-plus0-Fin₃ : Tactic
rm-plus0-Fin₃ (`Fin₃ .(n + 0) , fin+ n 0 i) =
  `Fin₃ n
  ,
  fin n (subst Fin (sym (plusrident n)) i)
rm-plus0-Fin₃ x = x

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

{-
A tactic to simplify by one step of `+.
-}

simp-step-plus0-Fin : Tactic
simp-step-plus0-Fin (`Fin₂ (`zero `+ a) , fin i) =
  `Fin₂ a , fin i
simp-step-plus0-Fin (`Fin₂ (`suc a₁ `+ a₂) , fin i) =
  `Fin₂ (`suc (a₁ `+ a₂)) , fin i
simp-step-plus0-Fin x = x

simp-step-n-plus0-Fin : ℕ → Tactic
simp-step-n-plus0-Fin zero x = x
simp-step-n-plus0-Fin (suc n) x =
  simp-step-n-plus0-Fin n (simp-step-plus0-Fin x)

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

{-
A semantics-preserving definitional evaluator, and a tactic
to simplify as far as possible using definitional equality.
This is like the "simp" tactic in Coq.
-}

eval₂ : (a₁ : Arith) → Σ Arith (λ a₂ → eval a₁ ≡ eval a₂)
eval₂ `zero = `zero , refl
eval₂ (`suc a)
  with eval₂ a
... | a′ , p
  rewrite p = `suc a′ , refl
eval₂ (`zero `+ a₂) = eval₂ a₂
eval₂ (`suc a₁ `+ a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = `suc (a₁′ `+ a₂′) , refl
eval₂ (a₁ `+ a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = (a₁′ `+ a₂′) , refl
eval₂ (`zero `* a₂) = `zero , refl
eval₂ (`suc a₁ `* a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = a₂′ `+ (a₁′ `* a₂′) , refl
eval₂ (a₁ `* a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = (a₁′ `* a₂′) , refl

simp-Fin : Tactic
simp-Fin (`Fin₂ a , fin i)
  with eval₂ a
... | a′ , p rewrite p =
  `Fin₂ a′ , fin i
simp-Fin x = x

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

{-
This file demonstrates a technique that simulates the ability to
pattern match against function calls rather than just variables
or constructors.

This technique is necessary to write certain kinds of tactics
as generic functions.
-}

module TacticsMatchingFunctionCalls where
open import Data.Bool hiding ( _≟_ )
open import Data.Nat
open import Data.Fin hiding ( _+_ )
open import Data.Product hiding ( map )
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Function

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

{-
Zero is the right identity of addition on the natural numbers.
-}

plusrident : (n : ℕ) → n ≡ n + 0
plusrident zero = refl
plusrident (suc n) = cong suc (plusrident n)

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

{-
Arith is a universe of codes representing the natural numbers
along with a limited set of functions over them. We would like to write
tactics that pattern match against types indexed by applications of
these functions.
-}

data Arith : Set where
  `zero : Arith
  `suc : (a : Arith) → Arith
  _`+_ _`*_ : (a₁ a₂ : Arith) → Arith

eval : Arith → ℕ
eval `zero = zero
eval (`suc a) = suc (eval a)
eval (a₁ `+ a₂) = eval a₁ + eval a₂
eval (a₁ `* a₂) = eval a₁ * eval a₂

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

{-
An alternative to the Arith codes is to create a *view* of the
natural numbers along with a collection of functions over them.
-}

data ArithView : ℕ → Set where
  `nat : (n : ℕ) → ArithView n
  _`+_ : (n₁ n₂ : ℕ) → ArithView (n₁ + n₂)
  _`*_ : (n₁ n₂ : ℕ) → ArithView (n₁ * n₂)

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

{-
Φ (standing for *function*-indexed types)
represents an indexed type, but we *can* pattern
match on function calls in its index position.

A - The type of codes, including constructors and functions.
  i.e. Arith
A′ - The model underlying the codes.
  i.e. ℕ
el - The evaluation function from code values to model values.
  i.e. eval
B - The genuine indexed datatype that Φ represents.
  i.e. Fin
a - The index value as a code, which may be a function call and hence supports
    pattern matching.
  i.e. (a `+ `zero)
-}

data Φ (A A′ : Set) (el : A → A′) (B : A′ → Set) (a : A) : Set where
  φ : (b : B (el a)) → Φ A A′ el B a

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

{-
Alternatively, we can specialize Φ to our Arith universe. This may be
a good use of our ability to cheaply define new datatypes via Desc.
-}

data ΦArith (B : ℕ → Set) (a : Arith) : Set where
  φ : (b : B (eval a)) → ΦArith B a

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

{-
Going further, we could even specialize B in ΦArith with Fin.
-}

data Fin₂ (a : Arith) : Set where
  fin : (i : Fin (eval a)) → Fin₂ a

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

{-
Here is the ArithView specialized with the Fin type.
-}

data Fin₃ : ℕ → Set where
  fin : (n : ℕ) (i : Fin n) → Fin₃ n
  fin+ : (n₁ n₂ : ℕ) (i : Fin (n₁ + n₂)) → Fin₃ (n₁ + n₂)
  fin* : (n₁ n₂ : ℕ) (i : Fin (n₁ * n₂)) → Fin₃ (n₁ * n₂)

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

{-
A small universe of dependent types that is sufficient for the
examples given below.
-}

data Type : Set
⟦_⟧ : Type → Set

data Type where
  `Bool `ℕ `Arith : Type
  `ArithView `Fin : (n : ℕ) → Type
  `Φ : (A A′ : Type)
    (el : ⟦ A ⟧ → ⟦ A′ ⟧)
    (B : ⟦ A′ ⟧ → Type)
    (a : ⟦ A ⟧)
    → Type
  `ΦArith : (B : ℕ → Type) (a : Arith) → Type
  `Fin₂ : (a : Arith) → Type
  `Fin₃ : (n : ℕ) → Type
  `Π `Σ : (A : Type) (B : ⟦ A ⟧ → Type) → Type
  `Id : (A : Type) (x y : ⟦ A ⟧) → Type

⟦ `Bool ⟧ = Bool
⟦ `ℕ ⟧ = ℕ
⟦ `Arith ⟧ = Arith
⟦ `ArithView n ⟧ = ArithView n
⟦ `Fin n ⟧ = Fin n
⟦ `Φ A A′ el B a ⟧ = Φ ⟦ A ⟧ ⟦ A′ ⟧ el (λ a → ⟦ B a ⟧) a
⟦ `ΦArith B a ⟧ = ΦArith (λ x → ⟦ B x ⟧) a
⟦ `Fin₂ a ⟧ = Fin₂ a
⟦ `Fin₃ n ⟧ = Fin₃ n
⟦ `Π A B ⟧ = (a : ⟦ A ⟧) → ⟦ B a ⟧
⟦ `Σ A B ⟧ = Σ ⟦ A ⟧ (λ a → ⟦ B a ⟧)
⟦ `Id A x y ⟧ = x ≡ y

_`→_ : (A B : Type) → Type
A `→ B = `Π A (const B)

_`×_ : (A B : Type) → Type
A `× B = `Σ A (const B)

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

{-
Tactics are represented as generic functions taking a Dynamic value (of
any type), and returning a Dynamic value (at a possibly different type).
The convention is to behave like the identity function if the tactic
doesn't match the current value or fails.

In practice, the context will be a List of Dynamic values, and a tactic
will map a Context to a Context. For simplicity, the tactics I give below
only map a Dynamic to a Dynamic.
-}

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

{-
Here is an example of a tactic that only needs to pattern match on a
variable or constructor, but not a function. We don't encounter
any problems when writing this kind of a tactic.

The tactic below changes a `Fin n` value into a `Fin (n + 0)` value.
-}

add-plus0-Fin : Tactic
add-plus0-Fin (`Fin n , i) = `Fin (n + 0) , subst Fin (plusrident n) i
add-plus0-Fin x = x

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

{-
In contrast, it is not straightforward to write tactics that need
to pattern match on function calls.
For example, below is ideally what we want to write to change
a value of `Fin (n + 0)` to a value of `Fin n`.
-}

-- rm-plus0-Fin : Tactic
-- rm-plus0-Fin (`Fin (n + 0) , i) = `Fin n , subst Fin (sym (plusrident n)) i
-- rm-plus0-Fin x = x

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

{-
Instead of matching directly on `Fin, we can match on a `Φ that
represents `Fin. This allows us to match on the the `+ function call
in the index position.

Because we cannot match against the function `el` (we would like to match
it against `eval`), we add to our return type that proves the
extentional equality between `el` and `eval`.

Also note that the tactic below can be used for any type indexed by
ℕ, not just Fin.
-}

rm-plus0 : Tactic
rm-plus0 (`Φ `Arith `ℕ el B (a `+ `zero) , φ b) =
  `Π `Arith (λ x → `Id `ℕ (el x) (eval x))
  `→
  `Φ `Arith `ℕ el B a
  ,
  λ f → φ
  (subst (λ x → ⟦ B x ⟧)
         (sym (f a))
         (subst (λ x → ⟦ B x ⟧)
                (sym (plusrident (eval a)))
                (subst (λ x → ⟦ B x ⟧)
                       (f (a `+ `zero))
                       b)))
rm-plus0 x = x

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

{-
Now it is possible to apply the generic tactic to a specific
value and have the desired behavior occur. Notice that the generated
extentional equality premise is trivially provable because
eval is always equal to eval.
-}

eg-rm-plus0 : (a : Arith)
  → ⟦ `Φ `Arith `ℕ eval `Fin (a `+ `zero) ⟧
  → ⟦ `Φ `Arith `ℕ eval `Fin a ⟧
eg-rm-plus0 a (φ i) = proj₂
  (rm-plus0 (`Φ `Arith `ℕ eval `Fin (a `+ `zero) , φ i))
  (λ _ → refl)

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

{-
Here is the same tactic but using the specialized ΦArith type.
-}

rm-plus0-Arith : Tactic
rm-plus0-Arith (`ΦArith B (a `+ `zero) , φ i) =
  `ΦArith B a
  ,
  φ (subst (λ x → ⟦ B x ⟧) (sym (plusrident (eval a))) i)
rm-plus0-Arith x = x

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

{-
And the same example usage, this time without needing to prove a premise.
-}

eg-rm-plus0-Arith : (a : Arith)
  → ⟦ `ΦArith `Fin (a `+ `zero) ⟧
  → ⟦ `ΦArith `Fin a ⟧
eg-rm-plus0-Arith a (φ i) = proj₂
  (rm-plus0-Arith (`ΦArith `Fin (a `+ `zero) , φ i))

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

{-
Finally, here is the same tactic but using the even more
specialized Fin₂ type.
-}

rm-plus0-Fin₂ : Tactic
rm-plus0-Fin₂ (`Fin₂ (a `+ `zero) , fin i) =
  `Fin₂ a
  ,
  fin (subst (λ x → ⟦ `Fin x ⟧) (sym (plusrident (eval a))) i)
rm-plus0-Fin₂ x = x

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

eg-rm-plus0-Fin₂ : (a : Arith)
  → ⟦ `Fin₂ (a `+ `zero) ⟧
  → ⟦ `Fin₂ a ⟧
eg-rm-plus0-Fin₂ a (fin i) = proj₂
  (rm-plus0-Fin₂ (`Fin₂ (a `+ `zero) , fin i))

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

{-
A tactic that simplifies an ArithView index.
To target Fin, ideally you want to match on something like:
`Σ `ℕ (λ n → `ArithView n `× Fin n)
But this requires matching on a λ, and a non-linear occurrence
of n.

The example after this one accomplishes the same thing via the
specialized Fin₃ type instead.
-}

rm-plus0-ArithView : Tactic
rm-plus0-ArithView (`ArithView .(n + 0) , (n `+ 0)) =
  `ArithView n , `nat n
rm-plus0-ArithView x = x

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

{-
A tactic to simplify to simplify the "view"-based Fin type Fin₃.
This is most similar to rm-plus0-Fin₂, except Fin₃ is view-based
while Fin₂ is universe-based (where the universe is the codes of
possible operations).

On one hand this Fin₃ approach is simpler than Fin₂, because you do
not need to write an eval function or tell it to reduce definitional
equalities explicitly (like you would to get Arith to compute).

On the other hand, the Fin₂ approach is more powerful because it
allows you to control when things reduce. This is more like Coq
tactics, where you might not want something to reduce and you use
"simpl" explicitly when you do. The "simpl" tactic is defined below
via the eval₂ function.
-}

rm-plus0-Fin₃ : Tactic
rm-plus0-Fin₃ (`Fin₃ .(n + 0) , fin+ n 0 i) =
  `Fin₃ n
  ,
  fin n (subst Fin (sym (plusrident n)) i)
rm-plus0-Fin₃ x = x

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

{-
A tactic to simplify by one step of `+.
-}

simp-step-plus0-Fin : Tactic
simp-step-plus0-Fin (`Fin₂ (`zero `+ a) , fin i) =
  `Fin₂ a , fin i
simp-step-plus0-Fin (`Fin₂ (`suc a₁ `+ a₂) , fin i) =
  `Fin₂ (`suc (a₁ `+ a₂)) , fin i
simp-step-plus0-Fin x = x

simp-step-n-plus0-Fin : ℕ → Tactic
simp-step-n-plus0-Fin zero x = x
simp-step-n-plus0-Fin (suc n) x =
  simp-step-n-plus0-Fin n (simp-step-plus0-Fin x)

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

{-
A semantics-preserving definitional evaluator, and a tactic
to simplify as far as possible using definitional equality.
This is like the "simp" tactic in Coq.
-}

eval₂ : (a₁ : Arith) → Σ Arith (λ a₂ → eval a₁ ≡ eval a₂)
eval₂ `zero = `zero , refl
eval₂ (`suc a)
  with eval₂ a
... | a′ , p
  rewrite p = `suc a′ , refl
eval₂ (`zero `+ a₂) = eval₂ a₂
eval₂ (`suc a₁ `+ a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = `suc (a₁′ `+ a₂′) , refl
eval₂ (a₁ `+ a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = (a₁′ `+ a₂′) , refl
eval₂ (`zero `* a₂) = `zero , refl
eval₂ (`suc a₁ `* a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = a₂′ `+ (a₁′ `* a₂′) , refl
eval₂ (a₁ `* a₂)
  with eval₂ a₁ | eval₂ a₂
... | a₁′ , p | a₂′ , q
  rewrite p | q = (a₁′ `* a₂′) , refl

simp-Fin : Tactic
simp-Fin (`Fin₂ a , fin i)
  with eval₂ a
... | a′ , p rewrite p =
  `Fin₂ a′ , fin i
simp-Fin x = x

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

change wording

change wording


module partial where

-- INCREMENTAL λ-CALCULUS
--   with (one-variable) partial derivatives
--
-- Features:
--   * Changes and derivatives are different.
--   * Δ x e  maps changes of x to changes of e.
--   * a full denotational semantics is given.
--   * the domain of change types `⟦Δ τ⟧` is uniformly defined as `⟦τ⟧ → ⟦τ⟧`.

open import Relation.Binary.PropositionalEquality

open import meaning

-- SIMPLE TYPES

-- Syntax

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

  -- `Δ τ` is the type of changes to `τ`
  Δ : (τ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

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

meaningOfType : Meaning Type
meaningOfType = meaning Set ⟦_⟧Type

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

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

  -- `Δ x dx t` maps changes `dx` in `x` to changes in `t`
  Δ : ∀ {Γ τ₁ τ₂} → (x : Var Γ τ₁) (dx : Var Γ (Δ τ₁)) → (t : 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 ⟧ ρ
⟦ Δ x dx t ⟧Term ρ = λ _ → ⟦ t ⟧Term (update x (⟦ dx ⟧ ρ) ρ)

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

-- NATURAL SEMANTICS

-- (without support for Δ for now)

-- Syntax

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

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

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

-- SOUNDNESS of natural semantics

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

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

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

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 ↦

-- 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 {Γ₁} {Γ₂} (Δ x dx t) = Δ (lift {Γ₁} {Γ₂} x) (lift {Γ₁} {Γ₂} dx) (weaken {Γ₁} {Γ₂} t)

module partial where

-- INCREMENTAL λ-CALCULUS
--   with (one-variable) partial derivatives
--
-- Features:
--   * Changes and derivatives are different.
--   * Δ x dx e  describes how e changes if x changes by dx.
--   * a full denotational semantics is given.
--   * the domain of change types `⟦Δ τ⟧` is uniformly defined as `⟦τ⟧ → ⟦τ⟧`.

open import Relation.Binary.PropositionalEquality

open import meaning

-- SIMPLE TYPES

-- Syntax

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

  -- `Δ τ` is the type of changes to `τ`
  Δ : (τ : Type) → Type

infixr 5 _⇒_

-- Denotational Semantics

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

meaningOfType : Meaning Type
meaningOfType = meaning Set ⟦_⟧Type

-- TYPING CONTEXTS, VARIABLES and WEAKENING

open import binding Type ⟦_⟧Type

-- TERMS

-- Syntax

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

  -- `Δ x dx t` maps changes `dx` in `x` to changes in `t`
  Δ : ∀ {Γ τ₁ τ₂} → (x : Var Γ τ₁) (dx : Var Γ (Δ τ₁)) → (t : 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 ⟧ ρ
⟦ Δ x dx t ⟧Term ρ = λ _ → ⟦ t ⟧Term (update x (⟦ dx ⟧ ρ) ρ)

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

-- NATURAL SEMANTICS

-- (without support for Δ for now)

-- Syntax

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

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

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

-- SOUNDNESS of natural semantics

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

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

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

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 ↦

-- 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 {Γ₁} {Γ₂} (Δ x dx t) = Δ (lift {Γ₁} {Γ₂} x) (lift {Γ₁} {Γ₂} dx) (weaken {Γ₁} {Γ₂} t)

Fix comment (fix #20).

Fix comment (fix #20).

Old-commit-hash: d5a7ef44c7c38bf82aa00466ee0bac803dd860d3


module Base.Change.Sums where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra
open import Base.Change.Equivalence
open import Postulate.Extensionality
open import Data.Sum

module SumChanges ℓ (X Y : Set ℓ) {{CX : ChangeAlgebra ℓ X}} {{CY : ChangeAlgebra ℓ Y}} where
  open ≡-Reasoning

  data SumChange : X ⊎ Y → Set ℓ where
    ch₁ : ∀ {x} → (dx : Δ x) → SumChange (inj₁ x)
    rp₁₂ : ∀ {x} → (y : Y) → SumChange (inj₁ x)
    ch₂ : ∀ {y} → (dy : Δ y) → SumChange (inj₂ y)
    rp₂₁ : ∀ {y} → (x : X) → SumChange (inj₂ y)

  _⊕_ : (v : X ⊎ Y) → SumChange v → X ⊎ Y
  inj₁ x ⊕ ch₁ dx = inj₁ (x ⊞ dx)
  inj₂ y ⊕ ch₂ dy = inj₂ (y ⊞ dy)
  inj₁ x ⊕ rp₁₂ y = inj₂ y
  inj₂ y ⊕ rp₂₁ x = inj₁ x

  _⊝_ : ∀ (v₂ v₁ : X ⊎ Y) → SumChange v₁
  inj₁ x₂ ⊝ inj₁ x₁ = ch₁ (x₂ ⊟ x₁)
  inj₂ y₂ ⊝ inj₂ y₁ = ch₂ (y₂ ⊟ y₁)
  inj₂ y₂ ⊝ inj₁ x₁ = rp₁₂ y₂
  inj₁ x₂ ⊝ inj₂ y₁ = rp₂₁ x₂

  s-nil : (v : X ⊎ Y) → SumChange v
  s-nil (inj₁ x) = ch₁ (nil x)
  s-nil (inj₂ y) = ch₂ (nil y)

  s-update-diff : ∀ (u v : X ⊎ Y) → v ⊕ (u ⊝ v) ≡ u
  s-update-diff (inj₁ x₂) (inj₁ x₁) = cong inj₁ (update-diff x₂ x₁)
  s-update-diff (inj₂ y₂) (inj₂ y₁) = cong inj₂ (update-diff y₂ y₁)
  s-update-diff (inj₁ x₂) (inj₂ y₁) = refl
  s-update-diff (inj₂ y₂) (inj₁ x₁) = refl

  s-update-nil : ∀ v → v ⊕ (s-nil v) ≡ v
  s-update-nil (inj₁ x) = cong inj₁ (update-nil x)
  s-update-nil (inj₂ y) = cong inj₂ (update-nil y)

  instance
    changeAlgebra : ChangeAlgebra ℓ (X ⊎ Y)
    changeAlgebra = record
      { Change = SumChange
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = s-nil
      ; isChangeAlgebra = record
        { update-diff = s-update-diff
        ; update-nil = s-update-nil
        }
      }

  -- Encode infix ascription.
  as' : ∀ {ℓ} (A : Set ℓ) (a : A) → A
  as' _ a = a
  syntax as' A a = a as A

  inj₁′ : RawChange (inj₁ as (X → (X ⊎ Y)))
  inj₁′ x dx = ch₁ dx

  inj₁′Derivative : IsDerivative (inj₁ as (X → (X ⊎ Y))) inj₁′
  inj₁′Derivative x dx = refl

  inj₂′ : RawChange (inj₂ as (Y → (X ⊎ Y)))
  inj₂′ y dy = ch₂ dy

  inj₂′Derivative : IsDerivative (inj₂ as (Y → (X ⊎ Y))) inj₂′
  inj₂′Derivative y dy = refl

  -- Elimination form for sums. This is a less dependently-typed version of
  -- [_,_].
  match : ∀ {Z : Set ℓ} → (X → Z) → (Y → Z) → X ⊎ Y → Z
  match f g (inj₁ x) = f x
  match f g (inj₂ y) = g y

  module _ {Z : Set ℓ} {{CZ : ChangeAlgebra ℓ Z}} where
    instance
      X→Z = FunctionChanges.changeAlgebra X Z {{CX}} {{CZ}}
      --module ΔX→Z = FunctionChanges X Z {{CX}} {{CZ}}
      Y→Z = FunctionChanges.changeAlgebra Y Z {{CY}} {{CZ}}
      --module ΔY→Z = FunctionChanges Y Z {{CY}} {{CZ}}
      X⊎Y→Z = FunctionChanges.changeAlgebra (X ⊎ Y) Z {{changeAlgebra}} {{CZ}}
      Y→Z→X⊎Y→Z = FunctionChanges.changeAlgebra (Y → Z) (X ⊎ Y → Z) {{Y→Z}} {{X⊎Y→Z}}

    open FunctionChanges using (apply; correct)

    match′₀-realizer : (f : X → Z) → Δ f → (g : Y → Z) → Δ g → (s : X ⊎ Y) → Δ s → Δ (match f g s)
    match′₀-realizer f df g dg (inj₁ x) (ch₁ dx) = apply df x dx
    match′₀-realizer f df g dg (inj₁ x) (rp₁₂ y) = ((g ⊞ dg) y) ⊟ (f x)
    match′₀-realizer f df g dg (inj₂ y) (rp₂₁ x) = ((f ⊞ df) x) ⊟ (g y)
    match′₀-realizer f df g dg (inj₂ y) (ch₂ dy) = apply dg y dy

    match′₀-realizer-correct : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) → (s : X ⊎ Y) → (ds : Δ s) → match f g (s ⊕ ds) ⊞ match′₀-realizer f df g dg (s ⊕ ds) (nil (s ⊕ ds)) ≡ match f g s ⊞ match′₀-realizer f df g dg s ds
    match′₀-realizer-correct f df g dg (inj₁ x) (ch₁ dx) = correct df x dx
    match′₀-realizer-correct f df g dg (inj₂ y) (ch₂ dy) = correct dg y dy
    match′₀-realizer-correct f df g dg (inj₁ x) (rp₁₂ y) rewrite update-diff ((g ⊞ dg) y) (f x) = refl
    match′₀-realizer-correct f df g dg (inj₂ y) (rp₂₁ x) rewrite update-diff ((f ⊞ df) x) (g y) = refl

    match′₀ : (f : X → Z) → Δ f → (g : Y → Z) → Δ g → Δ (match f g)
    match′₀ f df g dg = record { apply = match′₀-realizer f df g dg ; correct = match′₀-realizer-correct f df g dg }

    match′-realizer-correct-body : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) → (s : X ⊎ Y) →
      (match f (g ⊞ dg) ⊞ match′₀ f df (g ⊞ dg) (nil (g ⊞ dg))) s ≡ (match f g ⊞ match′₀ f df g dg) s

    match′-realizer-correct-body f df g dg (inj₁ x) = refl
    -- refl doesn't work here. That seems a *huge* bad smell. However, that's simply because we're only updating g, not f
    match′-realizer-correct-body f df g dg (inj₂ y) rewrite update-nil y = update-diff (g y ⊞ apply dg y (nil y)) (g y ⊞ apply dg y (nil y))

    match′-realizer-correct : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) →
      (match f (g ⊞ dg)) ⊞ match′₀ f df (g ⊞ dg) (nil (g ⊞ dg)) ≡ match f g ⊞ match′₀ f df g dg
    match′-realizer-correct f df g dg = ext (match′-realizer-correct-body f df g dg)
    match′ : (f : X → Z) → Δ f → Δ (match f)
    match′ f df = record { apply = λ g dg → match′₀ f df g dg ; correct = match′-realizer-correct f df }

module Base.Change.Sums where

open import Relation.Binary.PropositionalEquality
open import Level

open import Base.Change.Algebra
open import Base.Change.Equivalence
open import Postulate.Extensionality
open import Data.Sum

module SumChanges ℓ (X Y : Set ℓ) {{CX : ChangeAlgebra ℓ X}} {{CY : ChangeAlgebra ℓ Y}} where
  open ≡-Reasoning

  -- This is an indexed datatype, so it has two constructors per argument. But
  -- erasure would probably not be smart enough to notice.

  -- Should we rewrite this as two separate datatypes?
  data SumChange : X ⊎ Y → Set ℓ where
    ch₁ : ∀ {x} → (dx : Δ x) → SumChange (inj₁ x)
    rp₁₂ : ∀ {x} → (y : Y) → SumChange (inj₁ x)
    ch₂ : ∀ {y} → (dy : Δ y) → SumChange (inj₂ y)
    rp₂₁ : ∀ {y} → (x : X) → SumChange (inj₂ y)

  _⊕_ : (v : X ⊎ Y) → SumChange v → X ⊎ Y
  inj₁ x ⊕ ch₁ dx = inj₁ (x ⊞ dx)
  inj₂ y ⊕ ch₂ dy = inj₂ (y ⊞ dy)
  inj₁ x ⊕ rp₁₂ y = inj₂ y
  inj₂ y ⊕ rp₂₁ x = inj₁ x

  _⊝_ : ∀ (v₂ v₁ : X ⊎ Y) → SumChange v₁
  inj₁ x₂ ⊝ inj₁ x₁ = ch₁ (x₂ ⊟ x₁)
  inj₂ y₂ ⊝ inj₂ y₁ = ch₂ (y₂ ⊟ y₁)
  inj₂ y₂ ⊝ inj₁ x₁ = rp₁₂ y₂
  inj₁ x₂ ⊝ inj₂ y₁ = rp₂₁ x₂

  s-nil : (v : X ⊎ Y) → SumChange v
  s-nil (inj₁ x) = ch₁ (nil x)
  s-nil (inj₂ y) = ch₂ (nil y)

  s-update-diff : ∀ (u v : X ⊎ Y) → v ⊕ (u ⊝ v) ≡ u
  s-update-diff (inj₁ x₂) (inj₁ x₁) = cong inj₁ (update-diff x₂ x₁)
  s-update-diff (inj₂ y₂) (inj₂ y₁) = cong inj₂ (update-diff y₂ y₁)
  s-update-diff (inj₁ x₂) (inj₂ y₁) = refl
  s-update-diff (inj₂ y₂) (inj₁ x₁) = refl

  s-update-nil : ∀ v → v ⊕ (s-nil v) ≡ v
  s-update-nil (inj₁ x) = cong inj₁ (update-nil x)
  s-update-nil (inj₂ y) = cong inj₂ (update-nil y)

  instance
    changeAlgebra : ChangeAlgebra ℓ (X ⊎ Y)
    changeAlgebra = record
      { Change = SumChange
      ; update = _⊕_
      ; diff = _⊝_
      ; nil = s-nil
      ; isChangeAlgebra = record
        { update-diff = s-update-diff
        ; update-nil = s-update-nil
        }
      }

  -- Encode infix ascription.
  as' : ∀ {ℓ} (A : Set ℓ) (a : A) → A
  as' _ a = a
  syntax as' A a = a as A

  inj₁′ : RawChange (inj₁ as (X → (X ⊎ Y)))
  inj₁′ x dx = ch₁ dx

  inj₁′Derivative : IsDerivative (inj₁ as (X → (X ⊎ Y))) inj₁′
  inj₁′Derivative x dx = refl

  inj₂′ : RawChange (inj₂ as (Y → (X ⊎ Y)))
  inj₂′ y dy = ch₂ dy

  inj₂′Derivative : IsDerivative (inj₂ as (Y → (X ⊎ Y))) inj₂′
  inj₂′Derivative y dy = refl

  -- Elimination form for sums. This is a less dependently-typed version of
  -- [_,_].
  match : ∀ {Z : Set ℓ} → (X → Z) → (Y → Z) → X ⊎ Y → Z
  match f g (inj₁ x) = f x
  match f g (inj₂ y) = g y

  module _ {Z : Set ℓ} {{CZ : ChangeAlgebra ℓ Z}} where
    instance
      X→Z = FunctionChanges.changeAlgebra X Z {{CX}} {{CZ}}
      --module ΔX→Z = FunctionChanges X Z {{CX}} {{CZ}}
      Y→Z = FunctionChanges.changeAlgebra Y Z {{CY}} {{CZ}}
      --module ΔY→Z = FunctionChanges Y Z {{CY}} {{CZ}}
      X⊎Y→Z = FunctionChanges.changeAlgebra (X ⊎ Y) Z {{changeAlgebra}} {{CZ}}
      Y→Z→X⊎Y→Z = FunctionChanges.changeAlgebra (Y → Z) (X ⊎ Y → Z) {{Y→Z}} {{X⊎Y→Z}}

    open FunctionChanges using (apply; correct)

    match′₀-realizer : (f : X → Z) → Δ f → (g : Y → Z) → Δ g → (s : X ⊎ Y) → Δ s → Δ (match f g s)
    match′₀-realizer f df g dg (inj₁ x) (ch₁ dx) = apply df x dx
    match′₀-realizer f df g dg (inj₁ x) (rp₁₂ y) = ((g ⊞ dg) y) ⊟ (f x)
    match′₀-realizer f df g dg (inj₂ y) (rp₂₁ x) = ((f ⊞ df) x) ⊟ (g y)
    match′₀-realizer f df g dg (inj₂ y) (ch₂ dy) = apply dg y dy

    match′₀-realizer-correct : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) → (s : X ⊎ Y) → (ds : Δ s) → match f g (s ⊕ ds) ⊞ match′₀-realizer f df g dg (s ⊕ ds) (nil (s ⊕ ds)) ≡ match f g s ⊞ match′₀-realizer f df g dg s ds
    match′₀-realizer-correct f df g dg (inj₁ x) (ch₁ dx) = correct df x dx
    match′₀-realizer-correct f df g dg (inj₂ y) (ch₂ dy) = correct dg y dy
    match′₀-realizer-correct f df g dg (inj₁ x) (rp₁₂ y) rewrite update-diff ((g ⊞ dg) y) (f x) = refl
    match′₀-realizer-correct f df g dg (inj₂ y) (rp₂₁ x) rewrite update-diff ((f ⊞ df) x) (g y) = refl

    match′₀ : (f : X → Z) → Δ f → (g : Y → Z) → Δ g → Δ (match f g)
    match′₀ f df g dg = record { apply = match′₀-realizer f df g dg ; correct = match′₀-realizer-correct f df g dg }

    match′-realizer-correct-body : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) → (s : X ⊎ Y) →
      (match f (g ⊞ dg) ⊞ match′₀ f df (g ⊞ dg) (nil (g ⊞ dg))) s ≡ (match f g ⊞ match′₀ f df g dg) s

    match′-realizer-correct-body f df g dg (inj₁ x) = refl
    -- refl doesn't work here. That seems a *huge* bad smell. However, that's simply because we're only updating g, not f
    match′-realizer-correct-body f df g dg (inj₂ y) rewrite update-nil y = update-diff (g y ⊞ apply dg y (nil y)) (g y ⊞ apply dg y (nil y))

    match′-realizer-correct : (f : X → Z) → (df : Δ f) → (g : Y → Z) → (dg : Δ g) →
      (match f (g ⊞ dg)) ⊞ match′₀ f df (g ⊞ dg) (nil (g ⊞ dg)) ≡ match f g ⊞ match′₀ f df g dg
    match′-realizer-correct f df g dg = ext (match′-realizer-correct-body f df g dg)
    match′ : (f : X → Z) → Δ f → Δ (match f)
    match′ f df = record { apply = λ g dg → match′₀ f df g dg ; correct = match′-realizer-correct f df }

Add TODO

Add TODO


module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (ΔBase ι))
nil-term {Bool}   = curriedConst (nil-const {Bool})
nil-term {Map κ ι} = curriedConst (nil-const {Map κ ι})

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
Atlas-diff {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-diff {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-diff) m₁ m₂)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-apply {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-apply) m₁ m₂)

-- Shorthands for working with diff-term and apply-term

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

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

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

module Atlas.Change.Term where

open import Atlas.Syntax.Type
open import Atlas.Syntax.Term
open import Atlas.Change.Type

-- nil-changes

nil-const : ∀ {ι : Base} → Const  ∅ (base (ΔBase ι))
nil-const {ι} = neutral {ΔBase ι}

nil-term : ∀ {ι Γ} → Term Γ (base (ΔBase ι))
nil-term {Bool}   = curriedConst (nil-const {Bool})
nil-term {Map κ ι} = curriedConst (nil-const {Map κ ι})

-- diff-term and apply-term

open import Parametric.Change.Term Const ΔBase

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

diff-base : ∀ {ι Γ} →
  Term Γ (base ι ⇒ base ι ⇒ ΔType (base ι))
diff-base {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
diff-base {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs diff-base) m₁ m₂)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = abs₂ (λ b₁ b₂ → xor! b₁ b₂)
Atlas-apply {Map κ ι} = abs₂ (λ m₁ m₂ → zip! (abs Atlas-apply) m₁ m₂)

-- Shorthands for working with diff-term and apply-term

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

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

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  -- last argument is the change accumulator
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Term Γ (base κ) → Term Γ (base ι) →
  Term Γ (ΔType (base (Map κ ι))) →
  Term Γ (ΔType (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

Rename Atlas-diff to diff-base.

Rename Atlas-diff to diff-base.

Old-commit-hash: 8940b78431520f22d625a114d12ce0faee05542c


{-# OPTIONS --without-K #-}
module Data.Two where

open import Data.Bool public hiding (if_then_else_) renaming (Bool to 𝟚; false to 0₂; true to 1₂; T to ✓)
open import Data.Bool.Properties
  public
  using (isCommutativeSemiring-∨-∧
        ;commutativeSemiring-∨-∧
        ;module RingSolver
        ;isCommutativeSemiring-∧-∨
        ;commutativeSemiring-∧-∨
        ;isBooleanAlgebra
        ;booleanAlgebra
        ;commutativeRing-xor-∧
        ;module XorRingSolver
        ;not-involutive
        ;not-¬
        ;¬-not
        ;⇔→≡
        ;proof-irrelevance)
  renaming
        (T-≡ to ✓-≡
        ;T-∧ to ✓-∧
        ;T-∨ to ✓-∨)

open import Type using (★_)

open import Algebra                    using (module CommutativeRing; module CommutativeSemiring)
open import Algebra.FunctionProperties using (Op₁; Op₂)

open import Data.Nat     using (ℕ; _≤_; z≤n; s≤s; _⊓_; _⊔_; _∸_)
open import Data.Zero    using (𝟘-elim)
open import Data.One     using (𝟙)
open import Data.Product using (proj₁; proj₂; uncurry; _×_; _,_)
open import Data.Sum     using (_⊎_; inj₁; inj₂)

open import Function.Equivalence using (module Equivalence)
open import Function.Equality    using (_⟨$⟩_)
open import Function.NP          using (id; _∘_; _⟨_⟩°_)

open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; refl; idp; _∙_; !_)
open import Relation.Nullary                         using (¬_; Dec; yes; no)

open Equivalence using (to; from)

module Xor° = CommutativeRing     commutativeRing-xor-∧
module 𝟚°   = CommutativeSemiring commutativeSemiring-∧-∨

module _ {p} {P : 𝟚 → ★ p} where

    [0:_1:_] : P 0₂ → P 1₂ → (b : 𝟚) → P b
    [0: e₀ 1: e₁ ] 0₂ = e₀
    [0: e₀ 1: e₁ ] 1₂ = e₁

    tabulate₂ : ((b : 𝟚) → P b) → P 0₂ × P 1₂
    tabulate₂ f = f 0₂ , f 1₂

    η-[0:1:] : ∀ (f : (b : 𝟚) → P b) b → [0: f 0₂ 1: f 1₂ ] b ≡ f b
    η-[0:1:] f 0₂ = refl
    η-[0:1:] f 1₂ = refl

    proj : P 0₂ × P 1₂ → (b : 𝟚) → P b
    proj = uncurry [0:_1:_]

    proj-tabulate₂ : ∀ (f : (b : 𝟚) → P b) b → proj (tabulate₂ f) b ≡ f b
    proj-tabulate₂ = η-[0:1:]

module _ {a} {A : ★ a} where

    [0:_1:_]′ : A → A → 𝟚 → A
    [0:_1:_]′ = [0:_1:_]

    case_0:_1:_ : 𝟚 → A → A → A
    case b 0: e₀ 1: e₁ = [0: e₀
                          1: e₁ ] b

    proj′ : A × A → 𝟚 → A
    proj′ = proj

    proj[_] : 𝟚 → A × A → A
    proj[_] = [0: proj₁ 1: proj₂ ]

    mux : 𝟚 × (A × A) → A
    mux (s , eᵢ) = proj eᵢ s

nor : (b₀ b₁ : 𝟚) → 𝟚
nor b₀ b₁ = not (b₀ ∨ b₁)

nand : (b₀ b₁ : 𝟚) → 𝟚
nand b₀ b₁ = not (b₀ ∧ b₁)

-- For properties about _==_ see Data.Two.Equality
_==_ : (b₀ b₁ : 𝟚) → 𝟚
b₀ == b₁ = (not b₀) xor b₁

≡→✓ : ∀ {b} → b ≡ 1₂ → ✓ b
≡→✓ refl = _

≡→✓not : ∀ {b} → b ≡ 0₂ → ✓ (not b)
≡→✓not refl = _

✓→≡ : ∀ {b} → ✓ b → b ≡ 1₂
✓→≡ {1₂} _ = refl
✓→≡ {0₂} ()

✓not→≡ : ∀ {b} → ✓ (not b) → b ≡ 0₂
✓not→≡ {0₂} _ = refl
✓not→≡ {1₂} ()

✓∧ : ∀ {b₁ b₂} → ✓ b₁ → ✓ b₂ → ✓ (b₁ ∧ b₂)
✓∧ p q = _⟨$⟩_ (from ✓-∧) (p , q)

✓∧₁ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁
✓∧₁ = proj₁ ∘ _⟨$⟩_ (to ✓-∧)

✓∧₂ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₂
✓∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (✓-∧ {b₁}))

✓∨-⊎ : ∀ {b₁ b₂} → ✓ (b₁ ∨ b₂) → ✓ b₁ ⊎ ✓ b₂
✓∨-⊎ {b₁} = _⟨$⟩_ (to (✓-∨ {b₁}))

✓∨₁ : ∀ {b₁ b₂} → ✓ b₁ → ✓ (b₁ ∨ b₂)
✓∨₁ = _⟨$⟩_ (from ✓-∨) ∘ inj₁

✓∨₂ : ∀ {b₁ b₂} → ✓ b₂ → ✓ (b₁ ∨ b₂)
✓∨₂ {b₁} = _⟨$⟩_ (from (✓-∨ {b₁})) ∘ inj₂

✓-not-¬ : ∀ {b} → ✓ (not b) → ¬ (✓ b)
✓-not-¬ {0₂} _ = λ()
✓-not-¬ {1₂} ()

✓-¬-not : ∀ {b} → ¬ (✓ b) → ✓ (not b)
✓-¬-not {0₂} _ = _
✓-¬-not {1₂} f = f _

∧⇒∨ : ∀ x y → ✓ (x ∧ y) → ✓ (x ∨ y)
∧⇒∨ 0₂ _ = λ ()
∧⇒∨ 1₂ _ = _

✓dec : ∀ b → Dec (✓ b)
✓dec = [0: no (λ())
        1: yes _ ]

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan 0₂ _ = refl
de-morgan 1₂ _ = refl

≢0→≡1 : ∀ {x} → x ≢ 0₂ → x ≡ 1₂
≢0→≡1 {1₂} p = refl
≢0→≡1 {0₂} p = 𝟘-elim (p refl)

≢1→≡0 : ∀ {x} → x ≢ 1₂ → x ≡ 0₂
≢1→≡0 {0₂} p = refl
≢1→≡0 {1₂} p = 𝟘-elim (p refl)

-- 0₂ is 0 and 1₂ is 1
𝟚▹ℕ : 𝟚 → ℕ
𝟚▹ℕ = [0: 0
       1: 1 ]

𝟚▹ℕ≤1 : ∀ b → 𝟚▹ℕ b ≤ 1
𝟚▹ℕ≤1 = [0: z≤n
         1: s≤s z≤n ]

𝟚▹ℕ-⊓ : ∀ a b → 𝟚▹ℕ a ⊓ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ b)
𝟚▹ℕ-⊓ 1₂ 0₂ = refl
𝟚▹ℕ-⊓ 1₂ 1₂ = refl
𝟚▹ℕ-⊓ 0₂ _  = refl

𝟚▹ℕ-⊔ : ∀ a b → 𝟚▹ℕ a ⊔ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∨ b)
𝟚▹ℕ-⊔ 1₂ 0₂ = refl
𝟚▹ℕ-⊔ 1₂ 1₂ = refl
𝟚▹ℕ-⊔ 0₂ _  = refl

𝟚▹ℕ-∸ : ∀ a b → 𝟚▹ℕ a ∸ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ not b)
𝟚▹ℕ-∸ 0₂ 0₂ = refl
𝟚▹ℕ-∸ 0₂ 1₂ = refl
𝟚▹ℕ-∸ 1₂ 0₂ = refl
𝟚▹ℕ-∸ 1₂ 1₂ = refl

xor-not-not : ∀ x y → (not x) xor (not y) ≡ x xor y
xor-not-not 0₂ y = not-involutive y
xor-not-not 1₂ _ = refl

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {0₂} {0₂} _ = refl
not-inj {1₂} {1₂} _ = refl
not-inj {0₂} {1₂} ()
not-inj {1₂} {0₂} ()

xor-inj₁ : ∀ x {y z} → (x xor y) ≡ (x xor z) → y ≡ z
xor-inj₁ 0₂ = id
xor-inj₁ 1₂ = not-inj

xor-inj₂ : ∀ x {y z} → (y xor x) ≡ (z xor x) → y ≡ z
xor-inj₂ x {y} {z} p = xor-inj₁ x (Xor°.+-comm x y ∙ p ∙ Xor°.+-comm z x)

check : ∀ b → {pf : ✓ b} → 𝟙
check = _

module Indexed {a} {A : ★ a} where
    _∧°_ : Op₂ (A → 𝟚)
    x ∧° y = x ⟨ _∧_ ⟩° y

    _∨°_ : Op₂ (A → 𝟚)
    x ∨° y = x ⟨ _∨_ ⟩° y

    _xor°_ : Op₂ (A → 𝟚)
    x xor° y = x ⟨ _xor_ ⟩° y

    _==°_ : Op₂ (A → 𝟚)
    x ==° y = x ⟨ _==_ ⟩° y

    not° : Op₁ (A → 𝟚)
    not° f = not ∘ f
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Data.Two where

open import Data.Bool public hiding (if_then_else_) renaming (Bool to 𝟚; false to 0₂; true to 1₂; T to ✓)
open import Data.Bool.Properties
  public
  using (isCommutativeSemiring-∨-∧
        ;commutativeSemiring-∨-∧
        ;module RingSolver
        ;isCommutativeSemiring-∧-∨
        ;commutativeSemiring-∧-∨
        ;isBooleanAlgebra
        ;booleanAlgebra
        ;commutativeRing-xor-∧
        ;module XorRingSolver
        ;not-involutive
        ;not-¬
        ;¬-not
        ;⇔→≡
        ;proof-irrelevance)
  renaming
        (T-≡ to ✓-≡
        ;T-∧ to ✓-∧
        ;T-∨ to ✓-∨)

open import Type using (★_)

open import Algebra                    using (module CommutativeRing; module CommutativeSemiring)
open import Algebra.FunctionProperties using (Op₁; Op₂)

open import Data.Nat     using (ℕ; _≤_; z≤n; s≤s; _⊓_; _⊔_; _∸_)
open import Data.Zero    using (𝟘-elim)
open import Data.One     using (𝟙)
open import Data.Product using (proj₁; proj₂; uncurry; _×_; _,_)
open import Data.Sum     using (_⊎_; inj₁; inj₂)

open import Function.Equivalence using (module Equivalence)
open import Function.Equality    using (_⟨$⟩_)
open import Function.NP          using (id; _∘_; _⟨_⟩°_)

open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; refl; idp; _∙_; !_)
open import Relation.Nullary                         using (¬_; Dec; yes; no)

open Equivalence using (to; from)

module Xor° = CommutativeRing     commutativeRing-xor-∧
module 𝟚°   = CommutativeSemiring commutativeSemiring-∧-∨

_² : ∀ {a} → ★ a → ★ a
A ² = 𝟚 → A

module _ {p} {P : 𝟚 → ★ p} where

    [0:_1:_] : P 0₂ → P 1₂ → (b : 𝟚) → P b
    [0: e₀ 1: e₁ ] 0₂ = e₀
    [0: e₀ 1: e₁ ] 1₂ = e₁

    tabulate₂ : ((b : 𝟚) → P b) → P 0₂ × P 1₂
    tabulate₂ f = f 0₂ , f 1₂

    η-[0:1:] : ∀ (f : (b : 𝟚) → P b) b → [0: f 0₂ 1: f 1₂ ] b ≡ f b
    η-[0:1:] f 0₂ = refl
    η-[0:1:] f 1₂ = refl

    proj : P 0₂ × P 1₂ → (b : 𝟚) → P b
    proj = uncurry [0:_1:_]

    proj-tabulate₂ : ∀ (f : (b : 𝟚) → P b) b → proj (tabulate₂ f) b ≡ f b
    proj-tabulate₂ = η-[0:1:]

module _ {a} {A : ★ a} where

    [0:_1:_]′ : A → A → A ²
    [0:_1:_]′ = [0:_1:_]

    case_0:_1:_ : 𝟚 → A → A → A
    case b 0: e₀ 1: e₁ = [0: e₀
                          1: e₁ ] b

    proj′ : A × A → A ²
    proj′ = proj

    proj[_] : 𝟚 → A × A → A
    proj[_] = [0: proj₁ 1: proj₂ ]

    mux : 𝟚 × (A × A) → A
    mux (s , eᵢ) = proj eᵢ s

nor : (b₀ b₁ : 𝟚) → 𝟚
nor b₀ b₁ = not (b₀ ∨ b₁)

nand : (b₀ b₁ : 𝟚) → 𝟚
nand b₀ b₁ = not (b₀ ∧ b₁)

-- For properties about _==_ see Data.Two.Equality
_==_ : (b₀ b₁ : 𝟚) → 𝟚
b₀ == b₁ = (not b₀) xor b₁

≡→✓ : ∀ {b} → b ≡ 1₂ → ✓ b
≡→✓ refl = _

≡→✓not : ∀ {b} → b ≡ 0₂ → ✓ (not b)
≡→✓not refl = _

✓→≡ : ∀ {b} → ✓ b → b ≡ 1₂
✓→≡ {1₂} _ = refl
✓→≡ {0₂} ()

✓not→≡ : ∀ {b} → ✓ (not b) → b ≡ 0₂
✓not→≡ {0₂} _ = refl
✓not→≡ {1₂} ()

✓∧ : ∀ {b₁ b₂} → ✓ b₁ → ✓ b₂ → ✓ (b₁ ∧ b₂)
✓∧ p q = _⟨$⟩_ (from ✓-∧) (p , q)

✓∧₁ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₁
✓∧₁ = proj₁ ∘ _⟨$⟩_ (to ✓-∧)

✓∧₂ : ∀ {b₁ b₂} → ✓ (b₁ ∧ b₂) → ✓ b₂
✓∧₂ {b₁} = proj₂ ∘ _⟨$⟩_ (to (✓-∧ {b₁}))

✓∨-⊎ : ∀ {b₁ b₂} → ✓ (b₁ ∨ b₂) → ✓ b₁ ⊎ ✓ b₂
✓∨-⊎ {b₁} = _⟨$⟩_ (to (✓-∨ {b₁}))

✓∨₁ : ∀ {b₁ b₂} → ✓ b₁ → ✓ (b₁ ∨ b₂)
✓∨₁ = _⟨$⟩_ (from ✓-∨) ∘ inj₁

✓∨₂ : ∀ {b₁ b₂} → ✓ b₂ → ✓ (b₁ ∨ b₂)
✓∨₂ {b₁} = _⟨$⟩_ (from (✓-∨ {b₁})) ∘ inj₂

✓-not-¬ : ∀ {b} → ✓ (not b) → ¬ (✓ b)
✓-not-¬ {0₂} _ = λ()
✓-not-¬ {1₂} ()

✓-¬-not : ∀ {b} → ¬ (✓ b) → ✓ (not b)
✓-¬-not {0₂} _ = _
✓-¬-not {1₂} f = f _

∧⇒∨ : ∀ x y → ✓ (x ∧ y) → ✓ (x ∨ y)
∧⇒∨ 0₂ _ = λ ()
∧⇒∨ 1₂ _ = _

✓dec : ∀ b → Dec (✓ b)
✓dec = [0: no (λ())
        1: yes _ ]

de-morgan : ∀ x y → not (x ∨ y) ≡ not x ∧ not y
de-morgan 0₂ _ = refl
de-morgan 1₂ _ = refl

≢0→≡1 : ∀ {x} → x ≢ 0₂ → x ≡ 1₂
≢0→≡1 {1₂} p = refl
≢0→≡1 {0₂} p = 𝟘-elim (p refl)

≢1→≡0 : ∀ {x} → x ≢ 1₂ → x ≡ 0₂
≢1→≡0 {0₂} p = refl
≢1→≡0 {1₂} p = 𝟘-elim (p refl)

-- 0₂ is 0 and 1₂ is 1
𝟚▹ℕ : 𝟚 → ℕ
𝟚▹ℕ = [0: 0
       1: 1 ]

𝟚▹ℕ≤1 : ∀ b → 𝟚▹ℕ b ≤ 1
𝟚▹ℕ≤1 = [0: z≤n
         1: s≤s z≤n ]

𝟚▹ℕ-⊓ : ∀ a b → 𝟚▹ℕ a ⊓ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ b)
𝟚▹ℕ-⊓ 1₂ 0₂ = refl
𝟚▹ℕ-⊓ 1₂ 1₂ = refl
𝟚▹ℕ-⊓ 0₂ _  = refl

𝟚▹ℕ-⊔ : ∀ a b → 𝟚▹ℕ a ⊔ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∨ b)
𝟚▹ℕ-⊔ 1₂ 0₂ = refl
𝟚▹ℕ-⊔ 1₂ 1₂ = refl
𝟚▹ℕ-⊔ 0₂ _  = refl

𝟚▹ℕ-∸ : ∀ a b → 𝟚▹ℕ a ∸ 𝟚▹ℕ b ≡ 𝟚▹ℕ (a ∧ not b)
𝟚▹ℕ-∸ 0₂ 0₂ = refl
𝟚▹ℕ-∸ 0₂ 1₂ = refl
𝟚▹ℕ-∸ 1₂ 0₂ = refl
𝟚▹ℕ-∸ 1₂ 1₂ = refl

xor-not-not : ∀ x y → (not x) xor (not y) ≡ x xor y
xor-not-not 0₂ y = not-involutive y
xor-not-not 1₂ _ = refl

not-inj : ∀ {x y} → not x ≡ not y → x ≡ y
not-inj {0₂} {0₂} _ = refl
not-inj {1₂} {1₂} _ = refl
not-inj {0₂} {1₂} ()
not-inj {1₂} {0₂} ()

xor-inj₁ : ∀ x {y z} → (x xor y) ≡ (x xor z) → y ≡ z
xor-inj₁ 0₂ = id
xor-inj₁ 1₂ = not-inj

xor-inj₂ : ∀ x {y z} → (y xor x) ≡ (z xor x) → y ≡ z
xor-inj₂ x {y} {z} p = xor-inj₁ x (Xor°.+-comm x y ∙ p ∙ Xor°.+-comm z x)

check : ∀ b → {pf : ✓ b} → 𝟙
check = _

module Indexed {a} {A : ★ a} where
    _∧°_ : Op₂ (A → 𝟚)
    x ∧° y = x ⟨ _∧_ ⟩° y

    _∨°_ : Op₂ (A → 𝟚)
    x ∨° y = x ⟨ _∨_ ⟩° y

    _xor°_ : Op₂ (A → 𝟚)
    x xor° y = x ⟨ _xor_ ⟩° y

    _==°_ : Op₂ (A → 𝟚)
    x ==° y = x ⟨ _==_ ⟩° y

    not° : Op₁ (A → 𝟚)
    not° f = not ∘ f
-- -}
-- -}
-- -}

add _²

Data.Two: add _²


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

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

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

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality

open import Base.Change.Algebra as CA using
  ( ChangeAlgebra
  ; ChangeAlgebraFamily
  ; change-algebra₍_₎
  ; family
  )
open import Level

Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
  change-algebra (base ι) = change-algebra₍ ι ₎
  change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

  change-algebra-family : ChangeAlgebraFamily zero ⟦_⟧Type
  change-algebra-family = family change-algebra

  ----------------
  -- Parameters --
  ----------------

  Change-base : (ι : Base) → ⟦ ι ⟧Base → Set
  Change-base = CA.Δ₍_₎

  diff-change-base : ∀ ι → (u v : ⟦ ι ⟧Base) → Change-base ι v
  diff-change-base = CA.diff′

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

  open CA public
    using
      (
      )
    renaming
      ( Δ₍_₎ to Change
      ; update′ to apply-change
      ; diff′ to diff-change
      ; nil₍_₎ to nil-change
      )

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

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

  module _ {τ₁ τ₂ : Type} where
    open CA.FunctionChanges.FunctionChange _ _ {{change-algebra τ₁}} {{change-algebra τ₂}} public
      using
        (
        )
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  open CA public using
    ( before
    ; after
    ; before₍_₎
    ; after₍_₎
    )

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

  open CA.FunctionChanges public using (cons)
  open CA public using () renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  open CA.ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebra to environment-changes
    )

  ΔEnv : ∀ (Γ : Context) → ⟦ Γ ⟧ → Set
  ΔEnv Γ ρ = CA.Δ₍ Γ ₎ ρ

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : ΔEnv Γ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍ Γ ₎

  apply-env : ∀ Γ → (ρ : ⟦ Γ ⟧) → (dρ : ΔEnv Γ ρ) → ⟦ Γ ⟧
  apply-env = CA.update′

  diff-env : ∀ Γ → (π ρ : ⟦ Γ ⟧) → ΔEnv Γ ρ
  diff-env = CA.diff′

Remove apply-env and diff-env.

Remove apply-env and diff-env.

Old-commit-hash: 0901643e49a0e4ff70db8f16278c25bd28348d3a


--
-- In this module we conclude our proof: we have shown that t, derive-dterm t
-- and produce related values (in the sense of the fundamental property,
-- rfundamental3), and for related values v1, dv and v2 we have v1 ⊕ dv ≡
-- v2 (because ⊕ agrees with validity, rrelV3→⊕).
--
-- We now put these facts together via derive-correct-si and derive-correct.
-- This is immediate, even though I spend so much code on it:
-- Indeed, all theorems are immediate corollaries of what we established (as
-- explained above); only the statements are longer, especially because I bother
-- expanding them.

module Thesis.SIRelBigStep.DeriveCorrect where

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

open import Thesis.SIRelBigStep.IlcSILR
open import Thesis.SIRelBigStep.FundamentalProperty

-- Theorem statement. This theorem still mentions step-indexes explicitly.
derive-correct-si-type =
  ∀ {τ Γ k} (t : Term Γ τ) ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3-skeleton (λ v1 dv v2 _ → v1 ⊕ dv ≡ v2) t (derive-dterm t) t ρ1 dρ ρ2 k

-- A verified expansion of the theorem statement.
derive-correct-si-type-means :
  derive-correct-si-type ≡
  ∀ {τ Γ k} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  (v1 v2 : Val τ) →
  ∀ j (j<k : j < k) →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct-si-type-means = refl

derive-correct-si : derive-correct-si-type
derive-correct-si t ρ1 dρ ρ2 ρρ = rrelT3→⊕ t (derive-dterm t) t ρ1 dρ ρ2 (rfundamental3 _ t ρ1 dρ ρ2 ρρ)

-- Infinitely related environments:
rrelρ3-inf : ∀ Γ (ρ1 : ⟦ Γ ⟧Context) (dρ : ChΔ Γ) (ρ2 : ⟦ Γ ⟧Context) → Set
rrelρ3-inf Γ ρ1 dρ ρ2 = ∀ k → rrelρ3 Γ ρ1 dρ ρ2 k

-- A theorem statement for infinitely-related environments. On paper, if we informally
-- omit the arbitrary derivation step-index as usual, we get a statement without
-- step-indexes.
derive-correct :
  ∀ {τ Γ} (t : Term Γ τ)
  ρ1 dρ ρ2 (ρρ : rrelρ3-inf Γ ρ1 dρ ρ2) →
  (v1 v2 : Val τ) →
  ∀ j →
  (ρ1⊢t1↓[j]v1 : ρ1 ⊢ t ↓[ i' j ] v1) →
  (ρ2⊢t2↓[n2]v2 : ρ2 ⊢ t ↓[ no ] v2) →
  Σ[ dv ∈ DVal τ ]
  ρ1 D dρ ⊢ derive-dterm t ↓ dv ×
  v1 ⊕ dv ≡ v2
derive-correct t ρ1 dρ ρ2 ρρ v1 v2 j = derive-correct-si t ρ1 dρ ρ2 (ρρ (suc j)) v1 v2 j ≤-refl

open import Data.Unit

nilρ : ∀ {Γ n} (ρ : ⟦ Γ ⟧Context) → Σ[ dρ ∈ ChΔ Γ ] rrelρ3 Γ ρ dρ ρ n
nilV : ∀ {τ n} (v : Val τ) → Σ[ dv ∈ DVal τ ] rrelV3 τ v dv v n
nilV (closure t ρ) = let dρ , ρρ = nilρ ρ in dclosure (derive-dterm t) ρ dρ , rfundamental3svv _ (abs t) ρ dρ ρ ρρ
nilV (natV n₁) = dnatV zero , refl
nilV (pairV a b) = let 0a , aa = nilV a; 0b , bb = nilV b in dpairV 0a 0b , aa , bb

nilρ ∅ = ∅ , tt
nilρ (v • ρ) = let dv , vv = nilV v ; dρ , ρρ = nilρ ρ in dv • dρ , vv , ρρ

Define a correct nil on values and environments

Compose is trickier because I must match on two validity proofs, need an
inversion lemma for that.


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
  if : ∀ {Γ τ} → (t₁ : Term Γ bool) (t₂ t₃ : 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
⟦ if 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
  if-true : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₂ : Val τ} →
    ρ ⊢ t₁ ↓ true →
    ρ ⊢ t₂ ↓ v₂ →
    ρ ⊢ if t₁ t₂ t₃ ↓ v₂
  if-false : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₃ : Val τ} →
    ρ ⊢ t₁ ↓ false →
    ρ ⊢ t₃ ↓ v₃ →
    ρ ⊢ if 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 (if-true ↓₁ ↓₂) rewrite ↓-sound ↓₁ = ↓-sound ↓₂
↓-sound (if-false ↓₁ ↓₃) rewrite ↓-sound ↓₁ = ↓-sound ↓₃

-- WEAKENING

-- Weaken a term to a super context

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

-- SYMBOLIC EXECUTION
--
-- Naming Convention:
-- Γ ⟪_⟫X is like ⟦_⟧X but for symbolic execution in context Γ.

_⟪_⟫Type : Context → Type → Set
Γ₁ ⟪ τ₁ ⇒ τ₂ ⟫Type = ∀ {Γ₂} → Γ₁ ≼ Γ₂ → Γ₂ ⟪ τ₁ ⟫Type → Γ₂ ⟪ τ₂ ⟫Type
Γ₁ ⟪ bool ⟫Type = Term Γ₁ bool

module _ (Γ : Context) where
  import Denotational.Environments
  module SymEnv = Denotational.Environments Type (λ τ → Γ ⟪ τ ⟫Type)

  open SymEnv public using ()
    renaming (⟦_⟧Context to _⟪_⟫Context; ⟦_⟧Var to _⟪_⟫Var_)

liftVal : ∀ {τ Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → Γ₁ ⟪ τ ⟫Type → Γ₂ ⟪ τ ⟫Type
liftVal {τ₁ ⇒ τ₂} ≼₁ v₁ = λ ≼₂ v₂ → v₁ (≼-trans ≼₁ ≼₂) v₂
liftVal {bool} ≼₁ v = weaken ≼₁ v

liftEnv : ∀ {Γ Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → Γ₁ ⟪ Γ ⟫Context → Γ₂ ⟪ Γ ⟫Context
liftEnv {∅} ≼₁ ∅ = SymEnv.∅
liftEnv {τ • Γ} ≼₁ (v • ρ) = liftVal ≼₁ v SymEnv.• liftEnv ≼₁ ρ

mixed-if : ∀ {Γ₁} τ → (t₁ : Term Γ₁ bool) (v₂ v₃ : Γ₁ ⟪ τ ⟫Type) → Γ₁ ⟪ τ ⟫Type
mixed-if (τ₁ ⇒ τ₂) t₁ v₂ v₃ = λ ≼₁ v → mixed-if τ₂ (weaken ≼₁ t₁) (v₃ ≼₁ v) (v₃ ≼₁ v)
mixed-if bool t₁ t₂ t₃ = if t₁ t₂ t₃

_⟪_⟫Term_ : ∀ Γ₁ {Γ τ} → Term Γ τ → Γ₁ ⟪ Γ ⟫Context → Γ₁ ⟪ τ ⟫Type
Γ₁ ⟪ abs t ⟫Term ρ = λ {Γ₂} ≼₁ v → Γ₂ ⟪ t ⟫Term (v SymEnv.• liftEnv ≼₁ ρ)
Γ₁ ⟪ app t₁ t₂ ⟫Term ρ = (Γ₁ ⟪ t₁ ⟫Term ρ) ≼-refl (Γ₁ ⟪ t₂ ⟫Term ρ)
Γ₁ ⟪ var x ⟫Term ρ = Γ₁ ⟪ x ⟫Var ρ
Γ₁ ⟪ true ⟫Term ρ = true
Γ₁ ⟪ false ⟫Term ρ = false
Γ₁ ⟪ if t₁ t₂ t₃ ⟫Term ρ = mixed-if _ (Γ₁ ⟪ t₁ ⟫Term ρ) (Γ₁ ⟪ t₂ ⟫Term ρ) (Γ₁ ⟪ t₂ ⟫Term ρ)

↓ : ∀ {Γ} τ → Γ ⟪ τ ⟫Type → Term Γ τ
↑ : ∀ {Γ} τ → Term Γ τ → Γ ⟪ τ ⟫Type

↓ (τ₁ ⇒ τ₂) v = abs (↓ τ₂ (v (drop τ₁ • ≼-refl) (↑ τ₁ (var this))))
↓ bool v = v

↑ (τ₁ ⇒ τ₂) t = λ ≼₁ v → ↑ τ₂ (app (weaken ≼₁ t) (↓ τ₁ v))
↑ bool t = t

↑-Context : ∀ {Γ} → Γ ⟪ Γ ⟫Context
↑-Context {∅} = SymEnv.∅
↑-Context {τ • Γ} = ↑ τ (var this) SymEnv.• liftEnv (drop τ • ≼-refl) ↑-Context

norm : ∀ {Γ τ} → Term Γ τ → Term Γ τ
norm {Γ} {τ} t = ↓ τ (Γ ⟪ t ⟫Term ↑-Context)

Implement NbE for lambda calculus with conditionals (see #50).

This version is simpler than the code in NormalizationByEvaluation
in the following ways:

 - Instead of supporting arbitrary base types and constants,
   bool, true, false, and if are hard-coded.

 - Instead of supporting arbitrary Kripke structures,
   metacircular evaluation and symbolic evaluation are hard-coded.

Old-commit-hash: d25aa0871f3efecd4932029a007775f4c22568fb


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
-- We claim that this formalization
--
--   (1) proves every lemma and theorem in Sec. 2 and 3 of the paper,
--   (2) formally specifies the interface between our incrementalization
--       framework and potential plugins, and
--   (3) shows that the plugin interface can be instantiated.
--
-- The first claim is the main reason for a machine-checked
-- proof: We want to be sure that we got the proofs right.
--
-- The second claim is about reusability and applicability: Only
-- a clearly defined interface allows other researchers to
-- provide plugins for our framework.
--
-- The third claim is to show that the plugin interface is
-- consistent: An inconsistent plugin interface would allow to
-- prove arbitrary results in the framework.
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda, the Agda standard library (version 0.7), generate Everything.agda
-- with the attached Haskell helper, and finally run Agda on this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- We use Agda HEAD from September 2013; Agda 2.3.2.1 might happen to work, but
-- has some bugs with serialization of code using some recent syntactic sugar
-- which we use (https://code.google.com/p/agda/issues/detail?id=756), so it
-- might work or not. When it does not, removing Agda caches (.agdai files)
-- appears to often help. You can use "find . -name '*.agdai' | xargs rm" to do
-- that.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- (This import is also important to ensure that if we typecheck
-- README.agda, we also typecheck every other file of our
-- formalization).

-- THE AGDA CODE
-- =============
--
-- The formalization has four parts:
--
--   1. A formalization of change structures. This lives in
--   Base.Change.Algebra. (What we call "change structure" in the
--   paper, we call "change algebra" in the Agda code. We changed
--   the name when writing the paper, and never got around to
--   updating the name in the Agda code).
--
--   2. Incrementalization framework for first-class functions,
--   with extension points for plugging in data types and their
--   incrementalization. This lives in the Parametric.*
--   hierarchy.
--
--   3. An example plugin that provides integers and bags
--   with negative multiplicity. This lives in the Nehemiah.*
--   hierarchy. (For some reason, we choose to call this
--   particular incarnation of the plugin Nehemiah).
--
--   4. Other material that is unrelated to the framework/plugin
--   distinction. This is all other files.

-- FORMALIZATION OF CHANGE STRUCTURES
-- ==================================
--
-- Section 2 of the paper, and Base.Change.Algebra in Agda.

import Base.Change.Algebra

-- INCREMENTALIZATION FRAMEWORK
-- ============================
--
-- Section 3 of the paper, and Parametric.* hierarchy in Agda.
--
-- The extension points are implemented as module parameters. See
-- detailed explanation in Parametric.Syntax.Type and
-- Parametric.Syntax.Term. Some extension points are for types,
-- some for values, and some for proof fragments. In Agda, these
-- three kinds of entities are unified anyway, so we can encode
-- all of them as module parameters.
--
-- Every module in the Parametric.* hierarchy adds at least one
-- extension point, so the module hierarchy of a plugin will
-- typically mirror the Parametric.* hierarchy, defining the
-- values for these extension points.
--
-- Firstly, we have the syntax of types and terms, the erased
-- change structure for function types and incrementalization as
-- a term-to-term transformation. The contents of these modules
-- formalizes Sec. 3.1 and 3.2 of the paper, except for the
-- second and third line of Figure 3, which is formalized further
-- below.

import Parametric.Syntax.Type   -- syntax of types
import Parametric.Syntax.Term   -- syntax of terms
import Parametric.Change.Type   -- simply-typed changes
import Parametric.Change.Derive -- incrementalization

-- Secondly, we define the usual denotational semantics of the
-- simply-typed lambda calculus in terms of total functions, and
-- the change semantics in terms of a change structure on total
-- functions. The contents of these modules formalize Sec. 3.3,
-- 3.4 and 3.5 of the paper.

import Parametric.Denotation.Value      -- standard values
import Parametric.Denotation.Evaluation -- standard evaluation
import Parametric.Change.Validity       -- dependently-typed changes
import Parametric.Change.Specification  -- change evaluation

-- Thirdly, we define terms that operate on simply-typed changes,
-- and connect them to their values. The concents of these
-- modules formalize the second and third line of Figure 3, as
-- well as the semantics of these lines.

import Parametric.Change.Term        -- terms that operate on simply-typed changes
import Parametric.Change.Value       -- the values of these terms
import Parametric.Change.Evaluation  -- connecting the terms and their values

-- Finally, we prove correctness by connecting the (syntactic)
-- incrementalization to the (semantic) change evaluation by a
-- logical relation, and a proof that the values of terms
-- produced by the incrementalization transformation are related
-- to the change values of the original terms. The contents of
-- these modules formalize Sec. 3.6.

import Parametric.Change.Implementation -- logical relation
import Parametric.Change.Correctness    -- main correctness proof

-- EXAMPLE PLUGIN
-- ==============
--
-- Sec. 3.7 in the paper, and the Nehemiah.* hierarchy in Agda.
--
-- The module structure of the plugin follows the structure of
-- the Parametric.* hierarchy.  For example, the extension point
-- defined in Parametric.Syntax.Term is instantiated in
-- Nehemiah.Syntax.Term.
--
-- As discussed in Sec. 3.7 of the paper, the point of this
-- plugin is not to speed up any real programs, but to show "that
-- the interface for proof plugins can be implemented". As a
-- first step towards proving correctness of the more complicated
-- plugin with integers, bags and finite maps we implement in
-- Scala, we choose to define plugin with integers and bags in
-- Agda. Instead of implementing bags (with negative
-- multiplicities, like in the paper) in Agda, though, we
-- postulate that a group of such bags exist. Note that integer
-- bags with integer multiplicities are actually the free group
-- given a singleton operation `Integer -> Bag`, so this should
-- be easy to formalize in principle.

-- Before we start with the plugin, we postulate an abstract data
-- type for integer bags.
import Postulate.Bag-Nehemiah

-- Firstly, we extend the syntax of types and terms, the erased
-- change structure for function types, and incrementalization as
-- a term-to-term transformation to account for the data types of
-- the Nehemiah language. The contents of these modules
-- instantiate the extension points in Sec. 3.1 and 3.2 of the
-- paper, except for the second and third line of Figure 3, which
-- is instantiated further below.

import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term
import Nehemiah.Change.Type
import Nehemiah.Change.Derive

-- Secondly, we extend the usual denotational semantics and the
-- change semantics to account for the data types of the Nehemiah
-- language. The contents of these modules instantiate the
-- extension points in Sec. 3.3, 3.4 and 3.5 of the paper.

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation
import Nehemiah.Change.Validity
import Nehemiah.Change.Specification

-- Thirdly, we extend the terms that operate on simply-typed
-- changes, and the connection to their values to account for the
-- data types of the Nehemiah language. The concents of these
-- modules instantiate the extension points in the second and
-- third line of Figure 3.

import Nehemiah.Change.Term
import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- Finally, we extend the logical relation and the main
-- correctness proof to account for the data types in the
-- Nehemiah language. The contents of these modules instantiate
-- the extension points defined in Sec. 3.6.

import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness

-- OTHER MATERIAL
-- ==============
--
-- We postulate extensionality of Agda functions. This postulate
-- is well known to be compatible with Agda's type theory.

import Postulate.Extensionality

-- For historical reasons, we reexport Data.List.All from the
-- standard library under the name DependentList.

import Base.Data.DependentList

-- This module supports overloading the ⟦_⟧ notation based on
-- Agda's instance arguments.

import Base.Denotation.Notation

-- These modules implement contexts including typed de Bruijn
-- indices to represent bound variables, sets of bound variables,
-- and environments. These modules are parametric in the set of
-- types (that are stored in contexts) and the set of values
-- (that are stored in environments). So these modules are even
-- more parametric than the Parametric.* hierarchy.

import Base.Syntax.Context
import Base.Syntax.Vars
import Base.Denotation.Environment

-- This module contains some helper definitions to merge a
-- context of values and a context of changes.
import Base.Change.Context

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Machine-checked formalization of the theoretical results presented
-- in the paper:
--
--   Yufei Cai, Paolo G. Giarrusso, Tillmann Rendel, Klaus Ostermann.
--   A Theory of Changes for Higher-Order Languages:
--   Incrementalizing λ-Calculi by Static Differentiation.
--   To appear at PLDI, ACM 2014.
--
-- We claim that this formalization
--
--   (1) proves every lemma and theorem in Sec. 2 and 3 of the paper,
--   (2) formally specifies the interface between our incrementalization
--       framework and potential plugins, and
--   (3) shows that the plugin interface can be instantiated.
--
-- The first claim is the main reason for a machine-checked
-- proof: We want to be sure that we got the proofs right.
--
-- The second claim is about reusability and applicability: Only
-- a clearly defined interface allows other researchers to
-- provide plugins for our framework.
--
-- The third claim is to show that the plugin interface is
-- consistent: An inconsistent plugin interface would allow to
-- prove arbitrary results in the framework.
------------------------------------------------------------------------

module README where

-- We know two good ways to read this code base. You can either
-- use Emacs with agda2-mode to interact with the source files,
-- or you can use a web browser to view the pretty-printed and
-- hyperlinked source files. For Agda power users, we also
-- include basic setup information for your own machine.

-- IF YOU WANT TO USE A BROWSER
-- ============================
--
-- Start with *HTML* version of this readme. On the AEC
-- submission website (online or inside the VM), follow the link
-- "view the Agda code in their browser" to the file
-- agda/README.html.
--
-- The source code is syntax highlighted and hyperlinked. You can
-- click on module names to open the corresponding files, or you
-- can click on identifiers to jump to their definition. In
-- general, a Agda file with name `Foo/Bar/Baz.agda` contains a
-- module `Foo.Bar.Baz` and is shown in an HTML file
-- `Foo.Bar.Baz.html`.
--
-- Note that we also include the HTML files generated for our
-- transitive dependencies from the Agda standard library. This
-- allows you to follow hyperlinks to the Agda standard
-- library. It is the default behavior of `agda --html` which we
-- used to generate the HTML.
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE EMACS
-- ========================
--
-- Open this file in Emacs with agda2-mode installed. See below
-- for which Agda version you need to install. On the VM image,
-- everything is setup for you and you can just open this file in
-- Emacs.
--
--   C-c C-l   Load code. Type checks and syntax highlights. Use
--             this if the code is not syntax highlighted, or
--             after you changed something that you want to type
--             check.
--
--   M-.       Jump to definition of identifier at the point.
--   M-*       Jump back.
--
-- Note that README.agda imports Everything.agda which imports
-- every Agda file in our formalization. So if README.agda type
-- checks successfully, everything does. If you want to type
-- check everything from scratch, delete the *.agdai files to
-- disable separate compilation. You can use "find . -name
-- '*.agdai' | xargs rm" to do that.
--
-- More information on the Agda mode is available on the Agda wiki:
--
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=Docs.EmacsModeKeyCombinations
--
-- To get started, continue below on "Where to start reading?".

-- IF YOU WANT TO USE YOUR OWN SETUP
-- =================================
--
-- To typecheck this formalization, you need to install the appropriate version
-- of Agda (2.4.0), the Agda standard library (version 0.8), generate
-- Everything.agda with the attached Haskell helper, and finally run Agda on
-- this file.
--
-- Given a Unix-like environment (including Cygwin), running the ./agdaCheck.sh
-- script and following instructions given on output will eventually generate
-- Everything.agda and proceed to type check everything on command line.
--
-- If you're not an Agda power user, it is probably easier to use
-- the VM image or look at the pretty-printed and hyperlinked
-- HTML files, see above.

-- WHERE TO START READING?
-- =======================
--
-- modules.pdf
--   The graph of dependencies between Agda modules.
--   Good if you want to get a broad overview.
--
-- README.agda
--   This file. A coarse-grained introduction to the Agda
--   formalization.  Good if you want to begin at the beginning
--   and understand the structure of our code.
--
-- PLDI14-List-of-Theorems.agda
--   Pointers to the Agda formalizations of all theorems, lemmas
--   or definitions in the PLDI paper. Good if you want to read
--   the paper and the Agda code side by side.
--
--   Here is an import of this file, so you can jump to it
--   directly (use M-. in Emacs or click the module name in the
--   Browser):

import PLDI14-List-of-Theorems

-- Everything.agda
--   Imports every Agda module in our formalization. Good if you
--   want to make sure you don't miss anything.
--
--   Again, here's is an import of this file so you can navigate
--   there:

import Everything

-- (This import is also important to ensure that if we typecheck
-- README.agda, we also typecheck every other file of our
-- formalization).

-- THE AGDA CODE
-- =============
--
-- The formalization has four parts:
--
--   1. A formalization of change structures. This lives in
--   Base.Change.Algebra. (What we call "change structure" in the
--   paper, we call "change algebra" in the Agda code. We changed
--   the name when writing the paper, and never got around to
--   updating the name in the Agda code).
--
--   2. Incrementalization framework for first-class functions,
--   with extension points for plugging in data types and their
--   incrementalization. This lives in the Parametric.*
--   hierarchy.
--
--   3. An example plugin that provides integers and bags
--   with negative multiplicity. This lives in the Nehemiah.*
--   hierarchy. (For some reason, we choose to call this
--   particular incarnation of the plugin Nehemiah).
--
--   4. Other material that is unrelated to the framework/plugin
--   distinction. This is all other files.

-- FORMALIZATION OF CHANGE STRUCTURES
-- ==================================
--
-- Section 2 of the paper, and Base.Change.Algebra in Agda.

import Base.Change.Algebra

-- INCREMENTALIZATION FRAMEWORK
-- ============================
--
-- Section 3 of the paper, and Parametric.* hierarchy in Agda.
--
-- The extension points are implemented as module parameters. See
-- detailed explanation in Parametric.Syntax.Type and
-- Parametric.Syntax.Term. Some extension points are for types,
-- some for values, and some for proof fragments. In Agda, these
-- three kinds of entities are unified anyway, so we can encode
-- all of them as module parameters.
--
-- Every module in the Parametric.* hierarchy adds at least one
-- extension point, so the module hierarchy of a plugin will
-- typically mirror the Parametric.* hierarchy, defining the
-- values for these extension points.
--
-- Firstly, we have the syntax of types and terms, the erased
-- change structure for function types and incrementalization as
-- a term-to-term transformation. The contents of these modules
-- formalizes Sec. 3.1 and 3.2 of the paper, except for the
-- second and third line of Figure 3, which is formalized further
-- below.

import Parametric.Syntax.Type   -- syntax of types
import Parametric.Syntax.Term   -- syntax of terms
import Parametric.Change.Type   -- simply-typed changes
import Parametric.Change.Derive -- incrementalization

-- Secondly, we define the usual denotational semantics of the
-- simply-typed lambda calculus in terms of total functions, and
-- the change semantics in terms of a change structure on total
-- functions. The contents of these modules formalize Sec. 3.3,
-- 3.4 and 3.5 of the paper.

import Parametric.Denotation.Value      -- standard values
import Parametric.Denotation.Evaluation -- standard evaluation
import Parametric.Change.Validity       -- dependently-typed changes
import Parametric.Change.Specification  -- change evaluation

-- Thirdly, we define terms that operate on simply-typed changes,
-- and connect them to their values. The concents of these
-- modules formalize the second and third line of Figure 3, as
-- well as the semantics of these lines.

import Parametric.Change.Term        -- terms that operate on simply-typed changes
import Parametric.Change.Value       -- the values of these terms
import Parametric.Change.Evaluation  -- connecting the terms and their values

-- Finally, we prove correctness by connecting the (syntactic)
-- incrementalization to the (semantic) change evaluation by a
-- logical relation, and a proof that the values of terms
-- produced by the incrementalization transformation are related
-- to the change values of the original terms. The contents of
-- these modules formalize Sec. 3.6.

import Parametric.Change.Implementation -- logical relation
import Parametric.Change.Correctness    -- main correctness proof

-- EXAMPLE PLUGIN
-- ==============
--
-- Sec. 3.7 in the paper, and the Nehemiah.* hierarchy in Agda.
--
-- The module structure of the plugin follows the structure of
-- the Parametric.* hierarchy.  For example, the extension point
-- defined in Parametric.Syntax.Term is instantiated in
-- Nehemiah.Syntax.Term.
--
-- As discussed in Sec. 3.7 of the paper, the point of this
-- plugin is not to speed up any real programs, but to show "that
-- the interface for proof plugins can be implemented". As a
-- first step towards proving correctness of the more complicated
-- plugin with integers, bags and finite maps we implement in
-- Scala, we choose to define plugin with integers and bags in
-- Agda. Instead of implementing bags (with negative
-- multiplicities, like in the paper) in Agda, though, we
-- postulate that a group of such bags exist. Note that integer
-- bags with integer multiplicities are actually the free group
-- given a singleton operation `Integer -> Bag`, so this should
-- be easy to formalize in principle.

-- Before we start with the plugin, we postulate an abstract data
-- type for integer bags.
import Postulate.Bag-Nehemiah

-- Firstly, we extend the syntax of types and terms, the erased
-- change structure for function types, and incrementalization as
-- a term-to-term transformation to account for the data types of
-- the Nehemiah language. The contents of these modules
-- instantiate the extension points in Sec. 3.1 and 3.2 of the
-- paper, except for the second and third line of Figure 3, which
-- is instantiated further below.

import Nehemiah.Syntax.Type
import Nehemiah.Syntax.Term
import Nehemiah.Change.Type
import Nehemiah.Change.Derive

-- Secondly, we extend the usual denotational semantics and the
-- change semantics to account for the data types of the Nehemiah
-- language. The contents of these modules instantiate the
-- extension points in Sec. 3.3, 3.4 and 3.5 of the paper.

import Nehemiah.Denotation.Value
import Nehemiah.Denotation.Evaluation
import Nehemiah.Change.Validity
import Nehemiah.Change.Specification

-- Thirdly, we extend the terms that operate on simply-typed
-- changes, and the connection to their values to account for the
-- data types of the Nehemiah language. The concents of these
-- modules instantiate the extension points in the second and
-- third line of Figure 3.

import Nehemiah.Change.Term
import Nehemiah.Change.Value
import Nehemiah.Change.Evaluation

-- Finally, we extend the logical relation and the main
-- correctness proof to account for the data types in the
-- Nehemiah language. The contents of these modules instantiate
-- the extension points defined in Sec. 3.6.

import Nehemiah.Change.Implementation
import Nehemiah.Change.Correctness

-- OTHER MATERIAL
-- ==============
--
-- We postulate extensionality of Agda functions. This postulate
-- is well known to be compatible with Agda's type theory.

import Postulate.Extensionality

-- For historical reasons, we reexport Data.List.All from the
-- standard library under the name DependentList.

import Base.Data.DependentList

-- This module supports overloading the ⟦_⟧ notation based on
-- Agda's instance arguments.

import Base.Denotation.Notation

-- These modules implement contexts including typed de Bruijn
-- indices to represent bound variables, sets of bound variables,
-- and environments. These modules are parametric in the set of
-- types (that are stored in contexts) and the set of values
-- (that are stored in environments). So these modules are even
-- more parametric than the Parametric.* hierarchy.

import Base.Syntax.Context
import Base.Syntax.Vars
import Base.Denotation.Environment

-- This module contains some helper definitions to merge a
-- context of values and a context of changes.
import Base.Change.Context

Update Agda version in README.agda

Update Agda version in README.agda


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- Delta-observational equivalence: these asserts that two changes
  -- give the same result when applied to a base value.

  -- To avoid unification problems, use a one-field record.
  record _≙_ dx dy : Set a where
    -- doe = Delta-Observational Equivalence.
    constructor doe
    field
      proof : x ⊞ dx ≡ x ⊞ dy

  open _≙_ public

  -- Same priority as ≡
  infix 4 _≙_

  open import Relation.Binary

  -- _≙_ is indeed an equivalence relation:
  ≙-refl : ∀ {dx} → dx ≙ dx
  ≙-refl = doe refl

  ≙-sym : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
  ≙-sym ≙ = doe $ sym $ proof ≙

  ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
  ≙-trans ≙₁ ≙₂ = doe $ trans (proof ≙₁) (proof ≙₂)

  -- That's standard congruence applied to ≙
  ≙-cong  : ∀ {b} {B : Set b}
       (f : A → B) {dx dy} → dx ≙ dy → f (x ⊞ dx) ≡ f (x ⊞ dy)
  ≙-cong f da≙db = cong f $ proof da≙db

  ≙-isEquivalence : IsEquivalence (_≙_)
  ≙-isEquivalence = record
    { refl  = ≙-refl
    ; sym   = ≙-sym
    ; trans = ≙-trans
    }

  ≙-setoid : Setoid ℓ a
  ≙-setoid = record
    { Carrier       = Δ x
    ; _≈_           = _≙_
    ; isEquivalence = ≙-isEquivalence
    }

  ------------------------------------------------------------------------
  -- Convenient syntax for equational reasoning

  import Relation.Binary.EqReasoning as EqR

  module ≙-Reasoning where
    open EqR ≙-setoid public
      renaming (_≈⟨_⟩_ to _≙⟨_⟩_)

  -- By update-nil, if dx = nil x, then x ⊞ dx ≡ x.
  -- As a consequence, if dx ≙ nil x, then x ⊞ dx ≡ x
  nil-is-⊞-unit : ∀ dx → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil x)
    ≡⟨ update-nil x ⟩
      x
    ∎
    where
      open ≡-Reasoning

  -- Here we prove the inverse:
  ⊞-unit-is-nil : ∀ dx → x ⊞ dx ≡ x → dx ≙ nil x
  ⊞-unit-is-nil dx x⊞dx≡x = doe $
    begin
      x ⊞ dx
    ≡⟨ x⊞dx≡x ⟩
      x
    ≡⟨ sym (update-nil x) ⟩
      x ⊞ nil x
    ∎
    where
      open ≡-Reasoning

  -- TODO: we want to show that all functions of interest respect
  -- delta-observational equivalence, so that two d.o.e. changes can be
  -- substituted for each other freely.
  --
  -- * That should be be true for
  --   functions using changes parametrically.
  --
  -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
  --   this is proved below on both contexts at once by fun-change-respects.
  --
  -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
  --   it by definition, and ⊟ doesn't take change arguments - we will only
  --   need a proof for compose, when we define it.
  --
  -- Stating the general result, though, seems hard, we should
  -- rather have lemmas proving that certain classes of functions respect this
  -- equivalence.

  -- This results pairs with update-diff.
  diff-update : ∀ {dx} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : x ⊞ (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff (x ⊞ dx) x

module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
  {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

  module FC = FunctionChanges A B {{CA}} {{CB}}
  open FC using (changeAlgebra; incrementalization)
  open FC.FunctionChange

  fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
    df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = doe lemma
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
      -- Informally: use incrementalization on both sides and then apply
      -- congruence.
      lemma =
        begin
          f x ⊞ apply df₁ x dx₁
        ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
          (f ⊞ df₁) (x ⊞ dx₁)
        ≡⟨ ≙-cong (f ⊞ df₁) dx₁≙dx₂ ⟩
          (f ⊞ df₁) (x ⊞ dx₂)
        ≡⟨ ≙-cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
          (f ⊞ df₂) (x ⊞ dx₂)
        ≡⟨ incrementalization f df₂ x dx₂ ⟩
          f x ⊞ apply df₂ x dx₂
        ∎

  open import Postulate.Extensionality

  -- An extensionality principle for delta-observational equivalence: if
  -- applying two function changes to the same base value and input change gives
  -- a d.o.e. result, then the two function changes are d.o.e. themselves.

  delta-ext : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx → apply df x dx ≙ apply dg x dx) → df ≙ dg
  delta-ext {f} {df} {dg} df-x-dx≙dg-x-dx = doe lemma₂
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma₁ : ∀ x dx → f x ⊞ apply df x dx ≡ f x ⊞ apply dg x dx
      lemma₁ x dx = proof $ df-x-dx≙dg-x-dx x dx
      lemma₂ : f ⊞ df ≡ f ⊞ dg
      lemma₂ = ext (λ x → lemma₁ x (nil x))

  -- We know that Derivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> Derivative f (apply df).
  -- Now, we try to prove that if Derivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    Derivative f (apply df) → f ⊞ df ≡ f
  derivative-is-⊞-unit {f} df fdf =
    begin
      f ⊞ df
    ≡⟨⟩
      (λ x → f x ⊞ apply df x (nil x))
    ≡⟨ ext (λ x → fdf x (nil x)) ⟩
      (λ x → f (x ⊞ nil x))
    ≡⟨ ext (λ x → cong f (update-nil x)) ⟩
      (λ x → f x)
    ≡⟨⟩
      f
    ∎
    where
      open ≡-Reasoning

  -- We can restate the above as "df is a nil change".

  derivative-is-nil : ∀ {f : A → B} df →
    Derivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → Derivative f (apply df) → Derivative f (apply dg) → df ≙ dg
  derivative-unique {f} {df} {dg} fdf fdg =
    begin
      df
    ≙⟨ derivative-is-nil df fdf ⟩
      nil f
    ≙⟨ ≙-sym (derivative-is-nil dg fdg) ⟩
      dg
    ∎
    where
      open ≙-Reasoning
      -- Unused, but just to test that inference works.
      lemma : nil f ≙ dg
      lemma = ≙-sym (derivative-is-nil dg fdg)

Remove more dead code

Remove more dead code

Old-commit-hash: 20e82287ead4c99b0bce90e095ed1f7711119d2a