Reflection.NP: updates and improvements

Reflection.NP: updates and improvements

{-# OPTIONS --without-K #-}
module Reflection.NP where

open import Opaque
open import Type
open import Level.NP
open import Data.Nat using (ℕ; zero; suc; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Maybe.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙; 0₁)
open import Data.Two using (𝟚; 0₂; 1₂; [0:_1:_])
open import Data.List
open import Data.Vec using (Vec) -- ; []; _∷_)
open import Data.Product.NP
open import Function.NP

open import Reflection public

Args : ★
Args = List (Arg Term)

-- lamᵛ : Term → Term
pattern lamᵛ = lam visible

-- lamʰ : Term → Term
pattern lamʰ = lam hidden

-- argiᵛ : Relevance → Arg-info
pattern argiᵛ x = arg-info visible x

-- argiʳ : Visibility → Arg-info
pattern argiʳ x = arg-info x relevant

-- argiᵛʳ : Arg-info
pattern argiᵛʳ = argiᵛ relevant

-- argiʰ : Relevance → Arg-info
pattern argiʰ x = arg-info hidden x

-- argiʰʳ : Arg-info
pattern argiʰʳ = argiʰ relevant

-- argᵛ : ∀{A} → Relevance → A → Arg A
pattern argᵛ r v = arg (argiᵛ r) v

-- argᵛʳ : ∀{A} → Visibility → A → Arg A
pattern argʳ v x = arg (argiʳ v) x

-- argʰ : ∀{A} → Relevance → A → Arg A
pattern argʰ r v = arg (argiʰ r) v

-- argᵛʳ : ∀{A} → A → Arg A
pattern argᵛʳ v = arg argiᵛʳ v

-- argʰʳ : ∀{A} → A → Arg A
pattern argʰʳ v = arg argiʰʳ v

pattern conᵛ n r t = con n (argᵛ r t ∷ [])
pattern conʰ n r t = con n (argʰ r t ∷ [])
pattern defᵛ n r t = def n (argᵛ r t ∷ [])
pattern defʰ n r t = def n (argʰ r t ∷ [])

pattern conᵛʳ n t = con n (argᵛʳ t ∷ [])
pattern conʰʳ n t = con n (argʰʳ t ∷ [])
pattern defᵛʳ n t = def n (argᵛʳ t ∷ [])
pattern defʰʳ n t = def n (argʰʳ t ∷ [])

Arg-infos : ★
Arg-infos = List Arg-info

app` : (Args → Term) → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
app` f = go [] where
  go : Args → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
  go args []         = f (reverse args)
  go args (ai ∷ ais) = λ t → go (arg ai t ∷ args) ais

con` : Name → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
con` x = app` (con x)

def` : Name → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
def` x = app` (def x)

var` : ℕ → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
var` x = app` (var x)

coe : ∀ {A : ★} {z : A} n → (Term →⟨ length (replicate n z) ⟩ Term) → Term →⟨ n ⟩ Term
coe zero    t = t
coe (suc n) f = λ t → coe n (f t)

con`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
con`ⁿʳ x n = coe n (app` (con x) (replicate n argiᵛʳ))

def`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
def`ⁿʳ x n = coe n (app` (def x) (replicate n argiᵛʳ))

var`ⁿʳ : ℕ → (n : ℕ) → Term →⟨ n ⟩ Term
var`ⁿʳ x n = coe n (app` (var x) (replicate n argiᵛʳ))

-- sort₀ : Sort
pattern sort₀ = lit 0

-- sort₁ : Sort
pattern sort₁ = lit 1

-- `★_ : ℕ → Term
pattern  `★_ i = sort (lit i)

-- `★₀ : Term
pattern `★₀ = `★_ 0

-- el₀ : Term → Type
pattern el₀ t = el sort₀ t

-- Builds a type variable (of type ★₀)
``var₀ : ℕ → Args → Type
``var₀ n args = el₀ (var n args)

-- ``set : ℕ → ℕ → Type
pattern ``set i j = el (lit (suc j)) (`★_ i)

``★_ : ℕ → Type
``★_ i = el (lit (suc i)) (`★_ i)

-- ``★₀ : Type
pattern ``★₀ = ``set 0 0

unEl : Type → Term
unEl (el _ tm) = tm

getSort : Type → Sort
getSort (el s _) = s

unArg : ∀ {A} → Arg A → A
unArg (arg _ a) = a

-- `Level : Term
pattern `Level = def (quote Level) []

-- ``Level : Type
pattern ``Level = el₀ `Level

pattern `₀ = def (quote ₀) []

-- `ₛ_ : Term → Term
-- `ₛ_ = def`ⁿʳ (quote L.suc) 1
pattern `ₛ_ v = def (quote ₛ) (argᵛʳ v ∷ [])

-- `suc-sort : Sort → Sort
pattern `suc-sort s = set (`ₛ (sort s))

pattern `set₀ = set `₀
pattern `setₛ_ s = set (`ₛ s)
pattern `set_ s = set (sort s)

suc-sort : Sort → Sort
suc-sort (set t) = set (`ₛ t)
suc-sort (lit n) = lit (suc n)
suc-sort unknown = unknown

decode-Sort : Sort → Maybe ℕ
decode-Sort `set₀ = just zero
decode-Sort (`setₛ_ s) = map? suc (decode-Sort (set s))
decode-Sort (`set_ s) = decode-Sort s
decode-Sort (set _) = nothing
decode-Sort (lit n) = just n
decode-Sort unknown = nothing

pattern _`⊔_ s₁ s₂ = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

_`⊔`_ : Sort → Sort → Sort
s₁ `⊔` s₂ with decode-Sort s₁ | decode-Sort s₂
...          | just n₁        | just n₂        = lit (n₁ ⊔ℕ n₂)
...          | _              | _              = s₁ `⊔ s₂

mapVar : (ℕ → ℕ) → Term → Term
mapVarArgs : (ℕ → ℕ) → Args → Args
mapVarType : (ℕ → ℕ) → Type → Type
mapVarSort : (ℕ → ℕ) → Sort → Sort

mapVar↑ : (ℕ → ℕ) → (ℕ → ℕ)
mapVar↑ f zero    = zero
mapVar↑ f (suc n) = suc (f n)

mapVar f (var x args) = var (f x) (mapVarArgs f args)
mapVar f (con c args) = con c (mapVarArgs f args)
mapVar f (def d args) = def d (mapVarArgs f args)
mapVar f (lam v t) = lam v (mapVar (mapVar↑ f) t)
mapVar f (pat-lam cs args) = unknown
mapVar f (pi (arg i t₁) t₂) = pi (arg i (mapVarType f t₁)) (mapVarType (mapVar↑ f) t₂)
mapVar f (sort x) = sort (mapVarSort f x)
mapVar f (lit x) = lit x
mapVar f unknown = unknown

mapVarArgs f [] = []
mapVarArgs f (arg i x ∷ as) = arg i (mapVar f x) ∷ mapVarArgs f as
mapVarType f (el s t) = el (mapVarSort f s) (mapVar f t)
mapVarSort f (set t) = set (mapVar f t)
mapVarSort f (lit n) = lit n
mapVarSort f unknown = unknown

liftTerm : Term → Term
liftTerm = mapVar suc

liftType : Type → Type
liftType = mapVarType suc

pattern piᵛʳ t u = pi (argᵛʳ t) u
pattern piʰʳ t u = pi (argʰʳ t) u

`Π : Arg Type → Type → Type
`Π t u = el (getSort (unArg t) `⊔` getSort u) (pi t u)

`Πᵛʳ : Type → Type → Type
`Πᵛʳ t u = el (getSort t `⊔` getSort u) (piᵛʳ t u)

`Πʰʳ : Type → Type → Type
`Πʰʳ t u = el (getSort t `⊔` getSort u) (piʰʳ t u)

_`→_ : Arg Type → Type → Type
t `→ u = `Π t (liftType u)

_`→ʰʳ_ : Type → Type → Type
t `→ʰʳ u = `Πʰʳ t (liftType u)

_`→ᵛʳ_ : Type → Type → Type
t `→ᵛʳ u = `Πᵛʳ t (liftType u)

-- η vs mk: performs no shifting of the result of mk.
-- Safe values of mk are def and con for instance
η : List Arg-info → (Args → Term) → Term
η ais₀ mk = go ais₀ where
  vars : List Arg-info → Args
  vars []         = []
  vars (ai ∷ ais) = arg ai (var (length ais) []) ∷ vars ais
  go : List Arg-info → Term
  go []                   = mk (vars ais₀)
  go (arg-info v _ ∷ ais) = lam v (go ais)

ηʰ : ℕ → (Args → Term) → Term
ηʰ n = η (replicate n argiʰʳ)

ηᵛ : ℕ → (Args → Term) → Term
ηᵛ n = η (replicate n argiᵛʳ)

ηʰⁿ : ℕ → Name → Term
ηʰⁿ n = ηʰ n ∘ def

ηᵛⁿ : ℕ → Name → Term
ηᵛⁿ n = ηᵛ n ∘ def

arityOfTerm : Term → List Arg-info
arityOfType : Type → List Arg-info

arityOfType (el _ u) = arityOfTerm u
arityOfTerm (pi (arg ai _) t) = ai ∷ arityOfType t

-- no more arguments
arityOfTerm (var _ _) = []

-- TODO
arityOfTerm (con c args) = []
arityOfTerm (def f args) = []
arityOfTerm (sort s)     = []
arityOfTerm (lit _)      = []

-- fail
arityOfTerm unknown = []

-- absurd cases
arityOfTerm (lam _ _) = []
arityOfTerm (pat-lam _ _) = []

ηⁿ : Name → Term
ηⁿ nm = η (arityOfType (type nm)) (def nm)

Decode-Term : ∀ {a} → ★_ a → ★_ a
Decode-Term A = Term → Maybe A

pattern `𝟘 = def (quote 𝟘) []

pattern `𝟙  = def (quote 𝟙) []
pattern `0₁ = con (quote 0₁) []

decode-𝟙 : Decode-Term 𝟙
decode-𝟙 `0₁ = just 0₁
decode-𝟙 _   = nothing

pattern `𝟚  = def (quote 𝟚) []
pattern `0₂ = con (quote 0₂) []
pattern `1₂ = con (quote 1₂) []

decode-𝟚 : Decode-Term 𝟚
decode-𝟚 `0₂ = just 0₂
decode-𝟚 `1₂ = just 1₂
decode-𝟚 _   = nothing

pattern `ℕ     = def (quote ℕ) []
pattern `zero  = con (quote zero) []
pattern `suc t = conᵛʳ (quote suc) t

decode-ℕ : Decode-Term ℕ
decode-ℕ (lit (nat n)) = just n
-- these two should not happen anymore:
decode-ℕ `zero         = just 0
decode-ℕ (`suc t)      = map? suc (decode-ℕ t)
decode-ℕ _             = nothing

pattern `Maybe t = defᵛʳ (quote Maybe) t
pattern `nothing = con (quote Maybe.nothing) []
pattern `just  t = conᵛʳ (quote Maybe.just) t

decode-Maybe : ∀ {a} {A : ★_ a} → Decode-Term A → Decode-Term (Maybe A)
decode-Maybe decode-A `nothing  = just nothing
decode-Maybe decode-A (`just t) = map? just (decode-A t)
decode-Maybe decode-A _         = nothing

pattern `List t = defᵛʳ (quote List) t
pattern `[] = con (quote List.[]) []
pattern _`∷_ t u = con (quote List._∷_) (argᵛʳ t ∷ argᵛʳ u ∷ [])

decode-List : ∀ {a} {A : ★_ a} → Decode-Term A → Decode-Term (List A)
decode-List decode-A `[]      = just []
decode-List decode-A (t `∷ u) = ⟪ _∷_ · decode-A t · decode-List decode-A u ⟫?
decode-List decode-A _        = nothing

pattern `Vec t u = def (quote Vec) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern `v[]      = con (quote Vec.[]) []
pattern _`v∷_ t u = con (quote Vec._∷_) (argᵛʳ t ∷ argᵛʳ u ∷ [])

{-
decode-Vec : ∀ {a} {A : ★_ a} {n} → Decode-Term A → Decode-Term (Vec A n)
decode-Vec decode-A `[]      = just []
decode-Vec decode-A (t `∷ u) = ⟪ _∷_ · decode-A t · decode-Vec decode-A u ⟫?
decode-Vec decode-A _        = nothing
-}

pattern `Σ t u = def (quote Σ) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern _`,_ t u = con (quote _,_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern `fst t = defᵛʳ (quote fst) t
pattern `snd t = defᵛʳ (quote snd) t

module _ {a b} {A : ★_ a} {B : A → ★_ b}
         (decode-A : Decode-Term A)
         (decode-B : (x : A) → Decode-Term (B x))
         where
    decode-Σ : Decode-Term (Σ A B)
    decode-Σ (t `, u) = decode-A t   >>=? λ x →
                        decode-B x u >>=? λ y →
                        just (x , y)
    decode-Σ _        = nothing

data Abs : Set where
  var : ℕ → Abs
  []  : Abs
  _,_ : Abs → Abs → Abs
  abs : Abs → Abs

_,,_ : Abs → Abs → Abs
[]      ,, x  = x
x       ,, [] = x
(x , y) ,, z  = x ,, (y ,, z)
x       ,, y  = x , y

abs' : Abs → Abs
abs' [] = []
abs' x  = abs x

absTerm : Term → Abs
absArgs : Args → Abs
absType : Type → Abs
absSort : Sort → Abs

