Param: Take advantage of the latest dev version of Agda works better

open import Function
open import Opaque
open import Type
open import Data.Zero
open import Data.One hiding (_≟_)
open import Data.Two hiding (_≟_)
open import Data.Two.Logical
open import Data.Nat hiding (_≟_)
open import Data.Fin using (Fin; zero; suc; toℕ)
open import Data.Vec using (Vec; []; _∷_; replicate; tabulate; allFin; reverse; _⊛_; toList) renaming (map to vmap)
open import Data.Nat.Logical hiding (_≟_) renaming (zero to ⟦zero⟧; suc to ⟦suc⟧)
open import Data.List hiding (replicate; reverse)
open import Data.Sum.NP
open import Reflection.NP
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open import Relation.Nullary.NP
open import Relation.Binary.PropositionalEquality.NP

module Param where

module Revelator (tyH : Type) where
    tm : Term → ℕ → Args → Term
    tm (pi (arg (arg-info v _) t₁) (el _ t₂)) y as = lam visible (tm t₂ (suc y) (mapVarArgs suc as ++ argʳ v (var 0 []) ∷ []))
    tm (var x args) = var
    tm (def f args) = var
    tm (sort s)     = var
    tm unknown _ _ = unknown
    tm (con c args) _ _ = opaque "revealator/tm/con: impossible" unknown
    tm (lam v ty) _ _ = opaque "revealator/tm/lam: impossible" unknown
    tm (lit l) _ _ = opaque "revealator/tm/lit: impossible" unknown
    tm (pat-lam cs args) _ _ = opaque "revealator/tm/pat-lam: TODO" unknown
    tÿpe : Type
    tÿpe = tyH `→ᵛʳ Reveal-args.tÿpe tyH
    term : Term
    term = lam visible (tm (unEl tyH) 0 [])
    fun : FunctionDef
    fun = fun-def tÿpe (clause (argᵛʳ var ∷ []) (tm (unEl tyH) 0 []) ∷ [])

data VarKind (n : ℕ) : Set where
  Kᵢ : Fin n → VarKind n
  Kᵣ : VarKind n

record Env (n : ℕ)(A B : Set) : Set where
  field
    pVar : VarKind n → A → B
    pCon : Name → Name
    pDef : Name → Name
open Env

Env' = λ n → Env n ℕ ℕ

ε : ∀ n → Env' n
ε n = record { pVar = λ _ _ → opaque "ε.pVar" 0
             ; pCon = const (opaque "ε.pCon" (quote ε))
             ; pDef = const (opaque "ε.pDef" (quote ε)) }

extDefEnv : ((Name → Name) → (Name → Name)) → ∀ {n A B} → Env n A B → Env n A B
extDefEnv ext Γ = record Γ { pDef = ext (pDef Γ) }

ext1DefEnv : (old new : Name) → ∀ {n A B} → Env n A B → Env n A B
ext1DefEnv old new = extDefEnv (λ f x → [yes: (λ _ → new) no: (λ _ → f x) ]′ (x ≟-Name old))

↑pVar : ℕ → (ℕ → ℕ) → (ℕ → ℕ)
↑pVar zero = id
↑pVar (suc n) = ↑pVar n ∘ mapVar↑

on-pVar : ∀ {n A B C D} → (VarKind n → (A → B) → (C → D)) → Env n A B → Env n C D
on-pVar f Γ = record
  { pVar = λ k → f k (pVar Γ k)
  ; pCon = pCon Γ
  ; pDef = pDef Γ }

_+↑ : ∀ {n} → Env' n → Env' n
_+↑ {n} = on-pVar goK
  where
    goK : VarKind n → (ℕ → ℕ) → (ℕ → ℕ)
    goK (Kᵢ x) f = _+_ (n ∸ toℕ x) ∘ ↑pVar 1 (_+_ (toℕ x) ∘ f)
    goK Kᵣ     f = ↑pVar 1 (_+_ n ∘ f)

_+'_ : ∀ {w} → Env' w → ℕ → Env' w
Γ +' n = record { pVar = λ k → _+_ n ∘ pVar Γ k ; pCon = pCon Γ ; pDef = pDef Γ }

_+1 : ∀ {w} → Env' w → Env' w
Γ +1 = Γ +' 1

pattern `⟦zero⟧  = con (quote ⟦ℕ⟧.zero) []
pattern `⟦suc⟧ t = con (quote ⟦ℕ⟧.suc) (argᵛʳ t ∷ [])
pNat : ℕ → Term
pNat zero    = `⟦zero⟧
pNat (suc n) = `⟦suc⟧ (pNat n)

lam^ : ℕ → Visibility → Term → Term
lam^ zero    v x = x
lam^ (suc n) v x = lam v (lam^ n v x)

lam∈ : ∀ {n} → Env' n → (f : Env' n → Vec Term n → Term) → Term
lam∈ {n} Γ f = lam^ n visible (f (Γ +' n) (reverse (tabulate (λ x → var (toℕ x) []))))

app-tabulate : ∀ {n a} {A : Set a} → (Fin n → A) → List A → List A
app-tabulate {zero}  f xs = xs
app-tabulate {suc n} f xs = f zero ∷ app-tabulate (f ∘ suc) xs

p^args : ∀ {n A} → Relevance → (Fin n → A) → A → List (Arg A) → List (Arg A)
p^args r f x args = app-tabulate (λ k → argʰ r (f k)) (argᵛʳ x ∷ args)

p^lam : ℕ → Term → Term
p^lam n t = lam^ n hidden (lam visible t)

{-
pi^ : ℕ → Arg Type → Type → Type
pi^ zero    i t = t
pi^ (suc n) i t = `Π i (pi^ n i t)
-}

allVarsFrom : ∀ n → ℕ → Vec Term n
allVarsFrom zero    k = []
allVarsFrom (suc n) k = var (k + n) [] ∷ allVarsFrom n k

