Improve documentation of ΔVal.

Improve documentation of ΔVal.

Old-commit-hash: fb71a0ea6af97c62b01a9d8b7d3089e5cd3139ed

module Denotation.Change.Popl14 where

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

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Popl14.Denotation.Value
open import Theorem.Groups-Popl14
open import Postulate.Extensionality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14

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

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

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

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

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

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

-- (ΔVal τ) is 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 base-int) = ℤ
ΔVal (base base-bag) = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

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

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

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {base base-int} n Δn = ⊤
valid {base base-bag} b Δb = ⊤
valid {σ ⇒ τ} f Δf =
  ∀ (v : ⟦ σ ⟧) (Δv : ΔVal σ) (R[v,Δv] : valid v Δv)
  → valid (f v) (Δf v Δv R[v,Δv])
  -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
  × (_⊞_ {σ ⇒ τ} f Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]

-- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
v+[u-v]=u {base base-int} {u} {v} = n+[m-n]=m {v} {u}
v+[u-v]=u {base base-bag} {u} {v} = a++[b\\a]=b {v} {u}
v+[u-v]=u {σ ⇒ τ} {u} {v} =
  let
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₀_ = _⊞_ {σ}
    _-₀_ = _⊟_ {σ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
      begin
        (v + (u - v)) w
      ≡⟨ refl ⟩
        v w +₁ (u (w +₀ (w -₀ w)) -₁ v w)
      ≡⟨ cong (λ hole → v w +₁ (u hole -₁ v w)) (v+[u-v]=u {σ}) ⟩
        v w +₁ (u w -₁ v w)
      ≡⟨ v+[u-v]=u {τ} ⟩
        u w
      ∎) where
      open ≡-Reasoning

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

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

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

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

module Denotation.Change.Popl14 where

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

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Popl14.Denotation.Value
open import Theorem.Groups-Popl14
open import Postulate.Extensionality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14

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

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

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

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

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

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

-- ΔVal τ is intended to be the semantic domain for changes of values
-- of type τ.
--
-- ΔVal τ is the target of the denotational specification ⟦_⟧Δ.
-- Detailed motivation:
--
-- https://github.com/ps-mr/ilc/blob/184a6291ac6eef80871c32d2483e3e62578baf06/POPL14/paper/sec-formal.tex
--
-- ΔVal : Type → Set
ΔVal (base base-int) = ℤ
ΔVal (base base-bag) = Bag
ΔVal (σ ⇒ τ) = (v : ⟦ σ ⟧) → (dv : ΔVal σ) → valid v dv → ΔVal τ

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

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

-- valid : ∀ {τ} → ⟦ τ ⟧ → ΔVal τ → Set
valid {base base-int} n Δn = ⊤
valid {base base-bag} b Δb = ⊤
valid {σ ⇒ τ} f Δf =
  ∀ (v : ⟦ σ ⟧) (Δv : ΔVal σ) (R[v,Δv] : valid v Δv)
  → valid (f v) (Δf v Δv R[v,Δv])
  -- × (f ⊞ Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]
  × (_⊞_ {σ ⇒ τ} f Δf) (v ⊞ Δv) ≡ f v ⊞ Δf v Δv R[v,Δv]

-- v+[u-v]=u : ∀ {τ : Type} {u v : ⟦ τ ⟧} → v ⊞ (u ⊟ v) ≡ u
v+[u-v]=u {base base-int} {u} {v} = n+[m-n]=m {v} {u}
v+[u-v]=u {base base-bag} {u} {v} = a++[b\\a]=b {v} {u}
v+[u-v]=u {σ ⇒ τ} {u} {v} =
  let
    _+_ = _⊞_ {σ ⇒ τ}
    _-_ = _⊟_ {σ ⇒ τ}
    _+₀_ = _⊞_ {σ}
    _-₀_ = _⊟_ {σ}
    _+₁_ = _⊞_ {τ}
    _-₁_ = _⊟_ {τ}
  in
    ext {-⟦ σ ⟧} {λ _ → ⟦ τ ⟧-} (λ w →
      begin
        (v + (u - v)) w
      ≡⟨ refl ⟩
        v w +₁ (u (w +₀ (w -₀ w)) -₁ v w)
      ≡⟨ cong (λ hole → v w +₁ (u hole -₁ v w)) (v+[u-v]=u {σ}) ⟩
        v w +₁ (u w -₁ v w)
      ≡⟨ v+[u-v]=u {τ} ⟩
        u w
      ∎) where
      open ≡-Reasoning

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

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

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

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


Agda: weakening for Plotkin-style terms

Agda: weakening for Plotkin-style terms

Old-commit-hash: e2005584bd69f4ae0b7dac1a633a1a447dd64307

module Syntax.Term.Plotkin where

-- Terms of languages described in Plotkin style

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

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

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

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

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

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

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

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

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

-- Weakening

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

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

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

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

module Syntax.Term.Plotkin where

-- Terms of languages described in Plotkin style

open import Syntax.Type.Plotkin
open import Syntax.Context

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


Little tactic to take `n` steps of evaluation.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data Type : Set
⟦_⟧ : Type → Set

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

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

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

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

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

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

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

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

data Type : Set
⟦_⟧ : Type → Set

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

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

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

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

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

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

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

Dynamic : Set
Dynamic = Σ Type ⟦_⟧

Tactic : Set
Tactic = Dynamic → Dynamic

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Cosmetic changes.

Cosmetic changes.

Ignore-this: 2030b2f08b32be7107650d70f647ccbb

darcs-hash:20110519155111-3bd4e-273a84eb0d1491f18ef33a7d80f755f6d022f1f9.gz

------------------------------------------------------------------------------
-- Properties of the Collatz function
------------------------------------------------------------------------------

module FOTC.Program.Collatz.PropertiesI where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityI

open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.PropertiesI
open import FOTC.Program.Collatz.EquationsI

open import FOTC.Relation.Binary.EqReasoning

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

collatz-2^x : ∀ {n} → N n → ∃ (λ k → N k ∧ n ≡ two ^ k) → collatz n ≡ one
collatz-2^x zN _ = collatz-0
collatz-2^x (sN {n} Nn) (.zero , zN , Sn≡2^0) =
  subst (λ t → collatz t ≡ one)
        (cong succ (sym (Sx≡2^0→x≡0 Nn Sn≡2^0)))
        collatz-1
collatz-2^x (sN {n} Nn) (.(succ k) , sN {k} Nk , Sn≡2^k+1) =
  begin
    collatz (succ n)
      ≡⟨ cong collatz Sn≡2^k+1 ⟩
    collatz (two ^ (succ k))
      ≡⟨ cong collatz prf ⟩
    collatz (succ (succ ((two ^ (succ k)) ∸ two)))
      ≡⟨ collatz-even (x-Even→SSx-Even (∸-N (^-N 2-N (sN Nk)) 2-N)
                      (∸-Even (^-N 2-N (sN Nk)) 2-N (2^[x+1]-Even Nk)
                              (x-Even→SSx-Even zN even-0)))
      ⟩
    collatz ((succ (succ ((two ^ (succ k)) ∸ two))) / two)
      ≡⟨ cong collatz
              (subst (λ t → succ (succ (two ^ succ k ∸ two)) / two ≡ t / two)
                     (sym prf)
                     refl)
              ⟩
    collatz ((two ^ (succ k)) / two)
      ≡⟨ cong collatz (2^[x+1]/2≡2^x Nk) ⟩
    collatz (two ^ k)
      ≡⟨ collatz-2^x (^-N 2-N Nk) (k , Nk , refl) ⟩
    one
  ∎
  where
    prf : two ^ succ k ≡ succ (succ (two ^ succ k ∸ two))
    prf = (+∸2 (^-N 2-N (sN Nk)) (2^x≠0 (sN Nk)) (2^[x+1]≠1 Nk))

