module PLDI14-List-of-Theorems where

open import Function

-- List of theorems in PLDI submission
--
-- For hints about installation and execution, please refer
-- to README.agda.
--
-- Agda modules corresponding to definitions, lemmas and theorems
-- are listed here with the most important names. For example,
-- after this file type checks (C-C C-L), placing the cursor
-- on the purple "Base.Change.Algebra" and pressing M-. will
-- bring you to the file where change structures are defined.
-- The name for change structures in that file is
-- "ChangeAlgebra", given in the using-clause.

-- Definition 2.1 (Change structures)
open import Base.Change.Algebra using (ChangeAlgebra)
---- Carrier in record ChangeAlgebra                        --(a)
open Base.Change.Algebra.ChangeAlgebra   using (Change)     --(b)
open Base.Change.Algebra.ChangeAlgebra   using (update)     --(c)
open Base.Change.Algebra.ChangeAlgebra   using (diff)       --(d)
open Base.Change.Algebra.IsChangeAlgebra using (update-diff)--(e)

-- Definition 2.2 (Nil change)
-- IsChangeAlgebra.nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Lemma 2.3 (Behavior of nil)
-- IsChangeAlgebra.update-nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Definition 2.4 (Derivatives)
open Base.Change.Algebra using (Derivative)

-- Definition 2.5 (Carrier set of function changes)
open Base.Change.Algebra.FunctionChanges

-- Definition 2.6 (Operations on function changes)
-- ChangeAlgebra.update FunctionChanges.changeAlgebra
-- ChangeAlgebra.diff   FunctionChanges.changeAlgebra
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Theorem 2.7 (Function changes form a change structure)
-- (In Agda, the proof of Theorem 2.7 has to be included in the
-- definition of function changes, here
-- FunctionChanges.changeAlgebra.)
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Lemma 2.8 (Incrementalization)
open Base.Change.Algebra.FunctionChanges using (incrementalization)

-- Theorem 2.9 (Nil changes are derivatives)
open Base.Change.Algebra.FunctionChanges using (nil-is-derivative)

-- For each plugin requirement, we include its definition and
-- a concrete instantiation called "Nehemiah" with integers and
-- bags of integers as base types.

-- Plugin Requirement 3.1 (Domains of base types)
open import Parametric.Denotation.Value using (Structure)
open import     Nehemiah.Denotation.Value using (⟦_⟧Base)

-- Definition 3.2 (Domains)
open Parametric.Denotation.Value.Structure using (⟦_⟧Type)

-- Plugin Requirement 3.3 (Evaluation of constants)
open import Parametric.Denotation.Evaluation using (Structure)
open import     Nehemiah.Denotation.Evaluation using (⟦_⟧Const)

-- Definition 3.4 (Environments)
open import Base.Denotation.Environment using (⟦_⟧Context)

-- Definition 3.5 (Evaluation)
open Parametric.Denotation.Evaluation.Structure using (⟦_⟧Term)

-- Plugin Requirement 3.6 (Changes on base types)
open import Parametric.Change.Validity using (Structure)
open import     Nehemiah.Change.Validity using (change-algebra-base-family)

-- Definition 3.7 (Changes)
open Parametric.Change.Validity.Structure using (change-algebra)

-- Definition 3.8 (Change environments)
open Parametric.Change.Validity.Structure using (environment-changes)

-- Plugin Requirement 3.9 (Change semantics for constants)
open import Parametric.Change.Specification using (Structure)
open import     Nehemiah.Change.Specification using (specification-structure)

-- Definition 3.10 (Change semantics)
open Parametric.Change.Specification.Structure using (⟦_⟧Δ)

-- Lemma 3.11 (Change semantics is the derivative of semantics)
open Parametric.Change.Specification.Structure using (correctness)

-- Definition 3.12 (Erasure)
import Parametric.Change.Implementation
open Parametric.Change.Implementation.Structure using (_≈_)
open import Nehemiah.Change.Implementation using (implements-base)

-- Lemma 3.13 (The erased version of a change is almost the same)
open Parametric.Change.Implementation.Structure using (carry-over)

-- Lemma 3.14 (⟦ t ⟧Δ erases to Derive(t))
import Parametric.Change.Correctness
open Parametric.Change.Correctness.Structure using (derive-correct-closed)

-- Theorem 3.15 (Correctness of differentiation)
open Parametric.Change.Correctness.Structure using (main-theorem)

module PLDI14-List-of-Theorems where