absTerm (var x args) = var x ,, absArgs args
absTerm (con c args) = absArgs args
absTerm (def f args) = absArgs args
absTerm (lam v t) = abs' (absTerm t)
absTerm (pat-lam cs args) = opaque "absTm/pat-lam" []
absTerm (pi (arg _ t₁) t₂) = absType t₁ ,, abs' (absType t₂)
absTerm (sort x) = absSort x
absTerm (lit x) = []
absTerm unknown = []

absArgs [] = []
absArgs (arg i x ∷ as) = absTerm x ,, absArgs as
absType (el _ t) = absTerm t
absSort (set t) = absTerm t
absSort (lit n) = []
absSort unknown = []

app : Term → Args → Term
app (var x args) args₁ = var x (args ++ args₁)
app (con c args) args₁ = con c (args ++ args₁)
app (def f args) args₁ = def f (args ++ args₁)
app (lam v t) args = opaque "app/lam" unknown
app (pat-lam cs args) args₁ = opaque "app/pat-lam" unknown
app (pi t₁ t₂) args = opaque "app/pi" unknown
app (sort x) args = opaque "app/sort" unknown
app (lit x) args = opaque "app/lit" unknown
app unknown args = unknown

quoteNat : ℕ → Term
quoteNat zero    = `zero
quoteNat (suc n) = `suc (quoteNat n)

unlit : Literal → Term
unlit (nat x) = quoteNat x
unlit x = lit x

unknown-fun-def : FunctionDef
unknown-fun-def = opaque "unknown-fun-def" (fun-def (el unknown unknown) [])

unknown-definition : Definition
unknown-definition = opaque "unknown-definition" (function unknown-fun-def)

un-function : Definition → FunctionDef
un-function (function x) = x
un-function _            = unknown-fun-def

module Map-arg-info (f : Arg-info → Arg-info) where

    On : Set → Set
    On T = T → T

    pat : On Pattern
    pats : On (List (Arg Pattern))
    pat (con c ps) = con c (pats ps)
    pat dot = dot
    pat var = var
    pat (lit l) = lit l
    pat (proj p) = proj p
    pat absurd = absurd
    pats [] = []
    pats (arg i p ∷ ps) = arg (f i) (pat p) ∷ pats ps

    term : On Term
    tÿpe : On Type
    årgs : On Args
    sørt : On Sort
    clåuse  : On Clause
    clåuses : On (List Clause)

    term (var x as) = var x (årgs as)
    term (con c as) = con c (årgs as)
    term (def f as) = def f (årgs as)
    term (lam v t) = lam (visibility (f (arg-info v (relevant{- arbitrary choice -})))) (term t)
    term (pat-lam cs as) = pat-lam (clåuses cs) (årgs as)
    term (pi (arg i t₁) t₂) = pi (arg (f i) (tÿpe t₁)) (tÿpe t₂)
    term (sort s) = sort (sørt s)
    term (lit l) = lit l
    term unknown = unknown

    tÿpe (el s t) = el (sørt s) (term t)

    årgs [] = []
    årgs (arg i t ∷ as) = arg (f i) (term t) ∷ årgs as

    sørt (set t) = set (term t)
    sørt (lit n) = lit n
    sørt unknown = unknown

    clåuse (clause ps body) = clause (pats ps) (term body)
    clåuse (absurd-clause ps) = absurd-clause (pats ps)

    clåuses [] = []
    clåuses (x ∷ cs) = clåuse x ∷ clåuses cs

    fün-def : FunctionDef → FunctionDef
    fün-def (fun-def t cs) = fun-def (tÿpe t) (clåuses cs)

    dëf : Definition → Definition
    dëf (function x) = function (fün-def x)
    dëf (data-type x) = opaque "Map-arg-info.dëf/data-type" unknown-definition
    dëf (record′ x) = opaque "Map-arg-info.dëf/record′" unknown-definition
    dëf constructor′ = opaque "Map-arg-info.dëf/constructor′" unknown-definition
    dëf axiom = opaque "Map-arg-info.dëf/axiom" unknown-definition
    dëf primitive′ = opaque "Map-arg-info.dëf/primitive′" unknown-definition

    nåme : Name → Definition
    nåme = dëf ∘ definition

reveal-arg : Arg-info → Arg-info
reveal-arg (arg-info v r) = arg-info visible r

module Reveal-args = Map-arg-info reveal-arg

module Get-clauses where
    from-fun-def : FunctionDef → Clauses
    from-fun-def (fun-def _ cs) = cs
    from-def : Definition → Clauses
    from-def (function x) = from-fun-def x
    from-def (data-type x) = opaque "Get-clauses.from-def/data-type" []
    from-def (record′ x) = opaque "Get-clauses.from-def/record′" []
    from-def constructor′ = opaque "Get-clauses.from-def/constructor′" []
    from-def axiom = opaque "Get-clauses.from-def/axiom" []
    from-def primitive′ = opaque "Get-clauses.from-def/primitive′" []
    from-name : Name → Clauses
    from-name n = from-def (definition n)

module Get-type where
    from-clause : Clause → Term
    from-clause (clause [] body) = body
    from-clause (clause (arg _ var ∷ pats) body)
      = lam visible (from-clause (clause pats body))
    from-clause _ = unknown
    from-fun-def : FunctionDef → Type
    from-fun-def (fun-def t _) = t
    from-def : Definition → Type
    from-def (function x) = from-fun-def x
    from-def (data-type x) = opaque "Get-type.from-def/data-type" ``★₀
    from-def (record′ x) = opaque "Get-type.from-def/record′" ``★₀
    from-def constructor′ = opaque "Get-type.from-def/constructor" ``★₀
    from-def axiom = opaque "Get-type.from-def/axiom" ``★₀
    from-def primitive′ = opaque "Get-type.from-def/primitive′" ``★₀
    from-name : Name → Type
    from-name n = from-def (definition n)

module Get-term where
    from-clause : Clause → Term
    from-clause (clause [] body) = body
    from-clause (clause (arg _ var ∷ pats) body)
      = lam visible (from-clause (clause pats body))
    from-clause _ = unknown
    from-fun-def : FunctionDef → Term
    from-fun-def (fun-def _ (c ∷ [])) = from-clause c
    from-fun-def _ = unknown
    from-def : Definition → Term
    from-def (function x) = from-fun-def x
    from-def (data-type x) = unknown
    from-def (record′ x) = unknown
    from-def constructor′ = unknown
    from-def axiom = unknown
    from-def primitive′ = unknown
    from-name : Name → Term
    from-name n = from-def (definition n)