------------------------------------------------------------------------------
-- Properties of the Collatz function
------------------------------------------------------------------------------

module FOTC.Program.Collatz.PropertiesI where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.TotalityI

open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.PropertiesI
open import FOTC.Program.Collatz.EquationsI

open import FOTC.Relation.Binary.EqReasoning

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

collatz-2^x : ∀ {n} → N n → ∃ (λ k → N k ∧ n ≡ two ^ k) → collatz n ≡ one
collatz-2^x zN _ = collatz-0
collatz-2^x (sN {n} Nn) (.zero , zN , Sn≡2^0) =
  subst (λ t → collatz t ≡ one)
        (cong succ (sym (Sx≡2^0→x≡0 Nn Sn≡2^0)))
        collatz-1
collatz-2^x (sN {n} Nn) (.(succ k) , sN {k} Nk , Sn≡2^k+1) =
  begin
    collatz (succ n)
      ≡⟨ cong collatz Sn≡2^k+1 ⟩
    collatz (two ^ (succ k))
      ≡⟨ cong collatz prf ⟩
    collatz (succ (succ ((two ^ (succ k)) ∸ two)))
      ≡⟨ collatz-even (x-Even→SSx-Even (∸-N (^-N 2-N (sN Nk)) 2-N)
                      (∸-Even (^-N 2-N (sN Nk)) 2-N (2^[x+1]-Even Nk)
                              (x-Even→SSx-Even zN even-0)))
      ⟩
    collatz ((succ (succ ((two ^ (succ k)) ∸ two))) / two)
      ≡⟨ cong collatz
              (subst (λ t → succ (succ (succ (succ zero) ^ succ k ∸ succ (succ zero))) /
                            two ≡
                            t / two)
                     (sym prf)
                     refl)
              ⟩
    collatz ((two ^ (succ k)) / two)
      ≡⟨ cong collatz (2^[x+1]/2≡2^x Nk) ⟩
    collatz (two ^ k)
      ≡⟨ collatz-2^x (^-N 2-N Nk) (k , Nk , refl) ⟩
    one
  ∎
  where
    prf : two ^ succ k ≡ succ (succ (two ^ succ k ∸ two))
    prf = (+∸2 (^-N 2-N (sN Nk)) (2^x≠0 (sN Nk)) (2^[x+1]≠1 Nk))


Some progress on Strong-Fiat-Shamir

Some progress on Strong-Fiat-Shamir

open import Type
open import Data.Maybe
open import Data.Two
open import Data.List.NP
open import Data.Product.NP
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Control.Strategy

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}{Prf : Λ → ★}
  {RP RV RS : ★}{Q : ★}{Resp :    ★}
  (L? : ∀ w Y → Dec (L w Y))
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (Q? : Decidable (_≡_ {A = Q}))
  where

Random-Oracle : ★
Random-Oracle = Q → Resp

State : (S A : ★) → ★
State S A = S → A × S

data Adversary-Query : ★ where
  query-H : (q : Q) → Adversary-Query
  query-create-proof : (w : W)(Y : Λ) → Adversary-Query

Challenger-Resp : Adversary-Query → ★
Challenger-Resp (query-H s) = Resp
Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

Transcript = List (Σ Adversary-Query Challenger-Resp)

record Proof-System : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : RV → (Y : Λ)(π : Prf Y) → 𝟚

module H-def (ro : Random-Oracle)(t : Transcript)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q

record Simulator (PF : Proof-System) : ★ where
  open Proof-System PF

  field
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : (rs : RS)(rv : RV)(t : Transcript)(Y : Λ) →
                      let π = Simulate rs t Y
                      in Verify rv Y π ≡ 1₂

module Is-Zero-Knowledge
  (PF : Proof-System)
  (sim : Simulator PF)
  where

  open Simulator sim

  Adversary : ★
  Adversary = Strategy Adversary-Query Challenger-Resp 𝟚

  module _ (ro : Random-Oracle) where

    open H-def ro

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H t q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    simulated-Challenger rs t (query-create-proof w Y) | yes p = just (Simulate rs t Y)
    simulated-Challenger rs t (query-create-proof w Y) | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    Experiment : 𝟚 → RS → Adversary → 𝟚 × Transcript
    Experiment β rs adv = runT (challenger β rs) adv []

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RΣP : ★}
  (PF : Proof-System)
  where
  open Proof-System PF

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  (v ⇄ p) r Y c = Σ-Protocol.Σ-game (v , p) r Y c

  Correct : Σ-Protocol → ★
  Correct (v , p) = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Prover p
    in v Y (mk (get-A r Y) c (get-f r Y c)) ≡ 1₂

  module Special-Honest-Verifier-Zero-Knowledge where

    record SHVZK (Σ-proto : Σ-Protocol) : ★ where
      open Σ-Protocol Σ-proto
      field
        Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
        Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
        -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
        -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  module Special-Soundness where

    record SpSo : ★ where
      field
        Extract : (Y : Λ)(t₀ t₁ : Σ-Transcript Y) → W
        Extract-ok : ∀ Y A c₀ c₁ f₀ f₁ → (c₀ ≢ c₁) → L (Extract Y (mk A c₀ f₀) (mk A c₁ f₁)) Y

  module Simulation-Sound-Extractability
    (sim : Simulator PF)
    (open Is-Zero-Knowledge PF sim)
    {RA : ★}
    (Adv : Adversary)
    (ro : Random-Oracle)
    where

    module Initial-run where
        K-winning-Transcript : Transcript → 𝟚
        K-winning-Transcript []            = 1₂
        K-winning-Transcript ((query-H q , r) ∷ t) = K-winning-Transcript t -- nothing else to check right?
        K-winning-Transcript ((query-create-proof w Y , nothing) ∷ t) = ?
        K-winning-Transcript ((query-create-proof w Y , just π)  ∷ t) = ?
        {-with L? w Y
        ... | yes p = {!!}
        ... | no ¬p = {!!}-}

        game : (w : RA)(β : 𝟚)(rs : RS) → {!!}
        game w β rs = let (β' , t) = Experiment ro β rs Adv in {!!}

-- -}
-- -}
-- -}
-- -}
-- -}

open import Type
open import Data.Maybe
open import Data.Two
open import Data.Product.NP
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Control.Strategy