p3pi∈ : ∀ {n} (Γ : Env' n) (r : Relevance)
          (s : Type)
          (t : Env' n → Vec Term n → Type)
          (u : Env' n → Vec Term n → Type) → Term
p3pi∈ {n} Γ r s t u = unEl (go Γ (allFin n))
  where
  go : ∀ {m} → Env' n → Vec (Fin n) m → Type
  go Δ [] =
      `Πᵛʳ (t Δ (allVarsFrom n 0)) (u (Γ +↑) (allVarsFrom n 1))
  go Δ (x ∷ xs) =
      `Π (argʰ r (mapVarType (pVar Δ (Kᵢ x)) s))
         (go (Δ +1) xs)

pSort∈ : ∀ {n} → Sort → Vec Term n → Type
pSort∈ s = go 0
  where
    go : ℕ → ∀ {n} → Vec Term n → Type
    go k []       = el (suc-sort s) (sort s)
    go k (t ∷ ts) = `Πᵛʳ (mapVarType (_+_ k) (el s t)) (go (suc k) ts)

pEnvPats : List (Arg Pattern) → ∀ {n} → Env' n → Env' n
pEnvPat : Pattern → ∀ {n} → Env' n → Env' n

pEnvPat (con _ pats) = pEnvPats pats
pEnvPat dot = id
pEnvPat var = _+↑
pEnvPat (lit _) = id
pEnvPat (proj _) = opaque "pEnvPats/proj" id
pEnvPat absurd = id

pEnvPats [] = id
pEnvPats (arg i p ∷ ps) = pEnvPat p ∘ pEnvPats ps

pPats : ∀ {n} → Env' n → List (Arg Pattern) → List (Arg Pattern)
pPat  : ∀ {n} → Env' n → Arg Pattern → List (Arg Pattern)

pPats Γ [] = []
pPats Γ (pat ∷ ps) = pPat Γ pat ++ pPats Γ ps

--nodot = var

pPat {n} Γ (arg (arg-info _ r) (con c pats))
  = p^args {n} r (const dot) (con (pCon Γ c) (pPats Γ pats)) []
pPat {n} Γ (arg (arg-info _ r) dot)
  = p^args {n} r (const dot) dot []
pPat {n} Γ (arg (arg-info _ r) var)
  = p^args {n} r (const var) var []
pPat {n} Γ (arg i (lit (nat l))) = opaque "pPat/lit/nat" []
pPat {n} Γ (arg (arg-info _ r) (lit l))
  = p^args {n} r go
                 (con (quote refl) []) []
      where
        go : ∀ {n} → Fin n → Pattern
        go zero = lit l
        go (suc _) = dot
pPat {n} Γ (arg (arg-info _ r) absurd) = p^args {n} r (const var) absurd []
pPat {n} Γ (arg i (proj p)) = opaque "pPat/proj" []

pLit : Literal → Term
pLit (nat n) = pNat n
pLit _       = con (quote refl) []

pTerm  : ∀ {n} → Env' n → Term → Term
pArgs  : ∀ {n} → Env' n → Args → Args
pType∈ : ∀ {n} → Env' n → Type             → Vec Term n → Type
pTerm∈ : ∀ {n} → Env' n → Term             → Vec Term n → Term
pPi∈   : ∀ {n} → Env' n → Arg Type → Type → Vec Term n → Term

pType∈ Γ (el s t) as = el s (pTerm∈ Γ t as)

pTerm {n} Γ (lam _ t) = p^lam n (pTerm (Γ +↑) t)
pTerm Γ (var v args)  = var (pVar Γ Kᵣ v) (pArgs Γ args)
pTerm Γ (con c args)  = con (pCon Γ c) (pArgs Γ args)
pTerm Γ (def d args)  = def (pDef Γ d) (pArgs Γ args)
pTerm Γ (lit l)       = pLit l
pTerm Γ (pat-lam _ _) = opaque "pTerm/pat-lam" unknown
pTerm Γ unknown       = unknown

pTerm Γ (sort s) = lam∈ Γ λ _ as → unEl (pSort∈ s as)
pTerm Γ (pi s t) = lam∈ Γ λ Δ → pPi∈ Δ s t

pPi∈ {n} Γ (arg (arg-info _ r) s) t as =
  p3pi∈ Γ r s (λ Δ → pType∈ Δ s) (λ Δ vs → pType∈ Δ t
    (vmap (λ a v → app (mapVar (_+_ (suc n)) a) (argᵛʳ v ∷ [])) as ⊛ vs))

pTerm∈ Γ (sort s) as = unEl (pSort∈ s as)
pTerm∈ Γ (pi s t) = pPi∈ Γ s t
pTerm∈ Γ t as = app (pTerm Γ t) (toList (vmap argᵛʳ as))

pArgs Γ [] = []
pArgs Γ (arg (arg-info _ r) t ∷ as)
  = p^args r (λ k → mapVar (pVar (Γ +↑) (Kᵢ k)) t) (pTerm Γ t) (pArgs Γ as)

pClause  : ∀ {n} → Env' n → Clause → Clause
pClauses : ∀ {n} → Env' n → Clauses → Clauses

pClause Γ (clause pats body) = clause (pPats Γ pats) (pTerm (pEnvPats pats Γ) body)
pClause Γ (absurd-clause pats) = absurd-clause (pPats Γ pats)

pClauses Γ [] = []
pClauses Γ (c ∷ cs) = pClause Γ c ∷ pClauses Γ cs

pFunDef : ∀ {n} → Env' n → Name → FunctionDef → FunctionDef
pFunDef Γ d (fun-def t cs)
  = fun-def (pType∈ Γ t (replicate (def d []))) (pClauses Γ cs)

postulate
  IMPOSSIBLE : FunctionDef

pFunName : ∀ {n} → Env' n → Name → FunctionDef
pFunName Γ x with definition x
... | function d = pFunDef Γ x d
... | _ = IMPOSSIBLE -- opaque "pFunName" (fun-def {!!} {!!})

pFunNameRec : ∀ {n} → Env' n → (x xₚ : Name) → FunctionDef
pFunNameRec Γ x xₚ = pFunName (ext1DefEnv x xₚ Γ) x

{-
pDefinition : Env' 2 → Name → Definition → Definition
pDefinition Γ n (function x) = function {!pFunDef!}
pDefinition Γ n (data-type x) = {!!}
pDefinition Γ n (record′ x) = {!!}
pDefinition Γ n constructor′ = {!!}
pDefinition Γ n axiom = {!!}
pDefinition Γ n primitive′ = {!!}

pName : Env' 2 → Name → Definition
pName Γ n = pDefinition Γ n (definition n)
-}

open import Data.String.Core using (String)
open import Data.Float       using (Float)

infixr 1 _[₀→₀]_
_[₀→₀]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₀} (Bₚ : B → Set₀)
            (f : A → B) → Set₀
_[₀→₀]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₀→₁]_
_[₀→₁]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₀→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₁]_
_[₁→₁]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₁→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₂]_
_[₁→₂]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₂} (Bₚ : B → Set₂)
            (f : A → B) → Set₂
_[₁→₂]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

[[Set₀]] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
[[Set₀]] = λ A → A [₀→₁] [Set₀]

{-
EqEnv = {!!}
EqRes = {!!}

eqTerm : EqEnv → Term → Term → EqRes
eqTerm Γ (var x args) (var x₁ args₁) = {!!}
eqTerm Γ (def f₀ args₀) (def f₁ args₁) = {!!}
eqTerm Γ (con c₀ args₀) (con c₁ args₁) = {!!}
eqTerm Γ (lam v t) (lam v' t') = {!!}
eqTerm Γ (pi t₁ t₂) (pi u₁ u₂) = {!!}
eqTerm Γ (sort s₀) (sort s₁) = {!!}
eqTerm Γ (lit l₀) (lit l₁) = {!!}
eqTerm Γ unknown unknown = {!!}
eqTerm Γ (def f args) u = {!!}
--eqTerm Γ (pat-lam cs args) u = {!!}
eqTerm _ _ = ?
-}

import Reflection.Simple as Si
open Si using (var;con;def;lam;pi;sort;unknown;simple;showTerm)

p[Set₀] = pFunName (ε 1) (quote [Set₀])
q[[Set₀]] = definition (quote [[Set₀]]) -- quoteTerm [[Set₀]]
test-type-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀] ≡ unquote (unEl (Get-type.from-fun-def p[Set₀]))
test-type-p[Set₀] = refl
test-term-p[Set₀] : quoteTerm [[Set₀]] ≡ Get-term.from-fun-def p[Set₀]
test-term-p[Set₀] = refl
unquoteDecl u-p[Set₀] = p[Set₀]

{-
p-[→]-type = unEl (Get-type.from-fun-def p-[→])
p-[→]' : ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
                {Aₚ : A → Set₀} (A₁ₚ : {x : A} → A₀ₚ x → Set₀)
                {B : Set₀}       (B₀ₚ : B → Set₀)
                {Bₚ : B → Set₀} (B₁ₚ : {x : B} → B₀ₚ x → Set₀)
                {f : A → B}    (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
              → (Aₚ [₀→₀] Bₚ) f →
              {C : Set₀} → (C → Set₀) → {t : {!!}} → (A → B) → Set₀ -- _[₀→₀]_ {A} {-A₀ₚ} {Aₚ-} {-A₁ₚ-} {!!} {B} {!!} {-B₀ₚ} B₁ₚ-} f -- fₚ
p-[→]' = {!unquote (Get-term.from-fun-def p-[→])!}
-}

[String] : [★₀] String
[String] _ = 𝟙

[Float] : [★₀] Float
[Float] _ = 𝟙

⟦String⟧ : ⟦★₀⟧ String String
⟦String⟧ = _≡_

⟦Float⟧ : ⟦★₀⟧ Float Float
⟦Float⟧ = _≡_

data [𝟚] : [Set₀] 𝟚 where
  [0₂] : [𝟚] 0₂
  [1₂] : [𝟚] 1₂

data [ℕ] : [Set₀] ℕ where
  [zero] : [ℕ] zero
  [suc]  : ([ℕ] [→] [ℕ]) suc

[pred] : ([ℕ] [→] [ℕ]) pred
[pred] [zero]     = [zero]
[pred] ([suc] xₚ) = xₚ

revealed-[→] = Reveal-args.nåme (quote _[₀→₀]_)
unquoteDecl revealed-[→]' = un-function revealed-[→]

unquoteDecl revelator-[→] = Revelator.fun (type (quote _[₀→₀]_))

{-
p-[→] = pFunName (ε 1) (quote _[₀→₀]_)
p-[→]-type = unEl (Get-type.from-fun-def p-[→])

{-
p-[→]' : (x0 : Set) → (x1 : (x1 : x0) → Set) → (x2 : (x2 : x0) → Set) → (x3 : (x3 : x0) → (x4 : x1 x3) → (x5 : x2 x3) → Set) → (x4 : Set) → (x5 : (x5 : x4) → Set) → (x6 : (x6 : x4) → Set) → (x7 : (x7 : x4) → (x8 : x5 x7) → (x9 : x6 x7) → Set) → (x8 : (x8 : x0) → x4) → (x9 : (x9 : x0) → (x10 : x1 x9) → x5 (x8 x9)) → (x10 : _[₀→₀]_ {x0} x2 {x4} x6 x8) → Set
{-
p-[→]' : ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
                {Aₚ : A → Set₀} (A₁ₚ : {x : A} → A₀ₚ x → Set₀)
                {B : Set₀}       (B₀ₚ : B → Set₀)
                {Bₚ : B → Set₀} (B₁ₚ : {x : B} → B₀ₚ x → Set₀)
                {f : A → B}    (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
              → (Aₚ [₀→₀] Bₚ) f →
              {C : Set₀} → (C → Set₀) → {t : {!!}} → (A → B) → Set₀ -- _[₀→₀]_ {A} {-A₀ₚ} {Aₚ-} {-A₁ₚ-} {!!} {B} {!!} {-B₀ₚ} B₁ₚ-} f -- fₚ
-}
p-[→]' = {!unquote (Get-term.from-fun-def p-[→])!}

test : {!showTerm p-[→]-type!}
test = {!unquote (Get-term.from-fun-def p-[→])!}
-}
-- unquoteDecl _[[→]]_ = p-[→]

{-
data [[ℕ]] : [[Set₀]] [ℕ] [ℕ] where
  [[zero]] : [[ℕ]] [zero] [zero]
  [[suc]]  : ([[ℕ]] [[→]] [[ℕ]]) [suc] [suc]
-}

defDefEnv1 : Name → Name
defDefEnv1 (quote 𝟚) = quote [𝟚]
defDefEnv1 (quote ℕ) = quote [ℕ]
defDefEnv1 (quote String) = quote [String]
defDefEnv1 (quote Float) = quote [Float]
defDefEnv1 (quote ★₀) = quote [★₀]
defDefEnv1 (quote ★₁) = quote [★₁]
defDefEnv1 n         = opaque "defDefEnv1" n

defConEnv1 : Name → Name
defConEnv1 (quote 0₂) = quote [0₂]
defConEnv1 (quote 1₂) = quote [1₂]
defConEnv1 (quote ℕ.zero) = quote [zero]
defConEnv1 (quote ℕ.suc)  = quote [suc]
defConEnv1 n              = opaque "defConEnv1" n

defDefEnv2 : Name → Name
defDefEnv2 (quote 𝟚) = quote ⟦𝟚⟧
defDefEnv2 (quote ℕ) = quote ⟦ℕ⟧
defDefEnv2 (quote String) = quote ⟦String⟧
defDefEnv2 (quote Float) = quote ⟦Float⟧
defDefEnv2 (quote ★₀) = quote ⟦★₀⟧
defDefEnv2 (quote ★₁) = quote ⟦★₁⟧
defDefEnv2 n         = opaque "defDefEnv" n

defConEnv2 : Name → Name
defConEnv2 (quote 0₂) = quote ⟦0₂⟧
defConEnv2 (quote 1₂) = quote ⟦1₂⟧
defConEnv2 (quote ℕ.zero) = quote ⟦ℕ⟧.zero
defConEnv2 (quote ℕ.suc)  = quote ⟦ℕ⟧.suc
defConEnv2 n              = opaque "defConEnv2" n

defEnv0 : Env' 0
defEnv0 = record { pVar = λ _ _ → opaque "defEnv1.pVar" 0
                 ; pCon = id
                 ; pDef = id }

defEnv1 : Env' 1
defEnv1 = record { pVar = λ _ _ → opaque "defEnv1.pVar" 0
                 ; pCon = defConEnv1
                 ; pDef = defDefEnv1 }

defEnv2 : Env' 2
defEnv2 = record { pVar = λ _ _ → opaque "defEnv2.pVar" 0
                 ; pCon = defConEnv2
                 ; pDef = defDefEnv2 }

{-
_⟦+⟧_ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) _+_ _+_
zero  ⟦+⟧ n = n
suc m ⟦+⟧ n = suc (m ⟦+⟧ n)
-}

_/2 : ℕ → ℕ
zero        /2 = zero
suc zero    /2 = zero
suc (suc n) /2 = suc (n /2)

_⟦/2⟧ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _/2 _/2
⟦zero⟧         ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ ⟦zero⟧    ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ (⟦suc⟧ n) ⟦/2⟧ = ⟦suc⟧ (n ⟦/2⟧)

_+ℕ_ : ℕ → ℕ → ℕ
zero  +ℕ n = n
suc m +ℕ n = suc (m +ℕ n)

_⟦+ℕ⟧_ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _+ℕ_ _+ℕ_
⟦zero⟧  ⟦+ℕ⟧ n = n
⟦suc⟧ m ⟦+ℕ⟧ n = ⟦suc⟧ (m ⟦+ℕ⟧ n)

⟦⟦Set₀⟧⟧ : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
⟦⟦Set₀⟧⟧ = λ A₀ A₁ → A₀ ⟦₀→₁⟧ A₁ ⟦₀→₁⟧ ⟦Set₀⟧

⟦⟦Set₀⟧⟧' : {x₁ x₂ : Set} (xᵣ : x₁ → x₂ → Set) {x₃ : Set} {x₄ : Set}
            (xᵣ₁ : x₃ → x₄ → Set) →
            (x₁ → x₃ → Set) → (x₂ → x₄ → Set) → Set₁
⟦⟦Set₀⟧⟧' = λ A₀ A₁ f₁ f₂ →
  ∀ {x₁} {x₂} (xᵣ : A₀ x₁ x₂)
    {x₃} {x₄} (xᵣ₁ : A₁ x₃ x₄) →
    f₁ x₁ x₃ → f₂ x₂ x₄ → Set

-- Since quoteTerm normalises
test-⟦⟦Set₀⟧⟧ : quoteTerm ⟦⟦Set₀⟧⟧ ≡ quoteTerm ⟦⟦Set₀⟧⟧'
test-⟦⟦Set₀⟧⟧ = refl

⟦⟦Set₀⟧⟧-type = unquote (unEl (type (quote ⟦⟦Set₀⟧⟧)))
test-⟦⟦Set₀⟧⟧-type : ⟦⟦Set₀⟧⟧-type ≡ unquote (unEl (type (quote ⟦⟦Set₀⟧⟧')))
test-⟦⟦Set₀⟧⟧-type = refl

pSet₀ = pTerm defEnv2 `★₀
ppSet₀ = pTerm defEnv2 pSet₀
p⟦Set₀⟧ = pFunName defEnv2 (quote ⟦Set₀⟧)
test-pSet₀ : pSet₀ ≡ quoteTerm ⟦Set₀⟧
test-pSet₀ = refl
test-ppSet₀ : ppSet₀ ≡ quoteTerm ⟦⟦Set₀⟧⟧
test-ppSet₀ = refl
test-ppSet₀'' : ppSet₀ ≡ Get-term.from-fun-def p⟦Set₀⟧
test-ppSet₀'' = refl

unquoteDecl ⟦⟦Set₀⟧⟧'' = p⟦Set₀⟧
test-⟦⟦Set₀⟧⟧'' : _≡_ {A = ⟦⟦Set₀⟧⟧-type} ⟦⟦Set₀⟧⟧'' ⟦⟦Set₀⟧⟧
test-⟦⟦Set₀⟧⟧'' = refl

test-p0-⟦Set₀⟧ : pTerm defEnv0 (quoteTerm ⟦Set₀⟧) ≡ quoteTerm ⟦Set₀⟧
test-p0-⟦Set₀⟧ = refl

data ⟦⟦𝟚⟧⟧ : (⟦⟦Set₀⟧⟧ ⟦𝟚⟧ ⟦𝟚⟧) ⟦𝟚⟧ ⟦𝟚⟧ where
  ⟦⟦0₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧
  ⟦⟦1₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧

_≡clauses_ = λ x y → Get-clauses.from-def x ≡ Get-clauses.from-def y
_≡type_ = λ x y → Get-type.from-def x ≡ Get-type.from-def y

module Test where
  p1ℕ→ℕ = pTerm defEnv1 (quoteTerm (ℕ → ℕ))
  [ℕ→ℕ] = [ℕ] [→] [ℕ]
  test-p1ℕ→ℕ : unquote p1ℕ→ℕ ≡ [ℕ→ℕ]
  test-p1ℕ→ℕ = refl

  p2ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ))
  ⟦ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
  test-p2ℕ→ℕ : unquote p2ℕ→ℕ ≡ ⟦ℕ→ℕ⟧
  test-p2ℕ→ℕ = refl

  pℕ→ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ → ℕ))
  ⟦ℕ→ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
  test-pℕ→ℕ→ℕ : pℕ→ℕ→ℕ ≡ quoteTerm ⟦ℕ→ℕ→ℕ⟧
  test-pℕ→ℕ→ℕ = refl
  ZERO : Set₁
  ZERO = (A : Set₀) → A
  ⟦ZERO⟧ : ZERO → ZERO → Set₁
  ⟦ZERO⟧ f₀ f₁ =
    {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
    → Aᵣ (f₀ A₀) (f₁ A₁)
  pZERO = pTerm (ε 2) (quoteTerm ZERO)
  q⟦ZERO⟧ = quoteTerm ⟦ZERO⟧
  test-pZERO : pZERO ≡ q⟦ZERO⟧
  test-pZERO = refl
  ID : Set₁
  ID = (A : Set₀) → A → A
  ⟦ID⟧ : ID → ID → Set₁
  ⟦ID⟧ f₀ f₁ =
    {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
    {x₀ : A₀} {x₁ : A₁} (x : Aᵣ x₀ x₁)
    → Aᵣ (f₀ A₀ x₀) (f₁ A₁ x₁)
  pID = pTerm (ε 2) (quoteTerm ID)
  q⟦ID⟧ = quoteTerm ⟦ID⟧
  test-param : absTerm q⟦ID⟧ ≡ absTerm pID
  test-param = refl
  test-ID : q⟦ID⟧ ≡ pID
  test-ID = refl

  p-not = pFunName defEnv2 (quote not)
  unquoteDecl P-not = p-not
  test-not : ∀ {x₀ x₁ : 𝟚} (xᵣ : ⟦𝟚⟧ x₀ x₁) → ⟦not⟧ xᵣ ≡ P-not xᵣ
  test-not ⟦0₂⟧ = refl
  test-not ⟦1₂⟧ = refl

  p1-pred = pFunName defEnv1 (quote pred)
  q-[pred] = quoteTerm [pred]
  unquoteDecl [pred]' = p1-pred
  test-p1-pred : ∀ {n} (nₚ : [ℕ] n) → [pred]' nₚ ≡ [pred] nₚ
  test-p1-pred [zero] = refl
  test-p1-pred ([suc] nₚ) = refl

  p2-pred = pFunName defEnv2 (quote pred)
  q-⟦pred⟧ = definition (quote ⟦pred⟧)
  unquoteDecl ⟦pred⟧' = p2-pred
  test-p2-pred : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → ⟦pred⟧' nᵣ ≡ ⟦pred⟧ nᵣ
  test-p2-pred ⟦zero⟧ = refl
  test-p2-pred (⟦suc⟧ nᵣ) = refl

  p/2 = pFunNameRec defEnv2 (quote _/2)
  q⟦/2⟧ = definition (quote _⟦/2⟧)
  unquoteDecl _⟦/2⟧' = p/2 _⟦/2⟧'
  test-/2 : function (p/2 (quote _⟦/2⟧)) ≡ q⟦/2⟧
  test-/2 = refl
  test-/2' : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → nᵣ ⟦/2⟧' ≡ nᵣ ⟦/2⟧
  test-/2' ⟦zero⟧ = refl
  test-/2' (⟦suc⟧ ⟦zero⟧) = refl
  test-/2' (⟦suc⟧ (⟦suc⟧ nᵣ)) = ap ⟦suc⟧ (test-/2' nᵣ)

  p+ = pFunNameRec defEnv2 (quote _+ℕ_)
  q⟦+⟧ = definition (quote _⟦+ℕ⟧_)
  unquoteDecl _⟦+⟧'_ = p+ _⟦+⟧'_
  test-+ : function (p+ (quote _⟦+ℕ⟧_)) ≡ q⟦+⟧
  test-+ = refl
  test-+' : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) {n'₀ n'₁} (n'ᵣ : ⟦ℕ⟧ n'₀ n'₁) → nᵣ ⟦+⟧' n'ᵣ ≡ nᵣ ⟦+ℕ⟧ n'ᵣ
  test-+' ⟦zero⟧    n'ᵣ = refl
  test-+' (⟦suc⟧ nᵣ) n'ᵣ = ap ⟦suc⟧ (test-+' nᵣ n'ᵣ)

  {-
  is-good : String → 𝟚
  is-good "good" = 1₂
  is-good _      = 0₂

  ⟦is-good⟧ : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
  ⟦is-good⟧ {"good"} refl = ⟦1₂⟧
  ⟦is-good⟧ {_}      refl = {!!}

  p-is-good = pFunName defEnv2 (quote is-good)
  unquoteDecl ⟦is-good⟧' = p-is-good
  test-is-good = {!!}
  -}

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

