Data.Bits: use 2^ instead of _^_ 2 in allBits and #⟨_⟩

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Bool.Properties using (not-involutive)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)
open import Data.Vec.NP public using ([]; _∷_; head; tail; replicate)

Bit : Set
Bit = Bool

module Defs where
  0b = false
  1b = true
module Patterns where
  pattern 0b = false
  pattern 1b = true
open Patterns

Bits : ℕ → Set
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → Set
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0b

-- Warning: 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

vnot∘vnot≗id : ∀ {n} → vnot {n} ∘ vnot ≗ id
vnot∘vnot≗id [] = refl
vnot∘vnot≗id (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot≗id xs)

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ 0ⁿ
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ 1ⁿ
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1ⁿ ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1ⁿ x) ⟩
         x ⊕ (x ⊕ 1ⁿ) ≡⟨ sym (⊕-assoc x x 1ⁿ) ⟩
         (x ⊕ x) ⊕ 1ⁿ ≡⟨ cong (flip _⊕_ 1ⁿ) (⊕-≡ x) ⟩
         0ⁿ ⊕ 1ⁿ       ≡⟨ ⊕-left-identity 1ⁿ ⟩
         1ⁿ ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M : Set a → Set a} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2^ n)
allBits zero    = [] ∷ []
allBits (suc n) = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry [] = 0b ∷ []
sucBCarry (0b ∷ xs) = 0b ∷ sucBCarry xs
sucBCarry (1b ∷ xs) with sucBCarry xs
... | 0b ∷ bs = 0b ∷ 1b ∷ bs
... | 1b ∷ bs = 1b ∷ 0b ∷ bs

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

lookupTbl : ∀ {n a} {A : Set a} → Bits n → Vec A (2 ^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0b ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1b ∷ key) tbl      = lookupTbl key (take (2 ^ n) (drop (2 ^ n) tbl))

funFromTbl : ∀ {n a} {A : Set a} → Vec A (2 ^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Vec A (2 ^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero} f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_) ++ []

funFromTbl∘tblFromFun : ∀ {n a} {A : Set a} (fun : Bits n → A) → funFromTbl (tblFromFun fun) ≗ fun
funFromTbl∘tblFromFun {zero} f [] = refl
funFromTbl∘tblFromFun {suc n} f (0b ∷ xs)
  rewrite take-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ []) =
    funFromTbl∘tblFromFun {n} (f ∘ 0∷_) xs
funFromTbl∘tblFromFun {suc n} f (1b ∷ xs)
  rewrite drop-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ [])
        | take-++ (2 ^ n) (tblFromFun {n} (f ∘ 1∷_)) [] =
    funFromTbl∘tblFromFun {n} (f ∘ 1∷_) xs

tblFromFun∘funFromTbl : ∀ {n a} {A : Set a} (tbl : Vec A (2 ^ n)) → tblFromFun {n} (funFromTbl tbl) ≡ tbl
tblFromFun∘funFromTbl {zero} (x ∷ []) = refl
tblFromFun∘funFromTbl {suc n} tbl
  rewrite tblFromFun∘funFromTbl {n} (take _ tbl)
        | tblFromFun∘funFromTbl {n} (take (2 ^ n) (drop (2 ^ n) tbl))
        | take-them-all (2 ^ n) (drop (2 ^ n) tbl)
        | take-drop-lem (2 ^ n) tbl
   = refl

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

open Defs public

module Data.Bits where