module ZK.Strong-Fiat-Shamir
  {W S : ★}{L : W → S → ★}{Prf : S → ★}
  {RP RV RS : ★}{SimState : ★}{Q : ★}{Resp :    ★}
  (L? : ∀ w Y → Dec (L w Y))(L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  where

Random-Oracle : ★
Random-Oracle = Q → Resp

State : (S A : ★) → ★
State S A = S → A × S

record Proof-System : ★ where
  field
    Prove : RP →  (w : W)(Y : S) → Prf Y
    Verify : RV → (Y : S)(π : Prf Y) → 𝟚

record Simulator (PF : Proof-System) : ★ where
  open Proof-System PF
  field
    init : RS → SimState
    H : Q → State SimState Resp
    Simulate : (Y : S) → State SimState (Prf Y)
    verify-sim-spec : (rv : RV)(Y : S)(s : SimState) → let π = proj₁ (Simulate Y s)
                     in Verify rv Y π ≡ 1₂

module Is-Zero-Knowledge
  (PF : Proof-System)
  (sim : Simulator PF)
  where

  open Simulator sim

  data Adversary-Query : ★ where
    query-H : (q : Q) → Adversary-Query
    query-create-proof : (w : W)(Y : S) → Adversary-Query

  Challenger-Resp : Adversary-Query → ★
  Challenger-Resp (query-H s) = Resp
  Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

  Adversary : ★
  Adversary = Strategy Adversary-Query Challenger-Resp 𝟚

  simulated-Challenger : ∀ q → State SimState (Challenger-Resp q)
  simulated-Challenger (query-H q) s = H q s
  simulated-Challenger (query-create-proof w Y) s with L? w Y
  simulated-Challenger (query-create-proof w Y) s | yes p = first just (Simulate Y s)
  simulated-Challenger (query-create-proof w Y) s | no ¬p = nothing , s

  open StatefulRun
  simulated : SimState → Adversary → 𝟚
  simulated s adv = evalS simulated-Challenger adv s

  module _ (ro : Random-Oracle) where

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    real : Adversary → 𝟚
    real adv = run real-Challenger adv

    Experiment : 𝟚 → RS → Adversary → 𝟚
    Experiment 0₂ rs = real
    Experiment 1₂ rs = simulated (init rs)

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : S → ★)
  {RΣP : ★}
  (PF : Proof-System)
  where
  open Proof-System PF

  record Σ-Prover : ★ where
    field
      A : RΣP → (Y : S) → Commitment
      f : RΣP → (Y : S) → (c : Challenge) → Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : S)(A : Commitment)(c : Challenge)
             → Σ-Prf Y → 𝟚

  Correct : Σ-Verifier → Σ-Prover → ★
  Correct v p = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Prover p
    in v Y (A r Y) c (f r Y c) ≡ 1₂

  module Special-Honest-Verifier-Zero-Knowledge
    where

    record shvzk : ★ where

module Simulation-Sound-Extractability
  (PF : Proof-System)
  (sim : Simulator PF)
  where


Fixed doc.

Fixed doc.

Ignore-this: c9cba6e77a2ca004a4b55da3fc2e1bad

darcs-hash:20120620015414-3bd4e-a37101bccd1026e4ec2ea1720b6a25dd66be0c33.gz

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

module Test.Succeed.FOL.VariableNamesClash where

infix  4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set
  a b : D