open import Function
open import Opaque
open import Type
open import Data.Zero
open import Data.One hiding (_≟_)
open import Data.Two hiding (_≟_)
open import Data.Two.Logical
open import Data.Nat hiding (_≟_)
open import Data.Fin using (Fin; zero; suc; toℕ)
open import Data.Vec using (Vec; []; _∷_; replicate; tabulate; allFin; reverse; _⊛_; toList) renaming (map to vmap)
open import Data.Nat.Logical hiding (_≟_) renaming (zero to ⟦zero⟧; suc to ⟦suc⟧)
open import Data.List hiding (replicate; reverse)
open import Data.Sum.NP
open import Reflection.NP
open import Relation.Unary.Logical
open import Relation.Binary.Logical
open import Relation.Nullary.NP
open import Relation.Binary.PropositionalEquality.NP

module Param where

module Revelator (tyH : Type) where
    tm : Term → ℕ → Args → Term
    tm (pi (arg (arg-info v _) t₁) (el _ t₂)) y as = lam visible (tm t₂ (suc y) (mapVarArgs suc as ++ argʳ v (var 0 []) ∷ []))
    tm (var x args) = var
    tm (def f args) = var
    tm (sort s)     = var
    tm unknown _ _ = unknown
    tm (con c args) _ _ = opaque "revealator/tm/con: impossible" unknown
    tm (lam v ty) _ _ = opaque "revealator/tm/lam: impossible" unknown
    tm (lit l) _ _ = opaque "revealator/tm/lit: impossible" unknown
    tm (pat-lam cs args) _ _ = opaque "revealator/tm/pat-lam: TODO" unknown
    tÿpe : Type
    tÿpe = tyH `→ᵛʳ Reveal-args.tÿpe tyH
    term : Term
    term = lam visible (tm (unEl tyH) 0 [])
    fun : FunctionDef
    fun = fun-def tÿpe (clause (argᵛʳ var ∷ []) (tm (unEl tyH) 0 []) ∷ [])

data VarKind (n : ℕ) : Set where
  Kᵢ : Fin n → VarKind n
  Kᵣ : VarKind n

record Env (n : ℕ)(A B : Set) : Set where
  field
    pVar : VarKind n → A → B
    pCon : Name → Name
    pDef : Name → Name
open Env

Env' = λ n → Env n ℕ ℕ

ε : ∀ n → Env' n
ε n = record { pVar = λ _ _ → opaque "ε.pVar" 0
             ; pCon = const (opaque "ε.pCon" (quote ε))
             ; pDef = const (opaque "ε.pDef" (quote ε)) }

extDefEnv : ((Name → Name) → (Name → Name)) → ∀ {n A B} → Env n A B → Env n A B
extDefEnv ext Γ = record Γ { pDef = ext (pDef Γ) }

ext1DefEnv : (old new : Name) → ∀ {n A B} → Env n A B → Env n A B
ext1DefEnv old new = extDefEnv (λ f x → [yes: (λ _ → new) no: (λ _ → f x) ]′ (x ≟-Name old))

↑pVar : ℕ → (ℕ → ℕ) → (ℕ → ℕ)
↑pVar zero = id
↑pVar (suc n) = ↑pVar n ∘ mapVar↑

on-pVar : ∀ {n A B C D} → (VarKind n → (A → B) → (C → D)) → Env n A B → Env n C D
on-pVar f Γ = record
  { pVar = λ k → f k (pVar Γ k)
  ; pCon = pCon Γ
  ; pDef = pDef Γ }

_+↑ : ∀ {n} → Env' n → Env' n
_+↑ {n} = on-pVar goK
  where
    goK : VarKind n → (ℕ → ℕ) → (ℕ → ℕ)
    goK (Kᵢ x) f = _+_ (n ∸ toℕ x) ∘ ↑pVar 1 (_+_ (toℕ x) ∘ f)
    goK Kᵣ     f = ↑pVar 1 (_+_ n ∘ f)

_+'_ : ∀ {w} → Env' w → ℕ → Env' w
Γ +' n = record { pVar = λ k → _+_ n ∘ pVar Γ k ; pCon = pCon Γ ; pDef = pDef Γ }

_+1 : ∀ {w} → Env' w → Env' w
Γ +1 = Γ +' 1

pattern `⟦zero⟧  = con (quote ⟦ℕ⟧.zero) []
pattern `⟦suc⟧ t = con (quote ⟦ℕ⟧.suc) (argᵛʳ t ∷ [])
pNat : ℕ → Term
pNat zero    = `⟦zero⟧
pNat (suc n) = `⟦suc⟧ (pNat n)

lam^ : ℕ → Visibility → Term → Term
lam^ zero    v x = x
lam^ (suc n) v x = lam v (lam^ n v x)

lam∈ : ∀ {n} → Env' n → (f : Env' n → Vec Term n → Term) → Term
lam∈ {n} Γ f = lam^ n visible (f (Γ +' n) (reverse (tabulate (λ x → var (toℕ x) []))))

app-tabulate : ∀ {n a} {A : Set a} → (Fin n → A) → List A → List A
app-tabulate {zero}  f xs = xs
app-tabulate {suc n} f xs = f zero ∷ app-tabulate (f ∘ suc) xs

p^args : ∀ {n A} → Relevance → (Fin n → A) → A → List (Arg A) → List (Arg A)
p^args r f x args = app-tabulate (λ k → argʰ r (f k)) (argᵛʳ x ∷ args)

p^lam : ℕ → Term → Term
p^lam n t = lam^ n hidden (lam visible t)

{-
pi^ : ℕ → Arg Type → Type → Type
pi^ zero    i t = t
pi^ (suc n) i t = `Π i (pi^ n i t)
-}

allVarsFrom : ∀ n → ℕ → Vec Term n
allVarsFrom zero    k = []
allVarsFrom (suc n) k = var (k + n) [] ∷ allVarsFrom n k