-- List of theorems in PLDI submission
--
-- For hints about installation and execution, please refer
-- to README.agda.
--
-- Agda modules corresponding to definitions, lemmas and theorems
-- are listed here with the most important names. For example,
-- after this file type checks (C-C C-L), placing the cursor
-- on the purple "Base.Change.Algebra" and pressing M-. will
-- bring you to the file where change structures are defined.
-- The name for change structures in that file is
-- "ChangeAlgebra", given in the using-clause.

-- Definition 2.1 (Change structures)
open import Base.Change.Algebra using (ChangeAlgebra)
---- Carrier in record ChangeAlgebra                        --(a)
open Base.Change.Algebra.ChangeAlgebra   using (Change)     --(b)
open Base.Change.Algebra.ChangeAlgebra   using (update)     --(c)
open Base.Change.Algebra.ChangeAlgebra   using (diff)       --(d)
open Base.Change.Algebra.IsChangeAlgebra using (update-diff)--(e)

-- Definition 2.2 (Nil change)
-- IsChangeAlgebra.nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Lemma 2.3 (Behavior of nil)
-- IsChangeAlgebra.update-nil
open Base.Change.Algebra using (IsChangeAlgebra)

-- Definition 2.4 (Derivatives)
open Base.Change.Algebra using (Derivative)

-- Definition 2.5 (Carrier set of function changes)
open Base.Change.Algebra.FunctionChanges

-- Definition 2.6 (Operations on function changes)
-- ChangeAlgebra.update FunctionChanges.changeAlgebra
-- ChangeAlgebra.diff   FunctionChanges.changeAlgebra
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Theorem 2.7 (Function changes form a change structure)
-- (In Agda, the proof of Theorem 2.7 has to be included in the
-- definition of function changes, here
-- FunctionChanges.changeAlgebra.)
open Base.Change.Algebra.FunctionChanges using (changeAlgebra)

-- Lemma 2.8 (Incrementalization)
open Base.Change.Algebra.FunctionChanges using (incrementalization)

-- Theorem 2.9 (Nil changes are derivatives)
open Base.Change.Algebra.FunctionChanges using (nil-is-derivative)

-- Definition 3.1 (Domains)
import Parametric.Denotation.Value
open Parametric.Denotation.Value.Structure using (⟦_⟧Type)

-- Definition 3.2 (Environments)
open import Base.Denotation.Environment using (⟦_⟧Context)

-- Definition 3.3 (Evaluation)
import Parametric.Denotation.Evaluation
open Parametric.Denotation.Evaluation.Structure using (⟦_⟧Term)

-- Definition 3.4 (Changes)
-- Definition 3.5 (Change environments)
import Parametric.Change.Validity
open Parametric.Change.Validity.Structure using (change-algebra)
open Parametric.Change.Validity.Structure using (environment-changes)

-- Definition 3.6 (Change semantics)
-- Lemma 3.7 (Change semantics is the derivative of semantics)
import Parametric.Change.Specification
open Parametric.Change.Specification.Structure using (⟦_⟧Δ)
open Parametric.Change.Specification.Structure using (correctness)

-- Definition 3.8 (Erasure)
-- Lemma 3.9 (The erased version of a change is almost the same)
import Parametric.Change.Implementation
open Parametric.Change.Implementation.Structure using (_≈_)
open Parametric.Change.Implementation.Structure using (carry-over)

-- Lemma 3.10 (⟦ t ⟧Δ erases to Derive(t))
-- Theorem 3.11 (Correctness of differentiation)
import Parametric.Change.Correctness
open Parametric.Change.Correctness.Structure using (derive-correct-closed)
open Parametric.Change.Correctness.Structure using (main-theorem)

Update PLDI14-List-of-Theorems.agda (for #275).

The list included plugin requirements, but we left them out of the
paper, so the theorem numbers were off.

Old-commit-hash: d4ea643c7474f10c798fcb0d494db9f941e3deb5


module Denotational.Equivalence where

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Nullary using (¬_)

open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Denotational.Notation
open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total

open import Changes
open import ChangeContexts

-- TERMS

-- Term Equivalence

module _ {Γ} {τ} where
  data _≈_ (t₁ t₂ : Term Γ τ) : Set where
    ext-t :
      (∀ ρ → ⟦ t₁ ⟧ ρ ≡ ⟦ t₂ ⟧ ρ) →
      t₁ ≈ t₂

  ≈-refl : Reflexive _≈_
  ≈-refl = ext-t (λ ρ → ≡-refl)

  ≈-sym : Symmetric _≈_
  ≈-sym (ext-t ≈) = ext-t (λ ρ → ≡-sym (≈ ρ))

  ≈-trans : Transitive _≈_
  ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → ≡-trans (≈₁ ρ) (≈₂ ρ))

  ≈-isEquivalence : IsEquivalence _≈_
  ≈-isEquivalence = record
    { refl  = ≈-refl
    ; sym   = ≈-sym
    ; trans = ≈-trans
    }