postulate a≡b : a ≡ b
{-# ATP axiom a≡b #-}

foo : (n : D) → a ≡ b
foo n = prf n
  where
  -- The translation of this postulate must use two diferents
  -- quantified variables names e.g. ∀ x. ∀ y. a ≡ b.
  postulate prf : (n : D) → a ≡ b
  {-# ATP prove prf #-}

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

module Test.Succeed.FOL.VariableNamesClash where

infix  4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set
  a b : D

postulate a≡b : a ≡ b
{-# ATP axiom a≡b #-}

foo : (n : D) → a ≡ b
foo n = prf n
  where
  -- The translation of this postulate must use two diferents
  -- quantified variables names e.g. ∀ x. ∀ y. x ≡ y.
  postulate prf : (n : D) → a ≡ b
  {-# ATP prove prf #-}


Upgrade the some cost models

Upgrade the some cost models

module FunUniverse.Cost where

open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2*_; 2^_; _^_; _⊔_; module ℕ°; module ⊔°; 2*′_)
open import Data.Bool using (true; false)
open import Data.One
import Data.DifferenceNat
import Data.Vec.NP as V
import Function as F
import Data.Product as ×
import Relation.Binary.PropositionalEquality as ≡
open F using (const; _∘′_)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_)
open ≡ using (_≡_; _≗_)
open import Level.NP hiding (_⊔_)

open import Data.Bits using (Bits; 0∷_; 1∷_; _→ᵇ_)

open import FunUniverse.Core
open import FunUniverse.Category
open import FunUniverse.Rewiring.Linear
open import FunUniverse.Const

module D where
  open Data.DifferenceNat public renaming (suc to suc#; _+_ to _+#_)
  _*#_ : ℕ → Diffℕ → Diffℕ
  zero  *# d = 0#
  suc n *# d = (n *# d) +# d
  _*#′_ : ℕ → Diffℕ → Diffℕ
  zero  *#′ d = 0#
  suc n *#′ d = d +# (n *#′ d)
  2*#_ : Diffℕ → Diffℕ
  2*# n = n +# n
  2^#_ : ℕ → Diffℕ
  2^# zero = 1#
  2^# suc n = 2*# (2^# n)
  1+_+_D : Diffℕ → Diffℕ → Diffℕ
  1+ x + y D = 1# ∘′ (x ∘′ y)
open D using (Diffℕ)

private
  1+_+_ : ℕ → ℕ → ℕ
  1+ x + y = 1 + (x + y)
  1+_⊔_ : ℕ → ℕ → ℕ
  1+ x ⊔ y = 1 + (x ⊔ y)
  i⊔i≡i : ∀ i → i ⊔ i ≡ i
  i⊔i≡i zero = ≡.refl
  i⊔i≡i (suc i) = ≡.cong suc (i⊔i≡i i)

{-
seqTimeOpsD : FunOps (constFuns Diffℕ)
seqTimeOpsD = record {
            id = 0#; _∘_ = _∘′_;
            <0b> = 0#; <1b> = 0#; cond = 1#; fork = 1+_+_D; tt = 0#;
            <_,_> = _∘′_; fst = 0#; snd = 0#;
            dup = 0#; first = F.id; swap = 0#; assoc = 0#;
            <tt,id> = 0#; snd<tt,> = 0#;
            <_×_> = _∘′_; second = F.id;
            <[]> = 0#; <∷> = 0#; uncons = 0# }
            where open D

module SeqTimeOpsD where
  Time = Diffℕ
  open D
  open FunOps seqTimeOpsD public

  snoc≡0 : ∀ n → snoc {n} ≗ 0#
  snoc≡0 zero x = ≡.refl
  snoc≡0 (suc n) x rewrite snoc≡0 n x = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≗ 0#
  reverse≡0 zero x = ≡.refl
  reverse≡0 (suc n) x rewrite reverse≡0 n x | snoc≡0 n x = ≡.refl

  replicate≡0 : ∀ n → replicate {n} ≗ 0#
  replicate≡0 zero = λ _ → ≡.refl
  replicate≡0 (suc n) = replicate≡0 n

  constBit≡0 : ∀ b → constBit b ≗ 0#
  constBit≡0 true  {-1b-} _ = ≡.refl
  constBit≡0 false {-0b-} _ = ≡.refl

  sum′ : ∀ {n} → Vec Diffℕ n → Diffℕ
  sum′ = V.foldr (const Diffℕ) _∘′_ id

  constVec≡sum : ∀ {n b} {B : Set b} (f : B → Time) xs → constVec {n} f xs ≗ sum′ (V.map f xs)
  constVec≡sum f [] x = ≡.refl
  constVec≡sum {suc n} f (b ∷ bs) x rewrite ℕ°.+-comm (f b x ⊔ constVec f bs x) 0
                                          | constVec≡sum f bs x = ≡.refl

  constBits≡0 : ∀ {n} xs → constBits {n} xs ≗ 0#
  constBits≡0 [] x = ≡.refl
  constBits≡0 {suc n} (b ∷ bs) x rewrite constBits≡0 bs x
                                       | constBit≡0 b x = ≡.refl

  foldl≡* : ∀ m n → foldl {m} n ≗ m *# n
  foldl≡* zero    n x = ≡.refl
  foldl≡* (suc m) n x rewrite foldl≡* m n (n x) = ≡.refl

  foldr≡* : ∀ m n → foldr {m} n ≗ m *#′ n
  foldr≡* zero    n x = ≡.refl
  foldr≡* (suc m) n x rewrite foldr≡* m n x = ≡.refl

  #nodes : ∀ i → Diffℕ
  #nodes zero    = 0#
  #nodes (suc i) = 1# +# #nodes i +# #nodes i

  fromBitsFun≡ : ∀ {i o} (f : i →ᵇ o) → fromBitsFun f ≗ #nodes i
  fromBitsFun≡ {zero} f x = constBits≡0 (f []) x
  fromBitsFun≡ {suc i} f x rewrite fromBitsFun≡ {i} (f ∘′ 1∷_) x
                                 | fromBitsFun≡ {i} (f ∘′ 0∷_) (#nodes i x) = ≡.refl
-}

Time = ℕ
TimeCost = constFuns Time
Space = ℕ
SpaceCost = constFuns Space

seqTimeCat : Category {₀} {₀} {𝟙} (λ _ _ → Time)
seqTimeCat = 0 , _+_

seqTimeLin : LinRewiring TimeCost
seqTimeLin =
  record {
    cat = seqTimeCat;
    first = F.id;
    swap = 0;
    assoc = 0;
    <tt,id> = 0;
    snd<tt,> = 0;
    <_×_> = _+_;
    second = F.id;
    tt→[] = 0;
    []→tt = 0;
    <∷> = 0;
    uncons = 0 }

seqTimeRewiring : Rewiring TimeCost
seqTimeRewiring =
  record {
    linRewiring = seqTimeLin;
    tt = 0;
    dup = 0;
    <[]> = 0;
    <_,_> = _+_;
    fst = 0;
    snd = 0;
    rewire = const 0;
    rewireTbl = const 0 }

seqTimeFork : HasFork TimeCost
seqTimeFork = record { cond = 1; fork = 1+_+_ }

seqTimeOps : FunOps TimeCost
seqTimeOps = record { rewiring = seqTimeRewiring; hasFork = seqTimeFork;
                      <0b> = 0; <1b> = 0 }

seqTimeBij : Bijective TimeCost
seqTimeBij = FunOps.bijective seqTimeOps

timeCat : Category (λ _ _ → Time)
timeCat = seqTimeCat

timeLin : LinRewiring TimeCost
timeLin =
  record {
    cat = timeCat;
    first = F.id;
    swap = 0;
    assoc = 0;
    <tt,id> = 0;
    snd<tt,> = 0;
    <_×_> = _⊔_;
    second = F.id;
    tt→[] = 0;
    []→tt = 0;
    <∷> = 0;
    uncons = 0 }

timeRewiring : Rewiring TimeCost
timeRewiring =
  record {
    linRewiring = timeLin;
    tt = 0;
    dup = 0;
    <[]> = 0;
    <_,_> = _⊔_;
    fst = 0;
    snd = 0;
    rewire = const 0;
    rewireTbl = const 0 }

timeFork : HasFork TimeCost
timeFork = record { cond = 1; fork = 1+_⊔_ }

timeOps : FunOps TimeCost
timeOps = record { rewiring = timeRewiring; hasFork = timeFork;
                   <0b> = 0; <1b> = 0 }

{-
timeOps≡seqTimeOps : timeOps ≡ record seqTimeOps {
                                rewiring = record seqTimeRewiring {
                                             linRewiring = record seqTimeLin { <_×_> = _⊔_ };
                                             <_,_> = _⊔_};
                                fork = 1+_⊔_ }
                                {-;
                                <∷> = 0; uncons = 0 } -- Without <∷> = 0... this definition makes
                                                       -- the FunOps record def yellow
                                                       -}
timeOps≡seqTimeOps = ≡.refl
-}

{-
open import maxsemiring
open ⊔-+-SemiringSolver
timeOps' : ∀ n → FunOps (constFuns (Polynomial n))
timeOps' n = record {
            id = con 0; _∘_ = _:*_;
            <0b> = con 0; <1b> = con 0; cond = con 1; fork = 1+_+_; tt = con 0;
            <_,_> = _:*_; fst = con 0; snd = con 0;
            dup = con 0; <_×_> = _:+_; swap = con 0; assoc = con 0;
            <tt,id> = con 0; snd<tt,> = con 0;
            <[]> = con 0; <∷> = con 0; uncons = con 0 }
   where 1+_+_ : Polynomial n → Polynomial n → Polynomial n
         1+ x + y = con 1 :* (x :* y)

Module TimeOps' where
  Time = ℕ
  open FunOps (timeOps' 1) public

  snoc≡0 : ∀ n → snoc {n} := con 0
  snoc≡0 zero = ?
  snoc≡0 (suc n) = ?
-}

module TimeOps where
  open FunOps timeOps public

  snoc≡0 : ∀ n → snoc {n} ≡ 0
  snoc≡0 zero = ≡.refl
  snoc≡0 (suc n) rewrite snoc≡0 n = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≡ 0
  reverse≡0 zero = ≡.refl
  reverse≡0 (suc n) rewrite snoc≡0 n | reverse≡0 n = ≡.refl

  foldl≡* : ∀ m n → foldl {m} n ≡ m * n
  foldl≡* zero n = ≡.refl
  foldl≡* (suc m) n rewrite foldl≡* m n
                          | ⊔°.+-comm n 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n) n
                          = ≡.refl

  replicate≡0 : ∀ n → replicate {n} ≡ 0
  replicate≡0 zero = ≡.refl
  replicate≡0 (suc n) = replicate≡0 n

  constBit≡0 : ∀ b → constBit b ≡ 0
  constBit≡0 true  = ≡.refl
  constBit≡0 false = ≡.refl

  maximum : ∀ {n} → Vec ℕ n → ℕ
  maximum = V.foldr (const ℕ) (λ {_} x y → x ⊔ y) 0

  constVec⊤≡maximum : ∀ {n b} {B : Set b} (f : B → Time) xs → constVec⊤ {n} f xs ≡ maximum (V.map f xs)
  constVec⊤≡maximum f [] = ≡.refl
  constVec⊤≡maximum {suc n} f (b ∷ bs) rewrite ℕ°.+-comm (f b ⊔ constVec⊤ f bs) 0
                                              | constVec⊤≡maximum f bs = ≡.refl

  constBits≡0 : ∀ {n} xs → constBits {n} xs ≡ 0
  constBits≡0 [] = ≡.refl
  constBits≡0 {suc n} (b ∷ bs) rewrite constBit≡0 b
                                     | constBits≡0 bs = ≡.refl

  fromBitsFun≡i : ∀ {i o} (f : i →ᵇ o) → fromBitsFun f ≡ i
  fromBitsFun≡i {zero}  f rewrite constBits≡0 (f []) = ≡.refl
  fromBitsFun≡i {suc i} f rewrite fromBitsFun≡i {i} (f ∘′ 1∷_)
                                | fromBitsFun≡i {i} (f ∘′ 0∷_)
                                | ℕ°.+-comm (i ⊔ i) 0
                                = ≡.cong suc (i⊔i≡i i)

                                {-
spaceLin : LinRewiring SpaceCost
spaceLin =
  record {
    id = 0;
    _∘_ = _+_;
    first = F.id;
    swap = 0;
    assoc = 0;
    <tt,id> = 0;
    snd<tt,> = 0;
    <_×_> = _+_;
    second = F.id;
    tt→[] = 0;
    []→tt = 0;
    <∷> = 0;
    uncons = 0 }

spaceLin≡seqTimeLin : spaceLin ≡ seqTimeLin
spaceLin≡seqTimeLin = ≡.refl

spaceRewiring : Rewiring TimeCost
spaceRewiring =
  record {
    linRewiring = spaceLin;
    tt = 0;
    dup = 1;
    <[]> = 0;
    <_,_> = 1+_+_;
    fst = 0;
    snd = 0;
    rewire = λ {_} {o} _ → o;
    rewireTbl = λ {_} {o} _ → o }

spaceFork : HasFork SpaceCost
spaceFork = record { cond = 1; fork = 1+_+_ }

spaceOps : FunOps SpaceCost
spaceOps = record { rewiring = spaceRewiring; hasFork = spaceFork;
                    <0b> = 1; <1b> = 1 }

             {-
-- So far the space cost model is like the sequential time cost model but makes <0b>,<1b>,dup
-- cost one unit of space.
spaceOps≡seqTimeOps : spaceOps ≡ record seqTimeOps { <0b> = 1; <1b> = 1; dup = 1; <_,_> = 1+_+_
                                                    ; <∷> = 0; uncons = 0 } -- same bug here
spaceOps≡seqTimeOps = ≡.refl
-}

module SpaceOps where
  open FunOps spaceOps public

  snoc≡0 : ∀ n → snoc {n} ≡ 0
  snoc≡0 zero = ≡.refl
  snoc≡0 (suc n) rewrite snoc≡0 n = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≡ 0
  reverse≡0 zero = ≡.refl
  reverse≡0 (suc n) rewrite snoc≡0 n | reverse≡0 n = ≡.refl

  foldl≡* : ∀ m n → foldl {m} n ≡ m * n
  foldl≡* zero n = ≡.refl
  foldl≡* (suc m) n rewrite foldl≡* m n
                          | ℕ°.+-comm n 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n) n
                          = ≡.refl

  replicate≡n : ∀ n → replicate {n} ≡ n
  replicate≡n zero = ≡.refl
  replicate≡n (suc n) rewrite replicate≡n n = ≡.refl

  constBit≡1 : ∀ b → constBit b ≡ 1
  constBit≡1 true  = ≡.refl
  constBit≡1 false = ≡.refl

  constVec⊤≡sum : ∀ {n b} {B : Set b} (f : B → Space) xs → constVec⊤ {n} f xs ≡ V.sum (V.map f xs)
  constVec⊤≡sum f [] = ≡.refl
  constVec⊤≡sum {suc n} f (b ∷ bs) rewrite ℕ°.+-comm (f b + constVec⊤ f bs) 0
                                          | constVec⊤≡sum f bs = ≡.refl

  constVec≡sum : ∀ {n b} {B : Set b} (f : B → Space) xs → constVec {n} f xs ≡ V.sum (V.map f xs)
  constVec≡sum f xs rewrite constVec⊤≡sum f xs | ℕ°.+-comm (V.sum (V.map f xs)) 0 = ≡.refl

  constBits≡n : ∀ {n} xs → constBits {n} xs ≡ n
  constBits≡n [] = ≡.refl
  constBits≡n {suc n} (b ∷ bs) rewrite constBit≡1 b
                                     | constBits≡n bs
                                     | ℕ°.+-comm n 0 = ≡.refl

  fromBitsFun-cost : ∀ (i o : ℕ) → ℕ
  fromBitsFun-cost zero    o = o
  fromBitsFun-cost (suc i) o = 1 + 2*(fromBitsFun-cost i o)

  fromBitsFun≡ : ∀ {i o} (f : i →ᵇ o) → fromBitsFun f ≡ fromBitsFun-cost i o
  fromBitsFun≡ {zero}  {o} f rewrite constBits≡n (f []) | ℕ°.+-comm o 0 = ≡.refl
  fromBitsFun≡ {suc i} {o} f rewrite fromBitsFun≡ {i} (f ∘′ 1∷_)
                                   | fromBitsFun≡ {i} (f ∘′ 0∷_)
                                   | ℕ°.+-comm (2* (fromBitsFun-cost i o)) 0
                                   = ≡.refl

{-
time×spaceOps : FunOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-Ops timeOps spaceOps

module Time×SpaceOps = FunOps time×spaceOps
-}
-- -}
-- -}
-- -}
-- -}