-- cleanup
open import Category.Applicative
open import Category.Monad
open import Data.Nat.NP hiding (_≤_; _==_)
open import Data.Nat.DivMod
open import Data.Bool.NP hiding (_==_)
open import Data.Bool.Properties using (not-involutive)
open import Data.Maybe
import Data.Fin as Fin
open Fin using (Fin; zero; suc; #_; inject₁; inject+; raise)
open import Data.Vec.NP hiding (_⊛_) renaming (map to vmap)
open import Data.Vec.N-ary.NP
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Data.Product using (_×_; _,_; uncurry; proj₁; proj₂)
open import Function.NP hiding (_→⟨_⟩_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡
open import Algebra.FunctionProperties
import Data.List as L

open import Data.Bool.NP public using (_xor_)
open import Data.Vec.NP public using ([]; _∷_; head; tail; replicate)

Bit : Set
Bit = Bool

module Defs where
  0b = false
  1b = true
module Patterns where
  pattern 0b = false
  pattern 1b = true
open Patterns

Bits : ℕ → Set
Bits = Vec Bit

_→ᵇ_ : ℕ → ℕ → Set
i →ᵇ o = Bits i → Bits o

0ⁿ : ∀ {n} → Bits n
0ⁿ = replicate 0b

-- Warning: 0ⁿ {0} ≡ 1ⁿ {0}
1ⁿ : ∀ {n} → Bits n
1ⁿ = replicate 1b

0∷_ : ∀ {n} → Bits n → Bits (suc n)
0∷ xs = 0b ∷ xs

-- can't we make these pattern aliases?
1∷_ : ∀ {n} → Bits n → Bits (suc n)
1∷ xs = 1b ∷ xs

_!_ : ∀ {a n} {A : Set a} → Vec A n → Fin n → A
_!_ = flip lookup

_==ᵇ_ : (b₀ b₁ : Bit) → Bool
b₀ ==ᵇ b₁ = not (b₀ xor b₁)

_==_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bool
[] == [] = true
(b₀ ∷ bs₀) == (b₁ ∷ bs₁) = (b₀ ==ᵇ b₁) ∧ bs₀ == bs₁

infixr 5 _⊕_
_⊕_ : ∀ {n} (bs₀ bs₁ : Bits n) → Bits n
_⊕_ = zipWith _xor_

vnot : ∀ {n} → Endo (Bits n)
vnot = _⊕_ 1ⁿ

vnot∘vnot≗id : ∀ {n} → vnot {n} ∘ vnot ≗ id
vnot∘vnot≗id [] = refl
vnot∘vnot≗id (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot≗id xs)

⊕-assoc : ∀ {n} → Associative _≡_ (_⊕_ {n})
⊕-assoc [] [] [] = refl
⊕-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite ⊕-assoc xs ys zs | Xor°.+-assoc x y z = refl

⊕-comm  : ∀ {n} → Commutative _≡_ (_⊕_ {n})
⊕-comm [] [] = refl
⊕-comm (x ∷ xs) (y ∷ ys) rewrite ⊕-comm xs ys | Xor°.+-comm x y = refl

⊕-left-identity : ∀ {n} → LeftIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-left-identity [] = refl
⊕-left-identity (x ∷ xs) rewrite ⊕-left-identity xs = refl

⊕-right-identity : ∀ {n} → RightIdentity _≡_ 0ⁿ (_⊕_ {n})
⊕-right-identity [] = refl
⊕-right-identity (x ∷ xs) rewrite ⊕-right-identity xs | proj₂ Xor°.+-identity x = refl

⊕-≡ : ∀ {n} (x : Bits n) → x ⊕ x ≡ 0ⁿ
⊕-≡ [] = refl
⊕-≡ (x ∷ xs) rewrite ⊕-≡ xs | proj₂ Xor°.-‿inverse x = refl

⊕-≢ : ∀ {n} (x : Bits n) → x ⊕ vnot x ≡ 1ⁿ
⊕-≢ x = x ⊕ vnot x   ≡⟨ refl ⟩
         x ⊕ (1ⁿ ⊕ x) ≡⟨ cong (_⊕_ x) (⊕-comm 1ⁿ x) ⟩
         x ⊕ (x ⊕ 1ⁿ) ≡⟨ sym (⊕-assoc x x 1ⁿ) ⟩
         (x ⊕ x) ⊕ 1ⁿ ≡⟨ cong (flip _⊕_ 1ⁿ) (⊕-≡ x) ⟩
         0ⁿ ⊕ 1ⁿ       ≡⟨ ⊕-left-identity 1ⁿ ⟩
         1ⁿ ∎ where open ≡-Reasoning

msb : ∀ k {n} → Bits (k + n) → Bits k
msb = take

lsb : ∀ {n} k → Bits (n + k) → Bits k
lsb {n} k rewrite ℕ°.+-comm n k = reverse ∘ msb k ∘ reverse

msb₂ : ∀ {n} → Bits (2 + n) → Bits 2
msb₂ = msb 2

lsb₂ : ∀ {n} → Bits (2 + n) → Bits 2
lsb₂ = reverse ∘ msb 2 ∘ reverse

#1 : ∀ {n} → Bits n → Fin (suc n)
#1 [] = zero
#1 (0b ∷ bs) = inject₁ (#1 bs)
#1 (1b ∷ bs) = suc (#1 bs)

#0 : ∀ {n} → Bits n → Fin (suc n)
#0 = #1 ∘ vmap not

private
 module M {a} {A : Set a} {M : Set a → Set a} (appl : RawApplicative M) where
  open RawApplicative appl

  replicateM : ∀ {n} → M A → M (Vec A n)
  replicateM {n = zero}  _ = pure []
  replicateM {n = suc n} x = pure _∷_ ⊛ x ⊛ replicateM x

open M public

allBitsL : ∀ n → L.List (Bits n)
allBitsL _ = replicateM rawIApplicative (toList (0b ∷ 1b ∷ []))

  where open RawMonad L.monad
allBits : ∀ n → Vec (Bits n) (2 ^ n)
allBits zero = [] ∷ []
allBits (suc n) rewrite ℕ°.+-comm (2 ^ n) 0 = vmap 0∷_ bs ++ vmap 1∷_ bs
  where bs = allBits n

#⟨_⟩ : ∀ {n} → (Bits n → Bool) → Fin (suc (2 ^ n))
#⟨ pred ⟩ = count pred (allBits _)

sucBCarry : ∀ {n} → Bits n → Bits (1 + n)
sucBCarry [] = 0b ∷ []
sucBCarry (0b ∷ xs) = 0b ∷ sucBCarry xs
sucBCarry (1b ∷ xs) with sucBCarry xs
... | 0b ∷ bs = 0b ∷ 1b ∷ bs
... | 1b ∷ bs = 1b ∷ 0b ∷ bs

sucB : ∀ {n} → Bits n → Bits n
sucB = tail ∘ sucBCarry

_[mod_] : ℕ → ℕ → Set
a [mod b ] = DivMod' a b

proj : ∀ {a} {A : Set a} → A × A → Bit → A
proj (x₀ , x₁) 0b = x₀
proj (x₀ , x₁) 1b = x₁

module ReversedBits where
  sucRB : ∀ {n} → Bits n → Bits n
  sucRB [] = []
  sucRB (0b ∷ xs) = 1b ∷ xs
  sucRB (1b ∷ xs) = 0b ∷ sucRB xs

toFin : ∀ {n} → Bits n → Fin (2 ^ n)
toFin         []        = zero
toFin         (0b ∷ xs) = inject+ _ (toFin xs)
toFin {suc n} (1b ∷ xs) = raise (2 ^ n) (inject+ 0 (toFin xs))

{-
toℕ : ∀ {n} → Bits n → ℕ
toℕ = Fin.toℕ ∘ toFin
-}

toℕ : ∀ {n} → Bits n → ℕ
toℕ         []        = zero
toℕ         (0b ∷ xs) = toℕ xs
toℕ {suc n} (1b ∷ xs) = 2 ^ n + toℕ xs

fromℕ : ∀ {n} → ℕ → Bits n
fromℕ = fold 0ⁿ sucB

fromFin : ∀ {n} → Fin (2 ^ n) → Bits n
fromFin = fromℕ ∘ Fin.toℕ

lookupTbl : ∀ {n a} {A : Set a} → Bits n → Vec A (2 ^ n) → A
lookupTbl         []         (x ∷ []) = x
lookupTbl         (0b ∷ key) tbl      = lookupTbl key (take _ tbl)
lookupTbl {suc n} (1b ∷ key) tbl      = lookupTbl key (take (2 ^ n) (drop (2 ^ n) tbl))

funFromTbl : ∀ {n a} {A : Set a} → Vec A (2 ^ n) → (Bits n → A)
funFromTbl = flip lookupTbl

tblFromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Vec A (2 ^ n)
-- tblFromFun f = tabulate (f ∘ fromFin)
tblFromFun {zero} f = f [] ∷ []
tblFromFun {suc n} f = tblFromFun {n} (f ∘ 0∷_) ++ tblFromFun {n} (f ∘ 1∷_) ++ []

funFromTbl∘tblFromFun : ∀ {n a} {A : Set a} (fun : Bits n → A) → funFromTbl (tblFromFun fun) ≗ fun
funFromTbl∘tblFromFun {zero} f [] = refl
funFromTbl∘tblFromFun {suc n} f (0b ∷ xs)
  rewrite take-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ []) =
    funFromTbl∘tblFromFun {n} (f ∘ 0∷_) xs
funFromTbl∘tblFromFun {suc n} f (1b ∷ xs)
  rewrite drop-++ (2 ^ n) (tblFromFun {n} (f ∘ 0∷_)) (tblFromFun {n} (f ∘ 1∷_) ++ [])
        | take-++ (2 ^ n) (tblFromFun {n} (f ∘ 1∷_)) [] =
    funFromTbl∘tblFromFun {n} (f ∘ 1∷_) xs

tblFromFun∘funFromTbl : ∀ {n a} {A : Set a} (tbl : Vec A (2 ^ n)) → tblFromFun {n} (funFromTbl tbl) ≡ tbl
tblFromFun∘funFromTbl {zero} (x ∷ []) = refl
tblFromFun∘funFromTbl {suc n} tbl
  rewrite tblFromFun∘funFromTbl {n} (take _ tbl)
        | tblFromFun∘funFromTbl {n} (take (2 ^ n) (drop (2 ^ n) tbl))
        | take-them-all (2 ^ n) (drop (2 ^ n) tbl)
        | take-drop-lem (2 ^ n) tbl
   = refl

{-
sucB-lem : ∀ {n} x → toℕ {2 ^ n} (sucB x) [mod 2 ^ n ] ≡ (suc (toℕ x)) [mod 2 ^ n ]
sucB-lem x = {!!}

-- sucB-lem : ∀ {n} x → (sucB (fromℕ x)) [mod 2 ^ n ] ≡ fromℕ ((suc x) [mod 2 ^ n ])

toℕ∘fromℕ : ∀ {n} x → toℕ (fromℕ {n} x) ≡ x
toℕ∘fromℕ zero = {!!}
toℕ∘fromℕ (suc x) = {!toℕ∘fromℕ x!}

toℕ∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toℕ (fromFin x) ≡ Fin.toℕ x
toℕ∘fromFin x = {!!}

toFin∘fromFin : ∀ {n} (x : Fin (2 ^ n)) → toFin (fromFin x) ≡ x
toFin∘fromFin x = {!!}

-- _ᴮ : (s : String) {pf : IsBitString s} → Bits (length s)
-- _ᴮ =
-}

open Defs public


lemma churn

lemma churn


cleaning up a little and documenting why the holes are puzzling #37

open import Nat
open import Prelude
open import core
open import contexts

open import correspondence

module complete-expansion where
  -- todo remove when you've proven typed expansion
  postulate
        typed-expansion-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : dhexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
        typed-expansion-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : dhexp} {Δ : hctx} →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ' ~ τ) × (Δ , Γ ⊢ d :: τ')

  gcomp-extend : ∀{Γ τ x} → Γ gcomplete → τ tcomplete → (Γ ,, (x , τ)) gcomplete
  gcomp-extend {x = x} gc tc x₁ t x₂ with natEQ x₁ x
  gcomp-extend {Γ = Γ} gc tc x t x₃ | Inl refl with Γ x
  gcomp-extend gc tc x x₁ refl | Inl refl | Some .x₁ = {!!} -- stupid context stuff again
  gcomp-extend gc tc x t x₃ | Inl refl | None with natEQ x x
  gcomp-extend gc tc x τ refl | Inl refl | None | Inl refl = tc
  gcomp-extend gc tc x t x₃ | Inl refl | None | Inr x₁ = abort (somenotnone (! x₃))
  gcomp-extend {Γ = Γ} gc tc x₁ t x₃ | Inr x₂ with Γ x₁
  gcomp-extend gc tc x₁ t x₄ | Inr x₃ | Some x = {!tc!} -- ditto
  gcomp-extend {x = x} gc tc x₁ t x₃ | Inr x₂ | None with natEQ x x₁
  gcomp-extend gc tc x t refl | Inr x₃ | None | Inl refl = tc
  gcomp-extend gc tc x₁ t x₄ | Inr x₃ | None | Inr x₂ = abort (somenotnone (! x₄))

  -- this might be derivable from things below and a fact about => and ::
  -- that we seem to have not proven
  complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) → (Δ , Γ ⊢ d :: τ) → d dcomplete → τ tcomplete
  complete-ta gc TAConst comp = TCBase
  complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁
  complete-ta gc (TALam wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁) wt comp)
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) with complete-ta gc wt comp
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) | TCArr qq qq₁ = qq₁
  complete-ta gc (TAEHole x x₁) ()
  complete-ta gc (TANEHole x wt x₁) ()
  complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂
  complete-ta gc (TAFailedCast wt x x₁ x₂) ()

  comp-synth : ∀{Γ e τ} →
                   Γ gcomplete →
                   e ecomplete →
                   Γ ⊢ e => τ →
                   τ tcomplete
  comp-synth gc ec SConst = TCBase
  comp-synth gc (ECAsc x ec) (SAsc x₁) = x
  comp-synth gc ec (SVar x) = gc _ _ x
  comp-synth gc (ECAp ec ec₁) (SAp wt MAHole x₁) with comp-synth gc ec wt
  ... | ()
  comp-synth gc (ECAp ec ec₁) (SAp wt MAArr x₁) with comp-synth gc ec wt
  comp-synth gc (ECAp ec ec₁) (SAp wt MAArr x₁) | TCArr qq qq₁ = qq₁
  comp-synth gc () SEHole
  comp-synth gc () (SNEHole wt)
  comp-synth gc (ECLam2 ec x₁) (SLam x₂ wt) = TCArr x₁ (comp-synth (gcomp-extend gc x₁) ec wt)

  mutual
    complete-expansion-synth : ∀{e τ Γ Δ d} →
                               Γ gcomplete →
                               e ecomplete →
                               Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                               d dcomplete
    complete-expansion-synth gc ec ESConst = DCConst
    complete-expansion-synth gc ec (ESVar x₁) = DCVar
    complete-expansion-synth gc (ECLam2 ec x₁) (ESLam x₂ exp) = DCLam (complete-expansion-synth (gcomp-extend gc x₁) ec exp) x₁
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp x MAHole x₂ x₃) with comp-synth gc ec x
    ... | ()
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp x MAArr x₂ x₃)
      with complete-expansion-ana gc ec x₂ | complete-expansion-ana gc ec₁ x₃ | comp-synth gc ec x
    ... | ih1 | ih2 | TCArr c1 c2 = DCAp (DCCast ih1 (comp-ana gc x₂ ih1) (TCArr c1 c2))
                                         (DCCast ih2 (comp-ana gc x₃ ih2) c1)
    complete-expansion-synth gc () ESEHole
    complete-expansion-synth gc () (ESNEHole exp)
    complete-expansion-synth gc (ECAsc x ec) (ESAsc x₁)
      with complete-expansion-ana gc ec x₁
    ... | ih = DCCast ih (comp-ana gc x₁ ih) x

    complete-expansion-ana : ∀{e τ τ' Γ Δ d} →
                             Γ gcomplete →
                             e ecomplete →
                             Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                             d dcomplete
    complete-expansion-ana gc (ECLam1 ec) (EALam x₁ MAHole exp) = {!!} -- not an ih because the ctx isn't gcomplete,
    complete-expansion-ana gc (ECLam1 ec) (EALam x₁ MAArr exp) -- since this is the unannotated lambda form, τ1 comes out of the sky with no premise about completeness
      with complete-expansion-ana (gcomp-extend gc {!!}) ec exp
    ... | ih = DCLam ih {!!}
    complete-expansion-ana gc ec (EASubsume x x₁ x₂ x₃) = complete-expansion-synth gc ec x₂

    --this is just a convenience since it shows up a few times above
    comp-ana : ∀{Γ e τ d τ' Δ} →
       Γ gcomplete →
       Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
       d dcomplete →
       τ' tcomplete
    comp-ana gc ex dc = complete-ta gc (π2 (typed-expansion-ana ex)) dc

open import Nat
open import Prelude
open import core
open import contexts

open import correspondence

module complete-expansion where
  -- todo: do you really need this? didn't in complete preservation; come back to this
  gcomp-extend : ∀{Γ τ x} → Γ gcomplete → τ tcomplete → (Γ ,, (x , τ)) gcomplete
  gcomp-extend {x = x} gc tc x₁ t x₂ with natEQ x₁ x
  gcomp-extend {Γ = Γ} gc tc x t x₃ | Inl refl with Γ x
  gcomp-extend gc tc x x₁ refl | Inl refl | Some .x₁ = {!!} -- stupid context stuff again
  gcomp-extend gc tc x t x₃ | Inl refl | None with natEQ x x
  gcomp-extend gc tc x τ refl | Inl refl | None | Inl refl = tc
  gcomp-extend gc tc x t x₃ | Inl refl | None | Inr x₁ = abort (somenotnone (! x₃))
  gcomp-extend {Γ = Γ} gc tc x₁ t x₃ | Inr x₂ with Γ x₁
  gcomp-extend gc tc x₁ t x₄ | Inr x₃ | Some x = {!tc!} -- ditto
  gcomp-extend {x = x} gc tc x₁ t x₃ | Inr x₂ | None with natEQ x x₁
  gcomp-extend gc tc x t refl | Inr x₃ | None | Inl refl = tc
  gcomp-extend gc tc x₁ t x₄ | Inr x₃ | None | Inr x₂ = abort (somenotnone (! x₄))

  complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) → (Δ , Γ ⊢ d :: τ) → d dcomplete → τ tcomplete
  complete-ta gc TAConst comp = TCBase
  complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁
  complete-ta gc (TALam wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁) wt comp)
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) with complete-ta gc wt comp
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁) | TCArr qq qq₁ = qq₁
  complete-ta gc (TAEHole x x₁) ()
  complete-ta gc (TANEHole x wt x₁) ()
  complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂
  complete-ta gc (TAFailedCast wt x x₁ x₂) ()

  synth-hole-not-comp : ∀{Γ e} →  Γ ⊢ e => ⦇⦈ → Γ gcomplete → e ecomplete → ⊥ -- this is not a strong enough IH
  synth-hole-not-comp (SAsc x) gc (ECAsc () ec)
  synth-hole-not-comp (SVar {n = n} x) gc ec with gc n _ x
  ... | ()
  synth-hole-not-comp (SAp wt MAHole x₁) gc (ECAp ec ec₁) = synth-hole-not-comp wt gc ec
  synth-hole-not-comp (SAp wt MAArr x₁) gc (ECAp ec ec₁) = {!!}
  synth-hole-not-comp SEHole gc ()
  synth-hole-not-comp (SNEHole wt) gc ()

  -- todo remove when you've proven typed expansion
  postulate
        typed-expansion-synth : {Γ : tctx} {e : hexp} {τ : htyp} {d : dhexp} {Δ : hctx} →
                            Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                            Δ , Γ ⊢ d :: τ
        typed-expansion-ana : {Γ : tctx} {e : hexp} {τ τ' : htyp} {d : dhexp} {Δ : hctx} →
                          Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                          (τ' ~ τ) × (Δ , Γ ⊢ d :: τ')
  mutual
    complete-expansion-synth : ∀{e τ Γ Δ d} →
                               Γ gcomplete →
                               e ecomplete →
                               Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                               d dcomplete
    complete-expansion-synth gc ec ESConst = DCConst
    complete-expansion-synth gc ec (ESVar x₁) = DCVar
    complete-expansion-synth gc (ECLam2 ec x₁) (ESLam x₂ exp) = DCLam (complete-expansion-synth (gcomp-extend gc x₁) ec exp) x₁
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp x MAHole x₂ x₃) = abort (synth-hole-not-comp x gc ec)
    complete-expansion-synth gc (ECAp ec ec₁) (ESAp x MAArr x₂ x₃) = {!!}
    complete-expansion-synth gc () ESEHole
    complete-expansion-synth gc () (ESNEHole exp)
    complete-expansion-synth gc (ECAsc x ec) (ESAsc x₁) with complete-expansion-ana gc ec x₁
    ... | ih = DCCast ih (complete-ta gc (π2 (typed-expansion-ana x₁)) ih) x

    complete-expansion-ana : ∀{e τ τ' Γ Δ d} →
                             Γ gcomplete →
                             e ecomplete →
                             Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                             d dcomplete
    complete-expansion-ana gc (ECLam1 ec) (EALam x₁ MAHole exp) = {!!}
    complete-expansion-ana gc (ECLam1 ec) (EALam x₁ MAArr exp)
      with complete-expansion-ana (gcomp-extend gc {!!}) ec exp
    ... | ih = DCLam ih {!!}
    complete-expansion-ana gc ec (EASubsume x x₁ x₂ x₃) = complete-expansion-synth gc ec x₂


Cosmetic changes.

Cosmetic changes.

Ignore-this: 4effbc2cfa6aca7c6869101cc72a1849

darcs-hash:20110511171225-3bd4e-1596536d6deb7589d87a6ff01f607d89c680aaeb.gz

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.Properties.MainATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.EquationsATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.MCR
open import FOTC.Program.McCarthy91.MCR.LT2MCR-ATP
open import FOTC.Program.McCarthy91.MCR.Induction.Acc.WellFoundedInductionATP
open import FOTC.Program.McCarthy91.Properties.AuxiliaryATP

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

mc91-N-ineq : ∀ {n} → N n → N (mc91 n) ∧ LT n (mc91 n + eleven)
mc91-N-ineq = wfInd-MCR P mc91-N-ineq-aux
  where
    P : D → Set
    P d = N (mc91 d) ∧ LT d (mc91 d + eleven)

    mc91-N-ineq-aux : ∀ {m} → N m → (∀ {k} → N k → MCR k m → P k) → P m
    mc91-N-ineq-aux {m} Nm f with x>y∨x≤y Nm 100-N
    ... | inj₁ m>100 = ( Nmc91>100 Nm m>100 , x<mc91x+11>100 Nm m>100 )
    ... | inj₂ m≤100 =
      let Nm+11 : N (m + eleven)
          Nm+11 = x+11-N Nm

          ih1 : P (m + eleven)
          ih1 = f Nm+11 (LT2MCR (x+11-N Nm) Nm m≤100 (x<x+11 Nm))

          Nih1 : N (mc91 (m + eleven))
          Nih1 = ∧-proj₁ ih1

          LTih1 : LT (m + eleven) (mc91 (m + eleven) + eleven)
          LTih1 = ∧-proj₂ ih1

          m<mc91m+11 : LT m (mc91 (m + eleven))
          m<mc91m+11 = x+k<y+k→x<y Nm Nih1 11-N LTih1

          ih2 : P (mc91 (m + eleven))
          ih2 = f Nih1 (LT2MCR Nih1 Nm m≤100 m<mc91m+11)

          Nmc91≤100 : N (mc91 m)
          Nmc91≤100 = Nmc91≤100' Nm m≤100 (∧-proj₁ ih2)

      in ( Nmc91≤100 ,
           <-trans Nm Nih1 (x+11-N Nmc91≤100)
                   m<mc91m+11
                   (mc91x+11<mc91x+11 Nm m≤100 (∧-proj₂ ih2)))

mc91-res : ∀ {n} → N n → (GT n one-hundred ∧ mc91 n ≡ n ∸ ten) ∨
                         (LE n one-hundred ∧ mc91 n ≡ ninety-one)
mc91-res = wfInd-MCR P mc91-res-aux
  where
    P : D → Set
    P d = (GT d one-hundred ∧ mc91 d ≡ d ∸ ten) ∨
          (LE d one-hundred ∧ mc91 d ≡ ninety-one)

    mc91-res-aux : ∀ {m} → N m → (∀ {k} → N k → MCR k m → P k) → P m
    mc91-res-aux {m} Nm f with x>y∨x≤y Nm 100-N
    ... | inj₁ m>100 = inj₁ ( m>100 , mc91-eq₁ m m>100 )
    ... | inj₂ m≤100 with x<Sy→x<y∨x≡y Nm 100-N m≤100
    ... | inj₂ m≡100 = inj₂ ( m≤100 , mc91-res-100' m≡100 )
    ... | inj₁ m≤99 with x<Sy→x<y∨x≡y Nm 99-N m≤99
    ... | inj₂ m≡99 = inj₂ ( m≤100 , mc91-res-99' m≡99 )
    ... | inj₁ m≤98 with x<Sy→x<y∨x≡y Nm 98-N m≤98
    ... | inj₂ m≡98 = inj₂ ( m≤100 , mc91-res-98' m≡98 )
    ... | inj₁ m≤97 with x<Sy→x<y∨x≡y Nm 97-N m≤97
    ... | inj₂ m≡97 = inj₂ ( m≤100 , mc91-res-97' m≡97 )
    ... | inj₁ m≤96 with x<Sy→x<y∨x≡y Nm 96-N m≤96
    ... | inj₂ m≡96 = inj₂ ( m≤100 , mc91-res-96' m≡96 )
    ... | inj₁ m≤95 with x<Sy→x<y∨x≡y Nm 95-N m≤95
    ... | inj₂ m≡95 = inj₂ ( m≤100 , mc91-res-95' m≡95 )
    ... | inj₁ m≤94 with x<Sy→x<y∨x≡y Nm 94-N m≤94
    ... | inj₂ m≡94 = inj₂ ( m≤100 , mc91-res-94' m≡94 )
    ... | inj₁ m≤93 with x<Sy→x<y∨x≡y Nm 93-N m≤93
    ... | inj₂ m≡93 = inj₂ ( m≤100 , mc91-res-93' m≡93 )
    ... | inj₁ m≤92 with x<Sy→x<y∨x≡y Nm 92-N m≤92
    ... | inj₂ m≡92 = inj₂ ( m≤100 , mc91-res-92' m≡92 )
    ... | inj₁ m≤91 with x<Sy→x<y∨x≡y Nm 91-N m≤91
    ... | inj₂ m≡91 = inj₂ ( m≤100 , mc91-res-91' m≡91 )
    ... | inj₁ m≤90 with x<Sy→x<y∨x≡y Nm 90-N m≤90
    ... | inj₂ m≡90 = inj₂ ( m≤100 , mc91-res-90' m≡90 )
    ... | inj₁ m≤89 = inj₂ ( m≤100 , mc91-res-m≤89 )

      where mc91-res-m+11 : mc91 (m + eleven) ≡ ninety-one
            mc91-res-m+11 with f (x+11-N Nm)
                                 (LT2MCR (x+11-N Nm) Nm m≤100 (x<x+11 Nm))
            ... | inj₁ ( m+11>100 , _ ) = ⊥-elim (x≤89→x+11>100→⊥ Nm
                                                 m≤89 m+11>100)
            ... | inj₂ ( _ , res ) = res

            mc91-res-m≤89 : mc91 m ≡ ninety-one
            mc91-res-m≤89 = mc91x-res≤100 Nm ninety-one m≤100
                                          mc91-res-m+11 mc91-res-91

------------------------------------------------------------------------------
-- Main properties

-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N Nn = ∧-proj₁ (mc91-N-ineq Nn)

-- For all n, n < mc91 n + 11.
mc91-ineq : ∀ {n} → N n → LT n (mc91 n + eleven)
mc91-ineq Nn = ∧-proj₂ (mc91-N-ineq Nn)

-- For all n > 100, then mc91 n = n - 10.
mc91-res>100 : ∀ {n} → N n → GT n one-hundred → mc91 n ≡ n ∸ ten
mc91-res>100 Nn n>100  with mc91-res Nn
... | inj₁ ( _ , res ) = res
... | inj₂ ( n≤100 , _ ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100 n≤100)

-- For all n <= 100, then mc91 n = 91.
mc91-res≤100 : ∀ {n} → N n → LE n one-hundred → mc91 n ≡ ninety-one
mc91-res≤100 Nn n≤100  with mc91-res Nn
... | inj₁ ( n>100 , _ ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100 n≤100)
... | inj₂ ( _ , res ) = res

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

-- The main properties proved of the McCarthy 91 function (called
-- mc91) are

-- 1. The function always terminates.
-- 2. For all n, n < mc91 n + 11.
-- 3. For all n > 100, then mc91 n = n - 10.
-- 4. For all n <= 100, then mc91 n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.Properties.MainATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.EquationsATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.MCR
open import FOTC.Program.McCarthy91.MCR.LT2MCR-ATP
open import FOTC.Program.McCarthy91.MCR.Induction.Acc.WellFoundedInductionATP
open import FOTC.Program.McCarthy91.Properties.AuxiliaryATP

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

mc91-N-ineq : ∀ {n} → N n → N (mc91 n) ∧ LT n (mc91 n + eleven)
mc91-N-ineq = wfInd-MCR P mc91-N-ineq-aux
  where
    P : D → Set
    P d = N (mc91 d) ∧ LT d (mc91 d + eleven)

    mc91-N-ineq-aux : ∀ {m} → N m → (∀ {k} → N k → MCR k m → P k) → P m
    mc91-N-ineq-aux {m} Nm f with x>y∨x≤y Nm 100-N
    ... | inj₁ m>100 = ( Nmc91>100 Nm m>100 , x<mc91x+11>100 Nm m>100 )
    ... | inj₂ m≤100 =
      let Nm+11 : N (m + eleven)
          Nm+11 = x+11-N Nm

          ih1 : P (m + eleven)
          ih1 = f Nm+11 (LT2MCR (x+11-N Nm) Nm m≤100 (x<x+11 Nm))

          Nih1 : N (mc91 (m + eleven))
          Nih1 = ∧-proj₁ ih1

          LTih1 : LT (m + eleven) (mc91 (m + eleven) + eleven)
          LTih1 = ∧-proj₂ ih1

          m<mc91m+11 : LT m (mc91 (m + eleven))
          m<mc91m+11 = x+k<y+k→x<y Nm Nih1 11-N LTih1

          ih2 : P (mc91 (m + eleven))
          ih2 = f Nih1 (LT2MCR Nih1 Nm m≤100 m<mc91m+11)

          Nmc91≤100 : N (mc91 m)
          Nmc91≤100 = Nmc91≤100' Nm m≤100 (∧-proj₁ ih2)

      in ( Nmc91≤100 ,
           <-trans Nm Nih1 (x+11-N Nmc91≤100)
                   m<mc91m+11
                   (mc91x+11<mc91x+11 Nm m≤100 (∧-proj₂ ih2)))

mc91-res : ∀ {n} → N n → (GT n one-hundred ∧ mc91 n ≡ n ∸ ten) ∨
                         (LE n one-hundred ∧ mc91 n ≡ ninety-one)
mc91-res = wfInd-MCR P mc91-res-aux
  where
    P : D → Set
    P d = (GT d one-hundred ∧ mc91 d ≡ d ∸ ten) ∨
          (LE d one-hundred ∧ mc91 d ≡ ninety-one)

    mc91-res-aux : ∀ {m} → N m → (∀ {k} → N k → MCR k m → P k) → P m
    mc91-res-aux {m} Nm f with x>y∨x≤y Nm 100-N
    ... | inj₁ m>100 = inj₁ ( m>100 , mc91-eq₁ m m>100 )
    ... | inj₂ m≤100 with x<Sy→x<y∨x≡y Nm 100-N m≤100
    ... | inj₂ m≡100 = inj₂ ( m≤100 , mc91-res-100' m≡100 )
    ... | inj₁ m≤99 with x<Sy→x<y∨x≡y Nm 99-N m≤99
    ... | inj₂ m≡99 = inj₂ ( m≤100 , mc91-res-99' m≡99 )
    ... | inj₁ m≤98 with x<Sy→x<y∨x≡y Nm 98-N m≤98
    ... | inj₂ m≡98 = inj₂ ( m≤100 , mc91-res-98' m≡98 )
    ... | inj₁ m≤97 with x<Sy→x<y∨x≡y Nm 97-N m≤97
    ... | inj₂ m≡97 = inj₂ ( m≤100 , mc91-res-97' m≡97 )
    ... | inj₁ m≤96 with x<Sy→x<y∨x≡y Nm 96-N m≤96
    ... | inj₂ m≡96 = inj₂ ( m≤100 , mc91-res-96' m≡96 )
    ... | inj₁ m≤95 with x<Sy→x<y∨x≡y Nm 95-N m≤95
    ... | inj₂ m≡95 = inj₂ ( m≤100 , mc91-res-95' m≡95 )
    ... | inj₁ m≤94 with x<Sy→x<y∨x≡y Nm 94-N m≤94
    ... | inj₂ m≡94 = inj₂ ( m≤100 , mc91-res-94' m≡94 )
    ... | inj₁ m≤93 with x<Sy→x<y∨x≡y Nm 93-N m≤93
    ... | inj₂ m≡93 = inj₂ ( m≤100 , mc91-res-93' m≡93 )
    ... | inj₁ m≤92 with x<Sy→x<y∨x≡y Nm 92-N m≤92
    ... | inj₂ m≡92 = inj₂ ( m≤100 , mc91-res-92' m≡92 )
    ... | inj₁ m≤91 with x<Sy→x<y∨x≡y Nm 91-N m≤91
    ... | inj₂ m≡91 = inj₂ ( m≤100 , mc91-res-91' m≡91 )
    ... | inj₁ m≤90 with x<Sy→x<y∨x≡y Nm 90-N m≤90
    ... | inj₂ m≡90 = inj₂ ( m≤100 , mc91-res-90' m≡90 )
    ... | inj₁ m≤89 =  inj₂ ( m≤100 , mc91-res-m≤89 )

      where mc91-res-m+11 : mc91 (m + eleven) ≡ ninety-one
            mc91-res-m+11 with f (x+11-N Nm)
                                 (LT2MCR (x+11-N Nm) Nm m≤100 (x<x+11 Nm))
            ... | inj₁ ( m+11>100 , _) = ⊥-elim (x≤89→x+11>100→⊥ Nm
                                                m≤89 m+11>100)
            ... | inj₂ ( _ , res ) = res

            mc91-res-m≤89 : mc91 m ≡ ninety-one
            mc91-res-m≤89 = mc91x-res≤100 Nm ninety-one m≤100
                                          mc91-res-m+11 mc91-res-91

------------------------------------------------------------------------------
-- Main properties

-- The function always terminates.
mc91-N : ∀ {n} → N n → N (mc91 n)
mc91-N Nn = ∧-proj₁ (mc91-N-ineq Nn)

-- For all n, n < mc91 n + 11.
mc91-ineq : ∀ {n} → N n → LT n (mc91 n + eleven)
mc91-ineq Nn = ∧-proj₂ (mc91-N-ineq Nn)

-- For all n > 100, then mc91 n = n - 10.
mc91-res>100 : ∀ {n} → N n → GT n one-hundred → mc91 n ≡ n ∸ ten
mc91-res>100 Nn n>100  with mc91-res Nn
... | inj₁ ( _ , res ) = res
... | inj₂ ( n≤100 , _ ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100 n≤100)

-- For all n <= 100, then mc91 n = 91.
mc91-res≤100 : ∀ {n} → N n → LE n one-hundred → mc91 n ≡ ninety-one
mc91-res≤100 Nn n≤100  with mc91-res Nn
... | inj₁ ( n>100 , _ ) = ⊥-elim (x>y→x≤y→⊥ Nn 100-N n>100 n≤100)
... | inj₂ ( _ , res ) = res


Derive during symbolic execution (see #50).

Surprisingly painless. Is this what we want?

Old-commit-hash: af9942ac1056e270f468dc06560517ac7de2cc39

module lambda where

open import Relation.Binary.PropositionalEquality

open import Syntactic.Types public
open import Syntactic.Contexts Type public

open import Denotational.Notation
open import Denotational.Values public
open import Denotational.Environments Type ⟦_⟧Type public

-- TERMS

-- Syntax

data Term : Context → Type → Set where
  abs : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) → Term Γ (τ₁ ⇒ τ₂)
  app : ∀ {Γ τ₁ τ₂} → (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) → Term Γ τ₂
  var : ∀ {Γ τ} → (x : Var Γ τ) → Term Γ τ

  true false : ∀ {Γ} → Term Γ bool
  if : ∀ {Γ τ} → (t₁ : Term Γ bool) (t₂ t₃ : Term Γ τ) → Term Γ τ

-- Denotational Semantics

⟦_⟧Term : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧ → ⟦ τ ⟧
⟦ abs t ⟧Term ρ = λ v → ⟦ t ⟧Term (v • ρ)
⟦ app t₁ t₂ ⟧Term ρ = (⟦ t₁ ⟧Term ρ) (⟦ t₂ ⟧Term ρ)
⟦ var x ⟧Term ρ = ⟦ x ⟧ ρ

⟦ true ⟧Term ρ = true
⟦ false ⟧Term ρ = false
⟦ if t₁ t₂ t₃ ⟧Term ρ with ⟦ t₁ ⟧Term ρ
... | true = ⟦ t₂ ⟧Term ρ
... | false = ⟦ t₃ ⟧Term ρ

meaningOfTerm : ∀ {Γ τ} → Meaning (Term Γ τ)
meaningOfTerm = meaning ⟦_⟧Term

-- NATURAL SEMANTICS

-- Syntax

data Env : Context → Set
data Val : Type → Set

data Val where
  ⟨abs_,_⟩ : ∀ {Γ τ₁ τ₂} → (t : Term (τ₁ • Γ) τ₂) (ρ : Env Γ) → Val (τ₁ ⇒ τ₂)
  true : Val bool
  false : Val bool

data Env where
  ∅ : Env ∅
  _•_ : ∀ {Γ τ} → Val τ → Env Γ → Env (τ • Γ)

-- Lookup

infixr 8 _⊢_↓_ _⊢_↦_

data _⊢_↦_ : ∀ {Γ τ} → Env Γ → Var Γ τ → Val τ → Set where
  this : ∀ {Γ τ} {ρ : Env Γ} {v : Val τ} →
    v • ρ ⊢ this ↦ v
  that : ∀ {Γ τ₁ τ₂ x} {ρ : Env Γ} {v₁ : Val τ₁} {v₂ : Val τ₂} →
    ρ ⊢ x ↦ v₂ →
    v₁ • ρ ⊢ that x ↦ v₂

-- Reduction

data _⊢_↓_ : ∀ {Γ τ} → Env Γ → Term Γ τ → Val τ → Set where
  abs : ∀ {Γ τ₁ τ₂ ρ} {t : Term (τ₁ • Γ) τ₂} →
    ρ ⊢ abs t ↓ ⟨abs t , ρ ⟩
  app : ∀ {Γ Γ′ τ₁ τ₂ ρ ρ′ v₂ v′} {t₁ : Term Γ (τ₁ ⇒ τ₂)} {t₂ : Term Γ τ₁} {t′ : Term (τ₁ • Γ′) τ₂} →
    ρ ⊢ t₁ ↓ ⟨abs t′ , ρ′ ⟩ →
    ρ ⊢ t₂ ↓ v₂ →
    v₂ • ρ′ ⊢ t′ ↓ v′ →
    ρ ⊢ app t₁ t₂ ↓ v′
  var : ∀ {Γ τ x} {ρ : Env Γ} {v : Val τ}→
    ρ ⊢ x ↦ v →
    ρ ⊢ var x ↓ v
  if-true : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₂ : Val τ} →
    ρ ⊢ t₁ ↓ true →
    ρ ⊢ t₂ ↓ v₂ →
    ρ ⊢ if t₁ t₂ t₃ ↓ v₂
  if-false : ∀ {Γ τ} {ρ : Env Γ} {t₁ t₂ t₃} {v₃ : Val τ} →
    ρ ⊢ t₁ ↓ false →
    ρ ⊢ t₃ ↓ v₃ →
    ρ ⊢ if t₁ t₂ t₃ ↓ v₃

-- SOUNDNESS of natural semantics

⟦_⟧Env : ∀ {Γ} → Env Γ → ⟦ Γ ⟧
⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ ⟨abs t , ρ ⟩ ⟧Val = λ v → ⟦ t ⟧ (v • ⟦ ρ ⟧Env)
⟦ true ⟧Val = true
⟦ false ⟧Val = false

meaningOfEnv : ∀ {Γ} → Meaning (Env Γ)
meaningOfEnv = meaning ⟦_⟧Env

meaningOfVal : ∀ {τ} → Meaning (Val τ)
meaningOfVal = meaning ⟦_⟧Val

↦-sound : ∀ {Γ τ ρ v} {x : Var Γ τ} →
  ρ ⊢ x ↦ v →
  ⟦ x ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↦-sound this = refl
↦-sound (that ↦) = ↦-sound ↦

↓-sound : ∀ {Γ τ ρ v} {t : Term Γ τ} →
  ρ ⊢ t ↓ v →
  ⟦ t ⟧ ⟦ ρ ⟧ ≡ ⟦ v ⟧
↓-sound abs = refl
↓-sound (app ↓₁ ↓₂ ↓′) = trans (cong₂ (λ x y → x y) (↓-sound ↓₁) (↓-sound ↓₂)) (↓-sound ↓′)
↓-sound (var ↦) = ↦-sound ↦
↓-sound (if-true ↓₁ ↓₂) rewrite ↓-sound ↓₁ = ↓-sound ↓₂
↓-sound (if-false ↓₁ ↓₃) rewrite ↓-sound ↓₁ = ↓-sound ↓₃

-- WEAKENING

-- Weaken a term to a super context

weaken : ∀ {Γ₁ Γ₂ τ} → Γ₁ ≼ Γ₂ → Term Γ₁ τ → Term Γ₂ τ
weaken ≼₁ (abs t) = abs (weaken (keep _ • ≼₁) t)
weaken ≼₁ (app t₁ t₂) = app (weaken ≼₁ t₁) (weaken ≼₁ t₂)
weaken ≼₁ (var x) = var (lift ≼₁ x)
weaken ≼₁ true = true
weaken ≼₁ false = false
weaken ≼₁ (if e₁ e₂ e₃) = if (weaken ≼₁ e₁) (weaken ≼₁ e₂) (weaken ≼₁ e₃)

-- SYMBOLIC EXECUTION
--
-- Naming Convention:
-- Γ ⟪_⟫X is like ⟦_⟧X but for symbolic execution in context Γ.

_⟪_⟫Type : Context → Type → Set
Γ₁ ⟪ τ₁ ⇒ τ₂ ⟫Type = ∀ {Γ₂} → Γ₁ ≼ Γ₂ → Γ₂ ⟪ τ₁ ⟫Type → Γ₂ ⟪ τ₂ ⟫Type
Γ₁ ⟪ bool ⟫Type = Term Γ₁ bool

module _ (Γ : Context) where
  import Denotational.Environments
  module SymEnv = Denotational.Environments Type (λ τ → Γ ⟪ τ ⟫Type)

  open SymEnv public using ()
    renaming (⟦_⟧Context to _⟪_⟫Context; ⟦_⟧Var to _⟪_⟫Var_)

liftVal : ∀ {τ Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → Γ₁ ⟪ τ ⟫Type → Γ₂ ⟪ τ ⟫Type
liftVal {τ₁ ⇒ τ₂} ≼₁ v₁ = λ ≼₂ v₂ → v₁ (≼-trans ≼₁ ≼₂) v₂
liftVal {bool} ≼₁ v = weaken ≼₁ v

liftEnv : ∀ {Γ Γ₁ Γ₂} → Γ₁ ≼ Γ₂ → Γ₁ ⟪ Γ ⟫Context → Γ₂ ⟪ Γ ⟫Context
liftEnv {∅} ≼₁ ∅ = SymEnv.∅
liftEnv {τ • Γ} ≼₁ (v • ρ) = liftVal ≼₁ v SymEnv.• liftEnv ≼₁ ρ

mixed-if : ∀ {Γ₁} τ → (t₁ : Term Γ₁ bool) (v₂ v₃ : Γ₁ ⟪ τ ⟫Type) → Γ₁ ⟪ τ ⟫Type
mixed-if (τ₁ ⇒ τ₂) t₁ v₂ v₃ = λ ≼₁ v → mixed-if τ₂ (weaken ≼₁ t₁) (v₂ ≼₁ v) (v₃ ≼₁ v)
mixed-if bool t₁ t₂ t₃ = if t₁ t₂ t₃

_⟪_⟫Term_ : ∀ Γ₁ {Γ τ} → Term Γ τ → Γ₁ ⟪ Γ ⟫Context → Γ₁ ⟪ τ ⟫Type
Γ₁ ⟪ abs t ⟫Term ρ = λ {Γ₂} ≼₁ v → Γ₂ ⟪ t ⟫Term (v SymEnv.• liftEnv ≼₁ ρ)
Γ₁ ⟪ app t₁ t₂ ⟫Term ρ = (Γ₁ ⟪ t₁ ⟫Term ρ) ≼-refl (Γ₁ ⟪ t₂ ⟫Term ρ)
Γ₁ ⟪ var x ⟫Term ρ = Γ₁ ⟪ x ⟫Var ρ
Γ₁ ⟪ true ⟫Term ρ = true
Γ₁ ⟪ false ⟫Term ρ = false
Γ₁ ⟪ if t₁ t₂ t₃ ⟫Term ρ = mixed-if _ (Γ₁ ⟪ t₁ ⟫Term ρ) (Γ₁ ⟪ t₂ ⟫Term ρ) (Γ₁ ⟪ t₂ ⟫Term ρ)

↓ : ∀ {Γ} τ → Γ ⟪ τ ⟫Type → Term Γ τ
↑ : ∀ {Γ} τ → Term Γ τ → Γ ⟪ τ ⟫Type

↓ (τ₁ ⇒ τ₂) v = abs (↓ τ₂ (v (drop τ₁ • ≼-refl) (↑ τ₁ (var this))))
↓ bool v = v

↑ (τ₁ ⇒ τ₂) t = λ ≼₁ v → ↑ τ₂ (app (weaken ≼₁ t) (↓ τ₁ v))
↑ bool t = t

↑-Context : ∀ {Γ} → Γ ⟪ Γ ⟫Context
↑-Context {∅} = SymEnv.∅
↑-Context {τ • Γ} = ↑ τ (var this) SymEnv.• liftEnv (drop τ • ≼-refl) ↑-Context

norm : ∀ {Γ τ} → Term Γ τ → Term Γ τ
norm {Γ} {τ} t = ↓ τ (Γ ⟪ t ⟫Term ↑-Context)

-- SYMBOLIC DERIVATION
--
-- compare derive with _⟪_⟫_Term
-- and derive-var with ⟦_⟧Var

Δ-Type : Type → Type
Δ-Type (τ₁ ⇒ τ₂) = τ₁ ⇒ Δ-Type τ₁ ⇒ Δ-Type τ₂
Δ-Type bool = bool

Δ-Context : Context → Context
Δ-Context ∅ = ∅
Δ-Context (τ • Γ) = Δ-Type τ • Δ-Context Γ

xor₃ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool → Term Γ bool
xor₃ t₁ t₂ t₃
  = if t₁ (if t₂ t₃ (if t₃ false true)) (if t₂ (if t₃ false true) t₃)

derive-if : ∀ {τ Γ₁} →
  (t dt : Term Γ₁ bool) →
  (v₁ : Γ₁ ⟪ τ ⟫Type) (dv₁ : Γ₁ ⟪ Δ-Type τ ⟫Type) →
  (v₂ : Γ₁ ⟪ τ ⟫Type) (dv₂ : Γ₁ ⟪ Δ-Type τ ⟫Type) →
  Γ₁ ⟪ Δ-Type τ ⟫Type
derive-if {τ₁ ⇒ τ₂} t dt v₁ dv₁ v₂ dv₂ =
  λ ≼₁ v ≼₂ dv → let ≼₃ = ≼-trans ≼₁ ≼₂ in
    derive-if (weaken ≼₃ t) (weaken ≼₃ dt)
              (v₁ ≼₃ (liftVal ≼₂ v)) (dv₁ ≼₁ v ≼₂ dv)
              (v₂ ≼₃ (liftVal ≼₂ v)) (dv₂ ≼₁ v ≼₂ dv)
derive-if {bool} t₁ dt₁ t₂ dt₂ t₃ dt₃ =
  if dt₁ (if t₁ (xor₃ t₂ t₃ dt₃) (xor₃ t₂ t₃ dt₂)) (if t₁ dt₃ dt₂)

derive-var : ∀ {Γ₁ Γ τ} → Var Γ τ → Γ₁ ⟪ Δ-Context Γ ⟫Context → Γ₁ ⟪ Δ-Type τ ⟫Type
derive-var this (dv SymEnv.• dρ) = dv
derive-var (that x) (dv SymEnv.• dρ) = derive-var x dρ

derive : ∀ {Γ₁ Γ τ} → Term Γ τ → Γ₁ ⟪ Γ ⟫Context → Γ₁ ⟪ Δ-Context Γ ⟫Context → Γ₁ ⟪ Δ-Type τ ⟫Type
derive (abs t) ρ dρ =
  λ ≼₁ v ≼₂ dv → derive t (liftVal ≼₂ v SymEnv.• liftEnv (≼-trans ≼₁ ≼₂) ρ) (dv SymEnv.• liftEnv (≼-trans ≼₁ ≼₂) dρ)
derive (app t₁ t₂) ρ dρ =
  derive t₁ ρ dρ ≼-refl (_ ⟪ t₂ ⟫Term ρ) ≼-refl (derive t₂ ρ dρ)
derive (var x) ρ dρ = derive-var x dρ
derive true ρ dρ = false
derive false ρ dρ = false
derive {Γ₁} (if t₁ t₂ t₃) ρ dρ =
  derive-if (Γ₁ ⟪ t₁ ⟫Term ρ) (derive t₁ ρ dρ)
            (Γ₁ ⟪ t₂ ⟫Term ρ) (derive t₂ ρ dρ)
            (Γ₁ ⟪ t₃ ⟫Term ρ) (derive t₃ ρ dρ)


Renamed some properties.

Renamed some properties.

------------------------------------------------------------------------------
-- Properties for the equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality.PropertiesI where

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

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

stream-≈-refl : ∀ {xs} → Stream xs → xs ≈ xs
stream-≈-refl {xs} Sxs = ≈-coind R h₁ h₂
  where
  R : D → D → Set
  R xs ys = Stream xs ∧ Stream xs ∧ xs ≡ ys

  h₁ : ∀ {xs ys} → R xs ys → ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
       R xs' ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  h₁ (Sxs , Sys , refl) with (Stream-unf Sxs)
  ... | x' , xs' , Sxs' , prf = x' , xs' , xs' , (Sxs' , Sxs' , refl) , prf , prf

  h₂ : R xs xs
  h₂ = Sxs , Sxs , refl

stream-≡→≈ : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
stream-≡→≈ Sxs _ refl = stream-≈-refl Sxs

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = Stream-coind P₁ h₁ (ys , h) , Stream-coind P₂ h₂ (xs , h)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  h₁ : ∀ {ws} → P₁ ws → ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  h₁ {ws} (zs , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , prf₂ , _ = w' , ws' , (zs' , prf₁) , prf₂

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  h₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  h₂  {zs} (ws , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , _ , prf₂ = w' , zs' , (ws' , prf₁) , prf₂

------------------------------------------------------------------------------
-- Properties for the equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality.PropertiesI where

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

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

≈-Stream-refl : ∀ {xs} → Stream xs → xs ≈ xs
≈-Stream-refl {xs} Sxs = ≈-coind R h₁ h₂
  where
  R : D → D → Set
  R xs ys = Stream xs ∧ Stream xs ∧ xs ≡ ys

  h₁ : ∀ {xs ys} → R xs ys → ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
       R xs' ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  h₁ (Sxs , Sys , refl) with (Stream-unf Sxs)
  ... | x' , xs' , Sxs' , prf = x' , xs' , xs' , (Sxs' , Sxs' , refl) , prf , prf

  h₂ : R xs xs
  h₂ = Sxs , Sxs , refl

≡→≈-Stream : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
≡→≈-Stream Sxs _ refl = ≈-Stream-refl Sxs

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = Stream-coind P₁ h₁ (ys , h) , Stream-coind P₂ h₂ (xs , h)
  where
  P₁ : D → Set
  P₁ ws = ∃[ zs ] ws ≈ zs

  h₁ : ∀ {ws} → P₁ ws → ∃[ w' ] ∃[ ws' ] P₁ ws' ∧ ws ≡ w' ∷ ws'
  h₁ {ws} (zs , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , prf₂ , _ = w' , ws' , (zs' , prf₁) , prf₂

  P₂ : D → Set
  P₂ zs = ∃[ ws ] ws ≈ zs

  h₂ : ∀ {zs} → P₂ zs → ∃[ z' ] ∃[ zs' ] P₂ zs' ∧ zs ≡ z' ∷ zs'
  h₂  {zs} (ws , h₁) with ≈-unf h₁
  ... | w' , ws' , zs' , prf₁ , _ , prf₂ = w' , zs' , (ws' , prf₁) , prf₂


clean up cut elimination

clean up cut elimination

open import proto
open import Types
open import prelude
open import uri

module Terms where

infix 2 ⊢ˢ_ ⊢_ ⊢ᶜᶠ_

data ⊢_ : (Δ : Env) → Set₁ where
  end : ∀{Δ}{e : EndedEnv Δ}
       ------------------
      → ⊢ Δ

  output : ∀ {Δ d M P}{{_ : SER M}}
             (l : d ↦ send P ∈ Δ)(m : M)
             (p : ⊢ Δ [ l ≔ m ])
             -------------------
               → ⊢ Δ

  input : ∀ {Δ d M}{P : M → _}{{_ : SER M}}
            (l : d ↦ recv P ∈ Δ)
            (p : ∀ m → ⊢ Δ [ l ≔ m ])
                 ----------------------
                     → ⊢ Δ

  mix : ∀ {Δ Δ₀ Δ₁} (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ])
          (p : ⊢ Δ₀) (q : ⊢ Δ₁)
          --------------------
        → ⊢ Δ

  cut : ∀ {Δ Δ₀ Δ₁} (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ]) {P d}
          (p : ⊢ (Δ₀ , d ↦ dual P))
          (q : ⊢ (Δ₁ , d ↦ P))
          ---------------------
        → ⊢ Δ

  fwd : ∀ c d {P} → ⊢ (ε , c ↦ P , d ↦ dual P)

  exch-last :
      ∀ {Δ c d P Q} →
      (p : ⊢ Δ , c ↦ P , d ↦ Q)
      → ⊢ Δ , d ↦ Q , c ↦ P

  wk-last : ∀ {Δ d}
              (p : ⊢ Δ)
              -----------------------
                → ⊢ (Δ , d ↦ end)

  end-last : ∀ {Δ d}
               (p : ⊢ (Δ , d ↦ end))
               ----------------------
                 → ⊢ Δ

data ⊢ᶜᶠ_ (Δ : Env) : Set₁ where
  end : {e : EndedEnv Δ} → ⊢ᶜᶠ Δ

  output : ∀ {d M P}{{_ : SER M}}
            (l : d ↦ send P ∈ Δ) → (m : M)
            (p : ⊢ᶜᶠ Δ [ l ≔ m ])
            --------------------
              → ⊢ᶜᶠ Δ

  input : ∀ {d M}{P : M → _}{{_ : SER M}}
            (l : d ↦ recv P ∈ Δ)
            (p : ∀ m → ⊢ᶜᶠ Δ [ l ≔ m ])
            ----------------------------
                     → ⊢ᶜᶠ Δ

-- The Δ for the server contains the view point of the clients
-- The point is that the meaning of _,_ in Δ is ⊗ while it
-- is ⅋ in ⊢ᶜᶠ
record ⊢ˢ_ (Δ : Env) : Set₁ where
  coinductive
  field
    server-output :
      ∀ {d M}{{_ : SER M}}{P : M → Proto}
        (l : d ↦ recv P ∈ Δ) →
        Σ M λ m → ⊢ˢ Δ [ l ≔ m ]
    server-input :
      ∀ {d M}{{_ : SER M}}{P : M → Proto}
        (l : d ↦ send P ∈ Δ)
        (m : M) → ⊢ˢ Δ [ l ≔ m ]
open ⊢ˢ_ public

-- This is just to confirm that we have enough cases
telecom' : ∀ {Δ} → ⊢ᶜᶠ Δ → ⊢ˢ Δ → 𝟙
telecom' end q = _
telecom' (output l m p) q
  = telecom' p (server-input q l m)
telecom' (input l p) q
  = case server-output q l of λ { (m , s) →
      telecom' (p m) s }

embedᶜᶠ : ∀ {Δ} → ⊢ᶜᶠ Δ → ⊢ Δ
embedᶜᶠ (end {e = e}) = end {e = e}
embedᶜᶠ (output l m p) = output l m (embedᶜᶠ p)
embedᶜᶠ (input l p) = input l λ m → embedᶜᶠ (p m)

mixᶜᶠ : ∀ {Δ Δ₀ Δ₁} (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ])
         (p : ⊢ᶜᶠ Δ₀)
         (q : ⊢ᶜᶠ Δ₁)
         -------------
           → ⊢ᶜᶠ Δ
mixᶜᶠ Δₛ end q = tr ⊢ᶜᶠ_ (Zip-identity  Δₛ) q
mixᶜᶠ Δₛ (output l m p) q
  = output (Zip-com∈₀ Δₛ l) m (mixᶜᶠ (Zip-≔₀ l Δₛ) p q)
mixᶜᶠ Δₛ (input l p) q
  = input (Zip-com∈₀ Δₛ l) λ m → mixᶜᶠ (Zip-≔₀ l Δₛ) (p m) q

cutᶜᶠ : ∀ {Δ Δ₀ Δ₁}
         (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ]) d P
         (p : ⊢ᶜᶠ (Δ₀ , d ↦ dual P))
         (q : ⊢ᶜᶠ (Δ₁ , d ↦ P))
         ---------------------------
           → ⊢ᶜᶠ (Δ , d ↦ end)

cutᶜᶠ Δₛ d (recv P) (output here m p) (input here q) = cutᶜᶠ Δₛ d (P m) p (q m)
cutᶜᶠ Δₛ d (send P) (input here p) (output here m q) = cutᶜᶠ Δₛ d (P m) (p m) q

cutᶜᶠ Δₛ d P (output (there l) m p) q
  = output (there (Zip-com∈₀ Δₛ l)) m (cutᶜᶠ (Zip-≔₀ l Δₛ) d _ p q)
cutᶜᶠ Δₛ d P (input (there l) p) q
  = input (there (Zip-com∈₀ Δₛ l)) λ m → cutᶜᶠ (Zip-≔₀ l Δₛ) d _ (p m) q
cutᶜᶠ Δₛ d P p (output (there l) m q)
  = output (there (Zip-com∈₁ Δₛ l)) m (cutᶜᶠ (Zip-≔₁ l Δₛ) d _ p q)
cutᶜᶠ Δₛ d P p (input (there l) q)
  = input (there (Zip-com∈₁ Δₛ l)) λ m → cutᶜᶠ (Zip-≔₁ l Δₛ) d _ p (q m)

cutᶜᶠ Δₛ d end p q = mixᶜᶠ (Δₛ , d ↦₀ end) p q
cutᶜᶠ _ _ (com _ _) (end {e = _ , ()}) _
cutᶜᶠ _ _ (com _ _) _ (end {e = _ , ()})

end-lastᶜᶠ : ∀ {Δ d}
              (p : ⊢ᶜᶠ (Δ , d ↦ end))
              -----------------------
                → ⊢ᶜᶠ Δ
end-lastᶜᶠ (end {e = e , _}) = end {e = e}
end-lastᶜᶠ (output (there l) m p) = output l m (end-lastᶜᶠ p)
end-lastᶜᶠ (input (there l) p) = input l λ m → end-lastᶜᶠ (p m)

wk-lastᶜᶠ : ∀ {Δ d}
             (p : ⊢ᶜᶠ Δ)
             -----------------------
               → ⊢ᶜᶠ (Δ , d ↦ end)
wk-lastᶜᶠ end = end {e = … , _}
wk-lastᶜᶠ (output l m p) = output (there l) m (wk-lastᶜᶠ p)
wk-lastᶜᶠ (input l p) = input (there l) λ m → wk-lastᶜᶠ (p m)

wk-,,ᶜᶠ : ∀ {Δ₀ Δ₁} → ⊢ᶜᶠ Δ₀ → EndedEnv Δ₁ → ⊢ᶜᶠ Δ₀ ,, Δ₁
wk-,,ᶜᶠ {Δ₁ = ε} p E = p
wk-,,ᶜᶠ {Δ₁ = Δ₁ , d ↦ P} p (E , e) rewrite Ended-≡end e
  = wk-lastᶜᶠ (wk-,,ᶜᶠ p E)

module _ {d P Δ₀} where
  pre-wk-∈ : ∀ {Δ₁} → d ↦ P ∈ Δ₁ → d ↦ P ∈ (Δ₀ ,, Δ₁)
  pre-wk-∈ here = here
  pre-wk-∈ (there l) = there (pre-wk-∈ l)

{-
pre-wkᶜᶠ : ∀ {Δ₀ Δ₁} → EndedEnv Δ₀ → ⊢ᶜᶠ Δ₁ → ⊢ᶜᶠ Δ₀ ,, Δ₁
pre-wkᶜᶠ EΔ₀ end = end {e = {!!}}
pre-wkᶜᶠ {Δ₀} {Δ₁} EΔ₀ (output l m p) =
  output (pre-wk-∈ l) m (pre-wkᶜᶠ {Δ₀} {{!Δ₁!}} EΔ₀ {!!})
pre-wkᶜᶠ EΔ₀ (input l p) = {!!}
-}

fwd-mixᶜᶠ : ∀ {Δ c d} P → ⊢ᶜᶠ Δ → ⊢ᶜᶠ (Δ , c ↦ P , d ↦ dual P)
fwd-mixᶜᶠ end p = wk-lastᶜᶠ (wk-lastᶜᶠ p)
fwd-mixᶜᶠ (recv P) p = input (there here) λ m → output here m (fwd-mixᶜᶠ (P m) p)
fwd-mixᶜᶠ (send P) p = input here λ m → output (there here) m (fwd-mixᶜᶠ (P m) p)

fwdᶜᶠ : ∀ c d {P} → ⊢ᶜᶠ (ε , c ↦ P , d ↦ dual P)
fwdᶜᶠ _ _ {P} = fwd-mixᶜᶠ {ε} P end

ε,, : ∀ Δ → ε ,, Δ ≡ Δ
ε,, ε = refl
ε,, (Δ , d ↦ P) rewrite ε,, Δ = refl

postulate
 exchᶜᶠ :
  ∀ Δ₀ Δ₁ →
  (p : ⊢ᶜᶠ Δ₁ ,, Δ₀)
  → ⊢ᶜᶠ Δ₀ ,, Δ₁
  {-
exchᶜᶠ ε Δ₁ p rewrite ε,, Δ₁ = p
exchᶜᶠ Δ₀ ε p rewrite ε,, Δ₀ = p
exchᶜᶠ (Δ₀ , d ↦ P) (Δ₁ , d₁ ↦ P₁) end = {!!}
exchᶜᶠ (Δ₀ , d ↦ ._) (Δ₁ , d₁ ↦ P₁) (output here m p) = {!exchᶜᶠ!}
exchᶜᶠ (Δ₀ , d ↦ P) (Δ₁ , d₁ ↦ P₁) (output (there l) m p) = {!!}
exchᶜᶠ (Δ₀ , d ↦ P) (Δ₁ , d₁ ↦ P₁) (input l p) = {!!}
-}

pre-wkᶜᶠ : ∀ {Δ₀ Δ₁} → EndedEnv Δ₀ → ⊢ᶜᶠ Δ₁ → ⊢ᶜᶠ Δ₀ ,, Δ₁
pre-wkᶜᶠ {Δ₀} {Δ₁} E p = exchᶜᶠ Δ₀ Δ₁ (wk-,,ᶜᶠ p E)

end-of : Env → Env
end-of ε = ε
end-of (Δ , d ↦ P) = end-of Δ , d ↦ end

end-of-Ended : ∀ Δ → EndedEnv (end-of Δ)
end-of-Ended ε = _
end-of-Ended (Δ , d ↦ P) = end-of-Ended Δ , _

end-of-⋎ : ∀ Δ → [ Δ is Δ ⋎ end-of Δ ]
end-of-⋎ ε = ε
end-of-⋎ (Δ , d ↦ P) = end-of-⋎ Δ , d ↦₀ P

end-of-,,-⋎ : ∀ Δ₀ Δ₁ → [ Δ₀ ,, Δ₁ is Δ₀ ,, end-of Δ₁ ⋎ end-of Δ₀ ,, Δ₁ ]
end-of-,,-⋎ Δ₀ ε = end-of-⋎ Δ₀
end-of-,,-⋎ Δ₀ (Δ₁ , d ↦ P) = end-of-,,-⋎ Δ₀ Δ₁ , d ↦₁ P

,,-assoc : ∀ {Δ₀ Δ₁ Δ₂} → Δ₀ ,, (Δ₁ ,, Δ₂) ≡ (Δ₀ ,, Δ₁) ,, Δ₂
,,-assoc {Δ₂ = ε} = refl
,,-assoc {Δ₀} {Δ₁} {Δ₂ , d ↦ P} rewrite ,,-assoc {Δ₀} {Δ₁} {Δ₂} = refl

cut,,ᶜᶠ : ∀ {Δ₀ Δ₁} d P
            (p : ⊢ᶜᶠ (Δ₀ , d ↦ dual P))
            (q : ⊢ᶜᶠ (Δ₁ , d ↦ P))
           ---------------------------
              → ⊢ᶜᶠ Δ₀ ,, Δ₁
cut,,ᶜᶠ {Δ₀}{Δ₁} d P p q =
  end-lastᶜᶠ
    (cutᶜᶠ Δₛ d P
       (exchᶜᶠ (Δ₀ ,, end-of Δ₁) (ε , d ↦ dual P)
              (tr ⊢ᶜᶠ_ (! (,,-assoc {ε , d ↦ dual P} {Δ₀} {end-of Δ₁}))
                 (wk-,,ᶜᶠ {_} {end-of Δ₁}
                   (exchᶜᶠ (ε , d ↦ dual P) _ p) (end-of-Ended _))))
       (pre-wkᶜᶠ (end-of-Ended _) q))
  where Δₛ = end-of-,,-⋎ Δ₀ Δ₁

postulate
  !cut,,ᶜᶠ : ∀ {Δ₀ Δ₁} d P
            (p : ⊢ᶜᶠ (Δ₀ , d ↦ P))
            (q : ⊢ᶜᶠ (Δ₁ , d ↦ dual P))
           ---------------------------
              → ⊢ᶜᶠ Δ₀ ,, Δ₁
-- !cut,,ᶜᶠ {Δ₀}{Δ₁} d P p q = {!!}

-- only the last two are exchanged, some more has to be done
exch-lastᶜᶠ :
  ∀ {Δ c d P Q} →
  (p : ⊢ᶜᶠ Δ , c ↦ P , d ↦ Q)
  → ⊢ᶜᶠ Δ , d ↦ Q , c ↦ P
exch-lastᶜᶠ (end {e = (a , b) , c}) = end {e = (a , c) , b}
exch-lastᶜᶠ (output here m p) = output (there here) m (exch-lastᶜᶠ p)
exch-lastᶜᶠ (output (there here) m p) = output here m (exch-lastᶜᶠ p)
exch-lastᶜᶠ (output (there (there l)) m p) = output (there (there l)) m (exch-lastᶜᶠ p)
exch-lastᶜᶠ (input here p) = input (there here) λ m → exch-lastᶜᶠ (p m)
exch-lastᶜᶠ (input (there here) p) = input here λ m → exch-lastᶜᶠ (p m)
exch-lastᶜᶠ (input (there (there l)) p) = input (there (there l)) λ m → exch-lastᶜᶠ (p  m)

{-
data Relabel : Env → Env → Set where
  ε : Relabel ε ε
  _,_↦_ : ∀ {Δ₀ Δ₁ c d P} → Relabel Δ₀ Δ₁ → Relabel (Δ₀ , c ↦ P) (Δ₁ , d ↦ P)

module _ where
    rebalel-∈ : ∀ {Δ₀ Δ₁} → Relabel Δ₀ Δ₁
                  (l : d ↦ P ∈ Δ₀)
                    → ⊢ᶜᶠ Δ₁
    relabel : ∀ {Δ₀ Δ₁} → Relabel Δ₀ Δ₁
            (p : ⊢ᶜᶠ Δ₀)
              → ⊢ᶜᶠ Δ₁
    relabel end = {!end!}
    relabel (output l m p) = output {!l!} {!!} {!!}
    relabel (input l p) = {!!}

parᶜᶠ : ∀ {Δ c} P Q
        (p : ⊢ᶜᶠ (Δ , c ↦ P , c ↦ Q))
          → ⊢ᶜᶠ (Δ , c ↦ (P ⅋' Q))
-- TODO only one channel name!!!
-- TODO empty context
-- TODO try to match on 'p' first
broken-parᶜᶠ : ∀ {c d e} P Q
        (p : ⊢ᶜᶠ (ε , c ↦ P , d ↦ Q))
          → ⊢ᶜᶠ (ε , e ↦ (P ⅋' Q))
broken-parᶜᶠ end Q p = {!end-lastᶜᶠ (exch-lastᶜᶠ p)!}
broken-parᶜᶠ (com x P) end p = end-lastᶜᶠ {!p!}
broken-parᶜᶠ (com x P) (com y Q) (end {e = _ , ()})

broken-parᶜᶠ (com x P) (com .OUT Q) (output here m p)
  = output here R (output here m (broken-parᶜᶠ _ _ p))
broken-parᶜᶠ (com x P) (com .IN Q) (input here p)
  = output here R (input here λ m → broken-parᶜᶠ _ _ (p m))

broken-parᶜᶠ (com .OUT P) (com y Q) (output (there here) m p)
  = output here L (output here m (broken-parᶜᶠ _ _ p))
broken-parᶜᶠ (com .IN P) (com y Q) (input (there here) p)
  = output here L (input here λ m → broken-parᶜᶠ _ _ (p m))

broken-parᶜᶠ (com x P) (com y Q) (output (there (there ())) m p)
broken-parᶜᶠ (com x P) (com y Q) (input (there (there ())) p)
-}

module _ {c d cd} where
    bi-fwd : ∀ P Q → ⊢ᶜᶠ (ε , cd ↦ P ⊗ Q , c ↦ dual P , d ↦ dual Q)

    private
      module _ {M} {{_ : SER M}} {P : M → Proto} {Q} where
        goL : ∀ x → ⊢ᶜᶠ ε , cd ↦ com x (λ m → P m ⊗ Q)
                          , c  ↦ dual (com x P)
                          , d  ↦ dual Q

        goL IN  = input (there (there here)) λ m → output (there here) m (bi-fwd _ _)
        goL OUT = input (there here) λ m → output (there (there here)) m (bi-fwd _ _)

        goR : ∀ x → ⊢ᶜᶠ ε , cd ↦ com x (λ m → Q ⊗ P m)
                          , c  ↦ dual Q
                          , d  ↦ dual (com x P)
        goR IN  = input (there (there here)) λ m → output here m (bi-fwd _ _)
        goR OUT = input here λ m → output (there (there here)) m (bi-fwd _ _)

    bi-fwd end Q = exch-lastᶜᶠ (wk-lastᶜᶠ (fwdᶜᶠ _ _))
    bi-fwd (com x P) end = wk-lastᶜᶠ (fwdᶜᶠ _ _)
    bi-fwd (com x P) (com y Q) = input (there (there here)) [L: goL x ,R: goR y ]

    module _ {Δ₀ Δ₁ P Q} where
        ⊗ᶜᶠ : (p : ⊢ᶜᶠ (Δ₀ , c ↦ P))
             (q : ⊢ᶜᶠ (Δ₁ , d ↦ Q))
             ----------------------------------
               → ⊢ᶜᶠ (Δ₀ ,, Δ₁ , cd ↦ (P ⊗ Q))
        ⊗ᶜᶠ p q = !cut,,ᶜᶠ _ _ p (!cut,,ᶜᶠ _ _ q (bi-fwd P Q))

  {-
exchᶜᶠ :
  ∀ {Δ c d P Q} →
  (l : c ↦ P ∈ Δ)
  (p : ⊢ᶜᶠ Δ , d ↦ Q)
  → ⊢ᶜᶠ Δ [ l ≔ d ↦ Q ] , c ↦ P
exchᶜᶠ here p = exch-lastᶜᶠ p
exchᶜᶠ (there l) p = {!!}
-}

{-
rotᶜᶠ : ∀ Δ {c P} →
         (p : ⊢ᶜᶠ Δ , c ↦ P)
      → ⊢ᶜᶠ ε , c ↦ P ,, Δ
rotᶜᶠ ε p = p
rotᶜᶠ (Δ , d ↦ P) p = {!rotᶜᶠ Δ p!}

exchᶜᶠ :
  ∀ {Δ₀} Δ₁ {c d P Q} →
  (p : ⊢ᶜᶠ Δ₀ , c ↦ P , d ↦ Q ,, Δ₁)
  → ⊢ᶜᶠ Δ₀ , d ↦ Q , c ↦ P ,, Δ₁
exchᶜᶠ ε p = exch-lastᶜᶠ p
exchᶜᶠ (Δ₁ , d ↦ P)  (end e) = end {!!}
exchᶜᶠ (Δ₁ , d₁ ↦ ._) (output here m p) = output here m ({!exchᶜᶠ Δ₁ p!})
exchᶜᶠ (Δ₁ , d ↦ P)  (output (there l) m p) = {!!}
exchᶜᶠ (Δ₁ , d ↦ P)  (input l p) = {!!}
-}

_⊆_ : (Δ₀ Δ₁ : Env) → Set₁
_⊇_ : (Δ₀ Δ₁ : Env) → Set₁

Δ₀ ⊆ Δ₁ = ∀ {d P} → d ↦ P ∈ Δ₀ → d ↦ P ∈ Δ₁
Δ₀ ⊇ Δ₁ = Δ₁ ⊆ Δ₀

get-put : ∀ {d P Δ c Q} →
        (l : d ↦ P ∈ Δ) → c ↦ Q ∈ (Δ [ l ≔ c ↦ Q ])
get-put here = here
get-put (there l) = there (get-put l)

{-
⊆_[_≔_↦_] : ∀ {Δ₀ Δ₁} (f : Δ₀ ⊆ Δ₁)
               {d P} (l : d ↦ P ∈ Δ₀) (c : URI) (Q : Proto)
             → (Δ₀ [ l ≔ c ↦ Q ]) ⊆ (Δ₁ [ f l ≔ c ↦ Q ])
⊆ f [ l ≔ c ↦ Q ] {d'} {P'} l' = {!!}

(l : d ↦ P ∈ Δ)
→ Δ [ l ≔ ]

record _≈_ (Δ₀ Δ₁ : Env) : Set₁ where
  constructor _,_
  field
    ≈⊆ : Δ₀ ⊆ Δ₁
    ≈⊇ : Δ₀ ⊇ Δ₁
open _≈_ public

≈_[_≔_↦_] : ∀ {Δ₀ Δ₁} (Δₑ : Δ₀ ≈ Δ₁)
               {d P} (l : d ↦ P ∈ Δ₀) (c : URI) (Q : Proto)
             → (Δ₀ [ l ≔ c ↦ Q ]) ≈ (Δ₁ [ ≈⊆ Δₑ l ≔ m ])
≈ Δₑ [ here ≔ m ] = {!!}
≈ Δₑ [ there l ≔ m ] = {!!}

{-(λ l' → {!≈⊆ Δₑ!}) , from
  where
    from : ∀ {Δ₀ Δ₁ d io M} {P : M → Proto} {ser : SER M}
             {Δₑ : Δ₀ ≈ Δ₁} {l : d ↦ com io P ∈ Δ₀} {m : M} {d₁} {P₁} →
           d₁ ↦ P₁ ∈ (Δ₁ [ ≈⊆ Δₑ l ≔ m ]) → d₁ ↦ P₁ ∈ (Δ₀ [ l ≔ m ])
    from = {!!}

≈ᶜᶠ : ∀ {Δ₀ Δ₁}
       (Δₑ : Δ₀ ≈ Δ₁)
       (p : ⊢ᶜᶠ Δ₀)
       -----------
         → ⊢ᶜᶠ Δ₁
≈ᶜᶠ Δₑ (end {e = e}) = end {e = {!!}}
≈ᶜᶠ Δₑ (output l m p) = output (≈⊆ Δₑ l) m (≈ᶜᶠ (≈ Δₑ [ l ≔ m ]) p)
≈ᶜᶠ Δₑ (input l p) = {!!}
-}
-}

cut-elim : ∀ {Δ} (p : ⊢ Δ)
                 ------------
                   → ⊢ᶜᶠ Δ
cut-elim (end {e = e}) = end {e = e}
cut-elim (output l m p) = output l m (cut-elim p)
cut-elim (input l p) = input l (λ m → cut-elim (p m))
cut-elim (mix Δₛ p q) = mixᶜᶠ Δₛ (cut-elim p) (cut-elim q)
cut-elim (cut Δₛ {P} {d} p q) = end-lastᶜᶠ (cutᶜᶠ Δₛ d P (cut-elim p) (cut-elim q))
cut-elim (end-last p) = end-lastᶜᶠ (cut-elim p)
cut-elim (wk-last p) = wk-lastᶜᶠ (cut-elim p)
cut-elim (fwd c d) = fwdᶜᶠ c d
cut-elim (exch-last p) = exch-lastᶜᶠ (cut-elim p)

{-

start : ∀ {Δ} P
       → ⊢ [ clientURI ↦ dual P ]
       → (∀ d → ⊢ (Δ , d ↦ P))
       → ⊢ Δ
start P p q = cut {!!} (... p) (q {!!})
-}

⊢ᶜᶠ→⟦⟧ : ∀ {P d} → ⊢ᶜᶠ [ d ↦ P ] → ⟦ P ⟧
⊢ᶜᶠ→⟦⟧ {end} end = _
⊢ᶜᶠ→⟦⟧ {com x P} (end {e = _ , ()})
⊢ᶜᶠ→⟦⟧ (output here m der) = m , ⊢ᶜᶠ→⟦⟧ der
⊢ᶜᶠ→⟦⟧ (output (there ()) m der)
⊢ᶜᶠ→⟦⟧ (input here x₁) m = ⊢ᶜᶠ→⟦⟧ (x₁ m)
⊢ᶜᶠ→⟦⟧ (input (there ()) x₁)

Satisfy : ∀ {p d} P → (R : ⟦ log P ⟧ → Set p) → ⊢ [ d ↦ P ] → Set p
Satisfy P Rel d = (d' : ⟦ dual P ⟧) → Rel (telecom P (⊢ᶜᶠ→⟦⟧ (cut-elim d)) d')

⟦⟧→⊢ᶜᶠ : ∀ {P d} → ⟦ P ⟧ → ⊢ᶜᶠ [ d ↦ P ]
⟦⟧→⊢ᶜᶠ {end} p = end
⟦⟧→⊢ᶜᶠ {recv P} p = input here (λ m → ⟦⟧→⊢ᶜᶠ (p m))
⟦⟧→⊢ᶜᶠ {send P} (m , p) = output here m (⟦⟧→⊢ᶜᶠ p)

⟦⟧→⊢ : ∀ {P d} → ⟦ P ⟧ → ⊢ [ d ↦ P ]
⟦⟧→⊢ {end} p = end
⟦⟧→⊢ {recv P} p = input here (λ m → ⟦⟧→⊢ (p m))
⟦⟧→⊢ {send P} (m , p) = output here m (⟦⟧→⊢ p)

{-
⊢toProc : ∀ {Δ} → ⊢ Δ → JSProc
⊢toProc end = end
⊢toProc (output {d = d} l m prg) = output d (serialize m) (⊢toProc prg)
⊢toProc (input {d = d} l prg) = input d ([succeed: (λ m → ⊢toProc (prg m)) ,fail: error ] ∘ parse)
⊢toProc (start P prg x) = start (⊢toProc prg) (λ d → ⊢toProc (x d))

⊢toProc-WT : ∀ {Δ} (der : ⊢ Δ) → Δ ⊢ ⊢toProc der
⊢toProc-WT (end {x}) = end {_} {x}
⊢toProc-WT (output {{x}} l m der) = output l (sym (rinv m)) (⊢toProc-WT der)
⊢toProc-WT (input {{x}} l x₁) = input l λ s m x →
  subst (λ X → _ [ l ≔ m ] ⊢ [succeed: (⊢toProc ∘ x₁) ,fail: error ] X) x (⊢toProc-WT (x₁ m))
⊢toProc-WT (start P der x) = start P (⊢toProc-WT der) (λ d → ⊢toProc-WT (x d))
-}

⟦_⟧E : Env → Set
⟦ ε ⟧E = 𝟙
⟦ Δ , d ↦ P ⟧E = ⟦ Δ ⟧E × ⟦ P ⟧

mapEnv : (Proto → Proto) → Env → Env
mapEnv f ε = ε
mapEnv f (Δ , d ↦ P) = mapEnv f Δ , d ↦ f P

mapEnv-all : ∀ {P Q : URI → Proto → Set}{Δ}{f : Proto → Proto}
  → (∀ d x → P d x → Q d (f x))
  → AllEnv P Δ → AllEnv Q (mapEnv f Δ)
mapEnv-all {Δ = ε} f₁ ∀Δ = ∀Δ
mapEnv-all {Δ = Δ , d ↦ P₁} f₁ (∀Δ , P) = (mapEnv-all f₁ ∀Δ) , f₁ d P₁ P

mapEnv-Ended : ∀ {f : Proto → Proto}{Δ} → Ended (f end)
  → AllEnv (λ _ → Ended) Δ → AllEnv (λ _ → Ended) (mapEnv f Δ)
mapEnv-Ended eq = mapEnv-all (λ { d end _ → eq ; d (send P) () ; d (recv P) () })

mapEnv-∈ : ∀ {d P f Δ} → d ↦ P ∈ Δ → d ↦ f P ∈ mapEnv f Δ
mapEnv-∈ here = here
mapEnv-∈ (there der) = there (mapEnv-∈ der)

module _ {d c M cf}{m : M}{{_ : M ≃? SERIAL}}{p} where
  subst-lemma-one-point-four : ∀ {Δ}( l : d ↦ com c p ∈ Δ ) →
    let f = mapProto cf
    in (mapEnv f (Δ [ l ≔ m ])) ≡ (_[_≔_]{c = cf c} (mapEnv f Δ) (mapEnv-∈ l) m)
  subst-lemma-one-point-four here = refl
  subst-lemma-one-point-four (there {d' = d'}{P'} l) = ap (λ X → X , d' ↦ mapProto cf P') (subst-lemma-one-point-four l)

module _ {d P} where
  project : ∀ {Δ} → d ↦ P ∈ Δ → ⟦ Δ ⟧E → ⟦ P ⟧
  project here env = snd env
  project (there mem) env = project mem (fst env)

empty : ∀ {Δ} → AllEnv (λ _ → Ended) Δ → ⟦ Δ ⟧E
empty {ε} <> = _
empty {Δ , d ↦ end} (fst , <>) = empty fst , _
empty {Δ , d ↦ com x P} (fst , ())

noRecvInLog : ∀ {d M}{{_ : M ≃? SERIAL}}{P : M → _}{Δ} → d ↦ recv P ∈ mapEnv log Δ → 𝟘
noRecvInLog {Δ = ε} ()
noRecvInLog {Δ = Δ , d₁ ↦ end} (there l) = noRecvInLog l
noRecvInLog {Δ = Δ , d₁ ↦ com x₁ P₁} (there l) = noRecvInLog l

module _ {d M P}{{_ : M ≃? SERIAL}} where
  lookup : ∀ {Δ}(l : d ↦ send P ∈ Δ) → ⟦ Δ ⟧E → Σ M λ m → ⟦ Δ [ l ≔ m ] ⟧E
  lookup here (env , (m , p)) = m , (env , p)
  lookup (there l) (env , P') = let (m , env') = lookup l env in m , (env' , P')

  set : ∀ {Δ}(l : d ↦ recv P ∈ Δ) → ⟦ Δ ⟧E → (m : M) → ⟦ Δ [ l ≔ m ] ⟧E
  set here (env , f) m = env , f m
  set (there l) (env , P') m = set l env m , P'

  setΣ : ∀ {Δ}(l : d ↦ send P ∈ Δ) → (m : M) → ⟦ Δ [ l ≔ m ] ⟧E → ⟦ Δ ⟧E
  setΣ here m env = fst env , (m , snd env)
  setΣ (there l) m env = setΣ l m (fst env) , snd env

  {-
forgetConc : ∀ {Δ} → ⊢ᶜᶠ mapEnv log Δ → ⟦ mapEnv log Δ ⟧E
forgetConc (end e) = empty …
forgetConc {Δ} (output l m der) = setΣ l m (forgetConc {{!setΣ l m!}} der) -- (forgetConc der)
forgetConc (input l x₁) with noRecvInLog l
... | ()
-}

⊢telecom : ∀ {Δ} → ⊢ᶜᶠ Δ → ⟦ mapEnv dual Δ ⟧E → ⊢ mapEnv log Δ
⊢telecom end env = end {e = mapEnv-Ended _ …}
⊢telecom (output l m der) env = output (mapEnv-∈ l) m (subst (⊢_)
  (subst-lemma-one-point-four l) (⊢telecom der (subst ⟦_⟧E (sym (subst-lemma-one-point-four l)) (set (mapEnv-∈ l) env m))))
⊢telecom (input l x₁) env = let (m , env') = lookup (mapEnv-∈ l) env
                                hyp = ⊢telecom (x₁ m) (subst (⟦_⟧E) (sym (subst-lemma-one-point-four l)) env')
                             in output (mapEnv-∈ l) m
                             (subst (⊢_) (subst-lemma-one-point-four l) hyp)

-- old version
{-
cutᶜᶠ : ∀ {Δ d P} → ⟦ dual P ⟧ → ⊢ᶜᶠ Δ , d ↦ P → ⊢ᶜᶠ Δ
cutᶜᶠ D (end {allEnded = ΔE , PE }) = end {allEnded = ΔE}
cutᶜᶠ D (output here m E) = cutᶜᶠ (D m) E
cutᶜᶠ D (output (there l) m E) = output l m (cutᶜᶠ D E)
cutᶜᶠ (m , D) (input here x₁) = cutᶜᶠ D (x₁ m)
cutᶜᶠ D (input (there l) x₁) = input l (λ m → cutᶜᶠ D (x₁ m))

cut : ∀ {Δ Δ' Γ Γ' d P} → ⊢ Δ , clientURI ↦ dual P +++ Δ' → ⊢ Γ , d ↦ P +++ Γ' → ⊢ (Δ +++ Δ') +++ (Γ +++ Γ')
cut D E = {!!}
-}

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

open import proto
open import Types
open import prelude
open import uri

module Terms where

infix 2 ⊢ˢ_ ⊢_ ⊢ᶜᶠ_

data ⊢_ : (Δ : Env) → Set₁ where
  end : ∀{Δ}{e : EndedEnv Δ}
       ------------------
      → ⊢ Δ

  output : ∀ {Δ d M P}{{_ : SER M}}
             (l : d ↦ send P ∈ Δ)(m : M)
             (p : ⊢ Δ [ l ≔ m ])
             -------------------
               → ⊢ Δ

  input : ∀ {Δ d M}{P : M → _}{{_ : SER M}}
            (l : d ↦ recv P ∈ Δ)
            (p : ∀ m → ⊢ Δ [ l ≔ m ])
                 ----------------------
                     → ⊢ Δ

  mix : ∀ {Δ Δ₀ Δ₁} (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ])
          (p : ⊢ Δ₀) (q : ⊢ Δ₁)
          --------------------
        → ⊢ Δ

  cut : ∀ {Δ Δ₀ Δ₁} (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ]) {P d}
          (p : ⊢ (Δ₀ , d ↦ dual P))
          (q : ⊢ (Δ₁ , d ↦ P))
          ---------------------
        → ⊢ Δ

  fwd : ∀ c d {P} → ⊢ (ε , c ↦ P , d ↦ dual P)

  exch-last :
      ∀ {Δ c d P Q} →
      (p : ⊢ Δ , c ↦ P , d ↦ Q)
      → ⊢ Δ , d ↦ Q , c ↦ P

  wk-last : ∀ {Δ d}
              (p : ⊢ Δ)
              -----------------------
                → ⊢ (Δ , d ↦ end)

  end-last : ∀ {Δ d}
               (p : ⊢ (Δ , d ↦ end))
               ----------------------
                 → ⊢ Δ

data ⊢ᶜᶠ_ (Δ : Env) : Set₁ where
  end : {e : EndedEnv Δ} → ⊢ᶜᶠ Δ

  output : ∀ {d M P}{{_ : SER M}}
            (l : d ↦ send P ∈ Δ) → (m : M)
            (p : ⊢ᶜᶠ Δ [ l ≔ m ])
            --------------------
              → ⊢ᶜᶠ Δ

  input : ∀ {d M}{P : M → _}{{_ : SER M}}
            (l : d ↦ recv P ∈ Δ)
            (p : ∀ m → ⊢ᶜᶠ Δ [ l ≔ m ])
            ----------------------------
                     → ⊢ᶜᶠ Δ

-- The Δ for the server contains the view point of the clients
-- The point is that the meaning of _,_ in Δ is ⊗ while it
-- is ⅋ in ⊢ᶜᶠ
record ⊢ˢ_ (Δ : Env) : Set₁ where
  coinductive
  field
    server-output :
      ∀ {d M}{{_ : SER M}}{P : M → Proto}
        (l : d ↦ recv P ∈ Δ) →
        Σ M λ m → ⊢ˢ Δ [ l ≔ m ]
    server-input :
      ∀ {d M}{{_ : SER M}}{P : M → Proto}
        (l : d ↦ send P ∈ Δ)
        (m : M) → ⊢ˢ Δ [ l ≔ m ]
open ⊢ˢ_ public

-- This is just to confirm that we have enough cases
telecom' : ∀ {Δ} → ⊢ᶜᶠ Δ → ⊢ˢ Δ → 𝟙
telecom' end q = _
telecom' (output l m p) q
  = telecom' p (server-input q l m)
telecom' (input l p) q
  = case server-output q l of λ { (m , s) →
      telecom' (p m) s }

embedᶜᶠ : ∀ {Δ} → ⊢ᶜᶠ Δ → ⊢ Δ
embedᶜᶠ (end {e = e}) = end {e = e}
embedᶜᶠ (output l m p) = output l m (embedᶜᶠ p)
embedᶜᶠ (input l p) = input l λ m → embedᶜᶠ (p m)

mixᶜᶠ : ∀ {Δ Δ₀ Δ₁} (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ])
         (p : ⊢ᶜᶠ Δ₀)
         (q : ⊢ᶜᶠ Δ₁)
         -------------
           → ⊢ᶜᶠ Δ
mixᶜᶠ Δₛ end q = tr ⊢ᶜᶠ_ (Zip-identity  Δₛ) q
mixᶜᶠ Δₛ (output l m p) q
  = output (Zip-com∈₀ Δₛ l) m (mixᶜᶠ (Zip-≔₀ l Δₛ) p q)
mixᶜᶠ Δₛ (input l p) q
  = input (Zip-com∈₀ Δₛ l) λ m → mixᶜᶠ (Zip-≔₀ l Δₛ) (p m) q

cutᶜᶠ : ∀ {Δ Δ₀ Δ₁}
         (Δₛ : [ Δ is Δ₀ ⋎ Δ₁ ]) d P
         (p : ⊢ᶜᶠ (Δ₀ , d ↦ dual P))
         (q : ⊢ᶜᶠ (Δ₁ , d ↦ P))
         ---------------------------
           → ⊢ᶜᶠ (Δ , d ↦ end)
cutᶜᶠ Δₛ d end p q = mixᶜᶠ (Δₛ , d ↦₀ end) p q

cutᶜᶠ Δₛ d (recv P) (output here m p) (input here q) = cutᶜᶠ Δₛ d (P m) p (q m)
cutᶜᶠ Δₛ d (send P) (input here p) (output here m q) = cutᶜᶠ Δₛ d (P m) (p m) q

cutᶜᶠ Δₛ d (send P) (output (there l) m p) q
  = output (there (Zip-com∈₀ Δₛ l)) m (cutᶜᶠ (Zip-≔₀ l Δₛ) d _ p q)
cutᶜᶠ Δₛ d (recv P) (output (there l) m p) q
  = output (there (Zip-com∈₀ Δₛ l)) m (cutᶜᶠ (Zip-≔₀ l Δₛ) d _ p q)
cutᶜᶠ Δₛ d (recv P) (input (there l) p) q
  = input (there (Zip-com∈₀ Δₛ l)) λ m → cutᶜᶠ (Zip-≔₀ l Δₛ) d _ (p m) q
cutᶜᶠ Δₛ d (send P) (input (there l) p) q
  = input (there (Zip-com∈₀ Δₛ l)) λ m → cutᶜᶠ (Zip-≔₀ l Δₛ) d _ (p m) q
cutᶜᶠ Δₛ d (recv P) p (output (there l) m q)
  = output (there (Zip-com∈₁ Δₛ l)) m (cutᶜᶠ (Zip-≔₁ l Δₛ) d _ p q)
cutᶜᶠ Δₛ d (send P) p (output (there l) m q)
  = output (there (Zip-com∈₁ Δₛ l)) m (cutᶜᶠ (Zip-≔₁ l Δₛ) d _ p q)
cutᶜᶠ Δₛ d (send P) p (input (there l) q)
  = input (there (Zip-com∈₁ Δₛ l)) λ m → cutᶜᶠ (Zip-≔₁ l Δₛ) d _ p (q m)
cutᶜᶠ Δₛ d (recv P) p (input (there l) q)
  = input (there (Zip-com∈₁ Δₛ l)) λ m → cutᶜᶠ (Zip-≔₁ l Δₛ) d _ p (q m)

cutᶜᶠ _ _ (com _ _) (end {e = _ , ()}) _
cutᶜᶠ _ _ (com _ _) _ (end {e = _ , ()})

end-lastᶜᶠ : ∀ {Δ d}
              (p : ⊢ᶜᶠ (Δ , d ↦ end))
              -----------------------
                → ⊢ᶜᶠ Δ
end-lastᶜᶠ (end {e = e , _}) = end {e = e}
end-lastᶜᶠ (output (there l) m p) = output l m (end-lastᶜᶠ p)
end-lastᶜᶠ (input (there l) p) = input l λ m → end-lastᶜᶠ (p m)

wk-lastᶜᶠ : ∀ {Δ d}
             (p : ⊢ᶜᶠ Δ)
             -----------------------
               → ⊢ᶜᶠ (Δ , d ↦ end)
wk-lastᶜᶠ end = end {e = … , _}
wk-lastᶜᶠ (output l m p) = output (there l) m (wk-lastᶜᶠ p)
wk-lastᶜᶠ (input l p) = input (there l) λ m → wk-lastᶜᶠ (p m)

wk-,,ᶜᶠ : ∀ {Δ₀ Δ₁} → ⊢ᶜᶠ Δ₀ → EndedEnv Δ₁ → ⊢ᶜᶠ Δ₀ ,, Δ₁
wk-,,ᶜᶠ {Δ₁ = ε} p E = p
wk-,,ᶜᶠ {Δ₁ = Δ₁ , d ↦ P} p (E , e) rewrite Ended-≡end e
  = wk-lastᶜᶠ (wk-,,ᶜᶠ p E)

module _ {d P Δ₀} where
  pre-wk-∈ : ∀ {Δ₁} → d ↦ P ∈ Δ₁ → d ↦ P ∈ (Δ₀ ,, Δ₁)
  pre-wk-∈ here = here
  pre-wk-∈ (there l) = there (pre-wk-∈ l)

{-
pre-wkᶜᶠ : ∀ {Δ₀ Δ₁} → EndedEnv Δ₀ → ⊢ᶜᶠ Δ₁ → ⊢ᶜᶠ Δ₀ ,, Δ₁
pre-wkᶜᶠ EΔ₀ end = end {e = {!!}}
pre-wkᶜᶠ {Δ₀} {Δ₁} EΔ₀ (output l m p) =
  output (pre-wk-∈ l) m (pre-wkᶜᶠ {Δ₀} {{!Δ₁!}} EΔ₀ {!!})
pre-wkᶜᶠ EΔ₀ (input l p) = {!!}
-}

fwd-mixᶜᶠ : ∀ {Δ c d} P → ⊢ᶜᶠ Δ → ⊢ᶜᶠ (Δ , c ↦ P , d ↦ dual P)
fwd-mixᶜᶠ end p = wk-lastᶜᶠ (wk-lastᶜᶠ p)
fwd-mixᶜᶠ (recv P) p = input (there here) λ m → output here m (fwd-mixᶜᶠ (P m) p)
fwd-mixᶜᶠ (send P) p = input here λ m → output (there here) m (fwd-mixᶜᶠ (P m) p)

fwdᶜᶠ : ∀ c d {P} → ⊢ᶜᶠ (ε , c ↦ P , d ↦ dual P)
fwdᶜᶠ _ _ {P} = fwd-mixᶜᶠ {ε} P end

ε,, : ∀ Δ → ε ,, Δ ≡ Δ
ε,, ε = refl
ε,, (Δ , d ↦ P) rewrite ε,, Δ = refl

postulate
 exchᶜᶠ :
  ∀ Δ₀ Δ₁ →
  (p : ⊢ᶜᶠ Δ₁ ,, Δ₀)
  → ⊢ᶜᶠ Δ₀ ,, Δ₁
  {-
exchᶜᶠ ε Δ₁ p rewrite ε,, Δ₁ = p
exchᶜᶠ Δ₀ ε p rewrite ε,, Δ₀ = p
exchᶜᶠ (Δ₀ , d ↦ P) (Δ₁ , d₁ ↦ P₁) end = {!!}
exchᶜᶠ (Δ₀ , d ↦ ._) (Δ₁ , d₁ ↦ P₁) (output here m p) = {!exchᶜᶠ!}
exchᶜᶠ (Δ₀ , d ↦ P) (Δ₁ , d₁ ↦ P₁) (output (there l) m p) = {!!}
exchᶜᶠ (Δ₀ , d ↦ P) (Δ₁ , d₁ ↦ P₁) (input l p) = {!!}
-}

pre-wkᶜᶠ : ∀ {Δ₀ Δ₁} → EndedEnv Δ₀ → ⊢ᶜᶠ Δ₁ → ⊢ᶜᶠ Δ₀ ,, Δ₁
pre-wkᶜᶠ {Δ₀} {Δ₁} E p = exchᶜᶠ Δ₀ Δ₁ (wk-,,ᶜᶠ p E)

end-of : Env → Env
end-of ε = ε
end-of (Δ , d ↦ P) = end-of Δ , d ↦ end

end-of-Ended : ∀ Δ → EndedEnv (end-of Δ)
end-of-Ended ε = _
end-of-Ended (Δ , d ↦ P) = end-of-Ended Δ , _

end-of-⋎ : ∀ Δ → [ Δ is Δ ⋎ end-of Δ ]
end-of-⋎ ε = ε
end-of-⋎ (Δ , d ↦ P) = end-of-⋎ Δ , d ↦₀ P

end-of-,,-⋎ : ∀ Δ₀ Δ₁ → [ Δ₀ ,, Δ₁ is Δ₀ ,, end-of Δ₁ ⋎ end-of Δ₀ ,, Δ₁ ]
end-of-,,-⋎ Δ₀ ε = end-of-⋎ Δ₀
end-of-,,-⋎ Δ₀ (Δ₁ , d ↦ P) = end-of-,,-⋎ Δ₀ Δ₁ , d ↦₁ P

,,-assoc : ∀ {Δ₀ Δ₁ Δ₂} → Δ₀ ,, (Δ₁ ,, Δ₂) ≡ (Δ₀ ,, Δ₁) ,, Δ₂
,,-assoc {Δ₂ = ε} = refl
,,-assoc {Δ₀} {Δ₁} {Δ₂ , d ↦ P} rewrite ,,-assoc {Δ₀} {Δ₁} {Δ₂} = refl

cut,,ᶜᶠ : ∀ {Δ₀ Δ₁} d P
            (p : ⊢ᶜᶠ (Δ₀ , d ↦ dual P))
            (q : ⊢ᶜᶠ (Δ₁ , d ↦ P))
           ---------------------------
              → ⊢ᶜᶠ Δ₀ ,, Δ₁
cut,,ᶜᶠ {Δ₀}{Δ₁} d P p q =
  end-lastᶜᶠ
    (cutᶜᶠ Δₛ d P
       (exchᶜᶠ (Δ₀ ,, end-of Δ₁) (ε , d ↦ dual P)
              (tr ⊢ᶜᶠ_ (! (,,-assoc {ε , d ↦ dual P} {Δ₀} {end-of Δ₁}))
                 (wk-,,ᶜᶠ
                   (exchᶜᶠ (ε , d ↦ dual P) _ p) (end-of-Ended _))))
       (pre-wkᶜᶠ (end-of-Ended _) q))
  where Δₛ = end-of-,,-⋎ Δ₀ Δ₁

postulate
  !cut,,ᶜᶠ : ∀ {Δ₀ Δ₁} d P
            (p : ⊢ᶜᶠ (Δ₀ , d ↦ P))
            (q : ⊢ᶜᶠ (Δ₁ , d ↦ dual P))
           ---------------------------
              → ⊢ᶜᶠ Δ₀ ,, Δ₁
-- !cut,,ᶜᶠ {Δ₀}{Δ₁} d P p q = {!!}

-- only the last two are exchanged, some more has to be done
exch-lastᶜᶠ :
  ∀ {Δ c d P Q} →
  (p : ⊢ᶜᶠ Δ , c ↦ P , d ↦ Q)
  → ⊢ᶜᶠ Δ , d ↦ Q , c ↦ P
exch-lastᶜᶠ (end {e = (a , b) , c}) = end {e = (a , c) , b}
exch-lastᶜᶠ (output here m p) = output (there here) m (exch-lastᶜᶠ p)
exch-lastᶜᶠ (output (there here) m p) = output here m (exch-lastᶜᶠ p)
exch-lastᶜᶠ (output (there (there l)) m p) = output (there (there l)) m (exch-lastᶜᶠ p)
exch-lastᶜᶠ (input here p) = input (there here) λ m → exch-lastᶜᶠ (p m)
exch-lastᶜᶠ (input (there here) p) = input here λ m → exch-lastᶜᶠ (p m)
exch-lastᶜᶠ (input (there (there l)) p) = input (there (there l)) λ m → exch-lastᶜᶠ (p  m)

{-
data Relabel : Env → Env → Set where
  ε : Relabel ε ε
  _,_↦_ : ∀ {Δ₀ Δ₁ c d P} → Relabel Δ₀ Δ₁ → Relabel (Δ₀ , c ↦ P) (Δ₁ , d ↦ P)

module _ where
    rebalel-∈ : ∀ {Δ₀ Δ₁} → Relabel Δ₀ Δ₁
                  (l : d ↦ P ∈ Δ₀)
                    → ⊢ᶜᶠ Δ₁
    relabel : ∀ {Δ₀ Δ₁} → Relabel Δ₀ Δ₁
            (p : ⊢ᶜᶠ Δ₀)
              → ⊢ᶜᶠ Δ₁
    relabel end = {!end!}
    relabel (output l m p) = output {!l!} {!!} {!!}
    relabel (input l p) = {!!}

parᶜᶠ : ∀ {Δ c} P Q
        (p : ⊢ᶜᶠ (Δ , c ↦ P , c ↦ Q))
          → ⊢ᶜᶠ (Δ , c ↦ (P ⅋' Q))
-- TODO only one channel name!!!
-- TODO empty context
-- TODO try to match on 'p' first
broken-parᶜᶠ : ∀ {c d e} P Q
        (p : ⊢ᶜᶠ (ε , c ↦ P , d ↦ Q))
          → ⊢ᶜᶠ (ε , e ↦ (P ⅋' Q))
broken-parᶜᶠ end Q p = {!end-lastᶜᶠ (exch-lastᶜᶠ p)!}
broken-parᶜᶠ (com x P) end p = end-lastᶜᶠ {!p!}
broken-parᶜᶠ (com x P) (com y Q) (end {e = _ , ()})

broken-parᶜᶠ (com x P) (com .OUT Q) (output here m p)
  = output here R (output here m (broken-parᶜᶠ _ _ p))
broken-parᶜᶠ (com x P) (com .IN Q) (input here p)
  = output here R (input here λ m → broken-parᶜᶠ _ _ (p m))

broken-parᶜᶠ (com .OUT P) (com y Q) (output (there here) m p)
  = output here L (output here m (broken-parᶜᶠ _ _ p))
broken-parᶜᶠ (com .IN P) (com y Q) (input (there here) p)
  = output here L (input here λ m → broken-parᶜᶠ _ _ (p m))

broken-parᶜᶠ (com x P) (com y Q) (output (there (there ())) m p)
broken-parᶜᶠ (com x P) (com y Q) (input (there (there ())) p)
-}

module _ {c d cd} where
    bi-fwd : ∀ P Q → ⊢ᶜᶠ (ε , cd ↦ P ⊗ Q , c ↦ dual P , d ↦ dual Q)

    private
      module _ {M} {{_ : SER M}} {P : M → Proto} {Q} where
        goL : ∀ x → ⊢ᶜᶠ ε , cd ↦ com x (λ m → P m ⊗ Q)
                          , c  ↦ dual (com x P)
                          , d  ↦ dual Q

        goL IN  = input (there (there here)) λ m → output (there here) m (bi-fwd _ _)
        goL OUT = input (there here) λ m → output (there (there here)) m (bi-fwd _ _)

        goR : ∀ x → ⊢ᶜᶠ ε , cd ↦ com x (λ m → Q ⊗ P m)
                          , c  ↦ dual Q
                          , d  ↦ dual (com x P)
        goR IN  = input (there (there here)) λ m → output here m (bi-fwd _ _)
        goR OUT = input here λ m → output (there (there here)) m (bi-fwd _ _)

    bi-fwd end Q = exch-lastᶜᶠ (wk-lastᶜᶠ (fwdᶜᶠ _ _))
    bi-fwd (com x P) end = wk-lastᶜᶠ (fwdᶜᶠ _ _)
    bi-fwd (com x P) (com y Q) = input (there (there here)) [L: goL x ,R: goR y ]

    module _ {Δ₀ Δ₁ P Q} where
        ⊗ᶜᶠ : (p : ⊢ᶜᶠ (Δ₀ , c ↦ P))
             (q : ⊢ᶜᶠ (Δ₁ , d ↦ Q))
             ----------------------------------
               → ⊢ᶜᶠ (Δ₀ ,, Δ₁ , cd ↦ (P ⊗ Q))
        ⊗ᶜᶠ p q = !cut,,ᶜᶠ _ _ p (!cut,,ᶜᶠ _ _ q (bi-fwd P Q))

  {-
exchᶜᶠ :
  ∀ {Δ c d P Q} →
  (l : c ↦ P ∈ Δ)
  (p : ⊢ᶜᶠ Δ , d ↦ Q)
  → ⊢ᶜᶠ Δ [ l ≔ d ↦ Q ] , c ↦ P
exchᶜᶠ here p = exch-lastᶜᶠ p
exchᶜᶠ (there l) p = {!!}
-}

{-
rotᶜᶠ : ∀ Δ {c P} →
         (p : ⊢ᶜᶠ Δ , c ↦ P)
      → ⊢ᶜᶠ ε , c ↦ P ,, Δ
rotᶜᶠ ε p = p
rotᶜᶠ (Δ , d ↦ P) p = {!rotᶜᶠ Δ p!}

exchᶜᶠ :
  ∀ {Δ₀} Δ₁ {c d P Q} →
  (p : ⊢ᶜᶠ Δ₀ , c ↦ P , d ↦ Q ,, Δ₁)
  → ⊢ᶜᶠ Δ₀ , d ↦ Q , c ↦ P ,, Δ₁
exchᶜᶠ ε p = exch-lastᶜᶠ p
exchᶜᶠ (Δ₁ , d ↦ P)  (end e) = end {!!}
exchᶜᶠ (Δ₁ , d₁ ↦ ._) (output here m p) = output here m ({!exchᶜᶠ Δ₁ p!})
exchᶜᶠ (Δ₁ , d ↦ P)  (output (there l) m p) = {!!}
exchᶜᶠ (Δ₁ , d ↦ P)  (input l p) = {!!}
-}

_⊆_ : (Δ₀ Δ₁ : Env) → Set₁
_⊇_ : (Δ₀ Δ₁ : Env) → Set₁

Δ₀ ⊆ Δ₁ = ∀ {d P} → d ↦ P ∈ Δ₀ → d ↦ P ∈ Δ₁
Δ₀ ⊇ Δ₁ = Δ₁ ⊆ Δ₀

get-put : ∀ {d P Δ c Q} →
        (l : d ↦ P ∈ Δ) → c ↦ Q ∈ (Δ [ l ≔ c ↦ Q ])
get-put here = here
get-put (there l) = there (get-put l)

{-
⊆_[_≔_↦_] : ∀ {Δ₀ Δ₁} (f : Δ₀ ⊆ Δ₁)
               {d P} (l : d ↦ P ∈ Δ₀) (c : URI) (Q : Proto)
             → (Δ₀ [ l ≔ c ↦ Q ]) ⊆ (Δ₁ [ f l ≔ c ↦ Q ])
⊆ f [ l ≔ c ↦ Q ] {d'} {P'} l' = {!!}

(l : d ↦ P ∈ Δ)
→ Δ [ l ≔ ]

record _≈_ (Δ₀ Δ₁ : Env) : Set₁ where
  constructor _,_
  field
    ≈⊆ : Δ₀ ⊆ Δ₁
    ≈⊇ : Δ₀ ⊇ Δ₁
open _≈_ public

≈_[_≔_↦_] : ∀ {Δ₀ Δ₁} (Δₑ : Δ₀ ≈ Δ₁)
               {d P} (l : d ↦ P ∈ Δ₀) (c : URI) (Q : Proto)
             → (Δ₀ [ l ≔ c ↦ Q ]) ≈ (Δ₁ [ ≈⊆ Δₑ l ≔ m ])
≈ Δₑ [ here ≔ m ] = {!!}
≈ Δₑ [ there l ≔ m ] = {!!}

{-(λ l' → {!≈⊆ Δₑ!}) , from
  where
    from : ∀ {Δ₀ Δ₁ d io M} {P : M → Proto} {ser : SER M}
             {Δₑ : Δ₀ ≈ Δ₁} {l : d ↦ com io P ∈ Δ₀} {m : M} {d₁} {P₁} →
           d₁ ↦ P₁ ∈ (Δ₁ [ ≈⊆ Δₑ l ≔ m ]) → d₁ ↦ P₁ ∈ (Δ₀ [ l ≔ m ])
    from = {!!}

≈ᶜᶠ : ∀ {Δ₀ Δ₁}
       (Δₑ : Δ₀ ≈ Δ₁)
       (p : ⊢ᶜᶠ Δ₀)
       -----------
         → ⊢ᶜᶠ Δ₁
≈ᶜᶠ Δₑ (end {e = e}) = end {e = {!!}}
≈ᶜᶠ Δₑ (output l m p) = output (≈⊆ Δₑ l) m (≈ᶜᶠ (≈ Δₑ [ l ≔ m ]) p)
≈ᶜᶠ Δₑ (input l p) = {!!}
-}
-}

cut-elim : ∀ {Δ} (p : ⊢ Δ)
                 ------------
                   → ⊢ᶜᶠ Δ
cut-elim (end {e = e}) = end {e = e}
cut-elim (output l m p) = output l m (cut-elim p)
cut-elim (input l p) = input l (λ m → cut-elim (p m))
cut-elim (mix Δₛ p q) = mixᶜᶠ Δₛ (cut-elim p) (cut-elim q)
cut-elim (cut Δₛ {P} {d} p q) = end-lastᶜᶠ (cutᶜᶠ Δₛ d P (cut-elim p) (cut-elim q))
cut-elim (end-last p) = end-lastᶜᶠ (cut-elim p)
cut-elim (wk-last p) = wk-lastᶜᶠ (cut-elim p)
cut-elim (fwd c d) = fwdᶜᶠ c d
cut-elim (exch-last p) = exch-lastᶜᶠ (cut-elim p)

{-

start : ∀ {Δ} P
       → ⊢ [ clientURI ↦ dual P ]
       → (∀ d → ⊢ (Δ , d ↦ P))
       → ⊢ Δ
start P p q = cut {!!} (... p) (q {!!})
-}

⊢ᶜᶠ→⟦⟧ : ∀ {P d} → ⊢ᶜᶠ [ d ↦ P ] → ⟦ P ⟧
⊢ᶜᶠ→⟦⟧ {end} end = _
⊢ᶜᶠ→⟦⟧ {com x P} (end {e = _ , ()})
⊢ᶜᶠ→⟦⟧ (output here m der) = m , ⊢ᶜᶠ→⟦⟧ der
⊢ᶜᶠ→⟦⟧ (output (there ()) m der)
⊢ᶜᶠ→⟦⟧ (input here x₁) m = ⊢ᶜᶠ→⟦⟧ (x₁ m)
⊢ᶜᶠ→⟦⟧ (input (there ()) x₁)

Satisfy : ∀ {p d} P → (R : ⟦ log P ⟧ → Set p) → ⊢ [ d ↦ P ] → Set p
Satisfy P Rel d = (d' : ⟦ dual P ⟧) → Rel (telecom P (⊢ᶜᶠ→⟦⟧ (cut-elim d)) d')

⟦⟧→⊢ᶜᶠ : ∀ {P d} → ⟦ P ⟧ → ⊢ᶜᶠ [ d ↦ P ]
⟦⟧→⊢ᶜᶠ {end} p = end
⟦⟧→⊢ᶜᶠ {recv P} p = input here (λ m → ⟦⟧→⊢ᶜᶠ (p m))
⟦⟧→⊢ᶜᶠ {send P} (m , p) = output here m (⟦⟧→⊢ᶜᶠ p)

⟦⟧→⊢ : ∀ {P d} → ⟦ P ⟧ → ⊢ [ d ↦ P ]
⟦⟧→⊢ {end} p = end
⟦⟧→⊢ {recv P} p = input here (λ m → ⟦⟧→⊢ (p m))
⟦⟧→⊢ {send P} (m , p) = output here m (⟦⟧→⊢ p)

{-
⊢toProc : ∀ {Δ} → ⊢ Δ → JSProc
⊢toProc end = end
⊢toProc (output {d = d} l m prg) = output d (serialize m) (⊢toProc prg)
⊢toProc (input {d = d} l prg) = input d ([succeed: (λ m → ⊢toProc (prg m)) ,fail: error ] ∘ parse)
⊢toProc (start P prg x) = start (⊢toProc prg) (λ d → ⊢toProc (x d))

⊢toProc-WT : ∀ {Δ} (der : ⊢ Δ) → Δ ⊢ ⊢toProc der
⊢toProc-WT (end {x}) = end {_} {x}
⊢toProc-WT (output {{x}} l m der) = output l (sym (rinv m)) (⊢toProc-WT der)
⊢toProc-WT (input {{x}} l x₁) = input l λ s m x →
  subst (λ X → _ [ l ≔ m ] ⊢ [succeed: (⊢toProc ∘ x₁) ,fail: error ] X) x (⊢toProc-WT (x₁ m))
⊢toProc-WT (start P der x) = start P (⊢toProc-WT der) (λ d → ⊢toProc-WT (x d))
-}

⟦_⟧E : Env → Set
⟦ ε ⟧E = 𝟙
⟦ Δ , d ↦ P ⟧E = ⟦ Δ ⟧E × ⟦ P ⟧

mapEnv : (Proto → Proto) → Env → Env
mapEnv f ε = ε
mapEnv f (Δ , d ↦ P) = mapEnv f Δ , d ↦ f P

mapEnv-all : ∀ {P Q : URI → Proto → Set}{Δ}{f : Proto → Proto}
  → (∀ d x → P d x → Q d (f x))
  → AllEnv P Δ → AllEnv Q (mapEnv f Δ)
mapEnv-all {Δ = ε} f₁ ∀Δ = ∀Δ
mapEnv-all {Δ = Δ , d ↦ P₁} f₁ (∀Δ , P) = (mapEnv-all f₁ ∀Δ) , f₁ d P₁ P

mapEnv-Ended : ∀ {f : Proto → Proto}{Δ} → Ended (f end)
  → AllEnv (λ _ → Ended) Δ → AllEnv (λ _ → Ended) (mapEnv f Δ)
mapEnv-Ended eq = mapEnv-all (λ { d end _ → eq ; d (send P) () ; d (recv P) () })

mapEnv-∈ : ∀ {d P f Δ} → d ↦ P ∈ Δ → d ↦ f P ∈ mapEnv f Δ
mapEnv-∈ here = here
mapEnv-∈ (there der) = there (mapEnv-∈ der)

module _ {d c M cf}{m : M}{{_ : M ≃? SERIAL}}{p} where
  subst-lemma-one-point-four : ∀ {Δ}( l : d ↦ com c p ∈ Δ ) →
    let f = mapProto cf
    in (mapEnv f (Δ [ l ≔ m ])) ≡ (_[_≔_]{c = cf c} (mapEnv f Δ) (mapEnv-∈ l) m)
  subst-lemma-one-point-four here = refl
  subst-lemma-one-point-four (there {d' = d'}{P'} l) = ap (λ X → X , d' ↦ mapProto cf P') (subst-lemma-one-point-four l)

module _ {d P} where
  project : ∀ {Δ} → d ↦ P ∈ Δ → ⟦ Δ ⟧E → ⟦ P ⟧
  project here env = snd env
  project (there mem) env = project mem (fst env)

empty : ∀ {Δ} → AllEnv (λ _ → Ended) Δ → ⟦ Δ ⟧E
empty {ε} <> = _
empty {Δ , d ↦ end} (fst , <>) = empty fst , _
empty {Δ , d ↦ com x P} (fst , ())

noRecvInLog : ∀ {d M}{{_ : M ≃? SERIAL}}{P : M → _}{Δ} → d ↦ recv P ∈ mapEnv log Δ → 𝟘
noRecvInLog {Δ = ε} ()
noRecvInLog {Δ = Δ , d₁ ↦ end} (there l) = noRecvInLog l
noRecvInLog {Δ = Δ , d₁ ↦ com x₁ P₁} (there l) = noRecvInLog l

module _ {d M P}{{_ : M ≃? SERIAL}} where
  lookup : ∀ {Δ}(l : d ↦ send P ∈ Δ) → ⟦ Δ ⟧E → Σ M λ m → ⟦ Δ [ l ≔ m ] ⟧E
  lookup here (env , (m , p)) = m , (env , p)
  lookup (there l) (env , P') = let (m , env') = lookup l env in m , (env' , P')

  set : ∀ {Δ}(l : d ↦ recv P ∈ Δ) → ⟦ Δ ⟧E → (m : M) → ⟦ Δ [ l ≔ m ] ⟧E
  set here (env , f) m = env , f m
  set (there l) (env , P') m = set l env m , P'

  setΣ : ∀ {Δ}(l : d ↦ send P ∈ Δ) → (m : M) → ⟦ Δ [ l ≔ m ] ⟧E → ⟦ Δ ⟧E
  setΣ here m env = fst env , (m , snd env)
  setΣ (there l) m env = setΣ l m (fst env) , snd env

  {-
forgetConc : ∀ {Δ} → ⊢ᶜᶠ mapEnv log Δ → ⟦ mapEnv log Δ ⟧E
forgetConc (end e) = empty …
forgetConc {Δ} (output l m der) = setΣ l m (forgetConc {{!setΣ l m!}} der) -- (forgetConc der)
forgetConc (input l x₁) with noRecvInLog l
... | ()
-}

⊢telecom : ∀ {Δ} → ⊢ᶜᶠ Δ → ⟦ mapEnv dual Δ ⟧E → ⊢ mapEnv log Δ
⊢telecom end env = end {e = mapEnv-Ended _ …}
⊢telecom (output l m der) env = output (mapEnv-∈ l) m (subst (⊢_)
  (subst-lemma-one-point-four l) (⊢telecom der (subst ⟦_⟧E (sym (subst-lemma-one-point-four l)) (set (mapEnv-∈ l) env m))))
⊢telecom (input l x₁) env = let (m , env') = lookup (mapEnv-∈ l) env
                                hyp = ⊢telecom (x₁ m) (subst (⟦_⟧E) (sym (subst-lemma-one-point-four l)) env')
                             in output (mapEnv-∈ l) m
                             (subst (⊢_) (subst-lemma-one-point-four l) hyp)

-- old version
{-
cutᶜᶠ : ∀ {Δ d P} → ⟦ dual P ⟧ → ⊢ᶜᶠ Δ , d ↦ P → ⊢ᶜᶠ Δ
cutᶜᶠ D (end {allEnded = ΔE , PE }) = end {allEnded = ΔE}
cutᶜᶠ D (output here m E) = cutᶜᶠ (D m) E
cutᶜᶠ D (output (there l) m E) = output l m (cutᶜᶠ D E)
cutᶜᶠ (m , D) (input here x₁) = cutᶜᶠ D (x₁ m)
cutᶜᶠ D (input (there l) x₁) = input l (λ m → cutᶜᶠ D (x₁ m))

cut : ∀ {Δ Δ' Γ Γ' d P} → ⊢ Δ , clientURI ↦ dual P +++ Δ' → ⊢ Γ , d ↦ P +++ Γ' → ⊢ (Δ +++ Δ') +++ (Γ +++ Γ')
cut D E = {!!}
-}

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


Removed files related to agda2atp.

Removed files related to agda2atp.

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

module Test where

data _∨_ (A B : Set) : Set where
  inj₁ : A → A ∨ B
  inj₂ : B → A ∨ B

postulate
  A B    : Set
  ∨-comm : A ∨ B → B ∨ A
{-# ATP prove ∨-comm #-}


Use booleans from Data.Bool (fix #31).

Use booleans from Data.Bool (fix #31).

Old-commit-hash: c2de96202cc68d0b06b45d3c977bdf935e14eec1

module Denotational.Values where

-- VALUES
--
-- This module defines the model theory of simple types, that is,
-- it defines for every type, the set of values of that type.
--
-- In fact, we only describe a single model here.

open import Data.Bool public

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import Denotational.Notation

open import Syntactic.Types

-- Denotational Semantics

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type
⟦ bool ⟧Type = Bool

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- Value Equivalence
open import Level using (zero)
open import Relation.Binary.PropositionalEquality
postulate ext : Extensionality zero zero

not-not : ∀ a → a ≡ not (not a)
not-not true = refl
not-not false = refl

a-xor-a-false : ∀ a → (a xor a) ≡ false
a-xor-a-false true = refl
a-xor-a-false false = refl

a-xor-false-a : ∀ a → (false xor a) ≡ a
a-xor-false-a b = refl

xor-associative : ∀ a b c → ((b xor c) xor a) ≡ (b xor (c xor a))
xor-associative a true true = not-not a
xor-associative a true false = refl
xor-associative a false c = refl

a-xor-false : ∀ a → a xor false ≡ a
a-xor-false true = refl
a-xor-false false = refl

a-xor-true : ∀ a → a xor true ≡ not a
a-xor-true true = refl
a-xor-true false = refl

xor-commutative : ∀ a b → a xor b ≡ b xor a
xor-commutative true b rewrite a-xor-true b = refl
xor-commutative false b rewrite a-xor-false b = refl

xor-cancellative-2 : ∀ a b → (b xor (a xor a)) ≡ b
xor-cancellative-2 a b rewrite a-xor-a-false a = a-xor-false b

xor-cancellative : ∀ a b → ((b xor a) xor a) ≡ b
xor-cancellative a b rewrite xor-associative a b a = xor-cancellative-2 a b

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl = refl

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym = sym

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans = trans

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong f = cong f
≡-cong₂ : ∀ {τ₃ τ₁ τ₂ v₁ v₂ v₃ v₄} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧ → ⟦ τ₃ ⟧) →
  v₁ ≡ v₂ → v₃ ≡ v₄ → f v₁ v₃ ≡ f v₂ v₄
≡-cong₂ f = cong₂ f

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = ≡-cong₂ (λ x y → x y)

≡-isEquivalence : ∀ {τ : Set} → IsEquivalence (_≡_ {A = τ})
≡-isEquivalence = isEquivalence

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

≡-consistent : ¬ (∀ (τ : Type) → (v₁ v₂ : ⟦ τ ⟧) → v₁ ≡ v₂)
≡-consistent H with H bool true false
... | ()

module Denotational.Values where

-- VALUES
--
-- This module defines the model theory of simple types, that is,
-- it defines for every type, the set of values of that type.
--
-- In fact, we only describe a single model here.

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import Denotational.Notation

open import Syntactic.Types

-- Denotational Semantics

data Bool : Set where
  true false : Bool

not : Bool → Bool
not true = false
not false = true

_xor_ : Bool → Bool → Bool
true xor b = not b
false xor b = b

⟦_⟧Type : Type -> Set
⟦ τ₁ ⇒ τ₂ ⟧Type = ⟦ τ₁ ⟧Type → ⟦ τ₂ ⟧Type
⟦ bool ⟧Type = Bool

meaningOfType : Meaning Type
meaningOfType = meaning ⟦_⟧Type

-- Value Equivalence
open import Level using (zero)
open import Relation.Binary.PropositionalEquality
postulate ext : Extensionality zero zero

not-not : ∀ a → a ≡ not (not a)
not-not true = refl
not-not false = refl

a-xor-a-false : ∀ a → (a xor a) ≡ false
a-xor-a-false true = refl
a-xor-a-false false = refl

a-xor-false-a : ∀ a → (false xor a) ≡ a
a-xor-false-a b = refl

xor-associative : ∀ a b c → ((b xor c) xor a) ≡ (b xor (c xor a))
xor-associative a true true = not-not a
xor-associative a true false = refl
xor-associative a false c = refl

a-xor-false : ∀ a → a xor false ≡ a
a-xor-false true = refl
a-xor-false false = refl

a-xor-true : ∀ a → a xor true ≡ not a
a-xor-true true = refl
a-xor-true false = refl

xor-commutative : ∀ a b → a xor b ≡ b xor a
xor-commutative true b rewrite a-xor-true b = refl
xor-commutative false b rewrite a-xor-false b = refl

xor-cancellative-2 : ∀ a b → (b xor (a xor a)) ≡ b
xor-cancellative-2 a b rewrite a-xor-a-false a = a-xor-false b

xor-cancellative : ∀ a b → ((b xor a) xor a) ≡ b
xor-cancellative a b rewrite xor-associative a b a = xor-cancellative-2 a b

≡-refl : ∀ {τ} {v : ⟦ τ ⟧} →
  v ≡ v
≡-refl = refl

≡-sym : ∀ {τ} {v₁ v₂ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₁
≡-sym = sym

≡-trans : ∀ {τ} {v₁ v₂ v₃ : ⟦ τ ⟧} →
  v₁ ≡ v₂ → v₂ ≡ v₃ → v₁ ≡ v₃
≡-trans = trans

≡-cong : ∀ {τ₂ τ₁ v₁ v₂} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧) →
  v₁ ≡ v₂ → f v₁ ≡ f v₂
≡-cong f = cong f
≡-cong₂ : ∀ {τ₃ τ₁ τ₂ v₁ v₂ v₃ v₄} (f : ⟦ τ₁ ⟧ → ⟦ τ₂ ⟧ → ⟦ τ₃ ⟧) →
  v₁ ≡ v₂ → v₃ ≡ v₄ → f v₁ v₃ ≡ f v₂ v₄
≡-cong₂ f = cong₂ f

≡-app : ∀ {τ₁ τ₂} {v₁ v₂ : ⟦ τ₁ ⇒ τ₂ ⟧} {v₃ v₄ : ⟦ τ₁ ⟧} →
  v₁ ≡ v₂ → v₃ ≡ v₄ → v₁ v₃ ≡ v₂ v₄
≡-app = ≡-cong₂ (λ x y → x y)

≡-isEquivalence : ∀ {τ : Set} → IsEquivalence (_≡_ {A = τ})
≡-isEquivalence = isEquivalence

≡-setoid : Type → Setoid _ _
≡-setoid τ = record
  { Carrier       = ⟦ τ ⟧
  ; _≈_           = _≡_
  ; isEquivalence = ≡-isEquivalence
  }

≡-consistent : ¬ (∀ (τ : Type) → (v₁ v₂ : ⟦ τ ⟧) → v₁ ≡ v₂)
≡-consistent H with H bool true false
... | ()