≈-setoid : Context → Type → Setoid _ _
≈-setoid Γ τ = record
  { Carrier       = Term Γ τ
  ; _≈_           = _≈_
  ; isEquivalence = ≈-isEquivalence
  }

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

module ≈-Reasoning where
  module _ {Γ : Context} {τ : Type} where
    open import Relation.Binary.EqReasoning (≈-setoid Γ τ) public
      hiding (_≡⟨_⟩_)

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()

module Denotational.Equivalence where

-- TERM EQUIVALENCE
--
-- This module defines term equivalence as the relation that
-- identifies terms with the same meaning.

open import Relation.Nullary using (¬_)

open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality

open import Denotational.Notation

-- TERMS

-- Term Equivalence
--
-- This module is parametric in the syntax and semantics of types
-- and terms to make it work for different calculi.

module _ where
  open import Syntactic.Contexts
  open import Denotational.Environments

  module MakeEquivalence
      (Type : Set)
      (⟦_⟧Type : Type → Set)
      (Term : Context Type → Type → Set)
      (⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦_⟧Context Type ⟦_⟧Type Γ → ⟦ τ ⟧Type) where
    module _ {Γ} {τ} where
      data _≈_ (t₁ t₂ : Term Γ τ) : Set where
        ext-t :
          (∀ ρ → ⟦ t₁ ⟧Term ρ ≡ ⟦ t₂ ⟧Term ρ) →
          t₁ ≈ t₂

      ≈-refl : Reflexive _≈_
      ≈-refl = ext-t (λ ρ → refl)

      ≈-sym : Symmetric _≈_
      ≈-sym (ext-t ≈) = ext-t (λ ρ → sym (≈ ρ))

      ≈-trans : Transitive _≈_
      ≈-trans (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ → trans (≈₁ ρ) (≈₂ ρ))

      ≈-isEquivalence : IsEquivalence _≈_
      ≈-isEquivalence = record
        { refl  = ≈-refl
        ; sym   = ≈-sym
        ; trans = ≈-trans
        }

    ≈-setoid : Context Type → Type → Setoid _ _
    ≈-setoid Γ τ = record
      { Carrier       = Term Γ τ
      ; _≈_           = _≈_
      ; isEquivalence = ≈-isEquivalence
      }

    module ≈-Reasoning where
      module _ {Γ : Context Type} {τ : Type} where
        open import Relation.Binary.EqReasoning (≈-setoid Γ τ) public
          hiding (_≡⟨_⟩_)

open import Syntactic.Types
open import Syntactic.Contexts Type
open import Syntactic.Terms.Total

open import Denotational.Values
open import Denotational.Environments Type ⟦_⟧Type
open import Denotational.Evaluation.Total

open import Changes
open import ChangeContexts

-- Export a version of the equivalence for terms with total
-- derivatives

open MakeEquivalence Type ⟦_⟧ Term ⟦_⟧ public

-- Specialized congruence rules

≈-app : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term Γ (τ₁ ⇒ τ₂)} {t₃ t₄ : Term Γ τ₁} →
  t₁ ≈ t₂ → t₃ ≈ t₄ → app t₁ t₃ ≈ app t₂ t₄
≈-app (ext-t ≈₁) (ext-t ≈₂) = ext-t (λ ρ →
  ≡-cong₂ (λ x y → x y) (≈₁ ρ) (≈₂ ρ))

≈-abs : ∀ {Γ τ₁ τ₂} {t₁ t₂ : Term (τ₁ • Γ) τ₂} →
  t₁ ≈ t₂ → abs t₁ ≈ abs t₂
≈-abs (ext-t ≈) = ext-t (λ ρ →
  ext (λ v → ≈ (v • ρ)))

≈-Δ : ∀ {τ Γ} {t₁ t₂ : Term Γ τ} →
  t₁ ≈ t₂ → Δ t₁ ≈ Δ t₂
≈-Δ (ext-t ≈) = ext-t (λ ρ → ≡-diff (≈ (update ρ)) (≈ (ignore ρ)))

-- Consistency

≈-consistent : ¬ (∀ {Γ τ} (t₁ t₂ : Term Γ τ) → t₁ ≈ t₂)
≈-consistent H with H {∅} true false
... | ext-t x with x ∅
... | ()

Generalize term equivalence to arbitrary calculi.

Old-commit-hash: 239a4be82a8af884669ca62db624782bee407ca1


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