p3pi∈ : ∀ {n} (Γ : Env' n) (r : Relevance)
          (s : Type)
          (t : Env' n → Vec Term n → Type)
          (u : Env' n → Vec Term n → Type) → Term
p3pi∈ {n} Γ r s t u = unEl (go Γ (allFin n))
  where
  go : ∀ {m} → Env' n → Vec (Fin n) m → Type
  go Δ [] =
      `Πᵛʳ (t Δ (allVarsFrom n 0)) (u (Γ +↑) (allVarsFrom n 1))
  go Δ (x ∷ xs) =
      `Π (argʰ r (mapVarType (pVar Δ (Kᵢ x)) s))
         (go (Δ +1) xs)

pSort∈ : ∀ {n} → Sort → Vec Term n → Type
pSort∈ s = go 0
  where
    go : ℕ → ∀ {n} → Vec Term n → Type
    go k []       = el (suc-sort s) (sort s)
    go k (t ∷ ts) = `Πᵛʳ (mapVarType (_+_ k) (el s t)) (go (suc k) ts)

pEnvPats : List (Arg Pattern) → ∀ {n} → Env' n → Env' n
pEnvPat : Pattern → ∀ {n} → Env' n → Env' n

pEnvPat (con _ pats) = pEnvPats pats
pEnvPat dot = id
pEnvPat var = _+↑
pEnvPat (lit _) = id
pEnvPat (proj _) = opaque "pEnvPats/proj" id
pEnvPat absurd = id

pEnvPats [] = id
pEnvPats (arg i p ∷ ps) = pEnvPat p ∘ pEnvPats ps

pPats : ∀ {n} → Env' n → List (Arg Pattern) → List (Arg Pattern)
pPat  : ∀ {n} → Env' n → Arg Pattern → List (Arg Pattern)

pPats Γ [] = []
pPats Γ (pat ∷ ps) = pPat Γ pat ++ pPats Γ ps

nodot = var

pPat {n} Γ (arg (arg-info _ r) (con c pats))
  = p^args {n} r (const nodot) (con (pCon Γ c) (pPats Γ pats)) []
pPat {n} Γ (arg (arg-info _ r) dot)
  = p^args {n} r (const dot) dot []
pPat {n} Γ (arg (arg-info _ r) var)
  = p^args {n} r (const var) var []
pPat {n} Γ (arg i (lit (nat l))) = opaque "pPat/lit/nat" []
pPat {n} Γ (arg (arg-info _ r) (lit l))
  = p^args {n} r go
                 (con (quote refl) []) []
      where
        go : ∀ {n} → Fin n → Pattern
        go zero = lit l
        go (suc _) = nodot
pPat {n} Γ (arg (arg-info _ r) absurd) = p^args {n} r (const var) absurd []
pPat {n} Γ (arg i (proj p)) = opaque "pPat/proj" []

pLit : Literal → Term
pLit (nat n) = pNat n
pLit _       = con (quote refl) []

pTerm  : ∀ {n} → Env' n → Term → Term
pArgs  : ∀ {n} → Env' n → Args → Args
pType∈ : ∀ {n} → Env' n → Type             → Vec Term n → Type
pTerm∈ : ∀ {n} → Env' n → Term             → Vec Term n → Term
pPi∈   : ∀ {n} → Env' n → Arg Type → Type → Vec Term n → Term

pType∈ Γ (el s t) as = el s (pTerm∈ Γ t as)

pTerm {n} Γ (lam _ t) = p^lam n (pTerm (Γ +↑) t)
pTerm Γ (var v args)  = var (pVar Γ Kᵣ v) (pArgs Γ args)
pTerm Γ (con c args)  = con (pCon Γ c) (pArgs Γ args)
pTerm Γ (def d args)  = def (pDef Γ d) (pArgs Γ args)
pTerm Γ (lit l)       = pLit l
pTerm Γ (pat-lam _ _) = opaque "pTerm/pat-lam" unknown
pTerm Γ unknown       = unknown

pTerm Γ (sort s) = lam∈ Γ λ _ as → unEl (pSort∈ s as)
pTerm Γ (pi s t) = lam∈ Γ λ Δ → pPi∈ Δ s t

pPi∈ {n} Γ (arg (arg-info _ r) s) t as =
  p3pi∈ Γ r s (λ Δ → pType∈ Δ s) (λ Δ vs → pType∈ Δ t
    (vmap (λ a v → app (mapVar (_+_ (suc n)) a) (argᵛʳ v ∷ [])) as ⊛ vs))

pTerm∈ Γ (sort s) as = unEl (pSort∈ s as)
pTerm∈ Γ (pi s t) = pPi∈ Γ s t
pTerm∈ Γ t as = app (pTerm Γ t) (toList (vmap argᵛʳ as))

pArgs Γ [] = []
pArgs Γ (arg (arg-info _ r) t ∷ as)
  = p^args r (λ k → mapVar (pVar (Γ +↑) (Kᵢ k)) t) (pTerm Γ t) (pArgs Γ as)

pClause  : ∀ {n} → Env' n → Clause → Clause
pClauses : ∀ {n} → Env' n → Clauses → Clauses

pClause Γ (clause pats body) = clause (pPats Γ pats) (pTerm (pEnvPats pats Γ) body)
pClause Γ (absurd-clause pats) = absurd-clause (pPats Γ pats)

pClauses Γ [] = []
pClauses Γ (c ∷ cs) = pClause Γ c ∷ pClauses Γ cs

pFunDef : ∀ {n} → Env' n → Name → FunctionDef → FunctionDef
pFunDef Γ d (fun-def t cs)
  = fun-def (pType∈ Γ t (replicate (def d []))) (pClauses Γ cs)

postulate
  IMPOSSIBLE : FunctionDef

pFunName : ∀ {n} → Env' n → Name → FunctionDef
pFunName Γ x with definition x
... | function d = pFunDef Γ x d
... | _ = IMPOSSIBLE -- opaque "pFunName" (fun-def {!!} {!!})

pFunNameRec : ∀ {n} → Env' n → (x xₚ : Name) → FunctionDef
pFunNameRec Γ x xₚ = pFunName (ext1DefEnv x xₚ Γ) x

{-
pDefinition : Env' 2 → Name → Definition → Definition
pDefinition Γ n (function x) = function {!pFunDef!}
pDefinition Γ n (data-type x) = {!!}
pDefinition Γ n (record′ x) = {!!}
pDefinition Γ n constructor′ = {!!}
pDefinition Γ n axiom = {!!}
pDefinition Γ n primitive′ = {!!}

pName : Env' 2 → Name → Definition
pName Γ n = pDefinition Γ n (definition n)
-}

open import Data.String.Core using (String)
open import Data.Float       using (Float)

infixr 1 _[₀→₀]_
_[₀→₀]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₀} (Bₚ : B → Set₀)
            (f : A → B) → Set₀
_[₀→₀]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₀→₁]_
_[₀→₁]_ : ∀ {A : Set₀} (Aₚ : A → Set₀)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₀→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₁]_
_[₁→₁]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₁} (Bₚ : B → Set₁)
            (f : A → B) → Set₁
_[₁→₁]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

infixr 1 _[₁→₂]_
_[₁→₂]_ : ∀ {A : Set₁} (Aₚ : A → Set₁)
            {B : Set₂} (Bₚ : B → Set₂)
            (f : A → B) → Set₂
_[₁→₂]_ = λ {A} Aₚ {B} Bₚ f → ∀ {a} (aₚ : Aₚ a) → Bₚ (f a)

[[Set₀]] : ([Set₀] [₁→₂] [Set₁]) [Set₀]
[[Set₀]] = λ A → A [₀→₁] [Set₀]

{-
EqEnv = {!!}
EqRes = {!!}

eqTerm : EqEnv → Term → Term → EqRes
eqTerm Γ (var x args) (var x₁ args₁) = {!!}
eqTerm Γ (def f₀ args₀) (def f₁ args₁) = {!!}
eqTerm Γ (con c₀ args₀) (con c₁ args₁) = {!!}
eqTerm Γ (lam v t) (lam v' t') = {!!}
eqTerm Γ (pi t₁ t₂) (pi u₁ u₂) = {!!}
eqTerm Γ (sort s₀) (sort s₁) = {!!}
eqTerm Γ (lit l₀) (lit l₁) = {!!}
eqTerm Γ unknown unknown = {!!}
eqTerm Γ (def f args) u = {!!}
--eqTerm Γ (pat-lam cs args) u = {!!}
eqTerm _ _ = ?
-}

import Reflection.Simple as Si
open Si using (var;con;def;lam;pi;sort;unknown;simple;showTerm)

p[Set₀] = pFunName (ε 1) (quote [Set₀])
q[[Set₀]] = definition (quote [[Set₀]]) -- quoteTerm [[Set₀]]
test-type-p[Set₀] : ([Set₀] [₁→₂] [Set₁]) [Set₀] ≡ unquote (unEl (Get-type.from-fun-def p[Set₀]))
test-type-p[Set₀] = refl
test-term-p[Set₀] : quoteTerm [[Set₀]] ≡ Get-term.from-fun-def p[Set₀]
test-term-p[Set₀] = refl
unquoteDecl u-p[Set₀] = p[Set₀]

{-
p-[→]-type = unEl (Get-type.from-fun-def p-[→])
p-[→]' : ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
                {Aₚ : A → Set₀} (A₁ₚ : {x : A} → A₀ₚ x → Set₀)
                {B : Set₀}       (B₀ₚ : B → Set₀)
                {Bₚ : B → Set₀} (B₁ₚ : {x : B} → B₀ₚ x → Set₀)
                {f : A → B}    (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
              → (Aₚ [₀→₀] Bₚ) f →
              {C : Set₀} → (C → Set₀) → {t : {!!}} → (A → B) → Set₀ -- _[₀→₀]_ {A} {-A₀ₚ} {Aₚ-} {-A₁ₚ-} {!!} {B} {!!} {-B₀ₚ} B₁ₚ-} f -- fₚ
p-[→]' = {!unquote (Get-term.from-fun-def p-[→])!}
-}

[String] : [★₀] String
[String] _ = 𝟙

[Float] : [★₀] Float
[Float] _ = 𝟙

⟦String⟧ : ⟦★₀⟧ String String
⟦String⟧ = _≡_

⟦Float⟧ : ⟦★₀⟧ Float Float
⟦Float⟧ = _≡_

data [𝟚] : [Set₀] 𝟚 where
  [0₂] : [𝟚] 0₂
  [1₂] : [𝟚] 1₂

data [ℕ] : [Set₀] ℕ where
  [zero] : [ℕ] zero
  [suc]  : ([ℕ] [→] [ℕ]) suc

[pred] : ([ℕ] [→] [ℕ]) pred
[pred] [zero]     = [zero]
[pred] ([suc] xₚ) = xₚ

revealed-[→] = Reveal-args.nåme (quote _[₀→₀]_)
unquoteDecl revealed-[→]' = un-function revealed-[→]

unquoteDecl revelator-[→] = Revelator.fun (type (quote _[₀→₀]_))

{-
p-[→] = pFunName (ε 1) (quote _[₀→₀]_)
p-[→]-type = unEl (Get-type.from-fun-def p-[→])

p-[→]' : (x0 : Set) → (x1 : (x1 : x0) → Set) → (x2 : (x2 : x0) → Set) → (x3 : (x3 : x0) → (x4 : x1 x3) → (x5 : x2 x3) → Set) → (x4 : Set) → (x5 : (x5 : x4) → Set) → (x6 : (x6 : x4) → Set) → (x7 : (x7 : x4) → (x8 : x5 x7) → (x9 : x6 x7) → Set) → (x8 : (x8 : x0) → x4) → (x9 : (x9 : x0) → (x10 : x1 x9) → x5 (x8 x9)) → (x10 : _[₀→₀]_ {x0} x2 {x4} x6 x8) → Set
{-
p-[→]' : ∀ {A : Set₀}       (A₀ₚ : A → Set₀)
                {Aₚ : A → Set₀} (A₁ₚ : {x : A} → A₀ₚ x → Set₀)
                {B : Set₀}       (B₀ₚ : B → Set₀)
                {Bₚ : B → Set₀} (B₁ₚ : {x : B} → B₀ₚ x → Set₀)
                {f : A → B}    (fₚ : {x : A} → A₀ₚ x → B₀ₚ (f x))
              → (Aₚ [₀→₀] Bₚ) f →
              {C : Set₀} → (C → Set₀) → {t : {!!}} → (A → B) → Set₀ -- _[₀→₀]_ {A} {-A₀ₚ} {Aₚ-} {-A₁ₚ-} {!!} {B} {!!} {-B₀ₚ} B₁ₚ-} f -- fₚ
-}
p-[→]' = {!unquote (Get-term.from-fun-def p-[→])!}

test : {!showTerm p-[→]-type!}
test = {!unquote (Get-term.from-fun-def p-[→])!}
{-
-- unquoteDecl _[[→]]_ = p-[→]

{-
data [[ℕ]] : [[Set₀]] [ℕ] [ℕ] where
  [[zero]] : [[ℕ]] [zero] [zero]
  [[suc]]  : ([[ℕ]] [[→]] [[ℕ]]) [suc] [suc]
-}

defDefEnv1 : Name → Name
defDefEnv1 (quote 𝟚) = quote [𝟚]
defDefEnv1 (quote ℕ) = quote [ℕ]
defDefEnv1 (quote String) = quote [String]
defDefEnv1 (quote Float) = quote [Float]
defDefEnv1 (quote ★₀) = quote [★₀]
defDefEnv1 (quote ★₁) = quote [★₁]
defDefEnv1 n         = opaque "defDefEnv1" n

defConEnv1 : Name → Name
defConEnv1 (quote 0₂) = quote [0₂]
defConEnv1 (quote 1₂) = quote [1₂]
defConEnv1 (quote ℕ.zero) = quote [zero]
defConEnv1 (quote ℕ.suc)  = quote [suc]
defConEnv1 n              = opaque "defConEnv1" n

defDefEnv2 : Name → Name
defDefEnv2 (quote 𝟚) = quote ⟦𝟚⟧
defDefEnv2 (quote ℕ) = quote ⟦ℕ⟧
defDefEnv2 (quote String) = quote ⟦String⟧
defDefEnv2 (quote Float) = quote ⟦Float⟧
defDefEnv2 (quote ★₀) = quote ⟦★₀⟧
defDefEnv2 (quote ★₁) = quote ⟦★₁⟧
defDefEnv2 n         = opaque "defDefEnv" n

defConEnv2 : Name → Name
defConEnv2 (quote 0₂) = quote ⟦0₂⟧
defConEnv2 (quote 1₂) = quote ⟦1₂⟧
defConEnv2 (quote ℕ.zero) = quote ⟦ℕ⟧.zero
defConEnv2 (quote ℕ.suc)  = quote ⟦ℕ⟧.suc
defConEnv2 n              = opaque "defConEnv2" n

defEnv1 : Env' 1
defEnv1 = record { pVar = λ _ _ → opaque "defEnv1.pVar" 0
                 ; pCon = defConEnv1
                 ; pDef = defDefEnv1 }

defEnv2 : Env' 2
defEnv2 = record { pVar = λ _ _ → opaque "defEnv2.pVar" 0
                 ; pCon = defConEnv2
                 ; pDef = defDefEnv2 }

{-
_⟦+⟧_ : (⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧) _+_ _+_
zero  ⟦+⟧ n = n
suc m ⟦+⟧ n = suc (m ⟦+⟧ n)
-}

_/2 : ℕ → ℕ
zero        /2 = zero
suc zero    /2 = zero
suc (suc n) /2 = suc (n /2)

_⟦/2⟧ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _/2 _/2
⟦zero⟧         ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ ⟦zero⟧    ⟦/2⟧ = ⟦zero⟧
⟦suc⟧ (⟦suc⟧ n) ⟦/2⟧ = ⟦suc⟧ (n ⟦/2⟧)

_+ℕ_ : ℕ → ℕ → ℕ
zero  +ℕ n = n
suc m +ℕ n = suc (m +ℕ n)

_⟦+ℕ⟧_ : (⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧ ⟦₀→₀⟧ ⟦ℕ⟧) _+ℕ_ _+ℕ_
⟦zero⟧  ⟦+ℕ⟧ n = n
⟦suc⟧ m ⟦+ℕ⟧ n = ⟦suc⟧ (m ⟦+ℕ⟧ n)

⟦⟦Set₀⟧⟧ : (⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₀⟧ ⟦₁→₂⟧ ⟦Set₁⟧) ⟦Set₀⟧ ⟦Set₀⟧
⟦⟦Set₀⟧⟧ = λ A₀ A₁ → A₀ ⟦₀→₁⟧ A₁ ⟦₀→₁⟧ ⟦Set₀⟧

⟦⟦Set₀⟧⟧' : {x₁ x₂ : Set} (xᵣ : x₁ → x₂ → Set) {x₃ : Set} {x₄ : Set}
            (xᵣ₁ : x₃ → x₄ → Set) →
            (x₁ → x₃ → Set) → (x₂ → x₄ → Set) → Set₁
⟦⟦Set₀⟧⟧' = λ A₀ A₁ f₁ f₂ →
  ∀ {x₁} {x₂} (xᵣ : A₀ x₁ x₂)
    {x₃} {x₄} (xᵣ₁ : A₁ x₃ x₄) →
    f₁ x₁ x₃ → f₂ x₂ x₄ → Set

-- Since quoteTerm normalises
test-⟦⟦Set₀⟧⟧ : quoteTerm ⟦⟦Set₀⟧⟧ ≡ quoteTerm ⟦⟦Set₀⟧⟧'
test-⟦⟦Set₀⟧⟧ = refl

test-⟦⟦Set₀⟧⟧-type : unquote (unEl (type (quote ⟦⟦Set₀⟧⟧))) ≡ unquote (unEl (type (quote ⟦⟦Set₀⟧⟧')))
test-⟦⟦Set₀⟧⟧-type = refl

pSet₀ = pTerm defEnv2 `★₀
ppSet₀ = pTerm defEnv2 pSet₀
p⟦Set₀⟧ = pFunName defEnv2 (quote ⟦Set₀⟧)
test-pSet₀ : pSet₀ ≡ quoteTerm ⟦Set₀⟧
test-pSet₀ = refl
test-ppSet₀ : ppSet₀ ≡ quoteTerm ⟦⟦Set₀⟧⟧
test-ppSet₀ = refl
test-ppSet₀'' : ppSet₀ ≡ Get-term.from-fun-def p⟦Set₀⟧
test-ppSet₀'' = refl

-- unquoteDecl ⟦⟦Set₀⟧⟧'' = p⟦Set₀⟧

data ⟦⟦𝟚⟧⟧ : (⟦⟦Set₀⟧⟧ ⟦𝟚⟧ ⟦𝟚⟧) ⟦𝟚⟧ ⟦𝟚⟧ where
  ⟦⟦0₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧ ⟦0₂⟧
  ⟦⟦1₂⟧⟧ : ⟦⟦𝟚⟧⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧ ⟦1₂⟧

_≡clauses_ = λ x y → Get-clauses.from-def x ≡ Get-clauses.from-def y
_≡type_ = λ x y → Get-type.from-def x ≡ Get-type.from-def y

module Test where
  p1ℕ→ℕ = pTerm defEnv1 (quoteTerm (ℕ → ℕ))
  [ℕ→ℕ] = [ℕ] [→] [ℕ]
  test-p1ℕ→ℕ : unquote p1ℕ→ℕ ≡ [ℕ→ℕ]
  test-p1ℕ→ℕ = refl

  p2ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ))
  ⟦ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
  test-p2ℕ→ℕ : unquote p2ℕ→ℕ ≡ ⟦ℕ→ℕ⟧
  test-p2ℕ→ℕ = refl

  pℕ→ℕ→ℕ = pTerm defEnv2 (quoteTerm (ℕ → ℕ → ℕ))
  ⟦ℕ→ℕ→ℕ⟧ = ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧ ⟦→⟧ ⟦ℕ⟧
  test-pℕ→ℕ→ℕ : pℕ→ℕ→ℕ ≡ quoteTerm ⟦ℕ→ℕ→ℕ⟧
  test-pℕ→ℕ→ℕ = refl
  ZERO : Set₁
  ZERO = (A : Set₀) → A
  ⟦ZERO⟧ : ZERO → ZERO → Set₁
  ⟦ZERO⟧ f₀ f₁ =
    {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
    → Aᵣ (f₀ A₀) (f₁ A₁)
  pZERO = pTerm (ε 2) (quoteTerm ZERO)
  q⟦ZERO⟧ = quoteTerm ⟦ZERO⟧
  test-pZERO : pZERO ≡ q⟦ZERO⟧
  test-pZERO = refl
  ID : Set₁
  ID = (A : Set₀) → A → A
  ⟦ID⟧ : ID → ID → Set₁
  ⟦ID⟧ f₀ f₁ =
    {A₀ A₁ : Set₀} (Aᵣ : A₀ → A₁ → Set₀)
    {x₀ : A₀} {x₁ : A₁} (x : Aᵣ x₀ x₁)
    → Aᵣ (f₀ A₀ x₀) (f₁ A₁ x₁)
  pID = pTerm (ε 2) (quoteTerm ID)
  q⟦ID⟧ = quoteTerm ⟦ID⟧
  test-param : absTerm q⟦ID⟧ ≡ absTerm pID
  test-param = refl
  test-ID : q⟦ID⟧ ≡ pID
  test-ID = refl

  p-not = pFunName defEnv2 (quote not)
  unquoteDecl P-not = p-not
  test-not : ∀ {x₀ x₁ : 𝟚} (xᵣ : ⟦𝟚⟧ x₀ x₁) → ⟦not⟧ xᵣ ≡ P-not xᵣ
  test-not ⟦0₂⟧ = refl
  test-not ⟦1₂⟧ = refl

  p1-pred = pFunName defEnv1 (quote pred)
  q-[pred] = quoteTerm [pred]
  unquoteDecl [pred]' = p1-pred
  test-p1-pred : ∀ {n} (nₚ : [ℕ] n) → [pred]' nₚ ≡ [pred] nₚ
  test-p1-pred [zero] = refl
  test-p1-pred ([suc] nₚ) = refl

  p2-pred = pFunName defEnv2 (quote pred)
  q-⟦pred⟧ = definition (quote ⟦pred⟧)
  unquoteDecl ⟦pred⟧' = p2-pred
  test-p2-pred : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → ⟦pred⟧' nᵣ ≡ ⟦pred⟧ nᵣ
  test-p2-pred ⟦zero⟧ = refl
  test-p2-pred (⟦suc⟧ nᵣ) = refl

  p/2 = pFunNameRec defEnv2 (quote _/2)
  q⟦/2⟧ = definition (quote _⟦/2⟧)
  unquoteDecl _⟦/2⟧' = p/2 _⟦/2⟧'
  {-
  test-/2 : function (p/2 (quote _⟦/2⟧)) ≡ q⟦/2⟧
  test-/2 = refl
  -}
  test-/2 : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) → nᵣ ⟦/2⟧' ≡ nᵣ ⟦/2⟧
  test-/2 ⟦zero⟧ = refl
  test-/2 (⟦suc⟧ ⟦zero⟧) = refl
  test-/2 (⟦suc⟧ (⟦suc⟧ nᵣ)) = ap ⟦suc⟧ (test-/2 nᵣ)

  p+ = pFunNameRec defEnv2 (quote _+ℕ_)
  q⟦+⟧ = definition (quote _⟦+ℕ⟧_)
  unquoteDecl _⟦+⟧'_ = p+ _⟦+⟧'_
  -- test-+ : function (p+ (quote _⟦+ℕ⟧_)) ≡ q⟦+⟧
  -- test-+ = refl
  test-+ : ∀ {n₀ n₁} (nᵣ : ⟦ℕ⟧ n₀ n₁) {n'₀ n'₁} (n'ᵣ : ⟦ℕ⟧ n'₀ n'₁) → nᵣ ⟦+⟧' n'ᵣ ≡ nᵣ ⟦+ℕ⟧ n'ᵣ
  test-+ ⟦zero⟧    n'ᵣ = refl
  test-+ (⟦suc⟧ nᵣ) n'ᵣ = ap ⟦suc⟧ (test-+ nᵣ n'ᵣ)

  {-
  is-good : String → 𝟚
  is-good "good" = 1₂
  is-good _      = 0₂

  ⟦is-good⟧ : (⟦String⟧ ⟦₀→₀⟧ ⟦𝟚⟧) is-good is-good
  ⟦is-good⟧ {"good"} refl = ⟦1₂⟧
  ⟦is-good⟧ {_}      refl = {!!}

  p-is-good = pFunName defEnv2 (quote is-good)
  unquoteDecl ⟦is-good⟧' = p-is-good
  test-is-good = {!!}
  -}

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


Simplify change semantics

Simplify change semantics

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change evaluation (Def 3.6 and Fig. 4h).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity

module Parametric.Change.Specification
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    {{validity-structure : Validity.Structure ⟦_⟧Base}}
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Theorem.CongApp
open import Postulate.Extensionality

module Structure where
  ---------------
  -- Interface --
  ---------------

  -- We provide: Derivatives of terms.
  ⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ) → Δ₍ τ ₎ (⟦ t ⟧ ρ)

  -- And we provide correctness proofs about the derivatives.
  correctness : ∀ {τ Γ} (t : Term Γ τ) →
    IsDerivative₍ Γ , τ ₎ ⟦ t ⟧ ⟦ t ⟧Δ

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

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

  ⟦_⟧Δ (const {τ} c) ρ dρ = nil₍ τ ₎ (⟦ c ⟧Const)
  ⟦_⟧Δ (var x) ρ dρ = ⟦ x ⟧ΔVar ρ dρ
  ⟦_⟧Δ (app {σ} {τ} s t) ρ dρ =
       call-change {σ} {τ} (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)
  ⟦_⟧Δ (abs {σ} {τ} t) ρ dρ = record
    { apply = λ v dv → ⟦ t ⟧Δ (v • ρ) (dv • dρ)
    ; correct = λ v dv →
      begin
        ⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ)  ⊞₍ τ ₎
        ⟦ t ⟧Δ (v ⊞₍ σ ₎ dv • ρ) (nil₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ)
      ≡⟨  correctness t (v ⊞₍ σ ₎ dv • ρ) (nil₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ) ⟩
        ⟦ t ⟧ (after-env (nil₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ))
      ≡⟨⟩
        ⟦ t ⟧ (((v ⊞₍ σ ₎ dv) ⊞₍ σ ₎ nil₍ σ ₎ (v ⊞₍ σ ₎ dv)) • after-env dρ)
      ≡⟨  cong (λ hole → ⟦ t ⟧ (hole • after-env dρ)) (update-nil₍ σ ₎ (v ⊞₍ σ ₎ dv))  ⟩
        ⟦ t ⟧ (v ⊞₍ σ ₎ dv • after-env dρ)
      ≡⟨⟩
        ⟦ t ⟧ (after-env (dv • dρ))
      ≡⟨  sym (correctness t (v • ρ) (dv • dρ))  ⟩
        ⟦ t ⟧ (v • ρ)  ⊞₍ τ ₎  ⟦ t ⟧Δ (v • ρ) (dv • dρ)
      ∎
    } where open ≡-Reasoning

  correctVar : ∀ {τ Γ} (x : Var Γ τ) →
    IsDerivative₍ Γ , τ ₎ ⟦ x ⟧ ⟦ x ⟧ΔVar
  correctVar (this) (v • ρ) (dv • dρ) = refl
  correctVar (that y) (v • ρ) (dv • dρ) = correctVar y ρ dρ

  correctness (const {τ} c) ρ dρ = update-nil₍ τ ₎ ⟦ c ⟧Const
  correctness {τ} (var x) ρ dρ = correctVar {τ} x ρ dρ
  correctness (app {σ} {τ} s t) ρ dρ =
    let
      f₁ = ⟦ s ⟧ ρ
      f₂ = ⟦ s ⟧ (after-env dρ)
      Δf = ⟦ s ⟧Δ ρ dρ
      u₁ = ⟦ t ⟧ ρ
      u₂ = ⟦ t ⟧ (after-env dρ)
      Δu = ⟦ t ⟧Δ ρ dρ
    in
      begin
        f₁ u₁ ⊞₍ τ ₎ call-change {σ} {τ} Δf u₁ Δu
      ≡⟨  sym (is-valid {σ} {τ} Δf u₁ Δu) ⟩
        (f₁ ⊞₍ σ ⇒ τ ₎ Δf) (u₁ ⊞₍ σ ₎ Δu)
      ≡⟨ correctness {σ ⇒ τ} s ρ dρ ⟨$⟩ correctness {σ} t ρ dρ ⟩
        f₂ u₂
      ∎ where open ≡-Reasoning
  correctness {σ ⇒ τ} {Γ} (abs t) ρ dρ = ext (λ v →
    let
      -- dρ′ : ΔEnv (σ • Γ) (v • ρ)
      dρ′ = nil₍ σ ₎ v • dρ
    in
      begin
        ⟦ t ⟧ (v • ρ) ⊞₍ τ ₎ ⟦ t ⟧Δ _ dρ′
      ≡⟨ correctness {τ} t _ dρ′ ⟩
        ⟦ t ⟧ (after-env dρ′)
      ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • after-env dρ)) (update-nil₍ σ ₎ v) ⟩
        ⟦ t ⟧ (v • after-env dρ)
      ∎
    ) where open ≡-Reasoning

  -- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv

  corollary : ∀ {σ τ Γ}
    (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ) →
      (⟦ s ⟧ ρ ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ ρ dρ)
        (⟦ t ⟧ ρ ⊞₍ σ ₎ ⟦ t ⟧Δ ρ dρ)
    ≡ (⟦ s ⟧ ρ) (⟦ t ⟧ ρ)
      ⊞₍ τ ₎
      (call-change {σ} {τ} (⟦ s ⟧Δ ρ dρ)) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

  corollary {σ} {τ} s t ρ dρ =
    is-valid {σ} {τ} (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

  corollary-closed : ∀ {σ τ} (t : Term ∅ (σ ⇒ τ))
    (v : ⟦ σ ⟧) (dv : Δ₍ σ ₎ v)
    → ⟦ t ⟧ ∅ (after₍ σ ₎ dv)
    ≡ ⟦ t ⟧ ∅ v ⊞₍ τ ₎ call-change {σ} {τ} (⟦ t ⟧Δ ∅ ∅) v dv

  corollary-closed {σ} {τ} t v dv =
    let
      f  = ⟦ t ⟧ ∅
      Δf = ⟦ t ⟧Δ ∅ ∅
    in
      begin
        f (after₍ σ ₎ dv)
      ≡⟨ cong (λ hole → hole (after₍ σ ₎ dv))
              (sym (correctness {σ ⇒ τ} t ∅ ∅)) ⟩
         (f ⊞₍ σ ⇒ τ ₎ Δf) (after₍ σ ₎ dv)
      ≡⟨ is-valid {σ} {τ} (⟦ t ⟧Δ ∅ ∅) v dv ⟩
        f (before₍ σ ₎ dv) ⊞₍ τ ₎ call-change {σ} {τ} Δf v dv
      ∎ where open ≡-Reasoning

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Change evaluation (Def 3.6 and Fig. 4h).
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity

module Parametric.Change.Specification
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    {{validity-structure : Validity.Structure ⟦_⟧Base}}
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Theorem.CongApp
open import Postulate.Extensionality

module Structure where
  ---------------
  -- Interface --
  ---------------

  -- We provide: Derivatives of terms.
  ⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ) → Δ₍ τ ₎ (⟦ t ⟧ ρ)

  -- And we provide correctness proofs about the derivatives.
  correctness : ∀ {τ Γ} (t : Term Γ τ) →
    IsDerivative₍ Γ , τ ₎ ⟦ t ⟧ ⟦ t ⟧Δ

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

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

  ⟦_⟧Δ (const {τ} c) ρ dρ = nil₍ τ ₎ (⟦ const c ⟧Term ρ)
  ⟦_⟧Δ (var x) ρ dρ = ⟦ x ⟧ΔVar ρ dρ
  ⟦_⟧Δ (app {σ} {τ} s t) ρ dρ =
       call-change {σ} {τ} (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)
  ⟦_⟧Δ (abs {σ} {τ} t) ρ dρ = record
    { apply = λ v dv → ⟦ t ⟧Δ (v • ρ) (dv • dρ)
    ; correct = λ v dv →
      begin
        ⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ)  ⊞₍ τ ₎
        ⟦ t ⟧Δ (v ⊞₍ σ ₎ dv • ρ) (nil₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ)
      ≡⟨  correctness t (v ⊞₍ σ ₎ dv • ρ) (nil₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ) ⟩
        ⟦ t ⟧ (after-env (nil₍ σ ₎ (v ⊞₍ σ ₎ dv) • dρ))
      ≡⟨⟩
        ⟦ t ⟧ (((v ⊞₍ σ ₎ dv) ⊞₍ σ ₎ nil₍ σ ₎ (v ⊞₍ σ ₎ dv)) • after-env dρ)
      ≡⟨  cong (λ hole → ⟦ t ⟧ (hole • after-env dρ)) (update-nil₍ σ ₎ (v ⊞₍ σ ₎ dv))  ⟩
        ⟦ t ⟧ (v ⊞₍ σ ₎ dv • after-env dρ)
      ≡⟨⟩
        ⟦ t ⟧ (after-env (dv • dρ))
      ≡⟨  sym (correctness t (v • ρ) (dv • dρ))  ⟩
        ⟦ t ⟧ (v • ρ)  ⊞₍ τ ₎  ⟦ t ⟧Δ (v • ρ) (dv • dρ)
      ∎
    } where open ≡-Reasoning

  correctVar : ∀ {τ Γ} (x : Var Γ τ) →
    IsDerivative₍ Γ , τ ₎ ⟦ x ⟧ ⟦ x ⟧ΔVar
  correctVar (this) (v • ρ) (dv • dρ) = refl
  correctVar (that y) (v • ρ) (dv • dρ) = correctVar y ρ dρ

  correctness (const {τ} c) ρ dρ = update-nil₍ τ ₎ ⟦ c ⟧Const
  correctness {τ} (var x) ρ dρ = correctVar {τ} x ρ dρ
  correctness (app {σ} {τ} s t) ρ dρ =
    let
      f₁ = ⟦ s ⟧ ρ
      f₂ = ⟦ s ⟧ (after-env dρ)
      Δf = ⟦ s ⟧Δ ρ dρ
      u₁ = ⟦ t ⟧ ρ
      u₂ = ⟦ t ⟧ (after-env dρ)
      Δu = ⟦ t ⟧Δ ρ dρ
    in
      begin
        f₁ u₁ ⊞₍ τ ₎ call-change {σ} {τ} Δf u₁ Δu
      ≡⟨  sym (is-valid {σ} {τ} Δf u₁ Δu) ⟩
        (f₁ ⊞₍ σ ⇒ τ ₎ Δf) (u₁ ⊞₍ σ ₎ Δu)
      ≡⟨ correctness {σ ⇒ τ} s ρ dρ ⟨$⟩ correctness {σ} t ρ dρ ⟩
        f₂ u₂
      ∎ where open ≡-Reasoning
  correctness {σ ⇒ τ} {Γ} (abs t) ρ dρ = ext (λ v →
    let
      -- dρ′ : ΔEnv (σ • Γ) (v • ρ)
      dρ′ = nil₍ σ ₎ v • dρ
    in
      begin
        ⟦ t ⟧ (v • ρ) ⊞₍ τ ₎ ⟦ t ⟧Δ _ dρ′
      ≡⟨ correctness {τ} t _ dρ′ ⟩
        ⟦ t ⟧ (after-env dρ′)
      ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • after-env dρ)) (update-nil₍ σ ₎ v) ⟩
        ⟦ t ⟧ (v • after-env dρ)
      ∎
    ) where open ≡-Reasoning

  -- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv

  corollary : ∀ {σ τ Γ}
    (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ) →
      (⟦ s ⟧ ρ ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ ρ dρ)
        (⟦ t ⟧ ρ ⊞₍ σ ₎ ⟦ t ⟧Δ ρ dρ)
    ≡ (⟦ s ⟧ ρ) (⟦ t ⟧ ρ)
      ⊞₍ τ ₎
      (call-change {σ} {τ} (⟦ s ⟧Δ ρ dρ)) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

  corollary {σ} {τ} s t ρ dρ =
    is-valid {σ} {τ} (⟦ s ⟧Δ ρ dρ) (⟦ t ⟧ ρ) (⟦ t ⟧Δ ρ dρ)

  corollary-closed : ∀ {σ τ} (t : Term ∅ (σ ⇒ τ))
    (v : ⟦ σ ⟧) (dv : Δ₍ σ ₎ v)
    → ⟦ t ⟧ ∅ (after₍ σ ₎ dv)
    ≡ ⟦ t ⟧ ∅ v ⊞₍ τ ₎ call-change {σ} {τ} (⟦ t ⟧Δ ∅ ∅) v dv

  corollary-closed {σ} {τ} t v dv =
    let
      f  = ⟦ t ⟧ ∅
      Δf = ⟦ t ⟧Δ ∅ ∅
    in
      begin
        f (after₍ σ ₎ dv)
      ≡⟨ cong (λ hole → hole (after₍ σ ₎ dv))
              (sym (correctness {σ ⇒ τ} t ∅ ∅)) ⟩
         (f ⊞₍ σ ⇒ τ ₎ Δf) (after₍ σ ₎ dv)
      ≡⟨ is-valid {σ} {τ} (⟦ t ⟧Δ ∅ ∅) v dv ⟩
        f (before₍ σ ₎ dv) ⊞₍ τ ₎ call-change {σ} {τ} Δf v dv
      ∎ where open ≡-Reasoning