module FunUniverse.Cost where

open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_; 2*_; 2^_; _^_; _⊔_; module ℕ°; module ⊔°; 2*′_)
open import Data.Bool using (true; false)
import Data.DifferenceNat
import Data.Vec.NP as V
import Function as F
import Data.Product as ×
import Relation.Binary.PropositionalEquality as ≡
open F using (const; _∘′_)
open V using (Vec; []; _∷_; _++_; [_])
open × using (_×_)
open ≡ using (_≡_; _≗_)

open import Data.Bits using (Bits; 0∷_; 1∷_; _→ᵇ_)

open import FunUniverse.Core
open import FunUniverse.Const

module D where
  open Data.DifferenceNat public renaming (suc to suc#; _+_ to _+#_)
  _*#_ : ℕ → Diffℕ → Diffℕ
  zero  *# d = 0#
  suc n *# d = (n *# d) +# d
  _*#′_ : ℕ → Diffℕ → Diffℕ
  zero  *#′ d = 0#
  suc n *#′ d = d +# (n *#′ d)
  2*#_ : Diffℕ → Diffℕ
  2*# n = n +# n
  2^#_ : ℕ → Diffℕ
  2^# zero = 1#
  2^# suc n = 2*# (2^# n)
  1+_+_D : Diffℕ → Diffℕ → Diffℕ
  1+ x + y D = 1# ∘′ (x ∘′ y)
open D using (Diffℕ)

private
  1+_+_ : ℕ → ℕ → ℕ
  1+ x + y = 1 + (x + y)
  1+_⊔_ : ℕ → ℕ → ℕ
  1+ x ⊔ y = 1 + (x ⊔ y)
  i⊔i≡i : ∀ i → i ⊔ i ≡ i
  i⊔i≡i zero = ≡.refl
  i⊔i≡i (suc i) = ≡.cong suc (i⊔i≡i i)

{-
seqTimeOpsD : FunOps (constFuns Diffℕ)
seqTimeOpsD = record {
            id = 0#; _∘_ = _∘′_;
            <0b> = 0#; <1b> = 0#; cond = 1#; fork = 1+_+_D; tt = 0#;
            <_,_> = _∘′_; fst = 0#; snd = 0#;
            dup = 0#; first = F.id; swap = 0#; assoc = 0#;
            <tt,id> = 0#; snd<tt,> = 0#;
            <_×_> = _∘′_; second = F.id;
            <[]> = 0#; <∷> = 0#; uncons = 0# }
            where open D

module SeqTimeOpsD where
  Time = Diffℕ
  open D
  open FunOps seqTimeOpsD public

  snoc≡0 : ∀ n → snoc {n} ≗ 0#
  snoc≡0 zero x = ≡.refl
  snoc≡0 (suc n) x rewrite snoc≡0 n x = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≗ 0#
  reverse≡0 zero x = ≡.refl
  reverse≡0 (suc n) x rewrite reverse≡0 n x | snoc≡0 n x = ≡.refl

  replicate≡0 : ∀ n → replicate {n} ≗ 0#
  replicate≡0 zero = λ _ → ≡.refl
  replicate≡0 (suc n) = replicate≡0 n

  constBit≡0 : ∀ b → constBit b ≗ 0#
  constBit≡0 true  {-1b-} _ = ≡.refl
  constBit≡0 false {-0b-} _ = ≡.refl

  sum′ : ∀ {n} → Vec Diffℕ n → Diffℕ
  sum′ = V.foldr (const Diffℕ) _∘′_ id

  constVec≡sum : ∀ {n b} {B : Set b} (f : B → Time) xs → constVec {n} f xs ≗ sum′ (V.map f xs)
  constVec≡sum f [] x = ≡.refl
  constVec≡sum {suc n} f (b ∷ bs) x rewrite ℕ°.+-comm (f b x ⊔ constVec f bs x) 0
                                          | constVec≡sum f bs x = ≡.refl

  constBits≡0 : ∀ {n} xs → constBits {n} xs ≗ 0#
  constBits≡0 [] x = ≡.refl
  constBits≡0 {suc n} (b ∷ bs) x rewrite constBits≡0 bs x
                                       | constBit≡0 b x = ≡.refl

  foldl≡* : ∀ m n → foldl {m} n ≗ m *# n
  foldl≡* zero    n x = ≡.refl
  foldl≡* (suc m) n x rewrite foldl≡* m n (n x) = ≡.refl

  foldr≡* : ∀ m n → foldr {m} n ≗ m *#′ n
  foldr≡* zero    n x = ≡.refl
  foldr≡* (suc m) n x rewrite foldr≡* m n x = ≡.refl

  #nodes : ∀ i → Diffℕ
  #nodes zero    = 0#
  #nodes (suc i) = 1# +# #nodes i +# #nodes i

  fromBitsFun≡ : ∀ {i o} (f : i →ᵇ o) → fromBitsFun f ≗ #nodes i
  fromBitsFun≡ {zero} f x = constBits≡0 (f []) x
  fromBitsFun≡ {suc i} f x rewrite fromBitsFun≡ {i} (f ∘′ 1∷_) x
                                 | fromBitsFun≡ {i} (f ∘′ 0∷_) (#nodes i x) = ≡.refl
-}

Time = ℕ
TimeCost = constFuns Time
Space = ℕ
SpaceCost = constFuns Space

seqTimeLin : LinRewiring TimeCost
seqTimeLin =
  record {
    id = 0;
    _∘_ = _+_;
    first = F.id;
    swap = 0;
    assoc = 0;
    <tt,id> = 0;
    snd<tt,> = 0;
    <_×_> = _+_;
    second = F.id;
    tt→[] = 0;
    []→tt = 0;
    <∷> = 0;
    uncons = 0 }

seqTimeRewiring : Rewiring TimeCost
seqTimeRewiring =
  record {
    linRewiring = seqTimeLin;
    tt = 0;
    dup = 0;
    <[]> = 0;
    <_,_> = _+_;
    fst = 0;
    snd = 0;
    rewire = const 0;
    rewireTbl = const 0 }

seqTimeFork : HasFork TimeCost
seqTimeFork = record { cond = 1; fork = 1+_+_ }

seqTimeOps : FunOps TimeCost
seqTimeOps = record { rewiring = seqTimeRewiring; hasFork = seqTimeFork;
                      <0b> = 0; <1b> = 0 }

seqTimeBij : Bijective TimeCost
seqTimeBij = FunOps.bijective seqTimeOps

timeLin : LinRewiring TimeCost
timeLin =
  record {
    id = 0;
    _∘_ = _+_;
    first = F.id;
    swap = 0;
    assoc = 0;
    <tt,id> = 0;
    snd<tt,> = 0;
    <_×_> = _⊔_;
    second = F.id;
    tt→[] = 0;
    []→tt = 0;
    <∷> = 0;
    uncons = 0 }

timeRewiring : Rewiring TimeCost
timeRewiring =
  record {
    linRewiring = timeLin;
    tt = 0;
    dup = 0;
    <[]> = 0;
    <_,_> = _⊔_;
    fst = 0;
    snd = 0;
    rewire = const 0;
    rewireTbl = const 0 }

timeFork : HasFork TimeCost
timeFork = record { cond = 1; fork = 1+_⊔_ }

timeOps : FunOps TimeCost
timeOps = record { rewiring = timeRewiring; hasFork = timeFork;
                   <0b> = 0; <1b> = 0 }

{-
timeOps≡seqTimeOps : timeOps ≡ record seqTimeOps {
                                rewiring = record seqTimeRewiring {
                                             linRewiring = record seqTimeLin { <_×_> = _⊔_ };
                                             <_,_> = _⊔_};
                                fork = 1+_⊔_ }
                                {-;
                                <∷> = 0; uncons = 0 } -- Without <∷> = 0... this definition makes
                                                       -- the FunOps record def yellow
                                                       -}
timeOps≡seqTimeOps = ≡.refl
-}

{-
open import maxsemiring
open ⊔-+-SemiringSolver
timeOps' : ∀ n → FunOps (constFuns (Polynomial n))
timeOps' n = record {
            id = con 0; _∘_ = _:*_;
            <0b> = con 0; <1b> = con 0; cond = con 1; fork = 1+_+_; tt = con 0;
            <_,_> = _:*_; fst = con 0; snd = con 0;
            dup = con 0; <_×_> = _:+_; swap = con 0; assoc = con 0;
            <tt,id> = con 0; snd<tt,> = con 0;
            <[]> = con 0; <∷> = con 0; uncons = con 0 }
   where 1+_+_ : Polynomial n → Polynomial n → Polynomial n
         1+ x + y = con 1 :* (x :* y)

Module TimeOps' where
  Time = ℕ
  open FunOps (timeOps' 1) public

  snoc≡0 : ∀ n → snoc {n} := con 0
  snoc≡0 zero = ?
  snoc≡0 (suc n) = ?
-}

module TimeOps where
  open FunOps timeOps public

  snoc≡0 : ∀ n → snoc {n} ≡ 0
  snoc≡0 zero = ≡.refl
  snoc≡0 (suc n) rewrite snoc≡0 n = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≡ 0
  reverse≡0 zero = ≡.refl
  reverse≡0 (suc n) rewrite snoc≡0 n | reverse≡0 n = ≡.refl

  foldl≡* : ∀ m n → foldl {m} n ≡ m * n
  foldl≡* zero n = ≡.refl
  foldl≡* (suc m) n rewrite foldl≡* m n
                          | ⊔°.+-comm n 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n) n
                          = ≡.refl

  replicate≡0 : ∀ n → replicate {n} ≡ 0
  replicate≡0 zero = ≡.refl
  replicate≡0 (suc n) = replicate≡0 n

  constBit≡0 : ∀ b → constBit b ≡ 0
  constBit≡0 true  = ≡.refl
  constBit≡0 false = ≡.refl

  maximum : ∀ {n} → Vec ℕ n → ℕ
  maximum = V.foldr (const ℕ) (λ {_} x y → x ⊔ y) 0

  constVec⊤≡maximum : ∀ {n b} {B : Set b} (f : B → Time) xs → constVec⊤ {n} f xs ≡ maximum (V.map f xs)
  constVec⊤≡maximum f [] = ≡.refl
  constVec⊤≡maximum {suc n} f (b ∷ bs) rewrite ℕ°.+-comm (f b ⊔ constVec⊤ f bs) 0
                                              | constVec⊤≡maximum f bs = ≡.refl

  constBits≡0 : ∀ {n} xs → constBits {n} xs ≡ 0
  constBits≡0 [] = ≡.refl
  constBits≡0 {suc n} (b ∷ bs) rewrite constBit≡0 b
                                     | constBits≡0 bs = ≡.refl

  fromBitsFun≡i : ∀ {i o} (f : i →ᵇ o) → fromBitsFun f ≡ i
  fromBitsFun≡i {zero}  f rewrite constBits≡0 (f []) = ≡.refl
  fromBitsFun≡i {suc i} f rewrite fromBitsFun≡i {i} (f ∘′ 1∷_)
                                | fromBitsFun≡i {i} (f ∘′ 0∷_)
                                | ℕ°.+-comm (i ⊔ i) 0
                                = ≡.cong suc (i⊔i≡i i)

spaceLin : LinRewiring SpaceCost
spaceLin =
  record {
    id = 0;
    _∘_ = _+_;
    first = F.id;
    swap = 0;
    assoc = 0;
    <tt,id> = 0;
    snd<tt,> = 0;
    <_×_> = _+_;
    second = F.id;
    tt→[] = 0;
    []→tt = 0;
    <∷> = 0;
    uncons = 0 }

spaceLin≡seqTimeLin : spaceLin ≡ seqTimeLin
spaceLin≡seqTimeLin = ≡.refl

spaceRewiring : Rewiring TimeCost
spaceRewiring =
  record {
    linRewiring = spaceLin;
    tt = 0;
    dup = 1;
    <[]> = 0;
    <_,_> = 1+_+_;
    fst = 0;
    snd = 0;
    rewire = λ {_} {o} _ → o;
    rewireTbl = λ {_} {o} _ → o }

spaceFork : HasFork SpaceCost
spaceFork = record { cond = 1; fork = 1+_+_ }

spaceOps : FunOps SpaceCost
spaceOps = record { rewiring = spaceRewiring; hasFork = spaceFork;
                    <0b> = 1; <1b> = 1 }

             {-
-- So far the space cost model is like the sequential time cost model but makes <0b>,<1b>,dup
-- cost one unit of space.
spaceOps≡seqTimeOps : spaceOps ≡ record seqTimeOps { <0b> = 1; <1b> = 1; dup = 1; <_,_> = 1+_+_
                                                    ; <∷> = 0; uncons = 0 } -- same bug here
spaceOps≡seqTimeOps = ≡.refl
-}

module SpaceOps where
  open FunOps spaceOps public

  snoc≡0 : ∀ n → snoc {n} ≡ 0
  snoc≡0 zero = ≡.refl
  snoc≡0 (suc n) rewrite snoc≡0 n = ≡.refl

  reverse≡0 : ∀ n → reverse {n} ≡ 0
  reverse≡0 zero = ≡.refl
  reverse≡0 (suc n) rewrite snoc≡0 n | reverse≡0 n = ≡.refl

  foldl≡* : ∀ m n → foldl {m} n ≡ m * n
  foldl≡* zero n = ≡.refl
  foldl≡* (suc m) n rewrite foldl≡* m n
                          | ℕ°.+-comm n 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n + n) 0
                          | ℕ°.+-comm (m * n) n
                          = ≡.refl

  replicate≡n : ∀ n → replicate {n} ≡ n
  replicate≡n zero = ≡.refl
  replicate≡n (suc n) rewrite replicate≡n n = ≡.refl

  constBit≡1 : ∀ b → constBit b ≡ 1
  constBit≡1 true  = ≡.refl
  constBit≡1 false = ≡.refl

  constVec⊤≡sum : ∀ {n b} {B : Set b} (f : B → Space) xs → constVec⊤ {n} f xs ≡ V.sum (V.map f xs)
  constVec⊤≡sum f [] = ≡.refl
  constVec⊤≡sum {suc n} f (b ∷ bs) rewrite ℕ°.+-comm (f b + constVec⊤ f bs) 0
                                          | constVec⊤≡sum f bs = ≡.refl

  constVec≡sum : ∀ {n b} {B : Set b} (f : B → Space) xs → constVec {n} f xs ≡ V.sum (V.map f xs)
  constVec≡sum f xs rewrite constVec⊤≡sum f xs | ℕ°.+-comm (V.sum (V.map f xs)) 0 = ≡.refl

  constBits≡n : ∀ {n} xs → constBits {n} xs ≡ n
  constBits≡n [] = ≡.refl
  constBits≡n {suc n} (b ∷ bs) rewrite constBit≡1 b
                                     | constBits≡n bs
                                     | ℕ°.+-comm n 0 = ≡.refl

  fromBitsFun-cost : ∀ (i o : ℕ) → ℕ
  fromBitsFun-cost zero    o = o
  fromBitsFun-cost (suc i) o = 1 + 2*(fromBitsFun-cost i o)

  fromBitsFun≡ : ∀ {i o} (f : i →ᵇ o) → fromBitsFun f ≡ fromBitsFun-cost i o
  fromBitsFun≡ {zero}  {o} f rewrite constBits≡n (f []) | ℕ°.+-comm o 0 = ≡.refl
  fromBitsFun≡ {suc i} {o} f rewrite fromBitsFun≡ {i} (f ∘′ 1∷_)
                                   | fromBitsFun≡ {i} (f ∘′ 0∷_)
                                   | ℕ°.+-comm (2* (fromBitsFun-cost i o)) 0
                                   = ≡.refl