module Ex where
  open import Relation.Binary.PropositionalEquality
  postulate
    f : ℕ → ℕ → ℕ
    g : {x y : ℕ} → ℕ
    h : {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  H : ★
  H = {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  postulate
    h₂ : H
  test₁ : unquote (ηᵛⁿ 2 (quote f)) ≡ f
  test₁ = refl
  test₂ : unquote (ηʰⁿ 2 (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₂ = refl
  test₃ : unquote (ηⁿ (quote f)) ≡ f
  test₃ = refl
  test₄ : unquote (ηⁿ (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₄ = refl
  ηh = ηⁿ (quote h)
  -- this test passes but leave an undecided instance argument
  -- test₅ : unquote ηh ≡ λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  -- test₅ = refl
  ηh₂ : Term
  ηh₂ = ηⁿ (quote h₂)
  {-
  test₆ : unquote ηh₂ ≡ {!unquote ηh₂!} -- λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  test₆ = refl
  -}
  test₇ : decode-ℕ (quoteTerm (ℕ.suc (suc zero))) ≡ just 2
  test₇ = refl
  test₈ : decode-ℕ (quoteTerm (ℕ.suc (suc 3))) ≡ just 5
  test₈ = refl
  test₉ : decode-Maybe decode-𝟚 (quoteTerm (Maybe.just 0₂)) ≡ just (just 0₂)
  test₉ = refl
  test₁₀ : decode-List decode-ℕ (quoteTerm (0 ∷ 1 ∷ 2 ∷ [])) ≡ just (0 ∷ 1 ∷ 2 ∷ [])
  test₁₀ = refl
  test₁₁ : quoteTerm (_,′_ 0₂ 1₂) ≡ `0₂ `, `1₂
  test₁₁ = refl
  test₁₁' : decode-List (decode-Σ {A = 𝟚} {B = [0: 𝟚 1: ℕ ]} decode-𝟚 [0: decode-𝟚 1: decode-ℕ ])
                        (quoteTerm ((Σ._,_ {B = [0: 𝟚 1: ℕ ]} 0₂ 1₂) ∷ (1₂ , 4) ∷ [])) ≡ just ((0₂ , 1₂) ∷ (1₂ , 4) ∷ [])
  test₁₁' = refl

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

{-# OPTIONS --without-K #-}
module Reflection.NP where

open import Type
open import Level.NP
open import Data.Nat using (ℕ; zero; suc) renaming (_⊔_ to _⊔ℕ_)
open import Data.Maybe.NP
open import Data.Zero using (𝟘)
open import Data.One using (𝟙; 0₁)
open import Data.Two using (𝟚; 0₂; 1₂; [0:_1:_])
open import Data.List
open import Data.Vec using (Vec) -- ; []; _∷_)
open import Data.Product.NP
open import Function.NP hiding (Π)

open import Reflection public

Args : ★
Args = List (Arg Term)

-- lamᵛ : Term → Term
pattern lamᵛ = lam visible

-- lamʰ : Term → Term
pattern lamʰ = lam hidden

-- argiᵛʳ : Arg-info
pattern argiᵛʳ = arg-info visible relevant

-- argiʰʳ : Arg-info
pattern argiʰʳ = arg-info hidden relevant

-- argᵛʳ : ∀{A} → A → Arg A
pattern argᵛʳ v = arg argiᵛʳ v

-- argʰʳ : ∀{A} → A → Arg A
pattern argʰʳ v = arg argiʰʳ v

Arg-infos : ★
Arg-infos = List Arg-info

app` : (Args → Term) → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
app` f = go [] where
  go : Args → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
  go args []         = f (reverse args)
  go args (ai ∷ ais) = λ t → go (arg ai t ∷ args) ais

pattern conᵛʳ n t = con n (argᵛʳ t ∷ [])
pattern conʰʳ n t = con n (argʰʳ t ∷ [])
pattern defᵛʳ n t = def n (argᵛʳ t ∷ [])
pattern defʰʳ n t = def n (argʰʳ t ∷ [])

con` : Name → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
con` x = app` (con x)

def` : Name → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
def` x = app` (def x)

var` : ℕ → (ais : Arg-infos) → Term →⟨ length ais ⟩ Term
var` x = app` (var x)

coe : ∀ {A : ★} {z : A} n → (Term →⟨ length (replicate n z) ⟩ Term) → Term →⟨ n ⟩ Term
coe zero    t = t
coe (suc n) f = λ t → coe n (f t)

con`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
con`ⁿʳ x n = coe n (app` (con x) (replicate n argiᵛʳ))

def`ⁿʳ : Name → (n : ℕ) → Term →⟨ n ⟩ Term
def`ⁿʳ x n = coe n (app` (def x) (replicate n argiᵛʳ))

var`ⁿʳ : ℕ → (n : ℕ) → Term →⟨ n ⟩ Term
var`ⁿʳ x n = coe n (app` (var x) (replicate n argiᵛʳ))

-- sort₀ : Sort
pattern sort₀ = lit 0

-- sort₁ : Sort
pattern sort₁ = lit 1

-- `★₀ : Term
pattern `★₀ = sort sort₀

-- el₀ : Term → Type
pattern el₀ t = el sort₀ t

-- Builds a type variable (of type ★₀)
``var₀ : ℕ → Args → Type
``var₀ n args = el₀ (var n args)

-- ``★₀ : Type
pattern ``★₀ = el sort₁ `★₀

unEl : Type → Term
unEl (el _ tm) = tm

getSort : Type → Sort
getSort (el s _) = s

unArg : ∀ {A} → Arg A → A
unArg (arg _ a) = a

-- `Level : Term
pattern `Level = def (quote Level) []

-- ``Level : Type
pattern ``Level = el₀ `Level

pattern `₀ = def (quote ₀) []

-- `ₛ_ : Term → Term
-- `ₛ_ = def`ⁿʳ (quote L.suc) 1
pattern `ₛ_ v = def (quote ₛ) (argᵛʳ v ∷ [])

-- sucSort : Sort → Sort
pattern sucSort s = set (`ₛ (sort s))

pattern `set₀ = set `₀
pattern `setₛ_ s = set (`ₛ s)
pattern `set_ s = set (sort s)

decode-Sort : Sort → Maybe ℕ
decode-Sort `set₀ = just zero
decode-Sort (`setₛ_ s) = map? suc (decode-Sort (set s))
decode-Sort (`set_ s) = decode-Sort s
decode-Sort (set _) = nothing
decode-Sort (lit n) = just n
decode-Sort unknown = nothing

pattern _`⊔_ s₁ s₂ = set (def (quote _⊔_) (argᵛʳ (sort s₁) ∷ argᵛʳ (sort s₂) ∷ []))

_`⊔`_ : Sort → Sort → Sort
s₁ `⊔` s₂ with decode-Sort s₁ | decode-Sort s₂
...          | just n₁        | just n₂        = lit (n₁ ⊔ℕ n₂)
...          | _              | _              = s₁ `⊔ s₂

pattern piᵛʳ t u = pi (argᵛʳ t) u
pattern piʰʳ t u = pi (argʰʳ t) u

Π : Arg Type → Type → Type
Π t u = el (getSort (unArg t) `⊔` getSort u) (pi t u)

Πᵛʳ : Type → Type → Type
Πᵛʳ t u = el (getSort t `⊔` getSort u) (piᵛʳ t u)

Πʰʳ : Type → Type → Type
Πʰʳ t u = el (getSort t `⊔` getSort u) (piʰʳ t u)

-- η vs mk: performs no shifting of the result of mk.
-- Safe values of mk are def and con for instance
η : List Arg-info → (Args → Term) → Term
η ais₀ mk = go ais₀ where
  vars : List Arg-info → Args
  vars []         = []
  vars (ai ∷ ais) = arg ai (var (length ais) []) ∷ vars ais
  go : List Arg-info → Term
  go []                   = mk (vars ais₀)
  go (arg-info v _ ∷ ais) = lam v (go ais)

ηʰ : ℕ → (Args → Term) → Term
ηʰ n = η (replicate n argiʰʳ)

ηᵛ : ℕ → (Args → Term) → Term
ηᵛ n = η (replicate n argiᵛʳ)

ηʰⁿ : ℕ → Name → Term
ηʰⁿ n = ηʰ n ∘ def

ηᵛⁿ : ℕ → Name → Term
ηᵛⁿ n = ηᵛ n ∘ def

arityOfTerm : Term → List Arg-info
arityOfType : Type → List Arg-info

arityOfType (el _ u) = arityOfTerm u
arityOfTerm (pi (arg ai _) t) = ai ∷ arityOfType t

-- no more arguments
arityOfTerm (var _ _) = []

-- TODO
arityOfTerm (con c args) = []
arityOfTerm (def f args) = []
arityOfTerm (sort s)     = []

-- fail
arityOfTerm unknown = []

-- absurd cases
arityOfTerm (lam _ _) = []

ηⁿ : Name → Term
ηⁿ nm = η (arityOfType (type nm)) (def nm)

Decode-Term : ∀ {a} → ★_ a → ★_ a
Decode-Term A = Term → Maybe A

pattern `𝟘 = def (quote 𝟘) []

pattern `𝟙  = def (quote 𝟙) []
pattern `0₁ = con (quote 0₁) []

decode-𝟙 : Decode-Term 𝟙
decode-𝟙 `0₁ = just 0₁
decode-𝟙 _   = nothing

pattern `𝟚  = def (quote 𝟚) []
pattern `0₂ = con (quote 0₂) []
pattern `1₂ = con (quote 1₂) []

decode-𝟚 : Decode-Term 𝟚
decode-𝟚 `0₂ = just 0₂
decode-𝟚 `1₂ = just 1₂
decode-𝟚 _   = nothing

pattern `ℕ     = def (quote ℕ) []
pattern `zero  = con (quote zero) []
pattern `suc t = conᵛʳ (quote suc) t

decode-ℕ : Decode-Term ℕ
decode-ℕ `zero    = just 0
decode-ℕ (`suc t) = map? suc (decode-ℕ t)
decode-ℕ _        = nothing

pattern `Maybe t = defᵛʳ (quote Maybe) t
pattern `nothing = con (quote Maybe.nothing) []
pattern `just  t = conᵛʳ (quote Maybe.just) t

decode-Maybe : ∀ {a} {A : ★_ a} → Decode-Term A → Decode-Term (Maybe A)
decode-Maybe decode-A `nothing  = just nothing
decode-Maybe decode-A (`just t) = map? just (decode-A t)
decode-Maybe decode-A _         = nothing

pattern `List t = defᵛʳ (quote List) t
pattern `[] = con (quote List.[]) []
pattern _`∷_ t u = con (quote List._∷_) (argᵛʳ t ∷ argᵛʳ u ∷ [])

decode-List : ∀ {a} {A : ★_ a} → Decode-Term A → Decode-Term (List A)
decode-List decode-A `[]      = just []
decode-List decode-A (t `∷ u) = ⟪ _∷_ · decode-A t · decode-List decode-A u ⟫?
decode-List decode-A _        = nothing

pattern `Vec t u = def (quote Vec) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern `v[]      = con (quote Vec.[]) []
pattern _`v∷_ t u = con (quote Vec._∷_) (argᵛʳ t ∷ argᵛʳ u ∷ [])

{-
decode-Vec : ∀ {a} {A : ★_ a} {n} → Decode-Term A → Decode-Term (Vec A n)
decode-Vec decode-A `[]      = just []
decode-Vec decode-A (t `∷ u) = ⟪ _∷_ · decode-A t · decode-Vec decode-A u ⟫?
decode-Vec decode-A _        = nothing
-}

pattern `Σ t u = def (quote Σ) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern _`,_ t u = con (quote _,_) (argᵛʳ t ∷ argᵛʳ u ∷ [])
pattern `fst t = defᵛʳ (quote fst) t
pattern `snd t = defᵛʳ (quote snd) t

module _ {a b} {A : ★_ a} {B : A → ★_ b}
         (decode-A : Decode-Term A)
         (decode-B : (x : A) → Decode-Term (B x))
         where
    decode-Σ : Decode-Term (Σ A B)
    decode-Σ (t `, u) = decode-A t   >>=? λ x →
                        decode-B x u >>=? λ y →
                        just (x , y)
    decode-Σ _        = nothing

module Ex where
  open import Relation.Binary.PropositionalEquality
  postulate
    f : ℕ → ℕ → ℕ
    g : {x y : ℕ} → ℕ
    h : {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  H : ★
  H = {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → ℕ
  postulate
    h₂ : H
  test₁ : unquote (ηᵛⁿ 2 (quote f)) ≡ f
  test₁ = refl
  test₂ : unquote (ηʰⁿ 2 (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₂ = refl
  test₃ : unquote (ηⁿ (quote f)) ≡ f
  test₃ = refl
  test₄ : unquote (ηⁿ (quote g)) ≡ λ {x y : ℕ} → g {x} {y}
  test₄ = refl
  ηh = ηⁿ (quote h)
  -- this test passes but leave an undecided instance argument
  -- test₅ : unquote ηh ≡ λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  -- test₅ = refl
  ηh₂ : Term
  ηh₂ = ηⁿ (quote h₂)
  {-
  test₆ : unquote ηh₂ ≡ {!unquote ηh₂!} -- λ {x y : ℕ} {{z : ℕ}} (t u : ℕ) {v : ℕ} → h {x} {y} {{z}} t u {v}
  test₆ = refl
  -}
  test₇ : decode-ℕ (quoteTerm (suc (suc zero))) ≡ just 2
  test₇ = refl
  test₈ : decode-ℕ (quoteTerm (suc (suc 3))) ≡ just 5
  test₈ = refl
  test₉ : decode-Maybe decode-𝟚 (quoteTerm (Maybe.just 0₂)) ≡ just (just 0₂)
  test₉ = refl
  test₁₀ : decode-List decode-ℕ (quoteTerm (0 ∷ 1 ∷ 2 ∷ [])) ≡ just (0 ∷ 1 ∷ 2 ∷ [])
  test₁₀ = refl
  test₁₁ : quoteTerm (_,′_ 0₂ 1₂) ≡ `0₂ `, `1₂
  test₁₁ = refl
  test₁₁' : decode-List (decode-Σ {A = 𝟚} {B = [0: 𝟚 1: ℕ ]} decode-𝟚 [0: decode-𝟚 1: decode-ℕ ])
                        (quoteTerm ((_,_ {B = [0: 𝟚 1: ℕ ]} 0₂ 1₂) ∷ (1₂ , 4) ∷ [])) ≡ just ((0₂ , 1₂) ∷ (1₂ , 4) ∷ [])
  test₁₁' = refl

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


Added minus-0x (ER version).

Added minus-0x (ER version).

Ignore-this: 5e95c1e87f09e329be44ef0dd3f11352

darcs-hash:20100430180427-3bd4e-7ed9136ac05b1d498076d4a77bde0c33023f7429.gz

------------------------------------------------------------------------------
-- Arithmetic properties using equational reasoning
------------------------------------------------------------------------------

module LTC.Function.Arithmetic.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
  using ( +-leftIdentity ; *-leftZero ; *-comm )

open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module APER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

------------------------------------------------------------------------------
-- Closure properties

pred-N : {n : D} → N n → N (pred n)
pred-N zN          = subst (λ t → N t) (sym cP₁) zN
pred-N (sN {n} Nn) = subst (λ t → N t) (sym (cP₂ n)) Nn

minus-N : {m n : D} → N m → N n → N (m - n)
minus-N {m} Nm zN                   = subst (λ t → N t) (sym (minus-x0 m)) Nm
minus-N     zN (sN {n} Nn)          = subst (λ t → N t) (sym (minus-0S n)) zN
minus-N     (sN {m} Nm) (sN {n} Nn) = subst (λ t → N t)
                                            (sym (minus-SS m n))
                                            (minus-N Nm Nn)

+-N : {m n : D} → N m → N n → N (m + n)
+-N zN Nn = subst (λ t → N t) (sym (+-leftIdentity Nn)) Nn
+-N {n = n} (sN {m} Nm ) Nn =
  subst ((λ t → N t)) (sym (+-Sx m n)) (sN (+-N Nm Nn))

*-N : {m n : D} → N m → N n → N (m * n)
*-N zN Nn = subst (λ t → N t) (sym (*-leftZero Nn)) zN
*-N {n = n} (sN {m} Nm) Nn =
  subst (λ t → N t) (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

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

minus-0x : {n : D} → N n → zero - n  ≡ zero
minus-0x zN          = minus-x0 zero
minus-0x (sN {n} Nn) = minus-0S n

[x+y]-[x+z]≡y-z : {m n o : D} → N m → N n → N o →
                  (m + n) - (m + o) ≡ n - o
[x+y]-[x+z]≡y-z {n = n} {o = o} zN Nn No =
  begin
    (zero + n) - (zero + o) ≡⟨ subst (λ t → (zero + n) - (zero + o) ≡
                                            t - (zero + o))
                                      (+-0x n) refl
                            ⟩
     n - (zero + o)         ≡⟨ subst (λ t → n - (zero + o) ≡ n - t)
                                     (+-0x o)
                                     refl ⟩
    n - o
  ∎

[x+y]-[x+z]≡y-z {n = n} {o = o} (sN {m} Nm) Nn No =
  begin
    (succ m + n) - (succ m + o) ≡⟨ subst (λ t → succ m + n - (succ m + o) ≡
                                                t - (succ m + o))
                                         (+-Sx m n)
                                         refl
                                ⟩
    succ (m + n) - (succ m + o) ≡⟨ subst (λ t → succ (m + n) - (succ m + o) ≡
                                                succ (m + n) - t)
                                         (+-Sx m o)
                                         refl ⟩
    succ (m + n) - succ (m + o) ≡⟨ minus-SS (m + n) (m + o) ⟩
    (m + n) - (m + o) ≡⟨ [x+y]-[x+z]≡y-z Nm Nn No ⟩
    n - o
  ∎

[x-y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m - n) * o ≡ m * o - n * o
[x-y]z≡xz*yz {m} .{zero} {o} Nm zN No =
  begin
    (m - zero) * o   ≡⟨ subst (λ t → (m - zero) * o ≡ t * o)
                              (minus-x0 m)
                              refl
                      ⟩
    m * o            ≡⟨ sym (minus-x0 (m * o)) ⟩
    m * o - zero     ≡⟨ subst (λ t → m * o - zero ≡ m * o - t)
                              (sym (*-0x o))
                              refl
                     ⟩
    m * o - zero * o
  ∎

[x-y]z≡xz*yz {o = o} zN (sN {n} Nn) No =
  begin
    (zero - succ n) * o  ≡⟨ subst (λ t → (zero - succ n) * o ≡ t * o)
                                  (minus-0S n)
                                  refl
                         ⟩
    zero * o             ≡⟨ *-0x o ⟩
    zero                 ≡⟨ sym (minus-0x (*-N (sN Nn) No)) ⟩
    zero - succ n * o    ≡⟨ subst (λ t → zero - succ n * o ≡ t - succ n * o)
                                   (sym (*-0x o))
                                   refl
                         ⟩
    zero * o - succ n * o
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) zN =
  begin
    (succ m - succ n) * zero      ≡⟨ *-comm (minus-N (sN Nm) (sN Nn)) zN ⟩
    zero * (succ m - succ n)      ≡⟨ *-0x (succ m - succ n) ⟩
    zero                          ≡⟨ sym (minus-0x (*-N (sN Nn) zN)) ⟩
    zero - succ n * zero          ≡⟨ subst (λ t → zero - succ n * zero ≡
                                                  t - succ n * zero)
                                           (sym (*-0x (succ m)))
                                           refl
                                  ⟩
    zero * succ m - succ n * zero ≡⟨ subst
                                       (λ t → zero * succ m - succ n * zero ≡
                                              t - succ n * zero)
                                       (*-comm zN (sN Nm))
                                       refl
                                  ⟩
    succ m * zero - succ n * zero
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m - succ n) * succ o  ≡⟨ subst (λ t → (succ m - succ n) * succ o ≡
                                                t * succ o)
                                         (minus-SS m n)
                                         refl
                                ⟩
    (m - n) * succ o            ≡⟨ [x-y]z≡xz*yz Nm Nn (sN No) ⟩
    m * succ o - n * succ o     ≡⟨ sym ([x+y]-[x+z]≡y-z (sN No)
                                                        (*-N Nm (sN No))
                                                        (*-N Nn (sN No)))
                                ⟩
    (succ o + m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ o + m * succ o) - (succ o + n * succ o) ≡
                      t - (succ o + n * succ o))
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ m * succ o) - (succ o + n * succ o) ≡
                      (succ m * succ o) - t)
               (sym (*-Sx n (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ n * succ o)
  ∎

------------------------------------------------------------------------------
-- Arithmetic properties using equational reasoning
------------------------------------------------------------------------------

module LTC.Function.Arithmetic.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
  using ( +-leftIdentity ; *-leftZero ; *-comm ; minus-0x )

open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module APER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

------------------------------------------------------------------------------
-- Closure properties

pred-N : {n : D} → N n → N (pred n)
pred-N zN          = subst (λ t → N t) (sym cP₁) zN
pred-N (sN {n} Nn) = subst (λ t → N t) (sym (cP₂ n)) Nn

minus-N : {m n : D} → N m → N n → N (m - n)
minus-N {m} Nm zN                   = subst (λ t → N t) (sym (minus-x0 m)) Nm
minus-N     zN (sN {n} Nn)          = subst (λ t → N t) (sym (minus-0S n)) zN
minus-N     (sN {m} Nm) (sN {n} Nn) = subst (λ t → N t)
                                            (sym (minus-SS m n))
                                            (minus-N Nm Nn)

+-N : {m n : D} → N m → N n → N (m + n)
+-N zN Nn = subst (λ t → N t) (sym (+-leftIdentity Nn)) Nn
+-N {n = n} (sN {m} Nm ) Nn =
  subst ((λ t → N t)) (sym (+-Sx m n)) (sN (+-N Nm Nn))

*-N : {m n : D} → N m → N n → N (m * n)
*-N zN Nn = subst (λ t → N t) (sym (*-leftZero Nn)) zN
*-N {n = n} (sN {m} Nm) Nn =
  subst (λ t → N t) (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

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

[x+y]-[x+z]≡y-z : {m n o : D} → N m → N n → N o →
                  (m + n) - (m + o) ≡ n - o
[x+y]-[x+z]≡y-z {n = n} {o = o} zN Nn No =
  begin
    (zero + n) - (zero + o) ≡⟨ subst (λ t → (zero + n) - (zero + o) ≡
                                            t - (zero + o))
                                      (+-0x n) refl
                            ⟩
     n - (zero + o)         ≡⟨ subst (λ t → n - (zero + o) ≡ n - t)
                                     (+-0x o)
                                     refl ⟩
    n - o
  ∎

[x+y]-[x+z]≡y-z {n = n} {o = o} (sN {m} Nm) Nn No =
  begin
    (succ m + n) - (succ m + o) ≡⟨ subst (λ t → succ m + n - (succ m + o) ≡
                                                t - (succ m + o))
                                         (+-Sx m n)
                                         refl
                                ⟩
    succ (m + n) - (succ m + o) ≡⟨ subst (λ t → succ (m + n) - (succ m + o) ≡
                                                succ (m + n) - t)
                                         (+-Sx m o)
                                         refl ⟩
    succ (m + n) - succ (m + o) ≡⟨ minus-SS (m + n) (m + o) ⟩
    (m + n) - (m + o) ≡⟨ [x+y]-[x+z]≡y-z Nm Nn No ⟩
    n - o
  ∎

[x-y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m - n) * o ≡ m * o - n * o
[x-y]z≡xz*yz {m} .{zero} {o} Nm zN No =
  begin
    (m - zero) * o   ≡⟨ subst (λ t → (m - zero) * o ≡ t * o)
                              (minus-x0 m)
                              refl
                      ⟩
    m * o            ≡⟨ sym (minus-x0 (m * o)) ⟩
    m * o - zero     ≡⟨ subst (λ t → m * o - zero ≡ m * o - t)
                              (sym (*-0x o))
                              refl
                     ⟩
    m * o - zero * o
  ∎

[x-y]z≡xz*yz {o = o} zN (sN {n} Nn) No =
  begin
    (zero - succ n) * o  ≡⟨ subst (λ t → (zero - succ n) * o ≡ t * o)
                                  (minus-0S n)
                                  refl
                         ⟩
    zero * o             ≡⟨ *-0x o ⟩
    zero                 ≡⟨ sym (minus-0x (*-N (sN Nn) No)) ⟩
    zero - succ n * o    ≡⟨ subst (λ t → zero - succ n * o ≡ t - succ n * o)
                                   (sym (*-0x o))
                                   refl
                         ⟩
    zero * o - succ n * o
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) zN =
  begin
    (succ m - succ n) * zero      ≡⟨ *-comm (minus-N (sN Nm) (sN Nn)) zN ⟩
    zero * (succ m - succ n)      ≡⟨ *-0x (succ m - succ n) ⟩
    zero                          ≡⟨ sym (minus-0x (*-N (sN Nn) zN)) ⟩
    zero - succ n * zero          ≡⟨ subst (λ t → zero - succ n * zero ≡
                                                  t - succ n * zero)
                                           (sym (*-0x (succ m)))
                                           refl
                                  ⟩
    zero * succ m - succ n * zero ≡⟨ subst
                                       (λ t → zero * succ m - succ n * zero ≡
                                              t - succ n * zero)
                                       (*-comm zN (sN Nm))
                                       refl
                                  ⟩
    succ m * zero - succ n * zero
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m - succ n) * succ o  ≡⟨ subst (λ t → (succ m - succ n) * succ o ≡
                                                t * succ o)
                                         (minus-SS m n)
                                         refl
                                ⟩
    (m - n) * succ o            ≡⟨ [x-y]z≡xz*yz Nm Nn (sN No) ⟩
    m * succ o - n * succ o     ≡⟨ sym ([x+y]-[x+z]≡y-z (sN No)
                                                        (*-N Nm (sN No))
                                                        (*-N Nn (sN No)))
                                ⟩
    (succ o + m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ o + m * succ o) - (succ o + n * succ o) ≡
                      t - (succ o + n * succ o))
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ m * succ o) - (succ o + n * succ o) ≡
                      (succ m * succ o) - t)
               (sym (*-Sx n (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ n * succ o)
  ∎


Only indentation.

Only indentation.

Ignore-this: 78623b802d70c19e5a8e22e87d8d0439

darcs-hash:20100505231828-3bd4e-f52abd1371ed97700ba20e864a1ee177d0708b75.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = ⊥-elim prf
  where
    postulate
      prf : ⊥
    {-# ATP prove prf x≥0 #-}

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 Sx≤0 = ⊥-elim prf
  where
    postulate
      -- The proof uses the axiom true≠false
      prf : ⊥
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
  postulate prf : ⊥
  {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
  postulate prf : ¬ (LT m m) → ⊥
  {-# ATP prove prf #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
  postulate prf : lt (m + n) m ≡ false →
                  lt (succ m + n) (succ m) ≡ false

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
  postulate prf : (succ m - zero) + zero ≡ succ m
  {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
  postulate m>n : GT m n
  {-# ATP prove m>n #-}

  postulate prf : (m - n) + n ≡ m →
                  (succ m - succ n) + succ n ≡ succ m
  {-# ATP prove prf +-comm minus-N sN #-}


Compile fix

Compile fix

Not sure how I missed this.

------------------------------------------------------------------------
-- 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 {{validity-structure}}

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 --
  --------------------
  open import Base.Change.Equivalence
  open import Base.Change.Equivalence.Realizers

  module _ {σ τ : Type} {Γ : Context} (t : Term (σ • Γ) τ) where
    instance
      cΓ : ChangeAlgebra ⟦ Γ ⟧Context
      cΓ = change-algebra₍ Γ ₎
      cσ : ChangeAlgebra ⟦ σ ⟧Type
      cσ = change-algebra σ
      cτ : ChangeAlgebra ⟦ τ ⟧Type
      cτ = change-algebra τ

    private
      ⟦⟧Δλ = nil {{changeAlgebraFun {{cΓ}} {{change-algebra₍ σ ⇒ τ ₎}}}} ⟦ abs t ⟧

    ⟦⟧Δλ-realizer : ∀
      (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ)
      (v : ⟦ σ ⟧) (dv : Δ₍ σ ₎ v) →
      Δ₍ τ ₎ (⟦ t ⟧ (v • ρ))
    ⟦⟧Δλ-realizer ρ dρ v dv = ⟦ t ⟧Δ (v • ρ) (dv • dρ)

    ⟦⟧Δλ-realizer-correct :
      equiv-hp-binary {{cΓ}} {{cσ}} {{cτ}} (⟦ abs t ⟧) ⟦⟧Δλ ⟦⟧Δλ-realizer
    ⟦⟧Δλ-realizer-correct ρ dρ v dv =
      begin
        ⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ ⊞₍ Γ ₎ dρ) ⊟₍ τ ₎ ⟦ t ⟧ (v • ρ)
      ≙⟨ equiv-cancel-2 {{change-algebra τ}}
           (⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ ⊞₍ Γ ₎ dρ))
           (⟦ t ⟧Δ (v • ρ) (dv • dρ))
           (sym (correctness t (v • ρ) (dv • dρ)))
      ⟩
         ⟦ t ⟧Δ (v • ρ) (dv • dρ)
      ∎ where open ≙-Reasoning

    ⟦_⟧Δλ′-faster = proj₁ (equiv-raw-change-to-change-binary {{cΓ}} {{cσ}} {{cτ}} ⟦ abs t ⟧ ⟦⟧Δλ ⟦⟧Δλ-realizer ⟦⟧Δλ-realizer-correct)
      where
        open import Data.Product

  ⟦_⟧Δ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ρ = apply ⟦ t ⟧Δλ′-faster ρ dρ

  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ρ = equiv-raw-deriv-to-deriv-binary {{change-algebra₍ Γ ₎}} {{change-algebra σ}} ⟦ abs t ⟧Term (⟦⟧Δλ-realizer t) (⟦⟧Δλ-realizer-correct t) ρ dρ

  -- 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 --
  --------------------
  open import Base.Change.Equivalence
  open import Base.Change.Equivalence.Realizers

  module _ {σ τ : Type} {Γ : Context} (t : Term (σ • Γ) τ) where
    instance
      cΓ : ChangeAlgebra ⟦ Γ ⟧Context
      cΓ = change-algebra₍ Γ ₎
      cσ : ChangeAlgebra ⟦ σ ⟧Type
      cσ = change-algebra σ
      cτ : ChangeAlgebra ⟦ τ ⟧Type
      cτ = change-algebra τ

    private
      ⟦⟧Δλ = nil {{changeAlgebraFun {{cΓ}} {{change-algebra₍ σ ⇒ τ ₎}}}} ⟦ abs t ⟧

    ⟦⟧Δλ-realizer : ∀
      (ρ : ⟦ Γ ⟧) (dρ : Δ₍ Γ ₎ ρ)
      (v : ⟦ σ ⟧) (dv : Δ₍ σ ₎ v) →
      Δ₍ τ ₎ (⟦ t ⟧ (v • ρ))
    ⟦⟧Δλ-realizer ρ dρ v dv = ⟦ t ⟧Δ (v • ρ) (dv • dρ)

    ⟦⟧Δλ-realizer-correct :
      equiv-hp-binary {{cΓ}} {{cσ}} {{cτ}} (⟦ abs t ⟧) ⟦⟧Δλ ⟦⟧Δλ-realizer
    ⟦⟧Δλ-realizer-correct ρ dρ v dv =
      begin
        ⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ ⊞₍ Γ ₎ dρ) ⊟₍ τ ₎ ⟦ t ⟧ (v • ρ)
      ≙⟨ equiv-cancel-2 {{change-algebra τ}}
           (⟦ t ⟧ (v ⊞₍ σ ₎ dv • ρ ⊞₍ Γ ₎ dρ))
           (⟦ t ⟧Δ (v • ρ) (dv • dρ))
           (sym (correctness t (v • ρ) (dv • dρ)))
      ⟩
         ⟦ t ⟧Δ (v • ρ) (dv • dρ)
      ∎ where open ≙-Reasoning

    ⟦_⟧Δλ′-faster = proj₁ (equiv-raw-change-to-change-binary {{cΓ}} {{cσ}} {{cτ}} ⟦ abs t ⟧ ⟦⟧Δλ ⟦⟧Δλ-realizer ⟦⟧Δλ-realizer-correct)
      where
        open import Data.Product

  ⟦_⟧Δ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ρ = apply ⟦ t ⟧Δλ′-faster ρ dρ

  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ρ = equiv-raw-deriv-to-deriv-binary {{change-algebra₍ Γ ₎}} {{change-algebra σ}} ⟦ abs t ⟧Term (⟦⟧Δλ-realizer t) (⟦⟧Δλ-realizer-correct t) ρ dρ

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


Removed unnecessary definitions.

Removed unnecessary definitions.

------------------------------------------------------------------------------
-- Properties for the bisimilarity relation
------------------------------------------------------------------------------

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

module FOTC.Relation.Binary.Bisimilarity.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Base.PropertiesI
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, the
-- bisimilarity relation _≈_ on unbounded lists is also a pre-fixed
-- point of the bisimulation functional (see
-- FOTC.Relation.Binary.Bisimulation).
≈-pre-fixed : ∀ {xs ys} →
              (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
                xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ xs' ≈ ys') →
              xs ≈ ys
≈-pre-fixed {xs} {ys} h = ≈-coind (λ zs _ → zs ≡ zs) h' refl
  where
  h' : xs ≡ xs →
       ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ xs' ≡ xs'
  h' _ with h
  ... | x' , xs' , ys' , prf₁ , prf₂ , _ = x' , xs' , ys' , prf₁ , prf₂ , refl

≈-refl : ∀ {xs} → Stream xs → xs ≈ xs
≈-refl {xs} Sxs = ≈-coind (λ ys _ → ys ≡ ys) h refl
  where
  h : xs ≡ xs →
      ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ xs ≡ x' ∷ ys' ∧ xs' ≡ xs'
  h _ with Stream-unf Sxs
  ... | x' , xs' , prf , _ = x' , xs' , xs' , prf , prf , refl

≈-sym : ∀ {xs ys} → xs ≈ ys → ys ≈ xs
≈-sym {xs} {ys} xs≈ys = ≈-coind (λ zs _ → zs ≡ zs) h refl
  where
  h : ys ≡ ys →
      ∃[ y' ] ∃[ ys' ] ∃[ xs' ] ys ≡ y' ∷ ys' ∧ xs ≡ y' ∷ xs' ∧ ys' ≡ ys'
  h _ with ≈-unf xs≈ys
  ... | x' , xs' , ys' , prf₁ , prf₂ , _ = x' , ys' , xs' , prf₂ , prf₁ , refl

≈-trans : ∀ {xs ys zs} → xs ≈ ys → ys ≈ zs → xs ≈ zs
≈-trans {xs} {ys} {zs} xs≈ys ys≈zs = ≈-coind (λ ws _ → ws ≡ ws) h refl
  where
  h : xs ≡ xs →
      ∃[ x' ] ∃[ xs' ] ∃[ zs' ] xs ≡ x' ∷ xs' ∧ zs ≡ x' ∷ zs' ∧ xs' ≡ xs'
  h _ with ≈-unf xs≈ys
  ... | x' , xs' , ys' , prf₁ , prf₂ , _ with ≈-unf ys≈zs
  ... | y' , ys'' , zs' , prf₃ , prf₄ , _ =
    x'
    , xs'
    , zs'
    , prf₁
    , subst (λ t → zs ≡ t ∷ zs') y'≡x' prf₄
    , refl
    where
    y'≡x' : y' ≡ x'
    y'≡x' = ∧-proj₁ (∷-injective (trans (sym prf₃) prf₂))

∷-injective≈ : ∀ {x xs ys} → x ∷ xs ≈ x ∷ ys → xs ≈ ys
∷-injective≈ {x} {xs} {ys} h with ≈-unf h
... | x' , xs' , ys' , prf₁ , prf₂ , prf₃ = xs≈ys
  where
  xs≡xs' : xs ≡ xs'
  xs≡xs' = ∧-proj₂ (∷-injective prf₁)

  ys≡ys' : ys ≡ ys'
  ys≡ys' = ∧-proj₂ (∷-injective prf₂)

  xs≈ys : xs ≈ ys
  xs≈ys = subst (λ t → t ≈ ys)
                (sym xs≡xs')
                (subst (_≈_ xs') (sym ys≡ys') prf₃)

∷-rightCong≈ : ∀ {x xs ys} → xs ≈ ys → x ∷ xs ≈ x ∷ ys
∷-rightCong≈ {x} {xs} {ys} h = ≈-pre-fixed (x , xs , ys , refl , refl , h)

------------------------------------------------------------------------------
-- Properties for the bisimilarity relation
------------------------------------------------------------------------------

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

module FOTC.Relation.Binary.Bisimilarity.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Base.PropertiesI
open import FOTC.Data.Stream
open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, the
-- bisimilarity relation _≈_ on unbounded lists is also a pre-fixed
-- point of the bisimulation functional (see
-- FOTC.Relation.Binary.Bisimulation).
≈-pre-fixed : ∀ {xs ys} →
              (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
                xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ xs' ≈ ys') →
              xs ≈ ys
≈-pre-fixed {xs} {ys} h = ≈-coind (λ zs _ → zs ≡ zs) h' refl
  where
  h' : xs ≡ xs →
       ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ xs' ≡ xs'
  h' _ with h
  ... | x' , xs' , ys' , prf₁ , prf₂ , _ = x' , xs' , ys' , prf₁ , prf₂ , refl

≈-refl : ∀ {xs} → Stream xs → xs ≈ xs
≈-refl {xs} Sxs = ≈-coind (λ ys _ → ys ≡ ys) h refl
  where
  h : xs ≡ xs →
      ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ xs ≡ x' ∷ ys' ∧ xs' ≡ xs'
  h _ with Stream-unf Sxs
  ... | x' , xs' , prf , _ = x' , xs' , xs' , prf , prf , refl

≈-sym : ∀ {xs ys} → xs ≈ ys → ys ≈ xs
≈-sym {xs} {ys} xs≈ys = ≈-coind (λ zs _ → zs ≡ zs) h refl
  where
  B : D → D → Set
  B xs ys = xs ≡ xs

  h : ys ≡ ys →
      ∃[ y' ] ∃[ ys' ] ∃[ xs' ] ys ≡ y' ∷ ys' ∧ xs ≡ y' ∷ xs' ∧ ys' ≡ ys'
  h _ with ≈-unf xs≈ys
  ... | x' , xs' , ys' , prf₁ , prf₂ , _ = x' , ys' , xs' , prf₂ , prf₁ , refl

≈-trans : ∀ {xs ys zs} → xs ≈ ys → ys ≈ zs → xs ≈ zs
≈-trans {xs} {ys} {zs} xs≈ys ys≈zs = ≈-coind (λ ws _ → ws ≡ ws) h refl
  where
  B : D → D → Set
  B xs zs = xs ≡ xs

  h : xs ≡ xs →
      ∃[ x' ] ∃[ xs' ] ∃[ zs' ] xs ≡ x' ∷ xs' ∧ zs ≡ x' ∷ zs' ∧ xs' ≡ xs'
  h _ with ≈-unf xs≈ys
  ... | x' , xs' , ys' , prf₁ , prf₂ , _ with ≈-unf ys≈zs
  ... | y' , ys'' , zs' , prf₃ , prf₄ , _ =
    x'
    , xs'
    , zs'
    , prf₁
    , subst (λ t → zs ≡ t ∷ zs') y'≡x' prf₄
    , refl

    where
    y'≡x' : y' ≡ x'
    y'≡x' = ∧-proj₁ (∷-injective (trans (sym prf₃) prf₂))

∷-injective≈ : ∀ {x xs ys} → x ∷ xs ≈ x ∷ ys → xs ≈ ys
∷-injective≈ {x} {xs} {ys} h with ≈-unf h
... | x' , xs' , ys' , prf₁ , prf₂ , prf₃ = xs≈ys
  where
  xs≡xs' : xs ≡ xs'
  xs≡xs' = ∧-proj₂ (∷-injective prf₁)

  ys≡ys' : ys ≡ ys'
  ys≡ys' = ∧-proj₂ (∷-injective prf₂)

  xs≈ys : xs ≈ ys
  xs≈ys = subst (λ t → t ≈ ys)
                (sym xs≡xs')
                (subst (_≈_ xs') (sym ys≡ys') prf₃)

∷-rightCong≈ : ∀ {x xs ys} → xs ≈ ys → x ∷ xs ≈ x ∷ ys
∷-rightCong≈ {x} {xs} {ys} h = ≈-pre-fixed (x , xs , ys , refl , refl , h)


Revert "Added thesis' example."

Revert "Added thesis' example."

This reverts commit 1000130700500fc9f0c74f3feded244488fba784.

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

module CombiningProofs.ConatPropertiesATP where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Nat

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

∞-Conat : Conat ∞
∞-Conat = Conat-coind (λ n → n ≡ ∞) h refl
  where
  postulate h : ∀ {n} → n ≡ ∞ → n ≡ zero ∨ (∃[ n' ] n ≡ succ₁ n' ∧ n' ≡ ∞)
  {-# ATP prove h #-}


NomPa: Disable broken import

NomPa: Disable broken import

module NomPa.All where
import NomPa.Record
import NomPa.Derived
import NomPa.Derived.NaPa
import NomPa.Traverse
import NomPa.Implem
import NomPa.Examples.LC.DataTypes
import NomPa.Examples.LC.Contexts
import NomPa.Examples.LC.Equiv
-- import NomPa.Examples.LC.Monadic
-- import NomPa.Examples.LC.Monadic.Tests
import NomPa.Examples.LC.DbLevels
import NomPa.Examples.NaPa.LC
import NomPa.Examples.LC.Combined
import NomPa.Examples.LC
import NomPa.Examples.Records
-- import NomPa.Examples.Records.TypedVec
-- import NomPa.Examples.Records.Typed
import NomPa.Laws
import NomPa.Link
import NomPa.NomT
import NomPa.NomT.Maybe

-- Normalization By Evaluation
import NomPa.Examples.NBE
import NomPa.Examples.NBE.Can
import NomPa.Examples.NBE.Env
import NomPa.Examples.NBE.Neu
import NomPa.Examples.NBE.Tests

-- bare, raw, non-fancy…
import NomPa.Examples.BareDB
import NomPa.Examples.Raw
import NomPa.Examples.Raw.Parser
import NomPa.Examples.Raw.Printer
import NomPa.Examples.LC.WellScopedJudgment

-- Encodings: Emebedding of nominal types
import NomPa.Encodings.NominalTypes
import NomPa.Encodings.NominalTypes.Generic
import NomPa.Encodings.NominalTypes.Generic.Subst
import NomPa.Encodings.NominalTypes.Generic.Combined
import NomPa.Encodings.NominalTypes.MultiSorts
import NomPa.Encodings.NominalTypes.MultiSorts.Test
import NomPa.Encodings.AlphaCaml
import NomPa.Encodings.AlphaCaml.Test
import NomPa.Encodings.BindersUnbound
import NomPa.Encodings.BindersUnbound.Generic

-- Algorithms
import NomPa.Examples.LC.CC
import NomPa.Examples.LC.Monadic
import NomPa.Examples.LC.Monadic.Tests

-- hybrid
import NomPa.Examples.LN
import NomPa.Examples.LL
import NomPa.Examples.LocallyNamed

-- More examples
import NomPa.Examples.LC.Maybe
--import NomPa.Examples.LC.SymanticsTy
import NomPa.Examples.LC.Tests
import NomPa.Examples.LocallyClosed
import NomPa.Examples.PTS
import NomPa.Examples.PTS.F
import NomPa.Examples.Reg

-- Tests
import NomPa.Examples.Tests

-- Logical relations
import NomPa.Record.LogicalRelation
import NomPa.Implem.LogicalRelation
import NomPa.Examples.LC.DataTypes.Logical

-- Universal types
import NomPa.Universal.RegularTree
import NomPa.Universal.Sexp

import NomPa.Derived.WorldInclusion

module NomPa.All where
import NomPa.Record
import NomPa.Derived
import NomPa.Derived.NaPa
import NomPa.Traverse
import NomPa.Implem
import NomPa.Examples.LC.DataTypes
import NomPa.Examples.LC.Contexts
import NomPa.Examples.LC.Equiv
-- import NomPa.Examples.LC.Monadic
-- import NomPa.Examples.LC.Monadic.Tests
import NomPa.Examples.LC.DbLevels
import NomPa.Examples.NaPa.LC
import NomPa.Examples.LC.Combined
import NomPa.Examples.LC
import NomPa.Examples.Records
-- import NomPa.Examples.Records.TypedVec
-- import NomPa.Examples.Records.Typed
import NomPa.Laws
import NomPa.Link
import NomPa.NomT
import NomPa.NomT.Maybe

-- Normalization By Evaluation
import NomPa.Examples.NBE
import NomPa.Examples.NBE.Can
import NomPa.Examples.NBE.Env
import NomPa.Examples.NBE.Neu
import NomPa.Examples.NBE.Tests

-- bare, raw, non-fancy…
import NomPa.Examples.BareDB
import NomPa.Examples.Raw
import NomPa.Examples.Raw.Parser
import NomPa.Examples.Raw.Printer
import NomPa.Examples.LC.WellScopedJudgment

-- Encodings: Emebedding of nominal types
import NomPa.Encodings.NominalTypes
import NomPa.Encodings.NominalTypes.Generic
import NomPa.Encodings.NominalTypes.Generic.Subst
import NomPa.Encodings.NominalTypes.Generic.Combined
import NomPa.Encodings.NominalTypes.MultiSorts
import NomPa.Encodings.NominalTypes.MultiSorts.Test
import NomPa.Encodings.AlphaCaml
import NomPa.Encodings.AlphaCaml.Test
import NomPa.Encodings.BindersUnbound
import NomPa.Encodings.BindersUnbound.Generic

-- Algorithms
import NomPa.Examples.LC.CC
import NomPa.Examples.LC.Monadic
import NomPa.Examples.LC.Monadic.Tests

-- hybrid
import NomPa.Examples.LN
import NomPa.Examples.LL
import NomPa.Examples.LocallyNamed

-- More examples
import NomPa.Examples.LC.Maybe
import NomPa.Examples.LC.SymanticsTy
import NomPa.Examples.LC.Tests
import NomPa.Examples.LocallyClosed
import NomPa.Examples.PTS
import NomPa.Examples.PTS.F
import NomPa.Examples.Reg

-- Tests
import NomPa.Examples.Tests

-- Logical relations
import NomPa.Record.LogicalRelation
import NomPa.Implem.LogicalRelation
import NomPa.Examples.LC.DataTypes.Logical

-- Universal types
import NomPa.Universal.RegularTree
import NomPa.Universal.Sexp

import NomPa.Derived.WorldInclusion


Finished natural semantics ifthenelse proof thanks to Tillmanns pattern matching magic

Old-commit-hash: 269afa06d5278fb47afaf3509104feafd3c6d67a


proved a -> a, and therefore \bn -> \bn

proved a -> a, and therefore \bn -> \bn

module peano where

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ

zero + n     = n
(suc n) + n′ = suc (n + n′)

data _even : ℕ → Set where
  ZERO : zero even
  STEP : ∀ x → x even → (suc (suc x)) even

-- To prove four is even
proof₁ : suc (suc (suc (suc zero))) even
proof₁ = STEP (suc (suc zero)) (STEP zero ZERO)

proof₂′ : (A : Set) → A → A
proof₂′ _ a = a

proof₂ : ℕ → ℕ
proof₂ = proof₂′ ℕ

module peano where

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ

zero + zero  = zero
zero + n     = n
(suc n) + n′ = suc (n + n′)

data _even : ℕ → Set where
  ZERO : zero even
  STEP : ∀ x → x even → (suc (suc x)) even

-- To prove four is even
proof₁ : suc (suc (suc (suc zero))) even
proof₁ = STEP (suc (suc zero)) (STEP zero ZERO)


Adapt Base.Change.Algebra to Agda master


list functions

list functions


Missing changes.

Missing changes.

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

module LogicalFramework.AdequacyTheorems where

module Example5 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁    : A → C
    f₂    : B → C

  g : (A → C) → (B → C) → A ∨ B → C
  g f₁ f₂ (inj₁ a) = f₁ a
  g f₁ f₂ (inj₂ b) = f₂ b

  g' : (A → C) → (B → C) → A ∨ B → C
  g' f₁ f₂ x = case f₁ f₂ x

module Example7 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    C  : D → D → Set
    d  : ∀ {a} → C a a

  g : ∀ {a b} → a ≡ b → C a b
  g refl = d

  g' : ∀ {a b} → a ≡ b → C a b
  g' {a} h = subst (λ x → C a x) h d

module Example10 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁ : A → C
    f₂ : B → C

  f : A ∨ B → C
  f (inj₁ a) = f₁ a
  f (inj₂ b) = f₂ b

  f' : A ∨ B → C
  f' = case f₁ f₂

module Example20 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  f : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f {A} {t} {.t} refl At = d At
    where
    postulate d : A t → A t

  f' : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f' {A} h At = subst A h At

module Example30 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C E : Set
    f₁ : A → E
    f₂ : B → E
    f₃ : C → E

  g : (A ∨ B) ∨ C → E
  g (inj₁ (inj₁ a)) = f₁ a
  g (inj₁ (inj₂ b)) = f₂ b
  g (inj₂ c)        = f₃ c

  g' : (A ∨ B) ∨ C → E
  g' = case (case f₁ f₂) f₃

module Example40 where

  infixl 9  _+_ _+'_
  infix  7  _≡_

  data ℕ : Set where
    zero :     ℕ
    succ : ℕ → ℕ

  PA-ind : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  PA-ind A A0 h zero     = A0
  PA-ind A A0 h (succ n) = h n (PA-ind A A0 h n)

  data _≡_ (x : ℕ) : ℕ → Set where
    refl : x ≡ x

  subst : (A : ℕ → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A refl Ax = Ax

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

  _+'_ : ℕ → ℕ → ℕ
  m +' n = PA-ind (λ _ → ℕ) n (λ x y → succ y) m

  -- Properties using pattern matching.
  succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong refl = refl

  +-rightIdentity : ∀ n → n + zero ≡ n
  +-rightIdentity zero     = refl
  +-rightIdentity (succ n) = succCong (+-rightIdentity n)

  -- Properties using the basic inductive constants.
  succCong' : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong' {m} h = subst (λ x → succ m ≡ succ x) h refl

  +'-leftIdentity : ∀ n → zero +' n ≡ n
  +'-leftIdentity n = refl

  +'-rightIdentity : ∀ n → n +' zero ≡ n
  +'-rightIdentity = PA-ind A A0 is
    where
    A : ℕ → Set
    A n = n +' zero ≡ n

    A0 : A zero
    A0 = refl

    is : ∀ n → A n → A (succ n)
    is n ih = succCong' ih

module Example50 where

  infixl 10 _*_
  infixl 9  _+_
  infix  7  _≡_

  data ℕ : Set where
    zero :     ℕ
    succ : ℕ → ℕ

  PA-ind : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  PA-ind A A0 h zero     = A0
  PA-ind A A0 h (succ n) = h n (PA-ind A A0 h n)

  data _≡_ (x : ℕ) : ℕ → Set where
    refl : x ≡ x

  recℕ : {A : Set} → A → (ℕ → A → A) → ℕ → A
  recℕ {A} = PA-ind (λ _ → A)

  _+_ : ℕ → ℕ → ℕ
  m + n = recℕ n (λ _ x → succ x) m

  +-0x : ∀ n → zero + n ≡ n
  +-0x n = refl

  +-Sx : ∀ m n → succ m + n ≡ succ (m + n)
  +-Sx m n = refl

  _*_ : ℕ → ℕ → ℕ
  m * n = recℕ zero (λ _ x → n + x) m

  *-0x : ∀ n → zero * n ≡ zero
  *-0x n = refl

  *-Sx : ∀ m n → succ m * n ≡ n + m * n
  *-Sx m n = refl

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

module LogicalFramework.AdequacyTheorems where

module Example5 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁    : A → C
    f₂    : B → C

  g : (A → C) → (B → C) → A ∨ B → C
  g f₁ f₂ (inj₁ a) = f₁ a
  g f₁ f₂ (inj₂ b) = f₂ b

  g' : (A → C) → (B → C) → A ∨ B → C
  g' f₁ f₂ x = case f₁ f₂ x

module Example7 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    C  : D → D → Set
    d  : ∀ {a} → C a a

  g : ∀ {a b} → a ≡ b → C a b
  g refl = d

  g' : ∀ {a b} → a ≡ b → C a b
  g' {a} h = subst (λ x → C a x) h d

module Example10 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C : Set
    f₁ : A → C
    f₂ : B → C

  f : A ∨ B → C
  f (inj₁ a) = f₁ a
  f (inj₂ b) = f₂ b

  f' : A ∨ B → C
  f' = case f₁ f₂

module Example20 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  f : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f {A} {t} {.t} refl At = d At
    where
    postulate d : A t → A t

  f' : {A : D → Set}{t t' : D} → t ≡ t' → A t → A t'
  f' {A} h At = subst A h At

module Example30 where

  -- First-order logic with equality.
  open import Common.FOL.FOL-Eq public

  postulate
    A B C E : Set
    f₁ : A → E
    f₂ : B → E
    f₃ : C → E

  g : (A ∨ B) ∨ C → E
  g (inj₁ (inj₁ a)) = f₁ a
  g (inj₁ (inj₂ b)) = f₂ b
  g (inj₂ c)        = f₃ c

  g' : (A ∨ B) ∨ C → E
  g' = case (case f₁ f₂) f₃

module Example40 where

  infixl 9  _+_ _+'_
  infix  7  _≡_

  data M : Set where
    zero :     M
    succ : M → M

  PA-ind : (A : M → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n
  PA-ind A A0 h zero     = A0
  PA-ind A A0 h (succ n) = h n (PA-ind A A0 h n)

  data _≡_ (x : M) : M → Set where
    refl : x ≡ x

  subst : (A : M → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A refl Ax = Ax

  _+_ : M → M → M
  zero   + n = n
  succ m + n = succ (m + n)

  _+'_ : M → M → M
  m +' n = PA-ind (λ _ → M) n (λ x y → succ y) m

  -- Properties using pattern matching.
  succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong refl = refl

  +-rightIdentity : ∀ n → n + zero ≡ n
  +-rightIdentity zero     = refl
  +-rightIdentity (succ n) = succCong (+-rightIdentity n)

  -- Properties using the basic inductive constants.
  succCong' : ∀ {m n} → m ≡ n → succ m ≡ succ n
  succCong' {m} h = subst (λ x → succ m ≡ succ x) h refl

  +'-leftIdentity : ∀ n → zero +' n ≡ n
  +'-leftIdentity n = refl

  +'-rightIdentity : ∀ n → n +' zero ≡ n
  +'-rightIdentity = PA-ind A A0 is
    where
    A : M → Set
    A n = n +' zero ≡ n

    A0 : A zero
    A0 = refl

    is : ∀ n → A n → A (succ n)
    is n ih = succCong' ih


proved one of the two remaining stupid lemmas #8

open import Nat
open import Prelude
open import List
open import core
open import correspondence
open import contexts
open import lemmas-consistency

module typed-expansion where
  lem : (Γ : tctx) (x : Nat) → (((id Γ) x) == Some (X x) × (Σ[ τ ∈ htyp ]((Γ x) == Some τ)))
                             + (((id Γ) x) == None)
  lem Γ x with Γ x
  lem Γ x | Some x₁ = Inl (refl , x₁ , refl)
  lem Γ x | None = Inr refl

  lem-idsub : ∀{Δ Γ} → Δ , Γ ⊢ id Γ :s: Γ
  lem-idsub {Δ} {Γ} x d xin with lem Γ x
  lem-idsub {Δ} {Γ} x d xin | Inl (w , y , z) with (! xin) · w
  lem-idsub x .(X x) xin | Inl (w , y , z) | refl = y , z , TAVar z
  lem-idsub x d xin | Inr x₁ = abort (somenotnone ((! xin) · x₁))

  lem-subweak : ∀{Δ Γ Γ' Δ' σ} → Δ , Γ ⊢ σ :s: Γ' → (Δ ∪ Δ') , Γ ⊢ σ :s: Γ'
  lem-subweak sub x d xd∈σ with sub x d xd∈σ
  ... | τ , some , sub' = τ , some , {!!}

  lem-weakenΔ1 : ∀{Δ1 Δ2 Γ d τ} → Δ1 , Γ ⊢ d :: τ → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
  lem-weakenΔ1 TAConst = TAConst
  lem-weakenΔ1 (TAVar x₁) = TAVar x₁
  lem-weakenΔ1 (TALam D) = TALam (lem-weakenΔ1 D)
  lem-weakenΔ1 (TAAp D D₁) = TAAp (lem-weakenΔ1 D) (lem-weakenΔ1 D₁)
  lem-weakenΔ1 (TAEHole {Δ = Δ} x y) = TAEHole (x∈∪1 Δ _ _ _ x) (lem-subweak y)
  lem-weakenΔ1 (TANEHole {Δ = Δ} D x y) = TANEHole (x∈∪1 Δ _ _ _ D) (lem-weakenΔ1 x) (lem-subweak y)
  lem-weakenΔ1 (TACast D x) = TACast (lem-weakenΔ1 D) x
  lem-weakenΔ1 (TAFailedCast x y z w) = TAFailedCast (lem-weakenΔ1 x) y z w

  lem-weakenΔ2 : ∀{Δ1 Δ2 Γ d τ} → Δ2 , Γ ⊢ d :: τ → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
  lem-weakenΔ2 {Δ1} {Δ2} {Γ} {d} {τ} D = tr (λ q → q , Γ ⊢ d :: τ) (∪comm Δ2 Δ1) (lem-weakenΔ1 D)

  mutual
    typed-expansion-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : dhexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
    typed-expansion-synth ESConst = TAConst
    typed-expansion-synth (ESVar x₁) = TAVar x₁
    typed-expansion-synth (ESLam x₁ ex) = TALam (typed-expansion-synth ex)
    typed-expansion-synth (ESAp {Δ1 = Δ1} x₁ x₂ x₃ x₄)
      with typed-expansion-ana x₃ | typed-expansion-ana x₄
    ... | con1 , ih1 | con2 , ih2  = TAAp (TACast (lem-weakenΔ1 ih1) con1) (TACast (lem-weakenΔ2 {Δ1 = Δ1 }ih2) con2)
    typed-expansion-synth (ESEHole {Γ = Γ} {u = u})  = TAEHole (x∈sing ∅ u (Γ , ⦇⦈)) lem-idsub
    typed-expansion-synth (ESNEHole {Γ = Γ} {τ = τ} {u = u} {Δ = Δ} ex)
      with typed-expansion-synth ex
    ... | ih1 = TANEHole {Δ = Δ ,, (u , Γ , ⦇⦈)} (x∈sing Δ u (Γ , ⦇⦈)) (lem-weakenΔ1 ih1) lem-idsub
    typed-expansion-synth (ESAsc x)
      with typed-expansion-ana x
    ... | con , ih = TACast ih con

    typed-expansion-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : dhexp} {Δ : hctx} →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ' ~ τ) × (Δ , Γ ⊢ d :: τ')
    typed-expansion-ana (EALam x₁ MAHole ex)
      with typed-expansion-ana ex
    ... | con , D = TCHole1 , TALam D
    typed-expansion-ana (EALam x₁ MAArr ex)
      with typed-expansion-ana ex
    ... | con , D = TCArr TCRefl con , TALam D
    typed-expansion-ana (EASubsume x x₁ x₂ x₃) = ~sym x₃ , typed-expansion-synth x₂
    typed-expansion-ana (EAEHole {Γ = Γ} {u = u}) = TCRefl , TAEHole (x∈sing ∅ u (Γ , _)) lem-idsub
    typed-expansion-ana (EANEHole {Γ = Γ} {u = u} {τ = τ} {Δ = Δ}  x)
      with typed-expansion-synth x
    ... | ih1 = TCRefl , TANEHole {Δ = Δ ,, (u , Γ , τ)} (x∈sing Δ u (Γ , τ)) (lem-weakenΔ1 ih1) lem-idsub

open import Nat
open import Prelude
open import List
open import core
open import correspondence
open import contexts
open import lemmas-consistency

module typed-expansion where
  lem-idsub : ∀{Δ Γ} → Δ , Γ ⊢ id Γ :s: Γ
  lem-idsub {Δ} {Γ} x d xd∈σ with (id Γ) x
  lem-idsub x y refl | Some .y = {!!}
  lem-idsub x d xd∈σ | None = abort (somenotnone (! xd∈σ))

  lem-subweak : ∀{Δ Γ Γ' Δ' σ} → Δ , Γ ⊢ σ :s: Γ' → (Δ ∪ Δ') , Γ ⊢ σ :s: Γ'
  lem-subweak sub x d xd∈σ with sub x d xd∈σ
  ... | τ , some , sub' = τ , some , {!!}

  lem-weakenΔ1 : ∀{Δ1 Δ2 Γ d τ} → Δ1 , Γ ⊢ d :: τ → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
  lem-weakenΔ1 TAConst = TAConst
  lem-weakenΔ1 (TAVar x₁) = TAVar x₁
  lem-weakenΔ1 (TALam D) = TALam (lem-weakenΔ1 D)
  lem-weakenΔ1 (TAAp D D₁) = TAAp (lem-weakenΔ1 D) (lem-weakenΔ1 D₁)
  lem-weakenΔ1 (TAEHole {Δ = Δ} x y) = TAEHole (x∈∪1 Δ _ _ _ x) (lem-subweak y)
  lem-weakenΔ1 (TANEHole {Δ = Δ} D x y) = TANEHole (x∈∪1 Δ _ _ _ D) (lem-weakenΔ1 x) (lem-subweak y)
  lem-weakenΔ1 (TACast D x) = TACast (lem-weakenΔ1 D) x
  lem-weakenΔ1 (TAFailedCast x y z w) = TAFailedCast (lem-weakenΔ1 x) y z w

  lem-weakenΔ2 : ∀{Δ1 Δ2 Γ d τ} → Δ2 , Γ ⊢ d :: τ → (Δ1 ∪ Δ2) , Γ ⊢ d :: τ
  lem-weakenΔ2 {Δ1} {Δ2} {Γ} {d} {τ} D = tr (λ q → q , Γ ⊢ d :: τ) (∪comm Δ2 Δ1) (lem-weakenΔ1 D)

  mutual
    typed-expansion-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : dhexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
    typed-expansion-synth ESConst = TAConst
    typed-expansion-synth (ESVar x₁) = TAVar x₁
    typed-expansion-synth (ESLam x₁ ex) = TALam (typed-expansion-synth ex)
    typed-expansion-synth (ESAp {Δ1 = Δ1} x₁ x₂ x₃ x₄)
      with typed-expansion-ana x₃ | typed-expansion-ana x₄
    ... | con1 , ih1 | con2 , ih2  = TAAp (TACast (lem-weakenΔ1 ih1) con1) (TACast (lem-weakenΔ2 {Δ1 = Δ1 }ih2) con2)
    typed-expansion-synth (ESEHole {Γ = Γ} {u = u})  = TAEHole (x∈sing ∅ u (Γ , ⦇⦈)) lem-idsub
    typed-expansion-synth (ESNEHole {Γ = Γ} {τ = τ} {u = u} {Δ = Δ} ex)
      with typed-expansion-synth ex
    ... | ih1 = TANEHole {Δ = Δ ,, (u , Γ , ⦇⦈)} (x∈sing Δ u (Γ , ⦇⦈)) (lem-weakenΔ1 ih1) lem-idsub
    typed-expansion-synth (ESAsc x)
      with typed-expansion-ana x
    ... | con , ih = TACast ih con

    typed-expansion-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : dhexp} {Δ : hctx} →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ' ~ τ) × (Δ , Γ ⊢ d :: τ')
    typed-expansion-ana (EALam x₁ MAHole ex)
      with typed-expansion-ana ex
    ... | con , D = TCHole1 , TALam D
    typed-expansion-ana (EALam x₁ MAArr ex)
      with typed-expansion-ana ex
    ... | con , D = TCArr TCRefl con , TALam D
    typed-expansion-ana (EASubsume x x₁ x₂ x₃) = ~sym x₃ , typed-expansion-synth x₂
    typed-expansion-ana (EAEHole {Γ = Γ} {u = u}) = TCRefl , TAEHole (x∈sing ∅ u (Γ , _)) lem-idsub
    typed-expansion-ana (EANEHole {Γ = Γ} {u = u} {τ = τ} {Δ = Δ}  x)
      with typed-expansion-synth x
    ... | ih1 = TCRefl , TANEHole {Δ = Δ ,, (u , Γ , τ)} (x∈sing Δ u (Γ , τ)) (lem-weakenΔ1 ih1) lem-idsub


Simplified combined proof for ABP's lemma2.

------------------------------------------------------------------------------
-- ABP lemma 2
------------------------------------------------------------------------------

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

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2ATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
  using ( not-x≢x
        ; not-involutive
        )
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- 30 November 2013. If we don't have the following definitions
-- outside the where clause, the ATPs cannot prove the theorems.

ds^ : D → D → D
ds^ cs' os₂^ = corrupt os₂^ · cs'
{-# ATP definition ds^ #-}

as^ : D → D → D → D → D → D
as^ b i' is' cs' os₂^ = await b i' is' (ds^ cs' os₂^)
{-# ATP definition as^ #-}

bs^ : D → D → D → D → D → D → D
bs^ b i' is' cs' os₁^ os₂^ = corrupt os₁^ · as^ b i' is' cs' os₂^
{-# ATP definition bs^ #-}

cs^ : D → D → D → D → D → D → D
cs^ b i' is' cs' os₁^ os₂^ = ack (not b) · bs^ b i' is' cs' os₁^ os₂^
{-# ATP definition cs^ #-}

os₁^ : D → D
os₁^ os₁' = tail₁ os₁'
{-# ATP definition os₁^ #-}

os₂^ : D → D → D
os₂^ ft₂ os₂'' = ft₂ ++ os₂''
{-# ATP definition os₂^ #-}

-- Helper function for the lemma 2.
helper : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₁' →
         S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
         ∀ ft₂ os₂'' → F*T ft₂ → Fair os₂'' → os₂' ≡ ft₂ ++ os₂'' →
         ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₁''
           ∧ Fair os₂''
           ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
helper {b} {i'} {is'} {js' = js'} Bb Fos₁' s'
       .(T ∷ []) os₂'' f*tnil Fos₂'' os₂'-eq = prf
  where
  postulate
    prf : ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
          Fair os₁''
          ∧ Fair os₂''
          ∧ as'' ≡ send (not b) · is' · ds''
          ∧ bs'' ≡ corrupt os₁'' · as''
          ∧ cs'' ≡ ack (not b) · bs''
          ∧ ds'' ≡ corrupt os₂'' · cs''
          ∧ js'  ≡ out (not b) · bs''
  {-# ATP prove prf #-}

helper {b} {i'} {is'} {os₁'} {os₂'} {as'} {bs'} {cs'} {ds'} {js'}
       Bb Fos₁' s'
       .(F ∷ ft₂) os₂'' (f*tcons {ft₂} FTft₂) Fos₂'' os₂'-eq =
       helper Bb (tail-Fair Fos₁') ihS' ft₂ os₂'' FTft₂ Fos₂'' refl
  where
  postulate os₂'-eq-helper : os₂' ≡ F ∷ os₂^ ft₂ os₂''
  {-# ATP prove os₂'-eq-helper #-}

  postulate ds'-eq : ds' ≡ error ∷ ds^ cs' (os₂^ ft₂ os₂'')
  {-# ATP prove ds'-eq os₂'-eq-helper #-}

  postulate as'-eq : as' ≡ < i' , b > ∷ as^ b i' is' cs' (os₂^ ft₂ os₂'')
  {-# ATP prove as'-eq #-}

  postulate
    bs'-eq : bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
               ∨ bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove bs'-eq as'-eq head-tail-Fair #-}

  postulate
    cs'-eq-helper₁ :
      bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove cs'-eq-helper₁ not-x≢x not-involutive #-}

  postulate
    cs'-eq-helper₂ :
      bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove cs'-eq-helper₂ not-involutive #-}

  cs'-eq : cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

  postulate
    js'-eq : js' ≡ out (not b) · bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove js'-eq not-x≢x bs'-eq #-}

  postulate
    ds^-eq : ds^ cs' (os₂^ ft₂ os₂'') ≡
             corrupt (os₂^ ft₂ os₂'') ·
               (b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))

  ihS' : S' b i' is'
            (os₁^ os₁')
            (os₂^ ft₂ os₂'')
            (as^ b i' is' cs' (os₂^ ft₂ os₂''))
            (bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
            (cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
            (ds^ cs' (os₂^ ft₂ os₂''))
            js'
  ihS' = refl , refl , refl , ds^-eq , js'-eq

-- From Dybjer and Sander's paper: From the assumption that
-- os₂' ∈ Fair and hence by unfolding Fair, we conclude that there are
-- ft₂ : F*T and os₂'' : Fair, such that os₂' = ft₂ ++ os₂''.
--
-- We proceed by induction on ft₂ : F*T using helper.

lemma₂ : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₁' →
         Fair os₂' →
         S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
         ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₁''
           ∧ Fair os₂''
           ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
lemma₂ Bb Fos₁' Fos₂' s' with Fair-out Fos₂'
... | ft , os₁'' , FTft , prf , Fos₁'' =
  helper Bb Fos₁' s' ft os₁'' FTft Fos₁'' prf

------------------------------------------------------------------------------
-- ABP lemma 2
------------------------------------------------------------------------------

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

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2ATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
  using ( not-x≢x
        ; not-involutive
        )
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- 30 November 2013. If we don't have the following definitions
-- outside the where clause, the ATPs cannot prove the theorems.

ds^ : D → D → D
ds^ cs' os₂^ = corrupt os₂^ · cs'
{-# ATP definition ds^ #-}

as^ : D → D → D → D → D → D
as^ b i' is' cs' os₂^ = await b i' is' (ds^ cs' os₂^)
{-# ATP definition as^ #-}

bs^ : D → D → D → D → D → D → D
bs^ b i' is' cs' os₁^ os₂^ = corrupt os₁^ · as^ b i' is' cs' os₂^
{-# ATP definition bs^ #-}

cs^ : D → D → D → D → D → D → D
cs^ b i' is' cs' os₁^ os₂^ = ack (not b) · bs^ b i' is' cs' os₁^ os₂^
{-# ATP definition cs^ #-}

os₁^ : D → D
os₁^ os₁' = tail₁ os₁'
{-# ATP definition os₁^ #-}

os₂^ : D → D → D
os₂^ ft₂ os₂'' = ft₂ ++ os₂''
{-# ATP definition os₂^ #-}

-- Helper function for the lemma 2.
helper : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₁' →
         S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
         ∀ ft₂ os₂'' → F*T ft₂ → Fair os₂'' → os₂' ≡ ft₂ ++ os₂'' →
         ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₁''
           ∧ Fair os₂''
           ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
helper {b} {i'} {is'} {js' = js'} Bb Fos₁' s'
       .(T ∷ []) os₂'' f*tnil Fos₂'' os₂'-eq = prf
  where
  postulate
    prf : ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
          Fair os₁''
          ∧ Fair os₂''
          ∧ as'' ≡ send (not b) · is' · ds''
          ∧ bs'' ≡ corrupt os₁'' · as''
          ∧ cs'' ≡ ack (not b) · bs''
          ∧ ds'' ≡ corrupt os₂'' · cs''
          ∧ js'  ≡ out (not b) · bs''
  {-# ATP prove prf #-}

helper {b} {i'} {is'} {os₁'} {os₂'} {as'} {bs'} {cs'} {ds'} {js'}
       Bb Fos₁' s'
       .(F ∷ ft₂) os₂'' (f*tcons {ft₂} FTft₂) Fos₂'' os₂'-eq =
       helper Bb (tail-Fair Fos₁') ihS' ft₂ os₂'' FTft₂ Fos₂'' refl
  where
  postulate os₂'-eq-helper : os₂' ≡ F ∷ os₂^ ft₂ os₂''
  {-# ATP prove os₂'-eq-helper #-}

  postulate ds'-eq : ds' ≡ error ∷ ds^ cs' (os₂^ ft₂ os₂'')
  {-# ATP prove ds'-eq os₂'-eq-helper #-}

  postulate as'-eq : as' ≡ < i' , b > ∷ as^ b i' is' cs' (os₂^ ft₂ os₂'')
  {-# ATP prove as'-eq #-}

  postulate
    bs'-eq-helper₁ :
      os₁' ≡ T ∷ tail₁ os₁' →
      bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove bs'-eq-helper₁ as'-eq #-}

  postulate
    bs'-eq-helper₂ :
      os₁' ≡ F ∷ tail₁ os₁' →
      bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove bs'-eq-helper₂ as'-eq #-}

  bs'-eq : bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
             ∨ bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  bs'-eq = case (λ h → inj₁ (bs'-eq-helper₁ h))
                (λ h → inj₂ (bs'-eq-helper₂ h))
                (head-tail-Fair Fos₁')

  postulate
    cs'-eq-helper₁ :
      bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove cs'-eq-helper₁ not-x≢x not-involutive #-}

  postulate
    cs'-eq-helper₂ :
      bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove cs'-eq-helper₂ not-involutive #-}

  cs'-eq : cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

  postulate
    js'-eq-helper₁ :
      bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      js' ≡ out (not b) · bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove js'-eq-helper₁ not-x≢x #-}

  postulate
    js'-eq-helper₂ :
      bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      js' ≡ out (not b) · bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove js'-eq-helper₂ #-}

  js'-eq : js' ≡ out (not b) · bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  js'-eq = case js'-eq-helper₁ js'-eq-helper₂ bs'-eq

  postulate
    ds^-eq : ds^ cs' (os₂^ ft₂ os₂'') ≡
             corrupt (os₂^ ft₂ os₂'') ·
               (b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))

  ihS' : S' b i' is'
            (os₁^ os₁')
            (os₂^ ft₂ os₂'')
            (as^ b i' is' cs' (os₂^ ft₂ os₂''))
            (bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
            (cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
            (ds^ cs' (os₂^ ft₂ os₂''))
            js'
  ihS' = refl , refl , refl , ds^-eq , js'-eq

-- From Dybjer and Sander's paper: From the assumption that
-- os₂' ∈ Fair and hence by unfolding Fair, we conclude that there are
-- ft₂ : F*T and os₂'' : Fair, such that os₂' = ft₂ ++ os₂''.
--
-- We proceed by induction on ft₂ : F*T using helper.

lemma₂ : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₁' →
         Fair os₂' →
         S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
         ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₁''
           ∧ Fair os₂''
           ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
lemma₂ Bb Fos₁' Fos₂' s' with Fair-out Fos₂'
... | ft , os₁'' , FTft , prf , Fos₁'' =
  helper Bb Fos₁' s' ft os₁'' FTft Fos₁'' prf


Add missing projection for Receipts

Add missing projection for Receipts

{-# OPTIONS --without-K #-}
open import Function
open import Type
open import Data.Product renaming (zip to zip-×)
open import Data.Two
open import Data.List as L
open import Data.Nat.NP hiding (_==_)

module Game.ReceiptFreeness.Definitions
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₐ : ★)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CipherText)
  (Dec    : let Message = 𝟚 in
            SecKey → CipherText → Message)
  where

Candidate : ★
Candidate = 𝟚 -- as in the paper: "for simplicity"

alice bob : Candidate
alice = 0₂
bob   = 1₂

-- candidate order
-- also known as LHS or Message
-- represented by who is the first candidate
CO = 𝟚

alice-then-bob bob-then-alice : CO
alice-then-bob = alice
bob-then-alice = bob

data CO-spec : CO → Candidate → Candidate → ★ where
  alice-then-bob-spec : CO-spec alice-then-bob alice bob
  bob-then-alice-spec : CO-spec bob-then-alice bob alice

MarkedReceipt : ★
MarkedReceipt = 𝟚

marked-on-first-cell marked-on-second-cell : MarkedReceipt
marked-on-first-cell  = 0₂
marked-on-second-cell = 1₂

data MarkedReceipt-spec : CO → MarkedReceipt → Candidate → ★ where
  m1 : MarkedReceipt-spec alice-then-bob marked-on-first-cell  alice
  m2 : MarkedReceipt-spec alice-then-bob marked-on-second-cell bob
  m3 : MarkedReceipt-spec bob-then-alice marked-on-first-cell  bob
  m4 : MarkedReceipt-spec bob-then-alice marked-on-second-cell alice

data MarkedReceipt? : ★ where
  not-marked : MarkedReceipt?
  marked     : MarkedReceipt → MarkedReceipt?

-- Receipt or also called RHS
-- Made of a potential mark, a serial number, and an encrypted candidate order
Receipt : ★
Receipt = MarkedReceipt? × SerialNumber × CipherText

markedReceipt? : Receipt → MarkedReceipt?
markedReceipt? = proj₁

-- Marked when there is a 1
marked? : MarkedReceipt? → 𝟚
marked? not-marked = 0₂
marked? (marked _) = 1₂

marked-on-first-cell? : MarkedReceipt? → 𝟚
marked-on-first-cell? not-marked = 0₂
marked-on-first-cell? (marked x) = x == 0₂

marked-on-second-cell? : MarkedReceipt? → 𝟚
marked-on-second-cell? not-marked = 0₂
marked-on-second-cell? (marked x) = x == 1₂

enc-co : Receipt → CipherText
enc-co = proj₂ ∘ proj₂

m? : Receipt → MarkedReceipt?
m? = proj₁

Ballot : ★
Ballot = CO × Receipt

-- co or also called LHS
co : Ballot → CO
co = proj₁

-- receipt or also called RHS
receipt : Ballot → Receipt
receipt = proj₂

-- randomness for genBallot
Rgb : ★
Rgb = CO × SerialNumber × Rₑ

genBallot : PubKey → Rgb → Ballot
genBallot pk (r-co , sn , rₑ) = r-co , not-marked , sn , Enc pk r-co rₑ

mark : CO → Candidate → MarkedReceipt
mark co c = co xor c

mark-ok : ∀ co c → MarkedReceipt-spec co (mark co c) c
mark-ok 1₂ 1₂ = m3
mark-ok 1₂ 0₂ = m4
mark-ok 0₂ 1₂ = m2
mark-ok 0₂ 0₂ = m1

fillBallot : Candidate → Ballot → Ballot
fillBallot c (co , _ , sn , enc-co) = co , marked (mark co c) , sn , enc-co

-- TODO Ballot-spec c (fillBallot b)

ClearReceipt : ★
ClearReceipt = CO × MarkedReceipt?

ClearBB : ★
ClearBB = List ClearReceipt

Tally : ★
Tally = ℕ × ℕ

alice-score : Tally → ℕ
alice-score = proj₁

bob-score : Tally → ℕ
bob-score = proj₂

1:alice-0:bob 0:alice-1:bob : Tally
1:alice-0:bob = 1 , 0
0:alice-1:bob = 0 , 1

data TallyMarkedReceipt-spec : CO → MarkedReceipt → Tally → ★ where
  c1 : TallyMarkedReceipt-spec alice-then-bob marked-on-first-cell  1:alice-0:bob
  c2 : TallyMarkedReceipt-spec alice-then-bob marked-on-second-cell 0:alice-1:bob
  c3 : TallyMarkedReceipt-spec bob-then-alice marked-on-first-cell  0:alice-1:bob
  c4 : TallyMarkedReceipt-spec bob-then-alice marked-on-second-cell 1:alice-0:bob

marked-for-alice? : CO → MarkedReceipt → 𝟚
marked-for-alice? co m = co == m

marked-for-bob? : CO → MarkedReceipt → 𝟚
marked-for-bob? co m = not (marked-for-alice? co m)

tallyMarkedReceipt : CO → MarkedReceipt → Tally
tallyMarkedReceipt co m = 𝟚▹ℕ for-alice , 𝟚▹ℕ (not for-alice)
  where for-alice = marked-for-alice? co m

tallyMarkedReceipt-ok : ∀ co m → TallyMarkedReceipt-spec co m (tallyMarkedReceipt co m)
tallyMarkedReceipt-ok 1₂ 1₂ = c4
tallyMarkedReceipt-ok 1₂ 0₂ = c3
tallyMarkedReceipt-ok 0₂ 1₂ = c2
tallyMarkedReceipt-ok 0₂ 0₂ = c1

tallyMarkedReceipt? : CO → MarkedReceipt? → Tally
tallyMarkedReceipt? co not-marked    = 0 , 0
tallyMarkedReceipt? co (marked mark) = tallyMarkedReceipt co mark

_+,+_ : Tally → Tally → Tally
_+,+_ = zip-× _+_ _+_

-- Not taking advantage of any homomorphic encryption
tallyClearBB : ClearBB → Tally
tallyClearBB = L.foldr _+,+_ (0 , 0) ∘ L.map (uncurry tallyMarkedReceipt?)

BB : ★
BB = List Receipt

DecReceipt : SecKey → Receipt → CO × MarkedReceipt?
DecReceipt sk (m? , sn , enc-co) = Dec sk enc-co , m?

DecBB : SecKey → BB → ClearBB
DecBB = L.map ∘ DecReceipt

-- Not taking advantage of any homomorphic encryption
tally : SecKey → BB → Tally
tally sk bb = tallyClearBB (DecBB sk bb)

open import Game.ReceiptFreeness.Adversary PubKey (SerialNumber ²) Rₐ Receipt Ballot Tally CO BB public

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

{-# OPTIONS --without-K #-}
open import Function
open import Type
open import Data.Product renaming (zip to zip-×)
open import Data.Two
open import Data.List as L
open import Data.Nat.NP hiding (_==_)

module Game.ReceiptFreeness.Definitions
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₐ : ★)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CipherText)
  (Dec    : let Message = 𝟚 in
            SecKey → CipherText → Message)
  where

Candidate : ★
Candidate = 𝟚 -- as in the paper: "for simplicity"

alice bob : Candidate
alice = 0₂
bob   = 1₂

-- candidate order
-- also known as LHS or Message
-- represented by who is the first candidate
CO = 𝟚

alice-then-bob bob-then-alice : CO
alice-then-bob = alice
bob-then-alice = bob

data CO-spec : CO → Candidate → Candidate → ★ where
  alice-then-bob-spec : CO-spec alice-then-bob alice bob
  bob-then-alice-spec : CO-spec bob-then-alice bob alice

MarkedReceipt : ★
MarkedReceipt = 𝟚

marked-on-first-cell marked-on-second-cell : MarkedReceipt
marked-on-first-cell  = 0₂
marked-on-second-cell = 1₂

data MarkedReceipt-spec : CO → MarkedReceipt → Candidate → ★ where
  m1 : MarkedReceipt-spec alice-then-bob marked-on-first-cell  alice
  m2 : MarkedReceipt-spec alice-then-bob marked-on-second-cell bob
  m3 : MarkedReceipt-spec bob-then-alice marked-on-first-cell  bob
  m4 : MarkedReceipt-spec bob-then-alice marked-on-second-cell alice

data MarkedReceipt? : ★ where
  not-marked : MarkedReceipt?
  marked     : MarkedReceipt → MarkedReceipt?

-- Receipt or also called RHS
-- Made of a potential mark, a serial number, and an encrypted candidate order
Receipt : ★
Receipt = MarkedReceipt? × SerialNumber × CipherText

markedReceipt? : Receipt → MarkedReceipt?
markedReceipt? = proj₁

-- Marked when there is a 1
marked? : MarkedReceipt? → 𝟚
marked? not-marked = 0₂
marked? (marked _) = 1₂

marked-on-first-cell? : MarkedReceipt? → 𝟚
marked-on-first-cell? not-marked = 0₂
marked-on-first-cell? (marked x) = x == 0₂

marked-on-second-cell? : MarkedReceipt? → 𝟚
marked-on-second-cell? not-marked = 0₂
marked-on-second-cell? (marked x) = x == 1₂

enc-co : Receipt → CipherText
enc-co = proj₂ ∘ proj₂

Ballot : ★
Ballot = CO × Receipt

-- co or also called LHS
co : Ballot → CO
co = proj₁

-- receipt or also called RHS
receipt : Ballot → Receipt
receipt = proj₂

-- randomness for genBallot
Rgb : ★
Rgb = CO × SerialNumber × Rₑ

genBallot : PubKey → Rgb → Ballot
genBallot pk (r-co , sn , rₑ) = r-co , not-marked , sn , Enc pk r-co rₑ

mark : CO → Candidate → MarkedReceipt
mark co c = co xor c

mark-ok : ∀ co c → MarkedReceipt-spec co (mark co c) c
mark-ok 1₂ 1₂ = m3
mark-ok 1₂ 0₂ = m4
mark-ok 0₂ 1₂ = m2
mark-ok 0₂ 0₂ = m1

fillBallot : Candidate → Ballot → Ballot
fillBallot c (co , _ , sn , enc-co) = co , marked (mark co c) , sn , enc-co

-- TODO Ballot-spec c (fillBallot b)

ClearReceipt : ★
ClearReceipt = CO × MarkedReceipt?

ClearBB : ★
ClearBB = List ClearReceipt

Tally : ★
Tally = ℕ × ℕ

alice-score : Tally → ℕ
alice-score = proj₁

bob-score : Tally → ℕ
bob-score = proj₂

1:alice-0:bob 0:alice-1:bob : Tally
1:alice-0:bob = 1 , 0
0:alice-1:bob = 0 , 1

data TallyMarkedReceipt-spec : CO → MarkedReceipt → Tally → ★ where
  c1 : TallyMarkedReceipt-spec alice-then-bob marked-on-first-cell  1:alice-0:bob
  c2 : TallyMarkedReceipt-spec alice-then-bob marked-on-second-cell 0:alice-1:bob
  c3 : TallyMarkedReceipt-spec bob-then-alice marked-on-first-cell  0:alice-1:bob
  c4 : TallyMarkedReceipt-spec bob-then-alice marked-on-second-cell 1:alice-0:bob

marked-for-alice? : CO → MarkedReceipt → 𝟚
marked-for-alice? co m = co == m

marked-for-bob? : CO → MarkedReceipt → 𝟚
marked-for-bob? co m = not (marked-for-alice? co m)

tallyMarkedReceipt : CO → MarkedReceipt → Tally
tallyMarkedReceipt co m = 𝟚▹ℕ for-alice , 𝟚▹ℕ (not for-alice)
  where for-alice = marked-for-alice? co m

tallyMarkedReceipt-ok : ∀ co m → TallyMarkedReceipt-spec co m (tallyMarkedReceipt co m)
tallyMarkedReceipt-ok 1₂ 1₂ = c4
tallyMarkedReceipt-ok 1₂ 0₂ = c3
tallyMarkedReceipt-ok 0₂ 1₂ = c2
tallyMarkedReceipt-ok 0₂ 0₂ = c1

tallyMarkedReceipt? : CO → MarkedReceipt? → Tally
tallyMarkedReceipt? co not-marked    = 0 , 0
tallyMarkedReceipt? co (marked mark) = tallyMarkedReceipt co mark

_+,+_ : Tally → Tally → Tally
_+,+_ = zip-× _+_ _+_

-- Not taking advantage of any homomorphic encryption
tallyClearBB : ClearBB → Tally
tallyClearBB = L.foldr _+,+_ (0 , 0) ∘ L.map (uncurry tallyMarkedReceipt?)

BB : ★
BB = List Receipt

DecReceipt : SecKey → Receipt → CO × MarkedReceipt?
DecReceipt sk (m? , sn , enc-co) = Dec sk enc-co , m?

DecBB : SecKey → BB → ClearBB
DecBB = L.map ∘ DecReceipt

-- Not taking advantage of any homomorphic encryption
tally : SecKey → BB → Tally
tally sk bb = tallyClearBB (DecBB sk bb)

open import Game.ReceiptFreeness.Adversary PubKey (SerialNumber ²) Rₐ Receipt Ballot Tally CO BB public

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