Drop redundant import

Drop redundant import

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
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

data [_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ] dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

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

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ 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ρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x 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ρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.
open import Postulate.Extensionality

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ _ _ _ daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da a1 a2 daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ v1 v2 dv → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ v1 v2 dv x → tt
fromto→valid {pair σ τ} (a1 , b1) (a2 , b2) (da , db) (daa , dbb) = (fromto→valid  _ _ _ daa) , (fromto→valid _ _ _ dbb)
fromto→valid {σ ⇒ τ} f1 f2 df dff = λ a da ada →
  fromto→valid _ _ _ (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto _ _ ada)

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid _ _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ _ _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)

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

data [_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ] dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

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

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ 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ρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x 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ρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.
open import Postulate.Extensionality

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ _ _ _ daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da a1 a2 daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ v1 v2 dv → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ v1 v2 dv x → tt
fromto→valid {pair σ τ} (a1 , b1) (a2 , b2) (da , db) (daa , dbb) = (fromto→valid  _ _ _ daa) , (fromto→valid _ _ _ dbb)
fromto→valid {σ ⇒ τ} f1 f2 df dff = λ a da ada →
  fromto→valid _ _ _ (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto _ _ ada)

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid _ _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ _ _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)


Enable missing ChangeAlgebra instance for sums