{-
time×spaceOps : FunOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-Ops timeOps spaceOps

module Time×SpaceOps = FunOps time×spaceOps
-}


Resolve implicit arguments.

Resolve implicit arguments.

When I filled the last hole in total.agda in the previous commit,
Agda told me to 'resolve implicit argument', so I added explicit
implicit arguments until Agda was satisfied. I don't know whether
or why it matters to do this.

Old-commit-hash: ed138bd06659ab2caac47a670b7d3d60c4d97f3a

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

open import Relation.Binary.PropositionalEquality

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

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

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → (t : Term Γ₁ τ) →
  Δ {{Γ′}} t ≈ derive-term {{Γ′}} t
derive-term-correct {Γ₁} {{Γ′}} (abs {τ} t) =
  begin
     Δ {{Γ′}} (abs t)
  ≈⟨  Δ-abs {{Γ′}} t  ⟩
     abs (abs (Δ {τ • Γ₁} {{Γ″}} t))
  ≈⟨  ≈-abs (≈-abs (derive-term-correct {τ • Γ₁} {{Γ″}} t))  ⟩
     abs (abs (derive-term {τ • Γ₁} {{Γ″}} t))
  ≡⟨⟩
     derive-term {{Γ′}} (abs t)
  ∎ where
      open ≈-Reasoning
      Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term-correct {Γ₁} {{Γ′}} (app t₁ t₂) =
  begin
    Δ {{Γ′}} (app t₁ t₂)
  ≈⟨  Δ-app {{Γ′}} t₁ t₂  ⟩
     app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
  ≈⟨  ≈-app (≈-app (derive-term-correct {{Γ′}} t₁) ≈-refl) (derive-term-correct {{Γ′}} t₂)  ⟩
     app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
  ≡⟨⟩
    derive-term {{Γ′}} (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct {Γ₁} {{Γ′}} (var x) = ext-t (λ ρ →
  begin
    ⟦ Δ {{Γ′}} (var x) ⟧ ρ
  ≡⟨⟩
    diff
      (⟦ x ⟧ (update (⟦ Γ′ ⟧ ρ)))
      (⟦ x ⟧ (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨  derive-var-correct {Γ₁} (⟦ Γ′ ⟧ ρ) x  ⟩
    ⟦ derive-var x ⟧Var (⟦ Γ′ ⟧ ρ)
  ≡⟨ sym (lift-sound Γ′ (derive-var x) ρ) ⟩
    ⟦ lift Γ′ (derive-var x) ⟧Var ρ
  ∎) where open ≡-Reasoning
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct {{Γ′}} (if t₁ t₂ t₃) =
  begin
    Δ (if t₁ t₂ t₃)
  ≈⟨ Δ-if {{Γ′}} t₁ t₂ t₃ ⟩
    if (Δ t₁)
       (if (lift-term {{Γ′}} t₁)
           (diff-term (apply-term (Δ {{Γ′}} t₃) (lift-term {{Γ′}} t₃)) (lift-term {{Γ′}} t₂))
           (diff-term (apply-term (Δ {{Γ′}} t₂) (lift-term {{Γ′}} t₂)) (lift-term {{Γ′}} t₃)))
       (if (lift-term {{Γ′}} t₁)
           (Δ {{Γ′}} t₂)
           (Δ {{Γ′}} t₃))
  ≈⟨ ≈-if (derive-term-correct {{Γ′}} t₁)
          (≈-if (≈-refl)
                (≈-diff-term (≈-apply-term (derive-term-correct {{Γ′}} t₃) ≈-refl) ≈-refl)
                (≈-diff-term (≈-apply-term (derive-term-correct {{Γ′}} t₂) ≈-refl) ≈-refl))
          (≈-if (≈-refl)
                (derive-term-correct {{Γ′}} t₂)
                (derive-term-correct {{Γ′}} t₃)) ⟩
    if (derive-term {{Γ′}} t₁)
       (if (lift-term {{Γ′}} t₁)
           (diff-term (apply-term (derive-term {{Γ′}} t₃) (lift-term {{Γ′}} t₃)) (lift-term {{Γ′}} t₂))
           (diff-term (apply-term (derive-term {{Γ′}} t₂) (lift-term {{Γ′}} t₂)) (lift-term {{Γ′}} t₃)))
       (if (lift-term {{Γ′}} t₁)
           (derive-term {{Γ′}} t₂)
           (derive-term {{Γ′}} t₃))
  ≡⟨⟩
    derive-term {{Γ′}} (if t₁ t₂ t₃)
  ∎ where open ≈-Reasoning

derive-term-correct {{Γ′}} (Δ {{Γ″}} t) = ≈-Δ {{Γ′}} (derive-term-correct {{Γ″}} t)

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Note that Δ is *not* the same as the ∂ operator in
-- definition/intro.tex. See discussion at:
--
--   https://github.com/ps-mr/ilc/pull/34#discussion_r4290325
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

open import Relation.Binary.PropositionalEquality

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

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

open import Changes
open import ChangeContexts
open import ChangeContextLifting
open import PropsDelta
open import SymbolicDerivation

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ₁ Γ₂ τ} → {{Γ′ : Δ-Context Γ₁ ≼ Γ₂}} → (t : Term Γ₁ τ) →
  Δ {{Γ′}} t ≈ derive-term {{Γ′}} t
derive-term-correct {Γ₁} {{Γ′}} (abs {τ} t) =
  begin
     Δ (abs t)
  ≈⟨  Δ-abs t  ⟩
     abs (abs (Δ {τ • Γ₁} t))
  ≈⟨  ≈-abs (≈-abs (derive-term-correct {τ • Γ₁} t))  ⟩
     abs (abs (derive-term {τ • Γ₁} t))
  ≡⟨⟩
     derive-term (abs t)
  ∎ where
      open ≈-Reasoning
      Γ″ = keep Δ-Type τ • keep τ • Γ′
derive-term-correct {Γ₁} {{Γ′}} (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨  Δ-app t₁ t₂  ⟩
     app (app (Δ {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (Δ {{Γ′}} t₂)
  ≈⟨  ≈-app (≈-app (derive-term-correct {{Γ′}} t₁) ≈-refl) (derive-term-correct {{Γ′}} t₂)  ⟩
     app (app (derive-term {{Γ′}} t₁) (lift-term {{Γ′}} t₂)) (derive-term {{Γ′}} t₂)
  ≡⟨⟩
    derive-term {{Γ′}} (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct {Γ₁} {{Γ′}} (var x) = ext-t (λ ρ →
  begin
    ⟦ Δ {{Γ′}} (var x) ⟧ ρ
  ≡⟨⟩
    diff
      (⟦ x ⟧ (update (⟦ Γ′ ⟧ ρ)))
      (⟦ x ⟧ (ignore (⟦ Γ′ ⟧ ρ)))
  ≡⟨  derive-var-correct {Γ₁} (⟦ Γ′ ⟧ ρ) x  ⟩
    ⟦ derive-var x ⟧Var (⟦ Γ′ ⟧ ρ)
  ≡⟨ sym (lift-sound Γ′ (derive-var x) ρ) ⟩
    ⟦ lift Γ′ (derive-var x) ⟧Var ρ
  ∎) where open ≡-Reasoning
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct {{Γ′}} (if t₁ t₂ t₃) =
  begin
    Δ (if t₁ t₂ t₃)
  ≈⟨ Δ-if {{Γ′}} t₁ t₂ t₃ ⟩
    if (Δ t₁)
       (if (lift-term {{Γ′}} t₁)
           (diff-term (apply-term (Δ t₃) (lift-term {{Γ′}} t₃)) (lift-term {{Γ′}} t₂))
           (diff-term (apply-term (Δ t₂) (lift-term {{Γ′}} t₂)) (lift-term {{Γ′}} t₃)))
       (if (lift-term {{Γ′}} t₁)
           (Δ t₂)
           (Δ t₃))
  ≈⟨ ≈-if (derive-term-correct t₁)
          (≈-if (≈-refl)
                (≈-diff-term (≈-apply-term (derive-term-correct t₃) ≈-refl) ≈-refl)
                (≈-diff-term (≈-apply-term (derive-term-correct t₂) ≈-refl) ≈-refl))
          (≈-if (≈-refl)
                (derive-term-correct t₂)
                (derive-term-correct t₃)) ⟩
    if (derive-term t₁)
       (if (lift-term {{Γ′}} t₁)
           (diff-term (apply-term (derive-term t₃) (lift-term {{Γ′}} t₃)) (lift-term {{Γ′}} t₂))
           (diff-term (apply-term (derive-term t₂) (lift-term {{Γ′}} t₂)) (lift-term {{Γ′}} t₃)))
       (if (lift-term {{Γ′}} t₁)
           (derive-term t₂)
           (derive-term t₃))
  ≡⟨⟩
    derive-term (if t₁ t₂ t₃)
  ∎ where open ≈-Reasoning

derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)