module FFI.JS where

open import Data.Empty       public renaming (⊥ to 𝟘)
open import Data.Unit.Base   public renaming (⊤ to 𝟙)
open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List; []; _∷_)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)
open import Function         using (id; _∘_)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

postulate
  Number   : Set
  JSArray  : Set → Set
  JSObject : Set
  JSValue  : Set

postulate readNumber : String → Number
{-# COMPILED_JS readNumber Number #-}

postulate 0N : Number
{-# COMPILED_JS 0N 0 #-}

postulate 1N : Number
{-# COMPILED_JS 1N 1 #-}

postulate 2N : Number
{-# COMPILED_JS 2N 2 #-}

postulate 4N : Number
{-# COMPILED_JS 4N 4 #-}

postulate 8N : Number
{-# COMPILED_JS 8N 8 #-}

postulate 16N : Number
{-# COMPILED_JS 16N 16 #-}

postulate 32N : Number
{-# COMPILED_JS 32N 32 #-}

postulate 64N : Number
{-# COMPILED_JS 64N 64 #-}

postulate 128N : Number
{-# COMPILED_JS 128N 128 #-}

postulate 256N : Number
{-# COMPILED_JS 256N 256 #-}

postulate 512N : Number
{-# COMPILED_JS 512N 512 #-}

postulate 1024N : Number
{-# COMPILED_JS 1024N 1024 #-}

postulate 2048N : Number
{-# COMPILED_JS 2048N 2048 #-}

postulate 4096N : Number
{-# COMPILED_JS 4096N 4096 #-}

postulate _+_ : Number → Number → Number
{-# COMPILED_JS _+_ function(x) { return function(y) { return x + y; }; } #-}

postulate _−_ : Number → Number → Number
{-# COMPILED_JS _−_ function(x) { return function(y) { return x - y; }; } #-}

postulate _*_ : Number → Number → Number
{-# COMPILED_JS _*_ function(x) { return function(y) { return x * y; }; } #-}

postulate _/_ : Number → Number → Number
{-# COMPILED_JS _/_ function(x) { return function(y) { return x / y; }; } #-}

infixr 5  _++_
postulate _++_ : String → String → String
{-# COMPILED_JS _++_ function(x) { return function(y) { return x + y; }; } #-}

postulate _+JS_ : JSValue → JSValue → JSValue
{-# COMPILED_JS _+JS_ function(x) { return function(y) { return x + y; }; } #-}

postulate _≤JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≤JS_ function(x) { return function(y) { return x <= y; }; } #-}

postulate _<JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _<JS_ function(x) { return function(y) { return x < y; }; } #-}

postulate _>JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _>JS_ function(x) { return function(y) { return x > y; }; } #-}

postulate _≥JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≥JS_ function(x) { return function(y) { return x >= y; }; } #-}

postulate _===_ : JSValue → JSValue → Bool
{-# COMPILED_JS _===_ function(x) { return function(y) { return x === y; }; } #-}

postulate reverse : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS reverse function(ty) { return function(x) { return x.reverse(); }; } #-}

postulate sort : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS sort function(ty) { return function(x) { return x.sort(); }; } #-}

postulate split : (sep target : String) → JSArray String
{-# COMPILED_JS split function(sep) { return function(target) { return target.split(sep); }; } #-}

postulate join : (sep : String)(target : JSArray String) → String
{-# COMPILED_JS join function(sep) { return function(target) { return target.join(sep); }; } #-}

postulate fromList : {A B : Set}(xs : List A)(fromElt : A → B) → JSArray B
{-# COMPILED_JS fromList require("libagda").fromList #-}

postulate length : String → Number
{-# COMPILED_JS length function(s) { return s.length; } #-}

postulate JSON-stringify : JSValue → String
{-# COMPILED_JS JSON-stringify JSON.stringify #-}

postulate JSON-parse : String → JSValue
{-# COMPILED_JS JSON-parse JSON.parse #-}

postulate toString : JSValue → String
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}

postulate fromBool : Bool → JSValue
{-# COMPILED_JS fromBool function(x) { return x; } #-}

postulate fromString : String → JSValue
{-# COMPILED_JS fromString function(x) { return x; } #-}

postulate fromChar : Char → JSValue
{-# COMPILED_JS fromChar String #-}

postulate Char▹String : Char → String
{-# COMPILED_JS Char▹String String #-}

postulate fromNumber : Number → JSValue
{-# COMPILED_JS fromNumber function(x) { return x; } #-}

postulate fromJSArray : {A : Set} → JSArray A → JSValue
{-# COMPILED_JS fromJSArray function(ty) { return function(x) { return x; }; } #-}

postulate fromJSObject : JSObject → JSValue
{-# COMPILED_JS fromJSObject function(x) { return x; } #-}

postulate objectFromList : {A : Set}(xs : List A)(fromKey : A → String)(fromVal : A → JSValue) → JSObject
{-# COMPILED_JS objectFromList require("libagda").objectFromList #-}

postulate decodeJSArray : {A B : Set}(arr : JSArray A)(fromElt : Number → A → B) → List B
{-# COMPILED_JS decodeJSArray require("libagda").decodeJSArray #-}

postulate castNumber : JSValue → Number
{-# COMPILED_JS castNumber Number #-}

postulate castString : JSValue → String
{-# COMPILED_JS castString String #-}

-- TODO dyn check of length 1?
postulate castChar : JSValue → Char
{-# COMPILED_JS castChar String #-}

-- TODO dyn check of length 1?
postulate String▹Char : String → Char
{-# COMPILED_JS String▹Char String #-}

-- TODO dyn check?
postulate castJSArray : JSValue → JSArray JSValue
{-# COMPILED_JS castJSArray function(x) { return x; } #-}

-- TODO dyn check?
postulate castJSObject : JSValue → JSObject
{-# COMPILED_JS castJSObject function(x) { return x; } #-}

postulate nullJS : JSValue
{-# COMPILED_JS nullJS null #-}

postulate _·[_] : JSValue → JSValue → JSValue
{-# COMPILED_JS _·[_] require("libagda").readProp #-}

postulate _Array[_] : {A : Set} → JSArray A → Number → A
{-# COMPILED_JS _Array[_] function(ty) { return require("libagda").readProp; } #-}

postulate onJSArray : {A : Set} (f : JSArray JSValue → A) → JSValue → A
{-# COMPILED_JS onJSArray require("libagda").onJSArray #-}

postulate onString : {A : Set} (f : String → A) → JSValue → A
{-# COMPILED_JS onString require("libagda").onString #-}

-- Writes 'msg' and 'inp' to the console and then returns `f inp`
postulate trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
{-# COMPILED_JS trace require("libagda").trace #-}

postulate throw : {A : Set} → String → A → A
{-# COMPILED_JS throw require("libagda").throw #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number → Value
  bool   : Bool   → Value
  null   : Value

Object = List (String × JSValue)

postulate fromValue : Value → JSValue
{-# COMPILED_JS fromValue require("libagda").fromValue #-}

-- TODO we could make it a COMPILED type and remove the encoding by using JSValue as the internal repr.
data ValueView : Set₀ where
  array  : JSArray JSValue → ValueView
  object : JSObject        → ValueView
  string : String          → ValueView
  number : Number          → ValueView
  bool   : Bool            → ValueView
  null   : ValueView

-- TODO not yet tested
postulate viewJSValue : JSValue → ValueView
{-# COMPILED_JS viewJSValue require("libagda").viewJSValue #-}

Bool▹String : Bool → String
Bool▹String true  = "true"
Bool▹String false = "false"

List▹String : List Char → String
List▹String xs = join "" (fromList xs Char▹String)

String▹List : String → List Char
String▹List s = decodeJSArray (split "" s) (λ _ → String▹Char)

Number▹String : Number → String
Number▹String = castString ∘ fromNumber

JSArray▹ListString : {A : Set} → JSArray A → List A
JSArray▹ListString a = decodeJSArray a (λ _ → id)

fromObject : Object → JSObject
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_<Char_ : Char → Char → Bool
x <Char y = fromChar x <JS fromChar y

_>Char_ : Char → Char → Bool
x >Char y = fromChar x >JS fromChar y

_≥Char_ : Char → Char → Bool
x ≥Char y = fromChar x ≥JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_<String_ : String → String → Bool
x <String y = fromString x <JS fromString y

_>String_ : String → String → Bool
x >String y = fromString x >JS fromString y

_≥String_ : String → String → Bool
x ≥String y = fromString x ≥JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_<Number_ : Number → Number → Bool
x <Number y = fromNumber x <JS fromNumber y

_>Number_ : Number → Number → Bool
x >Number y = fromNumber x >JS fromNumber y

_≥Number_ : Number → Number → Bool
x ≥Number y = fromNumber x ≥JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

_·«_»A : JSValue → String → JSArray JSValue
v ·« s »A = castJSArray (v ·« s »)

trace-call : {A B : Set} → String → (A → B) → A → B
trace-call s f x = trace s (f x) id

postulate JSCmd : Set → Set

Callback1 : Set → Set
Callback1 A = JSCmd ((A → 𝟘) → 𝟘)

Callback0 : Set
Callback0 = Callback1 𝟙

Callback2 : Set → Set → Set
Callback2 A B = JSCmd ((A → B → 𝟘) → 𝟘)

postulate assert : Bool → Callback0
{-# COMPILED_JS assert require("libagda").assert #-}

check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
check true  errmsg x = x
check false errmsg x = throw (errmsg _) x

warn-check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
warn-check true  errmsg x = x
warn-check false errmsg x = trace ("Warning: " ++ errmsg _) x id

infixr 0  _>>_ _!₁_ _!₂_
data JS! : Set₁ where
  end  : JS!
  _!₁_ : {A : Set}(cmd : Callback1 A)(cb : A → JS!) → JS!
  _!₂_ : {A B : Set}(cmd : JSCmd ((A → B → 𝟘) → 𝟘))(cb : A → B → JS!) → JS!

_>>_ : Callback0 → JS! → JS!
cmd >> cont = cmd !₁ λ _ → cont
-- -}
-- -}
-- -}
-- -}
-- -}

module FFI.JS where

open import Data.Empty       public renaming (⊥ to 𝟘)
open import Data.Unit.Base   public renaming (⊤ to 𝟙)
open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List; []; _∷_)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)
open import Function         using (id; _∘_)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

postulate
  Number   : Set
  JSArray  : Set → Set
  JSObject : Set
  JSValue  : Set

postulate readNumber : String → Number
{-# COMPILED_JS readNumber Number #-}

postulate 0N : Number
{-# COMPILED_JS 0N 0 #-}

postulate 1N : Number
{-# COMPILED_JS 1N 1 #-}

postulate 2N : Number
{-# COMPILED_JS 2N 2 #-}

postulate 4N : Number
{-# COMPILED_JS 4N 4 #-}

postulate 8N : Number
{-# COMPILED_JS 8N 8 #-}

postulate 16N : Number
{-# COMPILED_JS 16N 16 #-}

postulate 32N : Number
{-# COMPILED_JS 32N 32 #-}

postulate 64N : Number
{-# COMPILED_JS 64N 64 #-}

postulate 128N : Number
{-# COMPILED_JS 128N 128 #-}

postulate 256N : Number
{-# COMPILED_JS 256N 256 #-}

postulate 512N : Number
{-# COMPILED_JS 512N 512 #-}

postulate 1024N : Number
{-# COMPILED_JS 1024N 1024 #-}

postulate 2048N : Number
{-# COMPILED_JS 2048N 2048 #-}

postulate 4096N : Number
{-# COMPILED_JS 4096N 4096 #-}

postulate _+_ : Number → Number → Number
{-# COMPILED_JS _+_ function(x) { return function(y) { return x + y; }; } #-}

postulate _−_ : Number → Number → Number
{-# COMPILED_JS _−_ function(x) { return function(y) { return x - y; }; } #-}

postulate _*_ : Number → Number → Number
{-# COMPILED_JS _*_ function(x) { return function(y) { return x * y; }; } #-}

postulate _/_ : Number → Number → Number
{-# COMPILED_JS _/_ function(x) { return function(y) { return x / y; }; } #-}

infixr 5  _++_
postulate _++_ : String → String → String
{-# COMPILED_JS _++_ function(x) { return function(y) { return x + y; }; } #-}

postulate _+JS_ : JSValue → JSValue → JSValue
{-# COMPILED_JS _+JS_ function(x) { return function(y) { return x + y; }; } #-}

postulate _≤JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≤JS_ function(x) { return function(y) { return x <= y; }; } #-}

postulate _<JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _<JS_ function(x) { return function(y) { return x < y; }; } #-}

postulate _>JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _>JS_ function(x) { return function(y) { return x > y; }; } #-}

postulate _≥JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≥JS_ function(x) { return function(y) { return x >= y; }; } #-}

postulate _===_ : JSValue → JSValue → Bool
{-# COMPILED_JS _===_ function(x) { return function(y) { return x === y; }; } #-}

postulate reverse : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS reverse function(ty) { return function(x) { return x.reverse(); }; } #-}

postulate sort : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS sort function(ty) { return function(x) { return x.sort(); }; } #-}

postulate split : (sep target : String) → JSArray String
{-# COMPILED_JS split function(sep) { return function(target) { return target.split(sep); }; } #-}

postulate join : (sep : String)(target : JSArray String) → String
{-# COMPILED_JS join function(sep) { return function(target) { return target.join(sep); }; } #-}

postulate fromList : {A B : Set}(xs : List A)(fromElt : A → B) → JSArray B
{-# COMPILED_JS fromList require("libagda").fromList #-}

postulate length : String → Number
{-# COMPILED_JS length function(s) { return s.length; } #-}

postulate JSON-stringify : JSValue → String
{-# COMPILED_JS JSON-stringify JSON.stringify #-}

postulate JSON-parse : String → JSValue
{-# COMPILED_JS JSON-parse JSON.parse #-}

postulate toString : JSValue → String
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}

postulate fromBool : Bool → JSValue
{-# COMPILED_JS fromBool function(x) { return x; } #-}

postulate fromString : String → JSValue
{-# COMPILED_JS fromString function(x) { return x; } #-}

postulate fromChar : Char → JSValue
{-# COMPILED_JS fromChar String #-}

postulate Char▹String : Char → String
{-# COMPILED_JS Char▹String String #-}

postulate fromNumber : Number → JSValue
{-# COMPILED_JS fromNumber function(x) { return x; } #-}

postulate fromJSArray : {A : Set} → JSArray A → JSValue
{-# COMPILED_JS fromJSArray function(ty) { return function(x) { return x; }; } #-}

postulate fromJSObject : JSObject → JSValue
{-# COMPILED_JS fromJSObject function(x) { return x; } #-}

postulate objectFromList : {A : Set}(xs : List A)(fromKey : A → String)(fromVal : A → JSValue) → JSObject
{-# COMPILED_JS objectFromList require("libagda").objectFromList #-}

postulate decodeJSArray : {A B : Set}(arr : JSArray A)(fromElt : Number → A → B) → List B
{-# COMPILED_JS decodeJSArray require("libagda").decodeJSArray #-}

postulate castNumber : JSValue → Number
{-# COMPILED_JS castNumber Number #-}

postulate castString : JSValue → String
{-# COMPILED_JS castString String #-}

-- TODO dyn check of length 1?
postulate castChar : JSValue → Char
{-# COMPILED_JS castChar String #-}

-- TODO dyn check of length 1?
postulate String▹Char : String → Char
{-# COMPILED_JS String▹Char String #-}

-- TODO dyn check?
postulate castJSArray : JSValue → JSArray JSValue
{-# COMPILED_JS castJSArray function(x) { return x; } #-}

-- TODO dyn check?
postulate castJSObject : JSValue → JSObject
{-# COMPILED_JS castJSObject function(x) { return x; } #-}

postulate nullJS : JSValue
{-# COMPILED_JS nullJS null #-}

postulate _·[_] : JSValue → JSValue → JSValue
{-# COMPILED_JS _·[_] require("libagda").readProp #-}

postulate _Array[_] : {A : Set} → JSArray A → Number → A
{-# COMPILED_JS _Array[_] function(ty) { return require("libagda").readProp; } #-}

postulate onJSArray : {A : Set} (f : JSArray JSValue → A) → JSValue → A
{-# COMPILED_JS onJSArray require("libagda").onJSArray #-}

postulate onString : {A : Set} (f : String → A) → JSValue → A
{-# COMPILED_JS onString require("libagda").onString #-}

-- Writes 'msg' and 'inp' to the console and then returns `f inp`
postulate trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
{-# COMPILED_JS trace require("libagda").trace #-}

postulate throw : {A : Set} → String → A → A
{-# COMPILED_JS throw require("libagda").throw #-}

postulate is-null : JSValue → Bool
{-# COMPILED_JS is-null function(x) { return (x == null); } #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number → Value
  bool   : Bool   → Value
  null   : Value

Object = List (String × JSValue)

postulate fromValue : Value → JSValue
{-# COMPILED_JS fromValue require("libagda").fromValue #-}

-- TODO we could make it a COMPILED type and remove the encoding by using JSValue as the internal repr.
data ValueView : Set₀ where
  array  : JSArray JSValue → ValueView
  object : JSObject        → ValueView
  string : String          → ValueView
  number : Number          → ValueView
  bool   : Bool            → ValueView
  null   : ValueView

-- TODO not yet tested
postulate viewJSValue : JSValue → ValueView
{-# COMPILED_JS viewJSValue require("libagda").viewJSValue #-}

Bool▹String : Bool → String
Bool▹String true  = "true"
Bool▹String false = "false"

List▹String : List Char → String
List▹String xs = join "" (fromList xs Char▹String)

String▹List : String → List Char
String▹List s = decodeJSArray (split "" s) (λ _ → String▹Char)

Number▹String : Number → String
Number▹String = castString ∘ fromNumber

JSArray▹ListString : {A : Set} → JSArray A → List A
JSArray▹ListString a = decodeJSArray a (λ _ → id)

fromObject : Object → JSObject
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_<Char_ : Char → Char → Bool
x <Char y = fromChar x <JS fromChar y

_>Char_ : Char → Char → Bool
x >Char y = fromChar x >JS fromChar y

_≥Char_ : Char → Char → Bool
x ≥Char y = fromChar x ≥JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_<String_ : String → String → Bool
x <String y = fromString x <JS fromString y

_>String_ : String → String → Bool
x >String y = fromString x >JS fromString y

_≥String_ : String → String → Bool
x ≥String y = fromString x ≥JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_<Number_ : Number → Number → Bool
x <Number y = fromNumber x <JS fromNumber y

_>Number_ : Number → Number → Bool
x >Number y = fromNumber x >JS fromNumber y

_≥Number_ : Number → Number → Bool
x ≥Number y = fromNumber x ≥JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

_·«_»A : JSValue → String → JSArray JSValue
v ·« s »A = castJSArray (v ·« s »)

trace-call : {A B : Set} → String → (A → B) → A → B
trace-call s f x = trace s (f x) id

postulate JSCmd : Set → Set

Callback1 : Set → Set
Callback1 A = JSCmd ((A → 𝟘) → 𝟘)

Callback0 : Set
Callback0 = Callback1 𝟙

Callback2 : Set → Set → Set
Callback2 A B = JSCmd ((A → B → 𝟘) → 𝟘)

postulate assert : Bool → Callback0
{-# COMPILED_JS assert require("libagda").assert #-}

check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
check true  errmsg x = x
check false errmsg x = throw (errmsg _) x

warn-check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
warn-check true  errmsg x = x
warn-check false errmsg x = trace ("Warning: " ++ errmsg _) x id

infixr 0  _>>_ _!₁_ _!₂_
data JS! : Set₁ where
  end  : JS!
  _!₁_ : {A : Set}(cmd : Callback1 A)(cb : A → JS!) → JS!
  _!₂_ : {A B : Set}(cmd : JSCmd ((A → B → 𝟘) → 𝟘))(cb : A → B → JS!) → JS!

_>>_ : Callback0 → JS! → JS!
cmd >> cont = cmd !₁ λ _ → cont
-- -}
-- -}
-- -}
-- -}
-- -}

add is-null

JS: add is-null


import Syntax.Type.Plotkin as Type

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

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product
open Type B
open import Syntax.Context {Type}

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

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

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

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

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

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

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

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

-- Weakening

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

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

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

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

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

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

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

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

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

import Syntax.Type.Plotkin as Type

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

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product
open Type B
open import Syntax.Context {Type}

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

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

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

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

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

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

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

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

-- Weakening

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

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

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

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

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

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

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

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

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

Put constructor arguments on different lines.

Old-commit-hash: 02f9c59c59ddef7050c2c035457c98ecb00464dc


{-# OPTIONS --type-in-type
            --no-termination-check
            --no-positivity-check #-}

module Desc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
record One : Set where

--****************
-- Sum and friends
--****************

data _+_ (A B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

-- Inductive types are implemented as a Universe. Hence, in this
-- section, we implement their code.

-- We can read this code as follow (see Conor's "Ornamental
-- algebras"): a description in |Desc| is a program to read one node
-- of the described tree.

data Desc : Set where
  Arg : (X : Set) -> (X -> Desc) -> Desc
  -- Read a field in |X|; continue, given its value

  -- Often, |X| is an |EnumT|, hence allowing to choose a constructor
  -- among a finite set of constructors

  Ind : (H : Set) -> Desc -> Desc
  -- Read a field in H; read a recursive subnode given the field,
  -- continue regarless of the subnode

  -- Often, |H| is |1|, hence |Ind| simplifies to |Inf : Desc -> Desc|,
  -- meaning: read a recursive subnode and continue regardless

  Done : Desc
  -- Stop reading

--********************************************
-- Desc decoder
--********************************************

-- Provided the type of the recursive subnodes |R|, we decode a
-- description as a record describing the node.

[|_|]_ : Desc -> Set -> Set
[| Arg A D |] R = Sigma A (\ a -> [| D a |] R)
[| Ind H D |] R = (H -> R) * [| D |] R
[| Done |] R = One

--********************************************
-- Functions on codes
--********************************************

-- Saying that a "predicate" |p| holds everywhere in |v| amounts to
-- write something of the following type:

Everywhere : (d : Desc) (D : Set) (bp : D -> Set) (V : [| d |] D) -> Set
Everywhere (Arg A f) d p v =  Everywhere (f (fst v)) d p (snd v)
-- It must hold for this constructor

Everywhere (Ind H x) d p v =  ((y : H) -> p (fst v y)) * Everywhere x d p (snd v)
-- It must hold for the subtrees

Everywhere Done _ _ _ =  _
-- It trivially holds at endpoints

-- Then, we can build terms that inhabits this type. That is, a
-- function that takes a "predicate" |bp| and makes it hold everywhere
-- in the data-structure. It is the equivalent of a "map", but in a
-- dependently-typed setting.

everywhere : (d : Desc) (D : Set) (bp : D -> Set) ->
           ((y : D) -> bp y) -> (v : [| d |] D) ->
           Everywhere d D bp v
everywhere (Arg a f) d bp p v =  everywhere (f (fst v)) d bp p (snd v)
-- It holds everywhere on this constructor

everywhere (Ind H x) d bp p v = (\y -> p (fst v y)) ,  everywhere x d bp p (snd v)
-- It holds here, and down in the recursive subtrees

everywhere Done _ _ _ _ =  One
-- Nothing needs to be done on endpoints

-- Looking at the decoder, a natural thing to do is to define its
-- fixpoint |Mu D|, hence instantiating |R| with |Mu D| itself.

data Mu (D : Desc) : Set where
  Con : [| D |] (Mu D) -> Mu D

-- Using the "map" defined by |everywhere|, we can implement a "fold"
-- over the |Mu| fixpoint:

foldDesc : (D : Desc) (bp : Mu D -> Set) ->
         ((x : [| D |] (Mu D)) -> Everywhere D (Mu D) bp x -> bp (Con x)) ->
         (v : Mu D) ->
         bp v
foldDesc D bp p (Con v) =  p v (everywhere D (Mu D) bp (\x -> foldDesc D bp p x) v)

--********************************************
-- Nat
--********************************************

data NatConst : Set where
  ZE : NatConst
  SU : NatConst

natc : NatConst -> Desc
natc ZE = Done
natc SU = Ind One Done

natd : Desc
natd = Arg NatConst natc

nat : Set
nat = Mu natd

zero : nat
zero = Con ( ZE ,  _ )

suc : nat -> nat
suc n = Con ( SU , ( (\_ -> n) ,  _ ) )

two : nat
two = suc (suc zero)

four : nat
four = suc (suc (suc (suc zero)))

sum : nat ->
      ((x : Sigma NatConst (\ a -> [| natc a |] Mu (Arg NatConst natc))) ->
      Everywhere (natc (fst x)) (Mu (Arg NatConst natc)) (\ _ -> Mu (Arg NatConst natc)) (snd x) ->
      Mu (Arg NatConst natc))
sum n2 (ZE , _) p =  n2
sum n2 (SU , f) p =  suc ( fst p _)

plus : nat -> nat -> nat
plus n1 n2 = foldDesc natd (\_ -> nat) (sum n2) n1

x : nat
x = plus two two

Update Desc model. Follow ICFP paper. With type-in-type, but termination-checker-friendly.


{-# OPTIONS --without-K #-}
-- Like Algebra.FunctionProperties but specialized to _≡_ and using implict arguments
-- Moreover there is some extensions such as:
-- * interchange
-- * non-zero inversions
-- * cancelation and non-zero cancelation

-- These properties can (for instance) be used to define algebraic
-- structures.

open import Level
open import Function using (flip)
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.NP

-- The properties are specified using the following relation as
-- "equality".

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

------------------------------------------------------------------------
-- Unary and binary operations

open import Algebra.FunctionProperties.Core public

------------------------------------------------------------------------
-- Properties of operations

Associative : Op₂ A → Set _
Associative _·_ = ∀ {x y z} → ((x · y) · z) ≡ (x · (y · z))

Commutative : Op₂ A → Set _
Commutative _·_ = ∀ {x y} → (x · y) ≡ (y · x)

LeftIdentity : A → Op₂ A → Set _
LeftIdentity e _·_ = ∀ {x} → (e · x) ≡ x

RightIdentity : A → Op₂ A → Set _
RightIdentity e _·_ = ∀ {x} → (x · e) ≡ x

Identity : A → Op₂ A → Set _
Identity e · = LeftIdentity e · × RightIdentity e ·

LeftZero : A → Op₂ A → Set _
LeftZero z _·_ = ∀ {x} → (z · x) ≡ z

RightZero : A → Op₂ A → Set _
RightZero z _·_ = ∀ {x} → (x · z) ≡ z

Zero : A → Op₂ A → Set _
Zero z · = LeftZero z · × RightZero z ·

LeftInverse : A → Op₁ A → Op₂ A → Set _
LeftInverse e _⁻¹ _·_ = ∀ {x} → (x ⁻¹ · x) ≡ e

LeftInverseNonZero : (zero e : A) → Op₁ A → Op₂ A → Set _
LeftInverseNonZero zero e _⁻¹ _·_ = ∀ {x} → x ≢ zero → (x ⁻¹ · x) ≡ e

RightInverse : A → Op₁ A → Op₂ A → Set _
RightInverse e _⁻¹ _·_ = ∀ {x} → (x · (x ⁻¹)) ≡ e

RightInverseNonZero : (zero e : A) → Op₁ A → Op₂ A → Set _
RightInverseNonZero zero e _⁻¹ _·_ = ∀ {x} → x ≢ zero → (x · (x ⁻¹)) ≡ e

Inverse : A → Op₁ A → Op₂ A → Set _
Inverse e ⁻¹ · = LeftInverse e ⁻¹ · × RightInverse e ⁻¹ ·

InverseNonZero : (zero e : A) → Op₁ A → Op₂ A → Set _
InverseNonZero zero e ⁻¹ · = LeftInverse e ⁻¹ · × RightInverse e ⁻¹ ·

_DistributesOverˡ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverˡ _+_ =
  ∀ {x y z} → (x * (y + z)) ≡ ((x * y) + (x * z))

_DistributesOverʳ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverʳ _+_ =
  ∀ {x y z} → ((y + z) * x) ≡ ((y * x) + (z * x))

_DistributesOver_ : Op₂ A → Op₂ A → Set _
* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +)

_IdempotentOn_ : Op₂ A → A → Set _
_·_ IdempotentOn x = (x · x) ≡ x

Idempotent : Op₂ A → Set _
Idempotent · = ∀ {x} → · IdempotentOn x

IdempotentFun : Op₁ A → Set _
IdempotentFun f = ∀ {x} → f (f x) ≡ f x

_Absorbs_ : Op₂ A → Op₂ A → Set _
_·_ Absorbs _∘_ = ∀ {x y} → (x · (x ∘ y)) ≡ x

Absorptive : Op₂ A → Op₂ A → Set _
Absorptive · ∘ = (· Absorbs ∘) × (∘ Absorbs ·)

Involutive : Op₁ A → Set _
Involutive f = ∀ {x} → f (f x) ≡ x

Interchange : Op₂ A → Op₂ A → Set _
Interchange _·_ _∘_ = ∀ {x y z t} → ((x · y) ∘ (z · t)) ≡ ((x ∘ z) · (y ∘ t))

LeftCancel : Op₂ A → Set _
LeftCancel _·_ = ∀ {c x y} → c · x ≡ c · y → x ≡ y

RightCancel : Op₂ A → Set _
RightCancel _·_ = ∀ {c x y} → x · c ≡ y · c → x ≡ y

LeftCancelNonZero : A → Op₂ A → Set _
LeftCancelNonZero zero _·_ = ∀ {c x y} → c ≢ zero → c · x ≡ c · y → x ≡ y

RightCancelNonZero : A → Op₂ A → Set _
RightCancelNonZero zero _·_ = ∀ {c x y} → c ≢ zero → x · c ≡ y · c → x ≡ y

module InterchangeFromAssocComm
         (_·_     : Op₂ A)
         (·-assoc : Associative _·_)
         (·-comm  : Commutative _·_)
         where

    open ≡-Reasoning

    ·= : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → (x · y) ≡ (x' · y')
    ·= refl refl = refl

    ·-interchange : Interchange _·_ _·_
    ·-interchange {x} {y} {z} {t}
                = (x · y) · (z · t)
                ≡⟨ ·-assoc ⟩
                  x · (y · (z · t))
                ≡⟨ ·= refl (! ·-assoc) ⟩
                  x · ((y · z) · t)
                ≡⟨ ·= refl (·= ·-comm refl) ⟩
                  x · ((z · y) · t)
                ≡⟨ ·= refl ·-assoc ⟩
                  x · (z · (y · t))
                ≡⟨ ! ·-assoc ⟩
                  (x · z) · (y · t)
                ∎

module _ {b} {B : Set b} (f : A → B) where

    Injective : Set (b ⊔ a)
    Injective = ∀ {x y} → f x ≡ f y → x ≡ y

    Conflict : Set (b ⊔ a)
    Conflict = ∃ λ x → ∃ λ y → (x ≢ y) × f x ≡ f y

module _ {b} {B : Set b} {f : A → B} where
    Injective-¬Conflict : Injective f → ¬ (Conflict f)
    Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj fx≡fy)

    Conflict-¬Injective : Conflict f → ¬ (Injective f)
    Conflict-¬Injective = flip Injective-¬Conflict
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
-- Like Algebra.FunctionProperties but specialized to _≡_ and using implict arguments
-- Moreover there is some extensions such as:
-- * interchange
-- * non-zero inversions
-- * cancelation and non-zero cancelation

-- These properties can (for instance) be used to define algebraic
-- structures.

open import Level
open import Function.NP using (_$⟨_⟩_; flip)
open import Data.Nat.Base using (ℕ)
open import Data.Product
open import Relation.Nullary
open import Relation.Binary.NP
open import Relation.Binary.PropositionalEquality.NP

-- The properties are specified using the following relation as
-- "equality".

module Algebra.FunctionProperties.Eq {a} {A : Set a} where

------------------------------------------------------------------------
-- Unary and binary operations

open import Algebra.FunctionProperties.Core public

------------------------------------------------------------------------
-- Properties of operations

Associative : Op₂ A → Set _
Associative _·_ = ∀ {x y z} → ((x · y) · z) ≡ (x · (y · z))

Commutative : Op₂ A → Set _
Commutative _·_ = ∀ {x y} → (x · y) ≡ (y · x)

LeftIdentity : A → Op₂ A → Set _
LeftIdentity e _·_ = ∀ {x} → (e · x) ≡ x

RightIdentity : A → Op₂ A → Set _
RightIdentity e _·_ = ∀ {x} → (x · e) ≡ x

Identity : A → Op₂ A → Set _
Identity e · = LeftIdentity e · × RightIdentity e ·

LeftZero : A → Op₂ A → Set _
LeftZero z _·_ = ∀ {x} → (z · x) ≡ z

RightZero : A → Op₂ A → Set _
RightZero z _·_ = ∀ {x} → (x · z) ≡ z

Zero : A → Op₂ A → Set _
Zero z · = LeftZero z · × RightZero z ·

LeftInverse : A → Op₁ A → Op₂ A → Set _
LeftInverse e _⁻¹ _·_ = ∀ {x} → (x ⁻¹ · x) ≡ e

LeftInverseNonZero : (zero e : A) → Op₁ A → Op₂ A → Set _
LeftInverseNonZero zero e _⁻¹ _·_ = ∀ {x} → x ≢ zero → (x ⁻¹ · x) ≡ e

RightInverse : A → Op₁ A → Op₂ A → Set _
RightInverse e _⁻¹ _·_ = ∀ {x} → (x · (x ⁻¹)) ≡ e

RightInverseNonZero : (zero e : A) → Op₁ A → Op₂ A → Set _
RightInverseNonZero zero e _⁻¹ _·_ = ∀ {x} → x ≢ zero → (x · (x ⁻¹)) ≡ e

Inverse : A → Op₁ A → Op₂ A → Set _
Inverse e ⁻¹ · = LeftInverse e ⁻¹ · × RightInverse e ⁻¹ ·

InverseNonZero : (zero e : A) → Op₁ A → Op₂ A → Set _
InverseNonZero zero e ⁻¹ · = LeftInverse e ⁻¹ · × RightInverse e ⁻¹ ·

_DistributesOverˡ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverˡ _+_ =
  ∀ {x y z} → (x * (y + z)) ≡ ((x * y) + (x * z))

_DistributesOverʳ_ : Op₂ A → Op₂ A → Set _
_*_ DistributesOverʳ _+_ =
  ∀ {x y z} → ((y + z) * x) ≡ ((y * x) + (z * x))

_DistributesOver_ : Op₂ A → Op₂ A → Set _
* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +)

_IdempotentOn_ : Op₂ A → A → Set _
_·_ IdempotentOn x = (x · x) ≡ x

Idempotent : Op₂ A → Set _
Idempotent · = ∀ {x} → · IdempotentOn x

IdempotentFun : Op₁ A → Set _
IdempotentFun f = ∀ {x} → f (f x) ≡ f x

_Absorbs_ : Op₂ A → Op₂ A → Set _
_·_ Absorbs _∘_ = ∀ {x y} → (x · (x ∘ y)) ≡ x

Absorptive : Op₂ A → Op₂ A → Set _
Absorptive · ∘ = (· Absorbs ∘) × (∘ Absorbs ·)

Involutive : Op₁ A → Set _
Involutive f = ∀ {x} → f (f x) ≡ x

Interchange : Op₂ A → Op₂ A → Set _
Interchange _·_ _∘_ = ∀ {x y z t} → ((x · y) ∘ (z · t)) ≡ ((x ∘ z) · (y ∘ t))

LeftCancel : Op₂ A → Set _
LeftCancel _·_ = ∀ {c x y} → c · x ≡ c · y → x ≡ y

RightCancel : Op₂ A → Set _
RightCancel _·_ = ∀ {c x y} → x · c ≡ y · c → x ≡ y

LeftCancelNonZero : A → Op₂ A → Set _
LeftCancelNonZero zero _·_ = ∀ {c x y} → c ≢ zero → c · x ≡ c · y → x ≡ y

RightCancelNonZero : A → Op₂ A → Set _
RightCancelNonZero zero _·_ = ∀ {c x y} → c ≢ zero → x · c ≡ y · c → x ≡ y

module InterchangeFromAssocComm
         (_·_     : Op₂ A)
         (·-assoc : Associative _·_)
         (·-comm  : Commutative _·_)
         where

    open ≡-Reasoning

    ·= : ∀ {x x' y y'} → x ≡ x' → y ≡ y' → (x · y) ≡ (x' · y')
    ·= refl refl = refl

    ·-interchange : Interchange _·_ _·_
    ·-interchange {x} {y} {z} {t}
                = (x · y) · (z · t)
                ≡⟨ ·-assoc ⟩
                  x · (y · (z · t))
                ≡⟨ ·= refl (! ·-assoc) ⟩
                  x · ((y · z) · t)
                ≡⟨ ·= refl (·= ·-comm refl) ⟩
                  x · ((z · y) · t)
                ≡⟨ ·= refl ·-assoc ⟩
                  x · (z · (y · t))
                ≡⟨ ! ·-assoc ⟩
                  (x · z) · (y · t)
                ∎

module _ {b} {B : Set b} (f : A → B) where

    Injective : Set (b ⊔ a)
    Injective = ∀ {x y} → f x ≡ f y → x ≡ y

    Conflict : Set (b ⊔ a)
    Conflict = ∃ λ x → ∃ λ y → (x ≢ y) × f x ≡ f y

module _ {b} {B : Set b} {f : A → B} where
    Injective-¬Conflict : Injective f → ¬ (Conflict f)
    Injective-¬Conflict inj (x , y , x≢y , fx≡fy) = x≢y (inj fx≡fy)

    Conflict-¬Injective : Conflict f → ¬ (Injective f)
    Conflict-¬Injective = flip Injective-¬Conflict

module Endo {f : A → A} where
    Cycle^ : ℕ → Set _
    Cycle^ n = ∃ λ x → f $⟨ n ⟩ x ≡ x

    Cycle = ∃ Cycle^
-- -}
-- -}
-- -}
-- -}

add Endo.Cycle

Alegbra.FunctionProperties.Eq: add Endo.Cycle


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

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

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

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

open import Base.Denotation.Notation public

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

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open import Base.Denotation.Notation public

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

import Structure.Tuples as Tuples
open Tuples

import Base.Data.DependentList as DependentList
open DependentList

open import Relation.Unary using (_⊆_)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

  ΔEnv : Context → Set
  ΔEnv = DependentList ValidChange

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

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

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

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

Rename ΔEnv-Entry to ValidChange.

Rename ΔEnv-Entry to ValidChange.

Also rename operations related to ΔEnv-Entry.

Old-commit-hash: 35ab981b89bab6eced9a7b20753bb140f6caf7a8


module Denotational.Environments
    (Type : Set)
    (⟦_⟧Type : Type → Set)
  where

-- ENVIRONMENTS
--
-- This module defines the meaning of contexts, that is,
-- the type of environments that fit a context, together
-- with operations and properties of these operations.
--
-- This module is parametric in the syntax and semantics
-- of types, so it can be reused for different calculi
-- and models.

open import Relation.Binary.PropositionalEquality

open import Syntactic.Contexts Type
open import Denotational.Notation

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

-- TYPING CONTEXTS

-- Denotational Semantics : Contexts Represent Environments

data Empty : Set where
  ∅ : Empty

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

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

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

-- VARIABLES

-- Denotational Semantics

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

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

-- WEAKENING

-- Remove a variable from an environment

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

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

-- Properties

⟦⟧-≼-trans : ∀ {Γ₃ Γ₁ Γ₂} → (Γ′ : Γ₁ ≼ Γ₂) (Γ″ : Γ₂ ≼ Γ₃) →
  ∀ (ρ : ⟦ Γ₃ ⟧) → ⟦ ≼-trans Γ′ Γ″ ⟧ ρ ≡ ⟦ Γ′ ⟧ (⟦ Γ″ ⟧ ρ)
⟦⟧-≼-trans Γ′ ∅ ∅ = refl
⟦⟧-≼-trans (keep τ • Γ′) (keep .τ • Γ″) (v • ρ) = cong₂ _•_ refl (⟦⟧-≼-trans Γ′ Γ″ ρ)
⟦⟧-≼-trans (drop τ • Γ′) (keep .τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ
⟦⟧-≼-trans Γ′ (drop τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ

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

-- SOUNDNESS of variable lifting

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

module Denotational.Environments
    (Type : Set)
    {ℓ}
    (⟦_⟧Type : Type → Set ℓ)
  where

-- ENVIRONMENTS
--
-- This module defines the meaning of contexts, that is,
-- the type of environments that fit a context, together
-- with operations and properties of these operations.
--
-- This module is parametric in the syntax and semantics
-- of types, so it can be reused for different calculi
-- and models.

open import Relation.Binary.PropositionalEquality

open import Syntactic.Contexts Type
open import Denotational.Notation

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

-- TYPING CONTEXTS

-- Denotational Semantics : Contexts Represent Environments

data Empty : Set ℓ where
  ∅ : Empty

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

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

meaningOfContext : Meaning Context
meaningOfContext = meaning ⟦_⟧Context

-- VARIABLES

-- Denotational Semantics

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

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

-- WEAKENING

-- Remove a variable from an environment

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

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

-- Properties

⟦⟧-≼-trans : ∀ {Γ₃ Γ₁ Γ₂} → (Γ′ : Γ₁ ≼ Γ₂) (Γ″ : Γ₂ ≼ Γ₃) →
  ∀ (ρ : ⟦ Γ₃ ⟧) → ⟦ ≼-trans Γ′ Γ″ ⟧ ρ ≡ ⟦ Γ′ ⟧ (⟦ Γ″ ⟧ ρ)
⟦⟧-≼-trans Γ′ ∅ ∅ = refl
⟦⟧-≼-trans (keep τ • Γ′) (keep .τ • Γ″) (v • ρ) = cong₂ _•_ refl (⟦⟧-≼-trans Γ′ Γ″ ρ)
⟦⟧-≼-trans (drop τ • Γ′) (keep .τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ
⟦⟧-≼-trans Γ′ (drop τ • Γ″) (v • ρ) = ⟦⟧-≼-trans Γ′ Γ″ ρ

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

-- SOUNDNESS of variable lifting

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

Generalize environments to values in higher universes.

Old-commit-hash: 4ff4102742306da9be77151d785aa608f8558977


import Parametric.Syntax.Type as Type

module Parametric.Syntax.MType where

module Structure (Base : Type.Structure) where
  open Type.Structure Base

  mutual
    --  Derived from CBPV
    data ValType : Set where
      U : (c : CompType) → ValType
      B : (ι : Base) → ValType
      vUnit : ValType
      _v×_ : (τ₁ : ValType) → (τ₂ : ValType) → ValType
      _v+_ : (τ₁ : ValType) → (τ₂ : ValType) → ValType

    data CompType : Set where
      F : ValType → CompType
      _⇛_ : ValType → CompType → CompType
      -- We did not use this in CBPV, so dropped.
      -- _Π_ : CompType → CompType → CompType

  cbnToCompType : Type → CompType
  cbnToCompType (base ι) = F (B ι)
  cbnToCompType (σ ⇒ τ) = U (cbnToCompType σ) ⇛ cbnToCompType τ

  cbvToValType : Type → ValType
  cbvToValType (base ι) = B ι
  cbvToValType (σ ⇒ τ) = U (cbvToValType σ ⇛ F (cbvToValType τ))

  open import Base.Syntax.Context ValType public
    using ()
    renaming
      ( ∅ to ∅∅
      ; _•_ to _••_
      ; mapContext to mapValCtx
      ; Var to ValVar
      ; Context to ValContext
      ; this to vThis; that to vThat)

  cbnToValType : Type → ValType
  cbnToValType τ = U (cbnToCompType τ)

  cbvToCompType : Type → CompType
  cbvToCompType τ = F (cbvToValType τ)

  fromCBNCtx : Context → ValContext
  fromCBNCtx Γ = mapValCtx cbnToValType Γ

  fromCBVCtx : Context → ValContext
  fromCBVCtx Γ = mapValCtx cbvToValType Γ

  open import Data.List
  open Data.List using (List) public
  fromCBVToCompList : Context → List CompType
  fromCBVToCompList Γ = mapValCtx cbvToCompType Γ

  fromVar : ∀ {Γ τ} → (f : Type → ValType) → Var Γ τ → ValVar (mapValCtx f Γ) (f τ)
  fromVar {x • Γ} f this = vThis
  fromVar {x • Γ} f (that v) = vThat (fromVar f v)

import Parametric.Syntax.Type as Type

module Parametric.Syntax.MType where

module Structure (Base : Type.Structure) where
  open Type.Structure Base

  mutual
    --  Derived from CBPV
    data ValType : Set where
      U : (c : CompType) → ValType
      B : (ι : Base) → ValType
      vUnit : ValType
      _v×_ : (τ₁ : ValType) → (τ₂ : ValType) → ValType
      _v+_ : (τ₁ : ValType) → (τ₂ : ValType) → ValType

    -- Same associativity as the standard _×_
    infixr 2 _v×_

    data CompType : Set where
      F : ValType → CompType
      _⇛_ : ValType → CompType → CompType
      -- We did not use this in CBPV, so dropped.
      -- _Π_ : CompType → CompType → CompType

  cbnToCompType : Type → CompType
  cbnToCompType (base ι) = F (B ι)
  cbnToCompType (σ ⇒ τ) = U (cbnToCompType σ) ⇛ cbnToCompType τ

  cbvToValType : Type → ValType
  cbvToValType (base ι) = B ι
  cbvToValType (σ ⇒ τ) = U (cbvToValType σ ⇛ F (cbvToValType τ))

  open import Base.Syntax.Context ValType public
    using ()
    renaming
      ( ∅ to ∅∅
      ; _•_ to _••_
      ; mapContext to mapValCtx
      ; Var to ValVar
      ; Context to ValContext
      ; this to vThis; that to vThat)

  cbnToValType : Type → ValType
  cbnToValType τ = U (cbnToCompType τ)

  cbvToCompType : Type → CompType
  cbvToCompType τ = F (cbvToValType τ)

  fromCBNCtx : Context → ValContext
  fromCBNCtx Γ = mapValCtx cbnToValType Γ

  fromCBVCtx : Context → ValContext
  fromCBVCtx Γ = mapValCtx cbvToValType Γ

  open import Data.List
  open Data.List using (List) public
  fromCBVToCompList : Context → List CompType
  fromCBVToCompList Γ = mapValCtx cbvToCompType Γ

  fromVar : ∀ {Γ τ} → (f : Type → ValType) → Var Γ τ → ValVar (mapValCtx f Γ) (f τ)
  fromVar {x • Γ} f this = vThis
  fromVar {x • Γ} f (that v) = vThat (fromVar f v)

Fix arity of _v×_

MType: Fix arity of _v×_


import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

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

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

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

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

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

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

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

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

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

-- Weakening

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

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

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

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

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

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

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

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

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

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

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

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

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

-- helper for lift-η-const, don't try to understand at home
lift-η-const-rec : ∀ {Σ Γ τ} → (Terms Γ Σ → Term Γ τ) → TermConstructor Γ Σ τ
lift-η-const-rec {∅} k = k ∅
lift-η-const-rec {τ • Σ} k = λ t → lift-η-const-rec (λ ts → k (t • ts))

lift-η-const : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → TermConstructor Γ Σ τ
lift-η-const constant = lift-η-const-rec (const constant)

import Syntax.Type.Plotkin as Type
import Syntax.Context as Context

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

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product

open Type B
open Context {Type}

open import Denotation.Environment Type
open import Syntax.Context.Plotkin B

data Term
  (Γ : Context) :
  (τ : Type) → Set

data Terms
  (Γ : Context) :
  (Σ : Context) → Set

data Term Γ where
  const : ∀ {Σ τ} →
    (c : C Σ τ) →
    Terms Γ Σ →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

data Terms Γ where
  ∅ : Terms Γ ∅
  _•_ : ∀ {τ Σ} →
    Term Γ τ →
    Terms Γ Σ →
    Terms Γ (τ • Σ)

infixr 9 _•_

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

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

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

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

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

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

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

-- Weakening

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

weakenAll : ∀ {Γ₁ Γ₂ Σ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Terms Γ₁ Σ →
  Terms Γ₂ Σ

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

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

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

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

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

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

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

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

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

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

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

-- helper for lift-η-const, don't try to understand at home
lift-η-const-rec : ∀ {Σ Γ τ} → (Terms Γ Σ → Term Γ τ) → TermConstructor Γ Σ τ
lift-η-const-rec {∅} k = k ∅
lift-η-const-rec {τ • Σ} k = λ t → lift-η-const-rec (λ ts → k (t • ts))

lift-η-const : ∀ {Σ τ} → C Σ τ → ∀ {Γ} → TermConstructor Γ Σ τ
lift-η-const constant = lift-η-const-rec (const constant)

Reorder definitions of Term and Terms.

Reorder definitions of Term and Terms.

The order of definitions should follow the order of declaration,
and this code seems easier to understand when one looks at Term
first.

Old-commit-hash: 517547b8eebe1b8803d9f30fa3945f02685b6cc5


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

open import Base.Change.Equivalence.Base public
open import Base.Change.Equivalence.EqReasoning public

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- 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 : Δ {{ca}} x) → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil {{ca}} x)
    ≡⟨ update-nil {{ca}} x ⟩
      x
    ∎
    where
      open ≡-Reasoning

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

  -- Let's show that nil x is d.o.e. to x ⊟ x
  nil-x-is-x⊟x : nil x ≙ x ⊟ x
  nil-x-is-x⊟x = ≙-sym (⊞-unit-is-nil (x ⊟ x) (update-diff {{ca}} x x))

  -- 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
  --   equiv-fun-changes-respect, and its corollaries fun-change-respects and
  --   equiv-fun-changes-funs.
  --
  -- * 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 : Δ {{ca}} x} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : _⊞_ {{ca}} x (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff {{ca}} (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; DerivativeAsChange)
  open FC.FunctionChange

  equiv-fun-changes-respect : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
    _≙_ {{changeAlgebra}} df₁ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  equiv-fun-changes-respect {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₂
        ∎

  fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} (df : Δ f) →
    dx₁ ≙ dx₂ → apply df x dx₁ ≙ apply df x dx₂
  fun-change-respects df dx₁≙dx₂ = equiv-fun-changes-respect (≙-refl {dx = df}) dx₁≙dx₂

  -- D.o.e. function changes behave like the same function (up to d.o.e.).
  equiv-fun-changes-funs : ∀ {x : A} {dx : Δ x} {f : A → B} {df₁ df₂ : Δ f} →
    _≙_ {{changeAlgebra}} df₁ df₂ → apply df₁ x dx ≙ apply df₂ x dx
  equiv-fun-changes-funs {dx = dx} df₁≙df₂ = equiv-fun-changes-respect df₁≙df₂ (≙-refl {dx = 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))

  -- You could think that the function should relate equivalent changes, but
  -- that's a stronger hypothesis, which doesn't give you extra guarantees. But
  -- here's the statement and proof, for completeness:

  delta-ext₂ : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx₁ dx₂ → _≙_ {{CA}} dx₁ dx₂ → apply df x dx₁ ≙ apply dg x dx₂) → df ≙ dg
  delta-ext₂ {f} {df} {dg} df-x-dx≙dg-x-dx = delta-ext (λ x dx → df-x-dx≙dg-x-dx x dx dx ≙-refl)

  -- We know that IsDerivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> IsDerivative f (apply df).
  -- Now, we try to prove that if IsDerivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    IsDerivative 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 {{CA}} x))
    ≡⟨ ext (λ x → cong f (update-nil {{CA}} 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 →
    IsDerivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  derivative-is-nil-alternative : ∀ {f : A → B} df →
    (IsDerivative-f-df : IsDerivative f df) → DerivativeAsChange IsDerivative-f-df ≙ nil f
  derivative-is-nil-alternative df IsDerivative-f-df = derivative-is-nil (DerivativeAsChange IsDerivative-f-df) IsDerivative-f-df

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → IsDerivative f (apply df) → IsDerivative 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

  -- This is Lemma 2.5 in the paper. Note that the statement in the paper uses
  -- (incorrectly) normal equality instead of delta-observational equivalence.
  deriv-zero :
    ∀ (f : A → B) df → IsDerivative f df →
    ∀ v → df v (nil {{CA}} v) ≙ nil {{CB}} (f v)
  deriv-zero f df proof v = doe lemma
    where
      open ≡-Reasoning
      lemma : f v ⊞ df v (nil v) ≡ f v ⊞ nil {{CB}} (f v)
      lemma =
        begin
          f v ⊞ df v (nil {{CA}} v)
        ≡⟨ proof v (nil {{CA}} v) ⟩
          f (v ⊞ (nil {{CA}} v))
        ≡⟨ cong f (update-nil {{CA}} v) ⟩
          f v
        ≡⟨ sym (update-nil {{CB}} (f v)) ⟩
          f v ⊞ nil {{CB}} (f v)
        ∎

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

open import Base.Change.Equivalence.Base public
open import Base.Change.Equivalence.EqReasoning public

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- 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 : Δ {{ca}} x) → dx ≙ nil x → x ⊞ dx ≡ x
  nil-is-⊞-unit dx dx≙nil-x =
    begin
      x ⊞ dx
    ≡⟨ proof dx≙nil-x ⟩
      x ⊞ (nil {{ca}} x)
    ≡⟨ update-nil {{ca}} x ⟩
      x
    ∎
    where
      open ≡-Reasoning

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

  -- Let's show that nil x is d.o.e. to x ⊟ x
  nil-x-is-x⊟x : nil x ≙ x ⊟ x
  nil-x-is-x⊟x = ≙-sym (⊞-unit-is-nil (x ⊟ x) (update-diff {{ca}} x x))

  -- 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
  --   equiv-fun-changes-respect, and its corollaries fun-change-respects and
  --   equiv-fun-changes-funs.
  --
  -- * 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 : Δ {{ca}} x} → (x ⊞ dx) ⊟ x ≙ dx
  diff-update {dx} = doe lemma
    where
      lemma : _⊞_ {{ca}} x (x ⊞ dx ⊟ x) ≡ x ⊞ dx
      lemma = update-diff {{ca}} (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; DerivativeAsChange)
  open FC.FunctionChange

  equiv-fun-changes-respect : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
    _≙_ {{changeAlgebra}} df₁ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  equiv-fun-changes-respect {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₂
        ∎

  fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} (df : Δ f) →
    dx₁ ≙ dx₂ → apply df x dx₁ ≙ apply df x dx₂
  fun-change-respects df dx₁≙dx₂ = equiv-fun-changes-respect (≙-refl {dx = df}) dx₁≙dx₂

  -- D.o.e. function changes behave like the same function (up to d.o.e.).
  equiv-fun-changes-funs : ∀ {x : A} {dx : Δ x} {f : A → B} {df₁ df₂ : Δ f} →
    _≙_ {{changeAlgebra}} df₁ df₂ → apply df₁ x dx ≙ apply df₂ x dx
  equiv-fun-changes-funs {dx = dx} df₁≙df₂ = equiv-fun-changes-respect df₁≙df₂ (≙-refl {dx = dx})

  derivative-doe-characterization : ∀ {a : A} {da : Δ a}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    _≙_ {{CB}} (df a da) (f (a ⊞ da) ⊟ f a)
  derivative-doe-characterization {a} {da} {f} {df} is-derivative = doe lemma
    where
      open ≡-Reasoning
      lemma : f a ⊞ df a da ≡ f a ⊞ (f (a ⊞ da) ⊟ f a)
      lemma =
        begin
          (f a ⊞ df a da)
        ≡⟨ is-derivative a da ⟩
          (f (a ⊞ da))
        ≡⟨ sym (update-diff (f (a ⊞ da)) (f a)) ⟩
          (f a ⊞ (f (a ⊞ da) ⊟ f a))
        ∎

  derivative-respects-doe : ∀ {x : A} {dx₁ dx₂ : Δ x}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    _≙_ {{CA}} dx₁ dx₂ →  _≙_ {{CB}} (df x dx₁) (df x dx₂)
  derivative-respects-doe {x} {dx₁} {dx₂} {f} {df} is-derivative dx₁≙dx₂ =
    begin
      df x dx₁
    ≙⟨ derivative-doe-characterization is-derivative ⟩
      f (x ⊞ dx₁) ⊟ f x
    ≡⟨ cong (λ v → f v  ⊟ f x) (proof dx₁≙dx₂) ⟩
      f (x ⊞ dx₂) ⊟ f x
    ≙⟨ ≙-sym (derivative-doe-characterization is-derivative) ⟩
      df x dx₂
    ∎
    where
      open ≙-Reasoning

  -- This is also a corollary of fun-changes-respect
  derivative-respects-doe-alt : ∀ {x : A} {dx₁ dx₂ : Δ x}
    {f : A → B} {df : RawChange f} (is-derivative : IsDerivative f df) →
    _≙_ {{CA}} dx₁ dx₂ →  _≙_ {{CB}} (df x dx₁) (df x dx₂)
  derivative-respects-doe-alt {x} {dx₁} {dx₂} {f} {df} is-derivative dx₁≙dx₂ =
    fun-change-respects (DerivativeAsChange is-derivative) dx₁≙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))

  -- You could think that the function should relate equivalent changes, but
  -- that's a stronger hypothesis, which doesn't give you extra guarantees. But
  -- here's the statement and proof, for completeness:

  delta-ext₂ : ∀ {f : A → B} → ∀ {df dg : Δ f} → (∀ x dx₁ dx₂ → _≙_ {{CA}} dx₁ dx₂ → apply df x dx₁ ≙ apply dg x dx₂) → df ≙ dg
  delta-ext₂ {f} {df} {dg} df-x-dx≙dg-x-dx = delta-ext (λ x dx → df-x-dx≙dg-x-dx x dx dx ≙-refl)

  -- We know that IsDerivative f (apply (nil f)) (by nil-is-derivative).
  -- That is, df = nil f -> IsDerivative f (apply df).
  -- Now, we try to prove that if IsDerivative f (apply df) -> df = nil f.
  -- But first, we prove that f ⊞ df = f.
  derivative-is-⊞-unit : ∀ {f : A → B} df →
    IsDerivative 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 {{CA}} x))
    ≡⟨ ext (λ x → cong f (update-nil {{CA}} 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 →
    IsDerivative f (apply df) → df ≙ nil f
  derivative-is-nil df fdf = ⊞-unit-is-nil df (derivative-is-⊞-unit df fdf)

  derivative-is-nil-alternative : ∀ {f : A → B} df →
    (IsDerivative-f-df : IsDerivative f df) → DerivativeAsChange IsDerivative-f-df ≙ nil f
  derivative-is-nil-alternative df IsDerivative-f-df = derivative-is-nil (DerivativeAsChange IsDerivative-f-df) IsDerivative-f-df

  -- If we have two derivatives, they're both nil, hence they're equal.
  derivative-unique : ∀ {f : A → B} {df dg : Δ f} → IsDerivative f (apply df) → IsDerivative 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

  -- This is Lemma 2.5 in the paper. Note that the statement in the paper uses
  -- (incorrectly) normal equality instead of delta-observational equivalence.
  deriv-zero :
    ∀ (f : A → B) df → IsDerivative f df →
    ∀ v → df v (nil {{CA}} v) ≙ nil {{CB}} (f v)
  deriv-zero f df proof v = doe lemma
    where
      open ≡-Reasoning
      lemma : f v ⊞ df v (nil v) ≡ f v ⊞ nil {{CB}} (f v)
      lemma =
        begin
          f v ⊞ df v (nil {{CA}} v)
        ≡⟨ proof v (nil {{CA}} v) ⟩
          f (v ⊞ (nil {{CA}} v))
        ≡⟨ cong f (update-nil {{CA}} v) ⟩
          f v
        ≡⟨ sym (update-nil {{CB}} (f v)) ⟩
          f v ⊞ nil {{CB}} (f v)
        ∎

Add new lemmas on change equivalence

Add new lemmas on change equivalence


module Syntax.Term.Popl14 where

-- Terms Calculus Popl14
--
-- Contents
-- - Term constructors
-- - Weakening on terms
-- - `fit`: weaken a term to its ΔContext
-- - diff-term, apply-term and their syntactic sugars

open import Syntax.Context.Popl14 public
open import Data.Integer

data Term (Γ : Context) : Type -> Set where
  int : (n : ℤ) → Term Γ int
  add : (s : Term Γ int) (t : Term Γ int) → Term Γ int
  minus : (t : Term Γ int) → Term Γ int

  empty : Term Γ bag
  insert : (s : Term Γ int) (t : Term Γ bag) → Term Γ bag
  union : (s : Term Γ bag) → (t : Term Γ bag) → Term Γ bag
  negate : (t : Term Γ bag) → Term Γ bag

  flatmap : (s : Term Γ (int ⇒ bag)) (t : Term Γ bag) → Term Γ bag
  sum : (t : Term Γ bag) → Term Γ int

  var : ∀ {τ} → (x : Var Γ τ) → Term Γ τ
  app : ∀ {σ τ} → (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) → Term Γ τ
  abs : ∀ {σ τ} → (t : Term (σ • Γ) τ) → Term Γ (σ ⇒ τ)

weaken : ∀ {Γ₁ Γ₂ τ} → (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken Γ₁≼Γ₂ (int x) = int x
weaken Γ₁≼Γ₂ (add s t) = add (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (minus t) = minus (weaken Γ₁≼Γ₂ t)

weaken Γ₁≼Γ₂ empty = empty
weaken Γ₁≼Γ₂ (insert s t) = insert (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (union s t) = union (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (negate t) = negate (weaken Γ₁≼Γ₂ t)

weaken Γ₁≼Γ₂ (flatmap s t) = flatmap (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (sum t) = sum (weaken Γ₁≼Γ₂ t)

weaken Γ₁≼Γ₂ (var x) = var (weakenVar Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {τ} t) = abs (weaken (keep τ • Γ₁≼Γ₂) t)

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

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

apply-term {int} =
  let Δx = var (that this)
      x  = var this
  in abs (abs (add x Δx))
apply-term {bag} =
  let Δx = var (that this)
      x  = var this
  in abs (abs (union x Δx))
apply-term {σ ⇒ τ} =
  let
    Δf = var (that (that this))
    f  = var (that this)
    x  = var this
  in
  -- Δf   f    x
    abs (abs (abs
      (app (app apply-term
        (app (app Δf x) (app (app diff-term x) x)))
        (app f x))))

diff-term {int} =
  let x = var (that this)
      y = var this
  in abs (abs (add x (minus y)))
diff-term {bag} =
  let x = var (that this)
      y = var this
  in abs (abs (union x (negate y)))
diff-term {σ ⇒ τ} =
  let
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
  in
  -- g    f    x    Δx
    abs (abs (abs (abs
      (app (app diff-term
        (app g (app (app apply-term Δx) x)))
        (app f x)))))

-- Sugars for diff-term and apply-term
infixl 6 _⊕_ _⊝_
_⊕_ : ∀ {τ Γ} → Term Γ τ → Term Γ (ΔType τ) → Term Γ τ
_⊝_ : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (ΔType τ)
t ⊕ Δt = app (app apply-term Δt) t
s ⊝ t  = app (app  diff-term  s) t

module Syntax.Term.Popl14 where

-- Terms Calculus Popl14
--
-- Contents
-- - Term constructors
-- - Weakening on terms
-- - `fit`: weaken a term to its ΔContext
-- - diff-term, apply-term and their syntactic sugars

open import Syntax.Context.Popl14 public
open import Data.Integer

data Term (Γ : Context) : Type -> Set where
  int : (n : ℤ) → Term Γ int
  add : (s : Term Γ int) (t : Term Γ int) → Term Γ int
  minus : (t : Term Γ int) → Term Γ int

  empty : Term Γ bag
  insert : (s : Term Γ int) (t : Term Γ bag) → Term Γ bag
  union : (s : Term Γ bag) → (t : Term Γ bag) → Term Γ bag
  negate : (t : Term Γ bag) → Term Γ bag

  flatmap : (s : Term Γ (int ⇒ bag)) (t : Term Γ bag) → Term Γ bag
  sum : (t : Term Γ bag) → Term Γ int

  var : ∀ {τ} → (x : Var Γ τ) → Term Γ τ
  app : ∀ {σ τ} → (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) → Term Γ τ
  abs : ∀ {σ τ} → (t : Term (σ • Γ) τ) → Term Γ (σ ⇒ τ)

weaken : ∀ {Γ₁ Γ₂ τ} → (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) → Term Γ₁ τ → Term Γ₂ τ
weaken Γ₁≼Γ₂ (int x) = int x
weaken Γ₁≼Γ₂ (add s t) = add (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (minus t) = minus (weaken Γ₁≼Γ₂ t)

weaken Γ₁≼Γ₂ empty = empty
weaken Γ₁≼Γ₂ (insert s t) = insert (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (union s t) = union (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (negate t) = negate (weaken Γ₁≼Γ₂ t)

weaken Γ₁≼Γ₂ (flatmap s t) = flatmap (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (sum t) = sum (weaken Γ₁≼Γ₂ t)

weaken Γ₁≼Γ₂ (var x) = var (weakenVar Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {τ} t) = abs (weaken (keep τ • Γ₁≼Γ₂) t)

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

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

-- Sugars for diff-term and apply-term
infixl 6 _⊕_ _⊝_
_⊕_ : ∀ {τ Γ} → Term Γ τ → Term Γ (ΔType τ) → Term Γ τ
_⊝_ : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (ΔType τ)
t ⊕ Δt = app (app apply-term Δt) t
s ⊝ t  = app (app  diff-term  s) t

apply-term {int} =
  let Δx = var (that this)
      x  = var this
  in abs (abs (add x Δx))
apply-term {bag} =
  let Δx = var (that this)
      x  = var this
  in abs (abs (union x Δx))
apply-term {σ ⇒ τ} =
  let
    Δf = var (that (that this))
    f  = var (that this)
    x  = var this
  in
  -- Δf   f    x
    abs (abs (abs
      (app f x ⊕ app (app Δf x) (x ⊝ x))))

diff-term {int} =
  let x = var (that this)
      y = var this
  in abs (abs (add x (minus y)))
diff-term {bag} =
  let x = var (that this)
      y = var this
  in abs (abs (union x (negate y)))
diff-term {σ ⇒ τ} =
  let
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
  in
  -- g    f    x    Δx
    abs (abs (abs (abs
      (app g (x ⊕ Δx) ⊝ app f x))))

agda: use ⊕ and ⊝ also when defining diff-term and apply-term

Goal: make diff-term and apply-term themselves more readable.

Old-commit-hash: fc206b02d6057172e7f49c02eb521abaaafcb1e8


module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Types
open import New.Derive

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set
[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2

[_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set
[ ∅ ]Γ ∅ from ∅ to ∅ = ⊤
[ τ • Γ ]Γ (dv • v1' • dρ) from (v1 • ρ1) to (v2 • ρ2) =
   [ τ ] dv from v1 to v2 × v1 ≡ v1' × [ Γ ]Γ dρ from ρ1 to ρ2

⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ1 ρ2 : ⟦ Γ ⟧Context) (dρ : eCh Γ) → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ ∅ ∅ ∅ tt = refl
⟦Γ≼ΔΓ⟧ (v1 • ρ1) (v2 • ρ2) (dv • .v1 • dρ) (dvv , refl , dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ1 ρ2 dρ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ1 ρ2 : ⟦ Γ ⟧Context) (dρ : eCh Γ) → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t ρ1 ρ2 dρ dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ ρ1 ρ2 dρ dρρ))
  (sym (weaken-sound t _))

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (dρ : eCh Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dv • .v1 • dρ) (v1 • ρ1) (v2 • ρ2) (dvv , refl , dρρ) = dvv
fromtoDeriveVar (that x) (dv • .v1 • dρ) (v1 • ρ1) (v2 • ρ2) (dvv , refl , dρρ) = fromtoDeriveVar x dρ ρ1 ρ2 dρρ

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x _ _ _ dρρ
fromtoDerive τ (app {σ} s t) {dρ} {ρ1} {ρ2} dρρ rewrite sym (fit-sound t ρ1 ρ2 dρ dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ da a1 a2 daa →
  fromtoDerive τ t (daa , refl , dρρ)

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Types
open import New.Derive

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set
[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2

-- XXX This would be more elegant as a datatype — that would avoid the need for
-- an equality proof.
[_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set
[ ∅ ]Γ ∅ from ∅ to ∅ = ⊤
[ τ • Γ ]Γ (dv • v1' • dρ) from (v1 • ρ1) to (v2 • ρ2) =
   [ τ ] dv from v1 to v2 × v1 ≡ v1' × [ Γ ]Γ dρ from ρ1 to ρ2

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ {∅} {∅} {∅} {∅} tt = refl
⟦Γ≼ΔΓ⟧ {_ • _} {v1 • ρ1} {v2 • ρ2} {dv • .v1 • dρ} (dvv , refl , dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {ρ1 ρ2 dρ} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (dρ : eCh Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dv • .v1 • dρ) (v1 • ρ1) (v2 • ρ2) (dvv , refl , dρρ) = dvv
fromtoDeriveVar (that x) (dv • .v1 • dρ) (v1 • ρ1) (v2 • ρ2) (dvv , refl , dρρ) = fromtoDeriveVar x dρ ρ1 ρ2 dρρ

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x _ _ _ dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ da a1 a2 daa →
  fromtoDerive τ t (daa , refl , dρρ)

Hide deducible arguments

NewNew.agda: Hide deducible arguments