module New.Changes where

open import Data.Product public hiding (map)
open import Data.Sum public hiding (map)
open import Data.Unit.Base public

open import Relation.Binary.PropositionalEquality public hiding ([_])
open import Postulate.Extensionality public
open import Level

open import Theorem.Groups-Nehemiah public

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    _⊚[_]_ : Ch → A → Ch → Ch
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
    ⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ da1 ⊚[ a ] da2 ≡ a ⊕ da1 ⊕ da2
    ⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (da1 ⊚[ a ] da2)
  infixl 6 _⊕_ _⊝_

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  default-⊚ : Ch → A → Ch → Ch
  default-⊚ da1 a da2 = a ⊕ da1 ⊕ da2 ⊝ a
  default-⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (default-⊚ da1 a da2)
  default-⊚-valid a da1 ada1 da2 ada2 = ⊝-valid a (a ⊕ da1 ⊕ da2)
  default-⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ default-⊚ da1 a da2 ≡ a ⊕ da1 ⊕ da2
  default-⊚-correct a da1 ada1 da2 ada2 = update-diff (a ⊕ da1 ⊕ da2) a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  open ≡-Reasoning
  open import Postulate.Extensionality
  instance
    funCA : ChAlg (A → B)
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : fCh) → ∀ a da → Set ℓ₂
  WellDefinedFunChangePoint f df a da = (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChange : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  WellDefinedFunChange f df = ∀ a da (ada : valid a da) → WellDefinedFunChangePoint f df a da

  private
    fvalid : (A → B) → fCh → Set (ℓ₁ ⊔ ℓ₂)
    fvalid =  λ f df → ∀ a da (ada : valid a da) →
        valid (f a) (df a da) ×
        WellDefinedFunChangePoint f df a da
    f⊝-valid : ∀ (f g : A → B) → fvalid f (g f⊝ f)
    f⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)

    -- Two alternatives. Proofs on f⊚ are a bit easier.
    -- f⊚ is optimized relying on the incrementalization property for df2.
    f⊚ f⊚2 : fCh → (A → B) → fCh → fCh
    f⊚ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)
    f⊚-valid : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚ df1 f df2)
    f⊚-valid f df1 fdf1 df2 fdf2 a da ada
      rewrite ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      | ⊚-correct
        (f (a ⊕ da))
        (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
        (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
      =
        ⊚-valid (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      , proj₂ (fdf2 a da ada)

    -- f⊚2 is optimized relying on the incrementalization property for df1, so we need to use that property to rewrite some goals.
    f⊚2 df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))
    f⊚-valid2 : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚2 df1 f df2)
    f⊚-valid2 f df1 fdf1 df2 fdf2 = lemma
      where
        -- Prove that (df2 (a ⊕ da) (nil (a ⊕ da))) is valid for (f a ⊕ df1 a da).
        -- Using the incrementalization property for df1, that becomes (f ⊕ df1) (a ⊕ da).
        --
        -- Since df2 is valid for f ⊕ df1, it follows that (df2 (a ⊕ da) (nil (a ⊕ da)))
        -- is indeed valid for (f ⊕ df1) (a ⊕ da).
        valid-df2-a2-nila2 : ∀ a da → (valid a da) → valid (f a ⊕ df1 a da) (df2 (a ⊕ da) (nil (a ⊕ da)))
        valid-df2-a2-nila2 a da ada rewrite sym (proj₂ (fdf1 a da ada)) = proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da)))

        lemma : fvalid f (f⊚2 df1 f df2)
        lemma a da ada
          rewrite ⊚-correct
            (f a)
            (df1 a da) (proj₁ (fdf1 a da ada))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          | update-nil (a ⊕ da)
          | ⊚-correct
            (f (a ⊕ da))
            (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
          | proj₂ (fdf1 a da ada)
          = ⊚-valid (f a) (df1 a da) (proj₁ (fdf1 a da ada)) (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          , refl

    f⊚-correct : ∀ (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → (a : A) →
      (f f⊕ f⊚ df1 f df2) a ≡ ((f f⊕ df1) f⊕ df2) a
    f⊚-correct f df1 fdf1 df2 fdf2 a = ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a (nil a)) (proj₁ (fdf2 a (nil a) (nil-valid a)))

  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = fvalid
      ; _⊚[_]_ = f⊚
      ; ⊝-valid = f⊝-valid
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      ; ⊚-correct = λ f df1 fdf1 df2 fdf2 → ext (f⊚-correct f df1 fdf1 df2 fdf2)
      ; ⊚-valid = f⊚-valid
      } }

  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → pCh → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    p⊚-valid : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → pvalid p (dp1 p⊚[ p ] dp2)
    p⊚-valid (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) = ⊚-valid a da1 ada1 da2 ada2 , ⊚-valid b db1 bdb1 db2 bdb2
    p⊚-correct : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → p p⊕ (dp1 p⊚[ p ] dp2) ≡ (p p⊕ dp1) p⊕ dp2
    p⊚-correct (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) rewrite ⊚-correct a da1 ada1 da2 ada2 | ⊚-correct b db1 bdb1 db2 bdb2 = refl
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = pCh
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    ; _⊚[_]_ = _p⊚[_]_
    ; ⊚-valid = p⊚-valid
    ; ⊚-correct = p⊚-correct
    } }

  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set (ℓ₁ ⊔ ℓ₂) where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  data SValid : A ⊎ B → SumChange → Set (ℓ₁ ⊔ ℓ₂) where
    sv₁ : ∀ (a : A) (da : Ch A) (ada : valid a da) → SValid (inj₁ a) (convert₁ (ch₁ da))
    sv₂ : ∀ (b : B) (db : Ch B) (bdb : valid b db) → SValid (inj₂ b) (convert₁ (ch₂ db))
    svrp₁ : ∀ a1 b2 → SValid (inj₁ a1) (convert₁ (rp (inj₂ b2)))
    svrp₂ : ∀ b1 a2 → SValid (inj₂ b1) (convert₁ (rp (inj₁ a2)))

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    s⊕2 : A ⊎ B → SumChange2 → A ⊎ B
    s⊕2 (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    s⊕2 (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    s⊕2 (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    s⊕2 (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    s⊕2 s (rp s₁) = s₁

    s⊕ : A ⊎ B → SumChange → A ⊎ B
    s⊕ s ds = s⊕2 s (convert ds)

    s⊝2 : A ⊎ B → A ⊎ B → SumChange2
    s⊝2 (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    s⊝2 (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    s⊝2 s2 s1 = rp s2

    s⊝ : A ⊎ B → A ⊎ B → SumChange
    s⊝ s2 s1 = convert₁ (s⊝2 s2 s1)

    s⊝-valid : (a b : A ⊎ B) → SValid a (s⊝ b a)
    s⊝-valid (inj₁ x1) (inj₁ x2) = sv₁ x1 (x2 ⊝ x1) (⊝-valid x1 x2)
    s⊝-valid (inj₂ y1) (inj₂ y2) = sv₂ y1 (y2 ⊝ y1) (⊝-valid y1 y2)
    s⊝-valid s1@(inj₁ x) s2@(inj₂ y) = svrp₁ x y
    s⊝-valid s1@(inj₂ y) s2@(inj₁ x) = svrp₂ y x

    s⊕-⊝ : (b a : A ⊎ B) → s⊕ a (s⊝ b a) ≡ b
    s⊕-⊝ (inj₁ x2) (inj₁ x1) rewrite ⊕-⊝ x2 x1 = refl
    s⊕-⊝ (inj₁ x2) (inj₂ y1) = refl
    s⊕-⊝ (inj₂ y2) (inj₁ x1) = refl
    s⊕-⊝ (inj₂ y2) (inj₂ y1) rewrite ⊕-⊝ y2 y1 = refl
    {-# TERMINATING #-}
    isSumCA : IsChAlg (A ⊎ B) SumChange
    s⊚-valid : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      SValid a (IsChAlg.default-⊚ isSumCA da1 a da2)
    s⊚-correct : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      s⊕ a (IsChAlg.default-⊚ isSumCA da1 a da2) ≡
      s⊕ (s⊕ a da1) da2

  instance
    sumCA : ChAlg (A ⊎ B)
  isSumCA = record
    { _⊕_ = s⊕
    ; _⊝_ = s⊝
    ; valid = SValid
    ; ⊝-valid = s⊝-valid
    ; ⊕-⊝ = s⊕-⊝
    ; _⊚[_]_ = IsChAlg.default-⊚ isSumCA
    ; ⊚-valid = s⊚-valid
    ; ⊚-correct = s⊚-correct
    }

  s⊚-valid = IsChAlg.default-⊚-valid isSumCA
  s⊚-correct = IsChAlg.default-⊚-correct isSumCA

  sumCA = record
    { Ch = SumChange
    ; isChAlg = isSumCA }

open import Data.Integer

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b}
  ; ⊚-valid = λ a da1 _ da2 _ → tt
  ; ⊚-correct = λ a da1 _ da2 _ → sym (associative-int a da1 da2)
  } }

module New.Changes where

open import Data.Product public hiding (map)
open import Data.Sum public hiding (map)
open import Data.Unit.Base public

open import Relation.Binary.PropositionalEquality public hiding ([_])
open import Postulate.Extensionality public
open import Level

open import Theorem.Groups-Nehemiah public

record IsChAlg {ℓ : Level} (A : Set ℓ) (Ch : Set ℓ) : Set (suc ℓ) where
  field
    _⊕_ : A → Ch → A
    _⊝_ : A → A → Ch
    valid : A → Ch → Set ℓ
    _⊚[_]_ : Ch → A → Ch → Ch
    ⊝-valid : ∀ (a b : A) → valid a (b ⊝ a)
    ⊕-⊝ : (b a : A) → a ⊕ (b ⊝ a) ≡ b
    ⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ da1 ⊚[ a ] da2 ≡ a ⊕ da1 ⊕ da2
    ⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (da1 ⊚[ a ] da2)
  infixl 6 _⊕_ _⊝_

  Δ : A → Set ℓ
  Δ a = Σ[ da ∈ Ch ] (valid a da)

  update-diff = ⊕-⊝

  nil : A → Ch
  nil a = a ⊝ a
  nil-valid : (a : A) → valid a (nil a)
  nil-valid a = ⊝-valid a a
  update-nil : (a : A) → a ⊕ nil a ≡ a
  update-nil a = update-diff a a

  default-⊚ : Ch → A → Ch → Ch
  default-⊚ da1 a da2 = a ⊕ da1 ⊕ da2 ⊝ a
  default-⊚-valid : (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 → valid a (default-⊚ da1 a da2)
  default-⊚-valid a da1 ada1 da2 ada2 = ⊝-valid a (a ⊕ da1 ⊕ da2)
  default-⊚-correct : ∀ (a : A) → (da1 : Ch) → valid a da1 → (da2 : Ch) → valid (a ⊕ da1) da2 →
      a ⊕ default-⊚ da1 a da2 ≡ a ⊕ da1 ⊕ da2
  default-⊚-correct a da1 ada1 da2 ada2 = update-diff (a ⊕ da1 ⊕ da2) a

record ChAlg {ℓ : Level} (A : Set ℓ) : Set (suc ℓ) where
  field
    Ch : Set ℓ
    isChAlg : IsChAlg A Ch
  open IsChAlg isChAlg public

open ChAlg {{...}} public hiding (Ch)
Ch : ∀ {ℓ} (A : Set ℓ) → {{CA : ChAlg A}} → Set ℓ
Ch A {{CA}} = ChAlg.Ch CA

-- Huge hack, but it does gives the output you want to see in all cases I've seen.

{-# DISPLAY IsChAlg.valid x = valid #-}
{-# DISPLAY ChAlg.valid x = valid #-}
{-# DISPLAY IsChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY ChAlg._⊕_ x = _⊕_ #-}
{-# DISPLAY IsChAlg.nil x = nil #-}
{-# DISPLAY ChAlg.nil x = nil #-}
{-# DISPLAY IsChAlg._⊝_ x = _⊝_ #-}
{-# DISPLAY ChAlg._⊝_ x = _⊝_ #-}

module _ {ℓ₁} {ℓ₂}
  {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where
  open ≡-Reasoning
  open import Postulate.Extensionality
  instance
    funCA : ChAlg (A → B)
  private
    fCh = A → Ch A → Ch B
    _f⊕_ : (A → B) → fCh → A → B
    _f⊕_ = λ f df a → f a ⊕ df a (nil a)
    _f⊝_ : (g f : A → B) → fCh
    _f⊝_ = λ g f a da → g (a ⊕ da) ⊝ f a

  IsDerivative : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  IsDerivative f df = ∀ a da (v : valid a da) → f (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChangePoint : ∀ (f : A → B) → (df : fCh) → ∀ a da → Set ℓ₂
  WellDefinedFunChangePoint f df a da = (f f⊕ df) (a ⊕ da) ≡ f a ⊕ df a da

  WellDefinedFunChange : ∀ (f : A → B) → (df : fCh) → Set (ℓ₁ ⊔ ℓ₂)
  WellDefinedFunChange f df = ∀ a da (ada : valid a da) → WellDefinedFunChangePoint f df a da

  private
    fvalid : (A → B) → fCh → Set (ℓ₁ ⊔ ℓ₂)
    fvalid =  λ f df → ∀ a da (ada : valid a da) →
        valid (f a) (df a da) ×
        WellDefinedFunChangePoint f df a da
    f⊝-valid : ∀ (f g : A → B) → fvalid f (g f⊝ f)
    f⊝-valid = λ f g a da (v : valid a da) →
         ⊝-valid (f a) (g (a ⊕ da))
        , ( begin
          f (a ⊕ da) ⊕ (g (a ⊕ da ⊕ nil (a ⊕ da)) ⊝ f (a ⊕ da))
        ≡⟨ cong (λ □ → f (a ⊕ da) ⊕ (g □ ⊝ f (a ⊕ da)))
             (update-nil (a ⊕ da)) ⟩
          f (a ⊕ da) ⊕ (g (a ⊕ da) ⊝ f (a ⊕ da))
        ≡⟨ update-diff (g (a ⊕ da)) (f (a ⊕ da)) ⟩
          g (a ⊕ da)
        ≡⟨ sym (update-diff (g (a ⊕ da)) (f a)) ⟩
          f a ⊕ (g (a ⊕ da) ⊝ f a)
        ∎)

    -- Two alternatives. Proofs on f⊚ are a bit easier.
    -- f⊚ is optimized relying on the incrementalization property for df2.
    f⊚ f⊚2 : fCh → (A → B) → fCh → fCh
    f⊚ df1 f df2 = λ a da → (df1 a (nil a)) ⊚[ f a ] (df2 a da)
    f⊚-valid : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚ df1 f df2)
    f⊚-valid f df1 fdf1 df2 fdf2 a da ada
      rewrite ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      | ⊚-correct
        (f (a ⊕ da))
        (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
        (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
      =
        ⊚-valid (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a da) (proj₁ (fdf2 a da ada))
      , proj₂ (fdf2 a da ada)

    -- f⊚2 is optimized relying on the incrementalization property for df1, so we need to use that property to rewrite some goals.
    f⊚2 df1 f df2 = λ a da → df1 a da ⊚[ f a ] df2 (a ⊕ da) (nil (a ⊕ da))
    f⊚-valid2 : (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → fvalid f (f⊚2 df1 f df2)
    f⊚-valid2 f df1 fdf1 df2 fdf2 = lemma
      where
        -- Prove that (df2 (a ⊕ da) (nil (a ⊕ da))) is valid for (f a ⊕ df1 a da).
        -- Using the incrementalization property for df1, that becomes (f ⊕ df1) (a ⊕ da).
        --
        -- Since df2 is valid for f ⊕ df1, it follows that (df2 (a ⊕ da) (nil (a ⊕ da)))
        -- is indeed valid for (f ⊕ df1) (a ⊕ da).
        valid-df2-a2-nila2 : ∀ a da → (valid a da) → valid (f a ⊕ df1 a da) (df2 (a ⊕ da) (nil (a ⊕ da)))
        valid-df2-a2-nila2 a da ada rewrite sym (proj₂ (fdf1 a da ada)) = proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da)))

        lemma : fvalid f (f⊚2 df1 f df2)
        lemma a da ada
          rewrite ⊚-correct
            (f a)
            (df1 a da) (proj₁ (fdf1 a da ada))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          | update-nil (a ⊕ da)
          | ⊚-correct
            (f (a ⊕ da))
            (df1 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf1 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
            (df2 (a ⊕ da) (nil (a ⊕ da))) (proj₁ (fdf2 (a ⊕ da) (nil (a ⊕ da)) (nil-valid (a ⊕ da))))
          | proj₂ (fdf1 a da ada)
          = ⊚-valid (f a) (df1 a da) (proj₁ (fdf1 a da ada)) (df2 (a ⊕ da) (nil (a ⊕ da))) (valid-df2-a2-nila2 a da ada)
          , refl

    f⊚-correct : ∀ (f : A → B) → (df1 : fCh) → fvalid f df1 → (df2 : fCh) → fvalid (f f⊕ df1) df2 → (a : A) →
      (f f⊕ f⊚ df1 f df2) a ≡ ((f f⊕ df1) f⊕ df2) a
    f⊚-correct f df1 fdf1 df2 fdf2 a = ⊚-correct (f a) (df1 a (nil a)) (proj₁ (fdf1 a (nil a) (nil-valid a))) (df2 a (nil a)) (proj₁ (fdf2 a (nil a) (nil-valid a)))

  private
    funUpdateDiff : ∀ g f a → (f f⊕ (g f⊝ f)) a ≡ g a
  funUpdateDiff g f a rewrite update-nil a = update-diff (g a) (f a)
  funCA = record
    { Ch = A → Ch A → Ch B
    ; isChAlg = record
      { _⊕_ = _f⊕_
      ; _⊝_ = _f⊝_
      ; valid = fvalid
      ; _⊚[_]_ = f⊚
      ; ⊝-valid = f⊝-valid
      ; ⊕-⊝ = λ g f → ext (funUpdateDiff g f)
      ; ⊚-correct = λ f df1 fdf1 df2 fdf2 → ext (f⊚-correct f df1 fdf1 df2 fdf2)
      ; ⊚-valid = f⊚-valid
      } }

  private
    pCh = Ch A × Ch B
    _p⊕_ : A × B → Ch A × Ch B → A × B
    _p⊕_ (a , b) (da , db) = a ⊕ da , b ⊕ db
    _p⊝_ : A × B → A × B → pCh
    _p⊝_ (a2 , b2) (a1 , b1) = a2 ⊝ a1 , b2 ⊝ b1
    pvalid : A × B → pCh → Set (ℓ₂ ⊔ ℓ₁)
    pvalid (a , b) (da , db) = valid a da × valid b db
    p⊝-valid : (p1 p2 : A × B) → pvalid p1 (p2 p⊝ p1)
    p⊝-valid (a1 , b1) (a2 , b2) = ⊝-valid a1 a2 , ⊝-valid b1 b2
    p⊕-⊝ : (p2 p1 : A × B) → p1 p⊕ (p2 p⊝ p1) ≡ p2
    p⊕-⊝ (a2 , b2) (a1 , b1) = cong₂ _,_ (⊕-⊝ a2 a1) (⊕-⊝ b2 b1)
    _p⊚[_]_ : pCh → A × B → pCh → pCh
    (da1 , db1) p⊚[ a , b ] (da2 , db2) = da1 ⊚[ a ] da2 , db1 ⊚[ b ] db2
    p⊚-valid : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → pvalid p (dp1 p⊚[ p ] dp2)
    p⊚-valid (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) = ⊚-valid a da1 ada1 da2 ada2 , ⊚-valid b db1 bdb1 db2 bdb2
    p⊚-correct : (p : A × B) (dp1 : pCh) →
      pvalid p dp1 →
      (dp2 : pCh) → pvalid (p p⊕ dp1) dp2 → p p⊕ (dp1 p⊚[ p ] dp2) ≡ (p p⊕ dp1) p⊕ dp2
    p⊚-correct (a , b) (da1 , db1) (ada1 , bdb1) (da2 , db2) (ada2 , bdb2) rewrite ⊚-correct a da1 ada1 da2 ada2 | ⊚-correct b db1 bdb1 db2 bdb2 = refl
  instance
    pairCA : ChAlg (A × B)
  pairCA = record
    { Ch = pCh
    ; isChAlg = record
    { _⊕_ = _p⊕_
    ; _⊝_ = _p⊝_
    ; valid = pvalid
    ; ⊝-valid = p⊝-valid
    ; ⊕-⊝ = p⊕-⊝
    ; _⊚[_]_ = _p⊚[_]_
    ; ⊚-valid = p⊚-valid
    ; ⊚-correct = p⊚-correct
    } }

  private
    SumChange = (Ch A ⊎ Ch B) ⊎ (A ⊎ B)

  data SumChange2 : Set (ℓ₁ ⊔ ℓ₂) where
    ch₁ : (da : Ch A) → SumChange2
    ch₂ : (db : Ch B) → SumChange2
    rp : (s : A ⊎ B) → SumChange2

  convert : SumChange → SumChange2
  convert (inj₁ (inj₁ da)) = ch₁ da
  convert (inj₁ (inj₂ db)) = ch₂ db
  convert (inj₂ s) = rp s
  convert₁ : SumChange2 → SumChange
  convert₁ (ch₁ da) = inj₁ (inj₁ da)
  convert₁ (ch₂ db) = inj₁ (inj₂ db)
  convert₁ (rp s) = inj₂ s

  data SValid : A ⊎ B → SumChange → Set (ℓ₁ ⊔ ℓ₂) where
    sv₁ : ∀ (a : A) (da : Ch A) (ada : valid a da) → SValid (inj₁ a) (convert₁ (ch₁ da))
    sv₂ : ∀ (b : B) (db : Ch B) (bdb : valid b db) → SValid (inj₂ b) (convert₁ (ch₂ db))
    svrp₁ : ∀ a1 b2 → SValid (inj₁ a1) (convert₁ (rp (inj₂ b2)))
    svrp₂ : ∀ b1 a2 → SValid (inj₂ b1) (convert₁ (rp (inj₁ a2)))

  inv1 : ∀ ds → convert₁ (convert ds) ≡ ds
  inv1 (inj₁ (inj₁ da)) = refl
  inv1 (inj₁ (inj₂ db)) = refl
  inv1 (inj₂ s) = refl
  inv2 : ∀ ds → convert (convert₁ ds) ≡ ds
  inv2 (ch₁ da) = refl
  inv2 (ch₂ db) = refl
  inv2 (rp s) = refl

  private
    s⊕2 : A ⊎ B → SumChange2 → A ⊎ B
    s⊕2 (inj₁ a) (ch₁ da) = inj₁ (a ⊕ da)
    s⊕2 (inj₂ b) (ch₂ db) = inj₂ (b ⊕ db)
    s⊕2 (inj₂ b) (ch₁ da) = inj₂ b -- invalid
    s⊕2 (inj₁ a) (ch₂ db) = inj₁ a -- invalid
    s⊕2 s (rp s₁) = s₁

    s⊕ : A ⊎ B → SumChange → A ⊎ B
    s⊕ s ds = s⊕2 s (convert ds)

    s⊝2 : A ⊎ B → A ⊎ B → SumChange2
    s⊝2 (inj₁ x2) (inj₁ x1) = ch₁ (x2 ⊝ x1)
    s⊝2 (inj₂ y2) (inj₂ y1) = ch₂ (y2 ⊝ y1)
    s⊝2 s2 s1 = rp s2

    s⊝ : A ⊎ B → A ⊎ B → SumChange
    s⊝ s2 s1 = convert₁ (s⊝2 s2 s1)

    s⊝-valid : (a b : A ⊎ B) → SValid a (s⊝ b a)
    s⊝-valid (inj₁ x1) (inj₁ x2) = sv₁ x1 (x2 ⊝ x1) (⊝-valid x1 x2)
    s⊝-valid (inj₂ y1) (inj₂ y2) = sv₂ y1 (y2 ⊝ y1) (⊝-valid y1 y2)
    s⊝-valid s1@(inj₁ x) s2@(inj₂ y) = svrp₁ x y
    s⊝-valid s1@(inj₂ y) s2@(inj₁ x) = svrp₂ y x

    s⊕-⊝ : (b a : A ⊎ B) → s⊕ a (s⊝ b a) ≡ b
    s⊕-⊝ (inj₁ x2) (inj₁ x1) rewrite ⊕-⊝ x2 x1 = refl
    s⊕-⊝ (inj₁ x2) (inj₂ y1) = refl
    s⊕-⊝ (inj₂ y2) (inj₁ x1) = refl
    s⊕-⊝ (inj₂ y2) (inj₂ y1) rewrite ⊕-⊝ y2 y1 = refl
    {-# TERMINATING #-}
    isSumCA : IsChAlg (A ⊎ B) SumChange
    s⊚-valid : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      SValid a (IsChAlg.default-⊚ isSumCA da1 a da2)
    s⊚-correct : (a : A ⊎ B) (da1 : SumChange) →
      SValid a da1 →
      (da2 : SumChange) →
      SValid (s⊕ a da1) da2 →
      s⊕ a (IsChAlg.default-⊚ isSumCA da1 a da2) ≡
      s⊕ (s⊕ a da1) da2

  sumCA : ChAlg (A ⊎ B)
  isSumCA = record
    { _⊕_ = s⊕
    ; _⊝_ = s⊝
    ; valid = SValid
    ; ⊝-valid = s⊝-valid
    ; ⊕-⊝ = s⊕-⊝
    ; _⊚[_]_ = IsChAlg.default-⊚ isSumCA
    ; ⊚-valid = s⊚-valid
    ; ⊚-correct = s⊚-correct
    }

  s⊚-valid = IsChAlg.default-⊚-valid isSumCA
  s⊚-correct = IsChAlg.default-⊚-correct isSumCA

  sumCA = record
    { Ch = SumChange
    ; isChAlg = isSumCA }

open import Data.Integer

instance
  intCA : ChAlg ℤ
intCA = record
  { Ch = ℤ
  ; isChAlg = record
  { _⊕_ = _+_
  ; _⊝_ = _-_
  ; valid = λ a b → ⊤
  ; ⊝-valid = λ a b → tt
  ; ⊕-⊝ = λ b a → n+[m-n]=m {a} {b}
  ; ⊚-valid = λ a da1 _ da2 _ → tt
  ; ⊚-correct = λ a da1 _ da2 _ → sym (associative-int a da1 da2)
  } }


Simplified a proof (from the Agsy proof).

Ignore-this: 7afe6f629a94a3225b9cdedb7794794e

darcs-hash:20110121131044-3bd4e-7fa7af65e37fd604644549d4eaab9685218abfa3.gz

------------------------------------------------------------------------------
-- PA propositional equality
------------------------------------------------------------------------------

module AxiomaticPA.Relation.Binary.PropositionalEqualityI where

open import AxiomaticPA.Base

------------------------------------------------------------------------------
-- Identity properties

refl : ∀ {n} → n ≣ n
refl {n} = S₁ (S₅ n) (S₅ n)
{-# ATP hint refl #-}

sym : ∀ {m n} → m ≣ n → n ≣ m
sym {m} = aux S₁ refl
  where
    aux : ∀ {r t} → (t ≣ r → t ≣ t → r ≣ t) → t ≣ t → t ≣ r → r ≣ t
    aux hyp t≣t t≣r = hyp t≣r t≣t
{-# ATP hint sym #-}

trans : ∀ {m n o} → m ≣ n → n ≣ o → m ≣ o
trans m≣n = S₁ (sym m≣n)
{-# ATP hint trans #-}


Cosmetic change.

Cosmetic change.

Ignore-this: ed9b9992b5c344edb014fc3c88be6946

darcs-hash:20120214135729-3bd4e-1a5e26411543607ffa3ae825731118608932af7d.gz

------------------------------------------------------------------------------
-- Group theory base
------------------------------------------------------------------------------

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

module GroupTheory.Base where

-- We add 3 to the fixities of the standard library.
infix  11 _⁻¹
infixl 10 _·_  -- The symbol is '\cdot'.

------------------------------------------------------------------------------
-- The group universe
open import Common.Universe public renaming ( D to G )

-- The equality
-- The equality is the propositional identity on the group universe.
import Common.Relation.Binary.PropositionalEquality
open module Eq =
  Common.Relation.Binary.PropositionalEquality.Inductive public

-- Logical constants
open import Common.LogicalConstants public

-- Group theory axioms
postulate
  ε   : G          -- The identity element.
  _·_ : G → G → G  -- The binary operation.
  _⁻¹ : G → G      -- The inverse function.

  assoc         : ∀ a b c → a · b · c ≡ a · (b · c)
  leftIdentity  : ∀ a → ε · a         ≡ a
  rightIdentity : ∀ a → a · ε         ≡ a
  leftInverse   : ∀ a → a ⁻¹ · a      ≡ ε
  rightInverse  : ∀ a → a · a ⁻¹      ≡ ε
{-# ATP axiom assoc leftIdentity rightIdentity leftInverse rightInverse #-}

-- Congruence property.
·-cong : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ y₁ → x₂ ≡ y₂ → x₁ · x₂ ≡ y₁ · y₂
·-cong = cong₂ _·_