more startx proofs

more startx proofs

-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level
open import Data.Product
open import Data.One

open import Relation.Binary.PropositionalEquality.NP

module Control.Protocol.Choreography where
open import Control.Strategy renaming (Strategy to Client) public

Π· : ∀ {a b}(A : ★_ a) → (B : ..(_ : A) → ★_ b) → ★_ (a ⊔ b)
Π· A B = ..(x : A) → B x

data Mod : ★ where S D : Mod

→M : ∀ {a b} → Mod → ★_ a → ★_ b → ★_ (a ⊔ b)
→M S A B = ..(_ : A) → B
→M D A B = A → B

ΠM : ∀ {a b}(m : Mod) → (A : ★_ a) → (B : →M m A (★_ b)) → ★_ (a ⊔ b)
ΠM S A B = Π· A B
ΠM D A B = Π A B

-- appM : ∀ {a b}(m : Mod){A : ★_ a}{B : →M m A (★_ b)}(P : ΠM m A B)(x : A) → B

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (f : Mod)(A : ★)(B : →M f A Proto) → Proto

{-
Tele : Proto → ★
Tele end = 𝟙
Tele (Π' A B) = Σ A λ x → Tele (B x)
Tele (Σ' A B) = Σ A λ x → Tele (B x)
Tele (later i P) = ?

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
Π' A B >>≡ Q = Π' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
Σ' A B >>≡ Q = Σ' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
later i P >>≡ Q = ?

++Tele : ∀ (P : Proto)(Q : Tele P → Proto) → (x : Tele P) → Tele (Q x) → Tele (P >>≡ Q)
++Tele end Q x y = y
++Tele (Π' M C) Q (m , x) y = m , ++Tele (C m) (λ x₁ → Q (m , x₁)) x y
++Tele (Σ' M C) Q (m , x) y = m , ++Tele (C m) _ x y
++Tele (later i P) Q x y = ?

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : ★_ b}{f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g) where
  right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ P
  right-unit end = refl
  right-unit (Π' M C) = let p = funExt (λ x → right-unit (C x)) in cong (Π' M) p
  right-unit (Σ' M C) = cong (Σ' M) (funExt (λ x → right-unit (C x)))
  right-unit (later i P) = ?

  assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P Q x y))) ≡ ((P >>≡ Q) >>≡ R)
  assoc end Q R = refl
  assoc (Π' M C₁) Q R = cong (Π' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (Σ' M C₁) Q R = cong (Σ' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (later i P) Q R = ?

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q
-}

_×'_ : Set → Proto → Proto
A ×' B = Σ' D A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' D A λ _ → B

dual : Proto → Proto
dual end = end
dual (Π' S A B) = Σ' S A (λ x → dual (B x))
dual (Π' D A B) = Σ' D A (λ x → dual (B x))
dual (Σ' S A B) = Π' S A (λ x → dual (B x))
dual (Σ' D A B) = Π' D A (λ x → dual (B x))

data Dual : Proto → Proto → ★₁ where
  end : Dual end end
  ΠΣ'S : ∀ {A B B'} → (∀ ..x → Dual (B x) (B' x)) → Dual (Π' S A B) (Σ' S A B')
  ΠΣ'D : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Π' D A B) (Σ' D A B')
  ΣΠ'S : ∀ {A B B'} → (∀ ..x → Dual (B x) (B' x)) → Dual (Σ' S A B) (Π' S A B')
  ΣΠ'D : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Σ' D A B) (Π' D A B')

Dual-sym : ∀ {P Q} → Dual P Q → Dual Q P
Dual-sym end = end
Dual-sym (ΠΣ'S f) = ΣΠ'S (λ x → Dual-sym (f x))
Dual-sym (ΠΣ'D f) = ΣΠ'D (λ x → Dual-sym (f x))
Dual-sym (ΣΠ'S f) = ΠΣ'S (λ x → Dual-sym (f x))
Dual-sym (ΣΠ'D f) = ΠΣ'D (λ x → Dual-sym (f x))

Dual-spec : ∀ P → Dual P (dual P)
Dual-spec end = end
Dual-spec (Π' S A B) = ΠΣ'S (λ x → Dual-spec (B x))
Dual-spec (Π' D A B) = ΠΣ'D (λ x → Dual-spec (B x))
Dual-spec (Σ' S A B) = ΣΠ'S (λ x → Dual-spec (B x))
Dual-spec (Σ' D A B) = ΣΠ'D (λ x → Dual-spec (B x))
{-
module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele P ≡ Tele (dual P)
  dual-Tele end = refl
  dual-Tele (Π' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (Σ' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (later i P) = ?
-}{-
module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
module _ where
  El : (P : Proto) → (Tele P → ★) → ★
  El end X = X _
  El (Π' A B) X = Π A λ x → El (B x) (λ y → X (x , y))
  El (Σ' A B) X = Σ A λ x → El (B x) (λ y → X (x , y))
  El (later i P) = ?

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto)(Q : Tele P → Proto)(X : Tele (P >>≡ Q) → ★) → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P Q x y)))
  bind-spec end Q X = refl
  bind-spec (Π' A B) Q X = cong (Π A) (funExt (λ x → bind-spec (B x) (λ xs → Q (x , xs)) (λ y → X (x , y))))
  bind-spec (Σ' A B) Q X = cong (Σ A) (funExt (λ x → bind-spec (B x) _ _))
  bind-spec (later i p) Q X = ?

module _ {A B} where
  com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (later i P) x y = ?

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
  com-cont end p q = (_ , p)  , (_ , q)
  com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (later i P) p q = ?
-}

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  recvD : ∀ {M P} → (ΠM D M λ m → this (P m)) → ProcessF this (Π' D M P)
  recvS : ∀ {M P} → (ΠM S M λ m → this (P m)) → ProcessF this (Π' S M P)
  sendD : ∀ {M P} → ΠM D M (λ m → this (P m) → ProcessF this (Σ' D M P))
  sendS : ∀ {M P} → ΠM S M (λ m → this (P m) → ProcessF this (Σ' S M P))

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

mutual
  SimL : Proto → Proto → ★₁
  SimL P Q = ProcessF (flip Sim Q) P

  SimR : Proto → Proto → ★₁
  SimR P Q = ProcessF (Sim P) Q

  data Sim : Proto → Proto → ★₁ where
    left  : ∀ {P Q} → SimL P Q → Sim P Q
    right : ∀ {P Q} → SimR P Q → Sim P Q
    end   : Sim end end

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' S A B) = right (recvS (λ x → left (sendS x (sim-id (B x)))))
sim-id (Π' D A B) = right (recvD (λ x → left (sendD x (sim-id (B x)))))
sim-id (Σ' S A B) = left (recvS (λ x → right (sendS x (sim-id (B x)))))
sim-id (Σ' D A B) = left (recvD (λ x → right (sendD x (sim-id (B x)))))

sim-comp : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → Sim Q' R → Sim P R
sim-compRL : ∀ {P Q Q' R} → Dual Q Q' → SimR P Q → SimL Q' R → Sim P R
sim-compL : ∀ {P Q Q' R} → Dual Q Q' → SimL P Q → Sim Q' R → SimL P R
sim-compR : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → SimR Q' R → SimR P R

sim-comp Q-Q' (left x) QR = left (sim-compL Q-Q' x QR)
sim-comp Q-Q' (right x) (left x₁) = sim-compRL Q-Q' x x₁
sim-comp Q-Q' (right x) (right x₁) = right (sim-compR Q-Q' (right x) x₁)
sim-comp end (right x) end = right x
sim-comp end end QR = QR

sim-compRL end () QR
sim-compRL (ΠΣ'S x₁) (recvS x) (sendS x₂ x₃) = sim-comp (x₁ x₂) (x x₂) x₃
sim-compRL (ΠΣ'D x₁) (recvD x) (sendD x₂ x₃) = sim-comp (x₁ x₂) (x x₂) x₃
sim-compRL (ΣΠ'S x) (sendS x₁ x₂) (recvS x₃) = sim-comp (x x₁) x₂ (x₃ x₁)
sim-compRL (ΣΠ'D x) (sendD x₁ x₂) (recvD x₃) = sim-comp (x x₁) x₂ (x₃ x₁)

sim-compL Q-Q' (recvD PQ) QR = recvD (λ m → sim-comp Q-Q' (PQ m) QR)
sim-compL Q-Q' (recvS PQ) QR = recvS (λ m → sim-comp Q-Q' (PQ m) QR)
sim-compL Q-Q' (sendD m PQ) QR = sendD m (sim-comp Q-Q' PQ QR)
sim-compL Q-Q' (sendS m PQ) QR = sendS m (sim-comp Q-Q' PQ QR)

sim-compR Q-Q' PQ (recvD QR)   = recvD (λ m → sim-comp Q-Q' PQ (QR m))
sim-compR Q-Q' PQ (recvS QR)   = recvS (λ x → sim-comp Q-Q' PQ (QR x))
sim-compR Q-Q' PQ (sendD m QR) = sendD m (sim-comp Q-Q' PQ QR)
sim-compR Q-Q' PQ (sendS m QR) = sendS m (sim-comp Q-Q' PQ QR)

{-
sim-comp : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → Sim Q' R → Sim P R
sim-comp Q-Q' (left (recvD PQ)) QR = left (recvD (λ m → sim-comp Q-Q' (PQ m) QR))
sim-comp Q-Q' (left (recvS PQ)) QR = left (recvS (λ m → sim-comp Q-Q' (PQ m) QR))
sim-comp Q-Q' (left (sendD m PQ)) QR = left (sendD m (sim-comp Q-Q' PQ QR))
sim-comp Q-Q' (left (sendS m PQ)) QR = left (sendS m (sim-comp Q-Q' PQ QR))
sim-comp end (right ()) (left x₁)
sim-comp end end QR = QR
sim-comp end PQ end = PQ
sim-comp (ΠΣ'S Q-Q') (right (recvS PQ)) (left (sendS m QR)) = sim-comp (Q-Q' m) (PQ m) QR
sim-comp (ΠΣ'D Q-Q') (right (recvD PQ)) (left (sendD m QR)) = sim-comp (Q-Q' m) (PQ m) QR
sim-comp (ΣΠ'S Q-Q') (right (sendS m PQ)) (left (recvS QR)) = sim-comp (Q-Q' m) PQ (QR m)
sim-comp (ΣΠ'D Q-Q') (right (sendD m PQ)) (left (recvD QR)) = sim-comp (Q-Q' m) PQ (QR m)
sim-comp Q-Q' PQ (right (recvD QR)) = right (recvD (λ m → sim-comp Q-Q' PQ (QR m)))
sim-comp Q-Q' PQ (right (recvS QR)) = right (recvS (λ x → sim-comp Q-Q' PQ (QR x)))
sim-comp Q-Q' PQ (right (sendD m QR)) = right (sendD m (sim-comp Q-Q' PQ QR))
sim-comp Q-Q' PQ (right (sendS m QR)) = right (sendS m (sim-comp Q-Q' PQ QR))
-}

_♦_ : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
_♦_ = sim-comp (Dual-spec _)

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = _♦_

!ˢ : ∀ {P Q} → Sim P Q → Sim Q P
sim-symL : ∀ {P Q} → SimL P Q → SimR Q P
sim-symR : ∀ {P Q} → SimR P Q → SimL Q P

!ˢ (left x) = right (sim-symL x)
!ˢ (right x) = left (sim-symR x)
!ˢ end = end

sim-symL (recvD PQ)   = recvD (λ m → !ˢ (PQ m))
sim-symL (recvS PQ)   = recvS (λ m → !ˢ (PQ m))
sim-symL (sendD m PQ) = sendD m (!ˢ PQ)
sim-symL (sendS m PQ) = sendS m (!ˢ PQ)

sim-symR (recvD PQ)   = recvD (λ m → !ˢ (PQ m))
sim-symR (recvS PQ)   = recvS (λ m → !ˢ (PQ m))
sim-symR (sendD m PQ) = sendD m (!ˢ PQ)
sim-symR (sendS m PQ) = sendS m (!ˢ PQ)

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (left ())
sim-unit (right (recvD P)) = do (recvD (λ m → sim-unit (P m)))
sim-unit (right (recvS P)) = do (recvS (λ m → sim-unit (P m)))
sim-unit (right (sendD m P)) = do (sendD m (sim-unit P))
sim-unit (right (sendS m P)) = do (sendS m (sim-unit P))
sim-unit end = end 0₁

module _ {P Q : Proto} where
  infix 2 _∼_
  _∼_ : (PQ PQ' : Sim P Q) → ★₁
  PQ ∼ PQ' = ∀ {P'} → (P'-P : Dual P' P) → (øP : Sim end P')
           → sim-comp P'-P øP PQ ≡ sim-comp P'-P øP PQ'

module _
  (funExtD : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  (funExtS : ∀ {a}{b}{A : ★_ a}{B : ..(_ : A) → ★_ b}{f g : ..(x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where

  Dual-sym-sym : ∀ {P Q} (P-Q : Dual P Q) → P-Q ≡ Dual-sym (Dual-sym P-Q)
  Dual-sym-sym end = refl
  Dual-sym-sym (ΠΣ'S x) = cong ΠΣ'S (funExtS (λ y → Dual-sym-sym (x y)))
  Dual-sym-sym (ΠΣ'D x) = cong ΠΣ'D (funExtD (λ y → Dual-sym-sym (x y)))
  Dual-sym-sym (ΣΠ'S x) = cong ΣΠ'S (funExtS (λ y → Dual-sym-sym (x y)))
  Dual-sym-sym (ΣΠ'D x) = cong ΣΠ'D (funExtD (λ y → Dual-sym-sym (x y)))

module _
  (funExtD : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  (funExtS : ∀ {a}{b}{A : ★_ a}{B : ..(_ : A) → ★_ b}{f g : ..(x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
  sim-comp-assoc-end : ∀ {P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (øP : Sim end P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' øP PQ) QR
    ≡ sim-comp P-P' øP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc-end P-P' Q-Q' (left ()) PQ QR
  sim-comp-assoc-end end Q-Q' (right ()) (left PQ) QR
  sim-comp-assoc-end (ΠΣ'S x₁) Q-Q' (right (recvS x)) (left (sendS x₂ x₃)) QR
    = sim-comp-assoc-end (x₁ x₂) Q-Q' (x x₂) x₃ QR
  sim-comp-assoc-end (ΠΣ'D x₁) Q-Q' (right (recvD x)) (left (sendD x₂ x₃)) QR
    = sim-comp-assoc-end (x₁ x₂) Q-Q' (x x₂) x₃ QR
  sim-comp-assoc-end (ΣΠ'S x) Q-Q' (right (sendS x₁ x₂)) (left (recvS x₃)) QR
    = sim-comp-assoc-end (x x₁) Q-Q' x₂ (x₃ x₁) QR
  sim-comp-assoc-end (ΣΠ'D x) Q-Q' (right (sendD x₁ x₂)) (left (recvD x₃)) QR
    = sim-comp-assoc-end (x x₁) Q-Q' x₂ (x₃ x₁) QR
  sim-comp-assoc-end P-P' end (right øP) (right ()) (left x₁)
  sim-comp-assoc-end P-P' (ΠΣ'S x₁) (right øP) (right (recvS x)) (left (sendS x₂ x₃))
    = sim-comp-assoc-end P-P' (x₁ x₂) (right øP) (x x₂) x₃
  sim-comp-assoc-end P-P' (ΠΣ'D x₁) (right øP) (right (recvD x)) (left (sendD x₂ x₃))
    = sim-comp-assoc-end P-P' (x₁ x₂) (right øP) (x x₂) x₃
  sim-comp-assoc-end P-P' (ΣΠ'S x) (right øP) (right (sendS x₁ x₂)) (left (recvS x₃))
    = sim-comp-assoc-end P-P' (x x₁) (right øP) x₂ (x₃ x₁)
  sim-comp-assoc-end P-P' (ΣΠ'D x) (right øP) (right (sendD x₁ x₂)) (left (recvD x₃))
    = sim-comp-assoc-end P-P' (x x₁) (right øP) x₂ (x₃ x₁)
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (recvD x₁))
    = cong (right ∘ recvD) (funExtD (λ m → sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (x₁ m)))
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (recvS x₁))
    = cong (right ∘ recvS) (funExtS (λ m → sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (x₁ m)))
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (sendD x₁ x₂))
    = cong (right ∘ sendD x₁) (sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) x₂)
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (sendS x₁ x₂))
    = cong (right ∘ sendS x₁) (sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) x₂)
  sim-comp-assoc-end P-P' end (right øP) (right ()) end
  sim-comp-assoc-end end end (right øP) end QR = refl
  sim-comp-assoc-end end Q-Q' end PQ QR = refl

  ♦-assoc-end : ∀ {P Q R}(øP : Sim end P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (øP ♦ PQ) ♦ QR ≡ øP ♦ (PQ ♦ QR)
  ♦-assoc-end = sim-comp-assoc-end (Dual-spec _) (Dual-spec _)

  open ≡-Reasoning
  sim-comp-assoc : ∀ {W P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (WP : Sim W P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' WP PQ) QR
    ∼ sim-comp P-P' WP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc P-P' Q-Q' WP PQ QR {W'} W'-W øW'
    = sim-comp W'-W øW' (sim-comp Q-Q' (sim-comp P-P' WP PQ) QR)
    ≡⟨ sym (sim-comp-assoc-end W'-W Q-Q' øW' (sim-comp P-P' WP PQ) QR) ⟩
      sim-comp Q-Q' (sim-comp W'-W øW' (sim-comp P-P' WP PQ)) QR
    ≡⟨ cong (λ X → sim-comp Q-Q' X QR) (sym (sim-comp-assoc-end W'-W P-P' øW' WP PQ)) ⟩
      sim-comp Q-Q' (sim-comp P-P' (sim-comp W'-W øW' WP) PQ) QR
    ≡⟨ sim-comp-assoc-end P-P' Q-Q' (sim-comp W'-W øW' WP) PQ QR ⟩
      sim-comp P-P' (sim-comp W'-W øW' WP) (sim-comp Q-Q' PQ QR)
    ≡⟨ sim-comp-assoc-end W'-W P-P' øW' WP (sim-comp Q-Q' PQ QR) ⟩
      sim-comp W'-W øW' (sim-comp P-P' WP (sim-comp Q-Q' PQ QR))
    ∎

  ♦-assoc : ∀ {W P Q R}(WP : Sim W P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (WP ♦ PQ) ♦ QR ∼ WP ♦ (PQ ♦ QR)
  ♦-assoc = sim-comp-assoc (Dual-spec _) (Dual-spec _)

∼-ø : ∀ {P}{s s' : Sim end P} → s ∼ s' → s ≡ s'
∼-ø s∼s' = s∼s' end end

module _
  (funExtD : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  (funExtS : ∀ {a}{b}{A : ★_ a}{B : ..(_ : A) → ★_ b}{f g : ..(x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where

  sim-!! : ∀ {P Q}(PQ : Sim P Q) → PQ ≡ !ˢ (!ˢ PQ)
  sim-!! (left (recvD x))    = cong (left ∘ recvD) (funExtD λ m → sim-!! (x m))
  sim-!! (left (recvS x))    = cong (left ∘ recvS) (funExtS λ m → sim-!! (x m))
  sim-!! (left (sendD x x₁)) = cong (left ∘ sendD x) (sim-!! x₁)
  sim-!! (left (sendS x x₁)) = cong (left ∘ sendS x) (sim-!! x₁)
  sim-!! (right (recvD x))    = cong (right ∘ recvD) (funExtD λ m → sim-!! (x m))
  sim-!! (right (recvS x))    = cong (right ∘ recvS) (funExtS λ m → sim-!! (x m))
  sim-!! (right (sendD x x₁)) = cong (right ∘ sendD x) (sim-!! x₁)
  sim-!! (right (sendS x x₁)) = cong (right ∘ sendS x) (sim-!! x₁)
  sim-!! end = refl

  sim-comp-!-end : ∀ {Q Q' R}(Q-Q' : Dual Q Q')(·Q : Sim end Q)(Q'R : Sim Q' R)
    → sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ ·Q) ≡ !ˢ (sim-comp Q-Q' ·Q Q'R)
  sim-comp-!-end Q-Q' (left ()) QR
  sim-comp-!-end end (right ()) (left x₁)
  sim-comp-!-end (ΠΣ'S x₁) (right (recvS x)) (left (sendS x₂ x₃)) = sim-comp-!-end (x₁ x₂) (x x₂) x₃
  sim-comp-!-end (ΠΣ'D x₁) (right (recvD x)) (left (sendD x₂ x₃)) = sim-comp-!-end (x₁ x₂) (x x₂) x₃
  sim-comp-!-end (ΣΠ'S x) (right (sendS x₁ x₂)) (left (recvS x₃)) = sim-comp-!-end (x x₁) x₂ (x₃ x₁)
  sim-comp-!-end (ΣΠ'D x) (right (sendD x₁ x₂)) (left (recvD x₃)) = sim-comp-!-end (x x₁) x₂ (x₃ x₁)
  sim-comp-!-end Q-Q' (right x) (right (recvD x₁))
    = cong (left ∘ recvD) (funExtD (λ x₂ → sim-comp-!-end Q-Q' (right x) (x₁ x₂)))
  sim-comp-!-end Q-Q' (right x) (right (recvS x₁))
    = cong (left ∘ recvS) (funExtS (λ x₂ → sim-comp-!-end Q-Q' (right x) (x₁ x₂)))
  sim-comp-!-end Q-Q' (right x) (right (sendD x₁ x₂))
    = cong (left ∘ sendD x₁) (sim-comp-!-end Q-Q' (right x) x₂)
  sim-comp-!-end Q-Q' (right x) (right (sendS x₁ x₂))
    = cong (left ∘ sendS x₁) (sim-comp-!-end Q-Q' (right x) x₂)
  sim-comp-!-end end (right x) end = refl
  sim-comp-!-end end end QR = {!!}

  open ≡-Reasoning
  module _ {P Q}{s s' : Sim P Q} where
    !ˢ-cong : s ∼ s' → !ˢ s ∼ !ˢ s'
    !ˢ-cong s∼s' Q'-Q øQ'
      = sim-comp Q'-Q øQ' (!ˢ s)
      ≡⟨ {!!} ⟩
        sim-comp Q'-Q øQ' (!ˢ (sim-comp (Dual-spec Q) s (sim-id _)))
      ≡⟨ {!!} ⟩
        sim-comp Q'-Q øQ' (!ˢ s')
      ∎

  postulate
    sim-comp-assoc-end' : ∀ {P Q Q' R R'}(Q-Q' : Dual Q Q')(R-R' : Dual R R')
      (PQ : Sim P Q)(QR : Sim Q' R )(Rø : Sim R' end)
      → sim-comp R-R' (sim-comp Q-Q' PQ QR) Rø
      ≡ sim-comp Q-Q' PQ (sim-comp R-R' QR Rø)

  sim-comp-! : ∀ {P Q Q' R}(Q-Q' : Dual Q Q')(PQ : Sim P Q)(Q'R : Sim Q' R)
    → sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ) ∼ !ˢ (sim-comp Q-Q' PQ Q'R)
  sim-comp-! Q-Q' PQ Q'R {R'} R'-R øR'
    = sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ))
    ≡⟨ sim-!! (sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ))) ⟩
      !ˢ( !ˢ ((sim-comp R'-R øR' (sim-comp (Dual-sym Q-Q') (!ˢ Q'R) (!ˢ PQ)))))
    ≡⟨ cong (!ˢ ∘ !ˢ) (sym (sim-comp-assoc-end funExtD funExtS R'-R (Dual-sym Q-Q') øR' (!ˢ Q'R) (!ˢ PQ))) ⟩
      !ˢ
        (!ˢ
         (sim-comp (Dual-sym Q-Q') (sim-comp R'-R øR' (!ˢ Q'R)) (!ˢ PQ)))
    ≡⟨ cong !ˢ (sym (sim-comp-!-end (Dual-sym Q-Q') (sim-comp R'-R øR' (!ˢ Q'R)) (!ˢ PQ))) ⟩
      !ˢ
        (sim-comp (Dual-sym (Dual-sym Q-Q')) (!ˢ (!ˢ PQ))
         (!ˢ (sim-comp R'-R øR' (!ˢ Q'R))))
    ≡⟨ cong₂ (λ X Y → !ˢ (sim-comp X Y (!ˢ (sim-comp R'-R øR' (!ˢ Q'R)))))
         (sym (Dual-sym-sym funExtD funExtS Q-Q')) (sym (sim-!! PQ)) ⟩
     !ˢ (sim-comp Q-Q' PQ (!ˢ (sim-comp R'-R øR' (!ˢ Q'R))))
    ≡⟨ cong (!ˢ ∘ sim-comp Q-Q' PQ) (sym (sim-comp-!-end R'-R øR' (!ˢ Q'R))) ⟩
      !ˢ
        (sim-comp Q-Q' PQ
         (sim-comp (Dual-sym R'-R) (!ˢ (!ˢ Q'R)) (!ˢ øR')))
    ≡⟨ cong
         (λ X → !ˢ (sim-comp Q-Q' PQ (sim-comp (Dual-sym R'-R) X (!ˢ øR'))))
         (sym (sim-!! Q'R)) ⟩
      !ˢ (sim-comp Q-Q' PQ (sim-comp (Dual-sym R'-R) Q'R (!ˢ øR')))
    -- ≡⟨ cong !ˢ (sym (sim-comp-assoc-end' Q-Q' (Dual-sym R'-R) PQ Q'R (!ˢ øR'))) ⟩
    ≡⟨ ∼-ø {!!}⟩
      !ˢ (sim-comp (Dual-sym R'-R) (sim-comp Q-Q' PQ Q'R) (!ˢ øR'))
    ≡⟨ cong (λ X → !ˢ (sim-comp (Dual-sym R'-R) X (!ˢ øR'))) (sim-!! (sim-comp Q-Q' PQ Q'R)) ⟩
      !ˢ (sim-comp (Dual-sym R'-R) (!ˢ (!ˢ (sim-comp Q-Q' PQ Q'R)))
                                   (!ˢ øR'))
    ≡⟨ cong !ˢ (sim-comp-!-end R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))) ⟩
      !ˢ (!ˢ (sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))))
    ≡⟨ sym (sim-!! (sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R)))) ⟩
      sim-comp R'-R øR' (!ˢ (sim-comp Q-Q' PQ Q'R))
    ∎

  ♦-! : ∀ {P Q R}(PQ : Sim P Q)(QR : Sim (dual Q) R)
    → !ˢ (PQ ♦ QR) ∼ (!ˢ QR) ♦ (!ˢ {!PQ!})
  ♦-! = {!!}
{-

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (sim-sym PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = refl
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}

-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level
open import Data.Product
open import Data.One

open import Relation.Binary.PropositionalEquality.NP

module Control.Protocol.Choreography where
open import Control.Strategy renaming (Strategy to Client) public

Π· : ∀ {a b}(A : ★_ a) → (B : ..(_ : A) → ★_ b) → ★_ (a ⊔ b)
Π· A B = ..(x : A) → B x

data Mod : ★ where S D : Mod

→M : ∀ {a b} → Mod → ★_ a → ★_ b → ★_ (a ⊔ b)
→M S A B = ..(_ : A) → B
→M D A B = A → B

ΠM : ∀ {a b}(m : Mod) → (A : ★_ a) → (B : →M m A (★_ b)) → ★_ (a ⊔ b)
ΠM S A B = Π· A B
ΠM D A B = Π A B

-- appM : ∀ {a b}(m : Mod){A : ★_ a}{B : →M m A (★_ b)}(P : ΠM m A B)(x : A) → B

data Proto : ★₁ where
  end : Proto
  Π' Σ' : (f : Mod)(A : ★)(B : →M f A Proto) → Proto

{-
Tele : Proto → ★
Tele end = 𝟙
Tele (Π' A B) = Σ A λ x → Tele (B x)
Tele (Σ' A B) = Σ A λ x → Tele (B x)
Tele (later i P) = ?

_>>≡_ : (P : Proto) → (Tele P → Proto) → Proto
end >>≡ Q = Q _
Π' A B >>≡ Q = Π' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
Σ' A B >>≡ Q = Σ' A (λ x → B x >>≡ (λ xs → Q (x , xs)))
later i P >>≡ Q = ?

++Tele : ∀ (P : Proto)(Q : Tele P → Proto) → (x : Tele P) → Tele (Q x) → Tele (P >>≡ Q)
++Tele end Q x y = y
++Tele (Π' M C) Q (m , x) y = m , ++Tele (C m) (λ x₁ → Q (m , x₁)) x y
++Tele (Σ' M C) Q (m , x) y = m , ++Tele (C m) _ x y
++Tele (later i P) Q x y = ?

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : ★_ b}{f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g) where
  right-unit : ∀ (P : Proto) → (P >>≡ λ x → end) ≡ P
  right-unit end = refl
  right-unit (Π' M C) = let p = funExt (λ x → right-unit (C x)) in cong (Π' M) p
  right-unit (Σ' M C) = cong (Σ' M) (funExt (λ x → right-unit (C x)))
  right-unit (later i P) = ?

  assoc : ∀ (P : Proto)(Q : Tele P → Proto)(R : Tele (P >>≡ Q) → Proto)
        → P >>≡ (λ x → Q x >>≡ (λ y → R (++Tele P Q x y))) ≡ ((P >>≡ Q) >>≡ R)
  assoc end Q R = refl
  assoc (Π' M C₁) Q R = cong (Π' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (Σ' M C₁) Q R = cong (Σ' M) (funExt (λ x → assoc (C₁ x) (λ xs → Q (x , xs)) (λ xs → R (x , xs))))
  assoc (later i P) Q R = ?

_>>_ : Proto → Proto → Proto
P >> Q = P >>≡ λ _ → Q
-}

_×'_ : Set → Proto → Proto
A ×' B = Σ' D A λ _ → B

_→'_ : Set → Proto → Proto
A →' B = Π' D A λ _ → B

dual : Proto → Proto
dual end = end
dual (Π' S A B) = Σ' S A (λ x → dual (B x))
dual (Π' D A B) = Σ' D A (λ x → dual (B x))
dual (Σ' S A B) = Π' S A (λ x → dual (B x))
dual (Σ' D A B) = Π' D A (λ x → dual (B x))

data Dual : Proto → Proto → ★₁ where
  end : Dual end end
  ΠΣ'S : ∀ {A B B'} → (∀ ..x → Dual (B x) (B' x)) → Dual (Π' S A B) (Σ' S A B')
  ΠΣ'D : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Π' D A B) (Σ' D A B')
  ΣΠ'S : ∀ {A B B'} → (∀ ..x → Dual (B x) (B' x)) → Dual (Σ' S A B) (Π' S A B')
  ΣΠ'D : ∀ {A B B'} → (∀ x → Dual (B x) (B' x)) → Dual (Σ' D A B) (Π' D A B')

Dual-sym : ∀ {P Q} → Dual P Q → Dual Q P
Dual-sym end = end
Dual-sym (ΠΣ'S f) = ΣΠ'S (λ x → Dual-sym (f x))
Dual-sym (ΠΣ'D f) = ΣΠ'D (λ x → Dual-sym (f x))
Dual-sym (ΣΠ'S f) = ΠΣ'S (λ x → Dual-sym (f x))
Dual-sym (ΣΠ'D f) = ΠΣ'D (λ x → Dual-sym (f x))

Dual-spec : ∀ P → Dual P (dual P)
Dual-spec end = end
Dual-spec (Π' S A B) = ΠΣ'S (λ x → Dual-spec (B x))
Dual-spec (Π' D A B) = ΠΣ'D (λ x → Dual-spec (B x))
Dual-spec (Σ' S A B) = ΣΠ'S (λ x → Dual-spec (B x))
Dual-spec (Σ' D A B) = ΣΠ'D (λ x → Dual-spec (B x))
{-
module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  dual-Tele : ∀ P → Tele P ≡ Tele (dual P)
  dual-Tele end = refl
  dual-Tele (Π' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (Σ' A B) = cong (Σ A) (funExt (λ x → dual-Tele (B x)))
  dual-Tele (later i P) = ?
-}{-
module _ X where
  El : Proto → ★
  El end = X
  El (Π' A B) = Π A λ x → El (B x)
  El (Σ' A B) = Σ A λ x → El (B x)
module _ where
  El : (P : Proto) → (Tele P → ★) → ★
  El end X = X _
  El (Π' A B) X = Π A λ x → El (B x) (λ y → X (x , y))
  El (Σ' A B) X = Σ A λ x → El (B x) (λ y → X (x , y))
  El (later i P) = ?

module ElBind (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where

  bind-spec : (P : Proto)(Q : Tele P → Proto)(X : Tele (P >>≡ Q) → ★) → El (P >>≡ Q) X ≡ El P (λ x → El (Q x) (λ y → X (++Tele P Q x y)))
  bind-spec end Q X = refl
  bind-spec (Π' A B) Q X = cong (Π A) (funExt (λ x → bind-spec (B x) (λ xs → Q (x , xs)) (λ y → X (x , y))))
  bind-spec (Σ' A B) Q X = cong (Σ A) (funExt (λ x → bind-spec (B x) _ _))
  bind-spec (later i p) Q X = ?

module _ {A B} where
  com : (P : Proto) → El P (const A) → El (dual P) (const B) → A × B
  com end a b = a , b
  com (Π' A B) f (x , y) = com (B x) (f x) y
  com (Σ' A B) (x , y) f = com (B x) y (f x)
  com (later i P) x y = ?

module _ (funExt : ∀ {a b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)where
  com-cont : (P : Proto){A : Tele P → ★}{B : Tele (dual P) → ★} → El P A → El (dual P) B → Σ (Tele P) A × Σ (Tele (dual P)) B
  com-cont end p q = (_ , p)  , (_ , q)
  com-cont (Π' A B) p (m , q) with com-cont (B m) (p m) q
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (Σ' A B) (m , p) q with com-cont (B m) p (q m)
  ... | (X , a) , (Y , b) = ((m , X) , a) , (m , Y) , b
  com-cont (later i P) p q = ?
-}

data ProcessF (this : Proto → ★₁): Proto → ★₁ where
  recvD : ∀ {M P} → (ΠM D M λ m → this (P m)) → ProcessF this (Π' D M P)
  recvS : ∀ {M P} → (ΠM S M λ m → this (P m)) → ProcessF this (Π' S M P)
  sendD : ∀ {M P} → ΠM D M (λ m → this (P m) → ProcessF this (Σ' D M P))
  sendS : ∀ {M P} → ΠM S M (λ m → this (P m) → ProcessF this (Σ' S M P))

data Process (A : ★) : Proto → ★₁ where
  do  : ∀ {P} → ProcessF (Process A) P → Process A P
  end : A → Process A end

mutual
  SimL : Proto → Proto → ★₁
  SimL P Q = ProcessF (flip Sim Q) P

  SimR : Proto → Proto → ★₁
  SimR P Q = ProcessF (Sim P) Q

  data Sim : Proto → Proto → ★₁ where
    left  : ∀ {P Q} → SimL P Q → Sim P Q
    right : ∀ {P Q} → SimR P Q → Sim P Q
    end   : Sim end end

_⟹_ : Proto → Proto → ★₁
P ⟹ Q = Sim (dual P) Q

_⟹ᴾ_ : Proto → Proto → ★₁
P ⟹ᴾ Q = ∀ {A} → Process A (dual P) → Process A Q

sim-id : ∀ P → Sim (dual P) P
sim-id end = end
sim-id (Π' S A B) = right (recvS (λ x → left (sendS x (sim-id (B x)))))
sim-id (Π' D A B) = right (recvD (λ x → left (sendD x (sim-id (B x)))))
sim-id (Σ' S A B) = left (recvS (λ x → right (sendS x (sim-id (B x)))))
sim-id (Σ' D A B) = left (recvD (λ x → right (sendD x (sim-id (B x)))))

sim-comp : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → Sim Q' R → Sim P R
sim-compRL : ∀ {P Q Q' R} → Dual Q Q' → SimR P Q → SimL Q' R → Sim P R
sim-compL : ∀ {P Q Q' R} → Dual Q Q' → SimL P Q → Sim Q' R → SimL P R
sim-compR : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → SimR Q' R → SimR P R

sim-comp Q-Q' (left x) QR = left (sim-compL Q-Q' x QR)
sim-comp Q-Q' (right x) (left x₁) = sim-compRL Q-Q' x x₁
sim-comp Q-Q' (right x) (right x₁) = right (sim-compR Q-Q' (right x) x₁)
sim-comp end (right x) end = right x
sim-comp end end QR = QR

sim-compRL end () QR
sim-compRL (ΠΣ'S x₁) (recvS x) (sendS x₂ x₃) = sim-comp (x₁ x₂) (x x₂) x₃
sim-compRL (ΠΣ'D x₁) (recvD x) (sendD x₂ x₃) = sim-comp (x₁ x₂) (x x₂) x₃
sim-compRL (ΣΠ'S x) (sendS x₁ x₂) (recvS x₃) = sim-comp (x x₁) x₂ (x₃ x₁)
sim-compRL (ΣΠ'D x) (sendD x₁ x₂) (recvD x₃) = sim-comp (x x₁) x₂ (x₃ x₁)

sim-compL Q-Q' (recvD PQ) QR = recvD (λ m → sim-comp Q-Q' (PQ m) QR)
sim-compL Q-Q' (recvS PQ) QR = recvS (λ m → sim-comp Q-Q' (PQ m) QR)
sim-compL Q-Q' (sendD m PQ) QR = sendD m (sim-comp Q-Q' PQ QR)
sim-compL Q-Q' (sendS m PQ) QR = sendS m (sim-comp Q-Q' PQ QR)

sim-compR Q-Q' PQ (recvD QR)   = recvD (λ m → sim-comp Q-Q' PQ (QR m))
sim-compR Q-Q' PQ (recvS QR)   = recvS (λ x → sim-comp Q-Q' PQ (QR x))
sim-compR Q-Q' PQ (sendD m QR) = sendD m (sim-comp Q-Q' PQ QR)
sim-compR Q-Q' PQ (sendS m QR) = sendS m (sim-comp Q-Q' PQ QR)

{-
sim-comp : ∀ {P Q Q' R} → Dual Q Q' → Sim P Q → Sim Q' R → Sim P R
sim-comp Q-Q' (left (recvD PQ)) QR = left (recvD (λ m → sim-comp Q-Q' (PQ m) QR))
sim-comp Q-Q' (left (recvS PQ)) QR = left (recvS (λ m → sim-comp Q-Q' (PQ m) QR))
sim-comp Q-Q' (left (sendD m PQ)) QR = left (sendD m (sim-comp Q-Q' PQ QR))
sim-comp Q-Q' (left (sendS m PQ)) QR = left (sendS m (sim-comp Q-Q' PQ QR))
sim-comp end (right ()) (left x₁)
sim-comp end end QR = QR
sim-comp end PQ end = PQ
sim-comp (ΠΣ'S Q-Q') (right (recvS PQ)) (left (sendS m QR)) = sim-comp (Q-Q' m) (PQ m) QR
sim-comp (ΠΣ'D Q-Q') (right (recvD PQ)) (left (sendD m QR)) = sim-comp (Q-Q' m) (PQ m) QR
sim-comp (ΣΠ'S Q-Q') (right (sendS m PQ)) (left (recvS QR)) = sim-comp (Q-Q' m) PQ (QR m)
sim-comp (ΣΠ'D Q-Q') (right (sendD m PQ)) (left (recvD QR)) = sim-comp (Q-Q' m) PQ (QR m)
sim-comp Q-Q' PQ (right (recvD QR)) = right (recvD (λ m → sim-comp Q-Q' PQ (QR m)))
sim-comp Q-Q' PQ (right (recvS QR)) = right (recvS (λ x → sim-comp Q-Q' PQ (QR x)))
sim-comp Q-Q' PQ (right (sendD m QR)) = right (sendD m (sim-comp Q-Q' PQ QR))
sim-comp Q-Q' PQ (right (sendS m QR)) = right (sendS m (sim-comp Q-Q' PQ QR))
-}

_♦_ : ∀ {P Q R} → Sim P Q → Sim (dual Q) R → Sim P R
_♦_ = sim-comp (Dual-spec _)

⟹-comp : ∀ {P Q R} → P ⟹ Q → Q ⟹ R → P ⟹ R
⟹-comp = _♦_

sim-sym : ∀ {P Q} → Sim P Q → Sim Q P
sim-symL : ∀ {P Q} → SimL P Q → SimR Q P
sim-symR : ∀ {P Q} → SimR P Q → SimL Q P

sim-sym (left x) = right (sim-symL x)
sim-sym (right x) = left (sim-symR x)
sim-sym end = end

sim-symL (recvD PQ)   = recvD (λ m → sim-sym (PQ m))
sim-symL (recvS PQ)   = recvS (λ m → sim-sym (PQ m))
sim-symL (sendD m PQ) = sendD m (sim-sym PQ)
sim-symL (sendS m PQ) = sendS m (sim-sym PQ)

sim-symR (recvD PQ)   = recvD (λ m → sim-sym (PQ m))
sim-symR (recvS PQ)   = recvS (λ m → sim-sym (PQ m))
sim-symR (sendD m PQ) = sendD m (sim-sym PQ)
sim-symR (sendS m PQ) = sendS m (sim-sym PQ)

sim-unit : ∀ {P} → Sim end P → Process 𝟙 P
sim-unit (left ())
sim-unit (right (recvD P)) = do (recvD (λ m → sim-unit (P m)))
sim-unit (right (recvS P)) = do (recvS (λ m → sim-unit (P m)))
sim-unit (right (sendD m P)) = do (sendD m (sim-unit P))
sim-unit (right (sendS m P)) = do (sendS m (sim-unit P))
sim-unit end = end 0₁

module _ {P Q : Proto} where
  infix 2 _∼_
  _∼_ : (PQ PQ' : Sim P Q) → ★₁
  PQ ∼ PQ' = ∀ {P'} → (P'-P : Dual P' P) → (øP : Sim end P')
           → sim-comp P'-P øP PQ ≡ sim-comp P'-P øP PQ'

module _
  (funExtD : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  (funExtS : ∀ {a}{b}{A : ★_ a}{B : ..(_ : A) → ★_ b}{f g : ..(x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g)
  where
  sim-comp-assoc-end : ∀ {P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (øP : Sim end P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' øP PQ) QR
    ≡ sim-comp P-P' øP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc-end P-P' Q-Q' (left ()) PQ QR
  sim-comp-assoc-end end Q-Q' (right ()) (left PQ) QR
  sim-comp-assoc-end (ΠΣ'S x₁) Q-Q' (right (recvS x)) (left (sendS x₂ x₃)) QR
    = sim-comp-assoc-end (x₁ x₂) Q-Q' (x x₂) x₃ QR
  sim-comp-assoc-end (ΠΣ'D x₁) Q-Q' (right (recvD x)) (left (sendD x₂ x₃)) QR
    = sim-comp-assoc-end (x₁ x₂) Q-Q' (x x₂) x₃ QR
  sim-comp-assoc-end (ΣΠ'S x) Q-Q' (right (sendS x₁ x₂)) (left (recvS x₃)) QR
    = sim-comp-assoc-end (x x₁) Q-Q' x₂ (x₃ x₁) QR
  sim-comp-assoc-end (ΣΠ'D x) Q-Q' (right (sendD x₁ x₂)) (left (recvD x₃)) QR
    = sim-comp-assoc-end (x x₁) Q-Q' x₂ (x₃ x₁) QR
  sim-comp-assoc-end P-P' end (right øP) (right ()) (left x₁)
  sim-comp-assoc-end P-P' (ΠΣ'S x₁) (right øP) (right (recvS x)) (left (sendS x₂ x₃))
    = sim-comp-assoc-end P-P' (x₁ x₂) (right øP) (x x₂) x₃
  sim-comp-assoc-end P-P' (ΠΣ'D x₁) (right øP) (right (recvD x)) (left (sendD x₂ x₃))
    = sim-comp-assoc-end P-P' (x₁ x₂) (right øP) (x x₂) x₃
  sim-comp-assoc-end P-P' (ΣΠ'S x) (right øP) (right (sendS x₁ x₂)) (left (recvS x₃))
    = sim-comp-assoc-end P-P' (x x₁) (right øP) x₂ (x₃ x₁)
  sim-comp-assoc-end P-P' (ΣΠ'D x) (right øP) (right (sendD x₁ x₂)) (left (recvD x₃))
    = sim-comp-assoc-end P-P' (x x₁) (right øP) x₂ (x₃ x₁)
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (recvD x₁))
    = cong (right ∘ recvD) (funExtD (λ m → sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (x₁ m)))
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (recvS x₁))
    = cong (right ∘ recvS) (funExtS (λ m → sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (x₁ m)))
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (sendD x₁ x₂))
    = cong (right ∘ sendD x₁) (sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) x₂)
  sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) (right (sendS x₁ x₂))
    = cong (right ∘ sendS x₁) (sim-comp-assoc-end P-P' Q-Q' (right øP) (right x) x₂)
  sim-comp-assoc-end P-P' end (right øP) (right ()) end
  sim-comp-assoc-end end end (right øP) end QR = refl
  sim-comp-assoc-end end Q-Q' end PQ QR = refl

  ♦-assoc-end : ∀ {P Q R}(øP : Sim end P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (øP ♦ PQ) ♦ QR ≡ øP ♦ (PQ ♦ QR)
  ♦-assoc-end = sim-comp-assoc-end (Dual-spec _) (Dual-spec _)

  open ≡-Reasoning
  sim-comp-assoc : ∀ {W P P' Q Q' R}(P-P' : Dual P P')(Q-Q' : Dual Q Q')
    (WP : Sim W P)(PQ : Sim P' Q)(QR : Sim Q' R)
    → sim-comp Q-Q' (sim-comp P-P' WP PQ) QR
    ∼ sim-comp P-P' WP (sim-comp Q-Q' PQ QR)
  sim-comp-assoc P-P' Q-Q' WP PQ QR {W'} W'-W øW'
    = sim-comp W'-W øW' (sim-comp Q-Q' (sim-comp P-P' WP PQ) QR)
    ≡⟨ sym (sim-comp-assoc-end W'-W Q-Q' øW' (sim-comp P-P' WP PQ) QR) ⟩
      sim-comp Q-Q' (sim-comp W'-W øW' (sim-comp P-P' WP PQ)) QR
    ≡⟨ cong (λ X → sim-comp Q-Q' X QR) (sym (sim-comp-assoc-end W'-W P-P' øW' WP PQ)) ⟩
      sim-comp Q-Q' (sim-comp P-P' (sim-comp W'-W øW' WP) PQ) QR
    ≡⟨ sim-comp-assoc-end P-P' Q-Q' (sim-comp W'-W øW' WP) PQ QR ⟩
      sim-comp P-P' (sim-comp W'-W øW' WP) (sim-comp Q-Q' PQ QR)
    ≡⟨ sim-comp-assoc-end W'-W P-P' øW' WP (sim-comp Q-Q' PQ QR) ⟩
      sim-comp W'-W øW' (sim-comp P-P' WP (sim-comp Q-Q' PQ QR))
    ∎

  ♦-assoc : ∀ {W P Q R}(WP : Sim W P)(PQ : Sim (dual P) Q)(QR : Sim (dual Q) R)
    → (WP ♦ PQ) ♦ QR ∼ WP ♦ (PQ ♦ QR)
  ♦-assoc = sim-comp-assoc (Dual-spec _) (Dual-spec _)

sim-comp-! : ∀ {P Q Q' R}(Q-Q' : Dual Q Q')(PQ : Sim P Q)(Q'R : Sim Q' R)
  → sim-comp (Dual-sym Q-Q') (sim-sym Q'R) (sim-sym PQ) ≡ sim-sym (sim-comp Q-Q' PQ Q'R)
sim-comp-! Q-Q' (left (recvD x)) (left x₁) = {!!}
sim-comp-! Q-Q' (left (recvS x)) (left x₁) = {!!}
sim-comp-! Q-Q' (left (sendD x x₁)) (left x₂) = cong (right ∘ sendD x) (sim-comp-! Q-Q' x₁ (left x₂))
sim-comp-! Q-Q' (left (sendS x x₁)) (left x₂) = cong (right ∘ sendS x) (sim-comp-! Q-Q' x₁ (left x₂))
sim-comp-! Q-Q' (left x) (right x₁) = {!!}
sim-comp-! Q-Q' (left x) end = {!!}
sim-comp-! Q-Q' (right x) QR = {!!}
sim-comp-! end end (left x) = refl
sim-comp-! end end (right x) = {!!}
sim-comp-! end end end = refl
{-

unit-sim : ∀ {P} → Process 𝟙 P → Sim end P
unit-sim (do (send m x)) = right (send m (unit-sim x))
unit-sim (do (recv x)) = right (recv (λ m → unit-sim (x m)))
unit-sim (end x) = end

{-
toEl : ∀ {P A} → Process A P → El P (const A)
toEl (end x) = x
toEl (do (recv f)) = λ x → toEl (f x)
toEl (do (send m x)) = m , toEl x
-}

idP : ∀ {A} → Process A (Π' A (const end))
idP = do (recv end)

dual² : ∀ {P A} → Process A P → Process A (dual (dual P))
dual² (end x) = end x
dual² (do (recv x)) = do (recv (λ m → dual² (x m)))
dual² (do (send m x)) = do (send m (dual² x))

apply-sim : ∀ {P Q} → Sim P Q → P ⟹ᴾ Q
apply-sim (left (send m x)) (do (recv x₁)) = apply-sim x (x₁ m)
apply-sim (left (recv x)) (do (send m x₁)) = apply-sim (x m) x₁
apply-sim (right (send m x)) P₂ = do (send m (apply-sim x P₂))
apply-sim (right (recv x)) P₂ = do (recv (λ m → apply-sim (x m) P₂))
apply-sim end P = P

apply-sim' : ∀ {P Q} → Sim P Q → Q ⟹ᴾ P -- ∀ {A} → Process A Q → Process A (dual P)
apply-sim' PQ P = apply-sim (sim-sym PQ) P

apply : ∀ {P Q A} → P ⟹ Q → Process A P → Process A Q
apply PQ P = apply-sim PQ (dual² P)

module _ (funExt : ∀ {a}{b}{A : ★_ a}{B : A → ★_ b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g) where
  apply-comp : ∀ {P Q R A}(PQ : Sim P Q)(QR : Sim (dual Q) R)(p : Process A (dual P)) → apply-sim (sim-comp PQ QR) p ≡ apply QR (apply-sim PQ p)
  apply-comp (left (send m x)) QR (do (recv x₁)) = apply-comp x QR (x₁ m)
  apply-comp (left (recv x)) QR (do (send m x₁)) = apply-comp (x m) QR x₁
  apply-comp (right (send m x)) (left (recv x₁)) p = apply-comp x (x₁ m) p
  apply-comp (right (send m x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m' → apply-comp (right (send m x)) (x₁ m') p))
  apply-comp (right (send m x)) (right (send m₁ x₁)) p
    rewrite apply-comp (right (send m x)) x₁ p = refl
  apply-comp (right (recv x)) (left (send m x₁)) p = apply-comp (x m) x₁ p
  apply-comp (right (recv x)) (right (send m x₁)) p
    rewrite apply-comp (right (recv x)) x₁ p = refl
  apply-comp (right (recv x)) (right (recv x₁)) p = cong (λ X → do (recv X))
    (funExt (λ m → apply-comp (right (recv x)) (x₁ m) p))
  apply-comp end QR (do ())
  apply-comp end QR (end x) = refl

{-
_>>=P_ : ∀ {A B P}{Q : Tele P → Proto} → Process A P → ((p : Tele P) → A → Process B (Q p)) → Process B (P >>≡ Q)
send m p >>=P k = send m (p >>=P (λ p₁ → k (m , p₁)))
recv x >>=P k = recv (λ m → x m >>=P (λ p → k (m , p)))
end x >>=P k = k 0₁ x

  {-
module _ where
  bind-com : (P : Proto)(Q : Tele P → Proto)(R : Tele (dual P) → Proto)
    (X : Tele (P >>≡ Q) → ★)(Y : Tele (dual P >>≡ R) → ★)
    → El (P >>≡ Q) X → El (dual P >>≡ R) Y → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}


Readd instance

Readd instance

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Dependently typed changes (Def 3.4 and 3.5, Fig. 4b and 4e)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Denotation.Value as Value
open import Base.Change.Algebra as CA
  using (ChangeAlgebraFamily)

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

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

open import Base.Denotation.Notation public

open import Relation.Binary.PropositionalEquality
open import Level

-- Extension Point: Change algebras for base types
Structure : Set₁
Structure = ChangeAlgebraFamily zero ⟦_⟧Base

module Structure (change-algebra-base : Structure) where
  -- change algebras

  open CA public renaming
    ( [] to ∅
    ; _∷_ to _•_
    )

  -- We provide: change algebra for every type
  instance
    change-algebra : ∀ τ → ChangeAlgebra zero ⟦ τ ⟧Type
    change-algebra (base ι) = change-algebra₍_₎ {{change-algebra-base}} ι
    change-algebra (τ₁ ⇒ τ₂) = CA.FunctionChanges.changeAlgebra _ _ {{change-algebra τ₁}} {{change-algebra τ₂}}

    change-algebra-family : ChangeAlgebraFamily zero ⟦_⟧Type
    change-algebra-family = family change-algebra

  -- function changes

  open FunctionChanges public using (cons)
  module _ {τ₁ τ₂ : Type} where
    open FunctionChanges.FunctionChange _ _ {{change-algebra τ₁}} {{change-algebra τ₂}} public
      renaming
        ( correct to is-valid
        ; apply to call-change
        )

  -- We also provide: change environments (aka. environment changes).

  open ListChanges ⟦_⟧Type {{change-algebra-family}} public using () renaming
    ( changeAlgebra to environment-changes
    )

  after-env : ∀ {Γ : Context} → {ρ : ⟦ Γ ⟧} (dρ : Δ₍_₎ {{environment-changes}} Γ ρ) → ⟦ Γ ⟧
  after-env {Γ} = after₍_₎ Γ


Added foldr.

Added foldr.

Ignore-this: ea015214744665e73d11c17cfab71321

darcs-hash:20100702160458-3bd4e-fbf3e5957dd6548bc9fe93f1963cdf972226d6c0.gz

------------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------------

module LTC.Data.List where

open import LTC.Minimal

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

infixr 5 _∷_ _++_

-- List terms
postulate
  []   : D
  _∷_  : D → D → D

-- Basic functions

postulate
  length : D → D
  length-[] : length []                     ≡ zero
  length-∷  : ( d ds : D) → length (d ∷ ds) ≡ succ (length ds)
{-# ATP axiom length-[] #-}
{-# ATP axiom length-∷ #-}

postulate
  _++_  : D → D → D
  ++-[] : (ds : D) → [] ++ ds            ≡ ds
  ++-∷  : (d ds es : D) → (d ∷ ds) ++ es ≡ d ∷ (ds ++ es)
{-# ATP axiom ++-[] #-}
{-# ATP axiom ++-∷ #-}

-- List transformations

postulate
  map    : D → D → D
  map-[] : (f : D ) → map f []           ≡ []
  map-∷  : (f d ds : D) → map f (d ∷ ds) ≡ f ∙ d ∷ map f ds
{-# ATP axiom map-[] #-}
{-# ATP axiom map-∷ #-}

postulate
  reverse    : D → D
  reverse-[] : reverse []                    ≡ []
  reverse-∷  : (d ds : D) → reverse (d ∷ ds) ≡ reverse ds ++ d ∷ []
{-# ATP axiom reverse-[] #-}
{-# ATP axiom reverse-∷ #-}

postulate
  replicate : D → D → D
  replicate-0 : (d : D) → replicate zero d       ≡ []
  replicate-S : (d e : D) → replicate (succ e) d ≡ d ∷ replicate e d
{-# ATP axiom replicate-0 #-}
{-# ATP axiom replicate-S #-}

-- Reducing lists

postulate
  foldr    : D → D → D → D
  foldr-[] : (f n : D) → foldr f n []            ≡ n
  foldr-∷  : (f n d ds : D) → foldr f n (d ∷ ds) ≡ f ∙ d ∙ (foldr f n ds)
{-# ATP axiom foldr-[] #-}
{-# ATP axiom foldr-∷ #-}

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

-- The LTC list data type
data List : D → Set where
  nil  : List []
  cons : (d : D){ds : D} → (dsL : List ds) → List (d ∷ ds)

-- Induction principle for List
indList : (P : D → Set) →
          P [] →
          ((d : D){ds : D} → List ds → P ds → P (d ∷ ds)) →
          {ds : D} → List ds → P ds
indList P p[] iStep nil               = p[]
indList P p[] iStep (cons d {ds} dsL) = iStep d dsL (indList P p[] iStep dsL)

------------------------------------------------------------------------------
-- Lists
------------------------------------------------------------------------------

module LTC.Data.List where

open import LTC.Minimal

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

infixr 5 _∷_ _++_

-- List terms
postulate
  []   : D
  _∷_  : D → D → D

-- Basic functions

postulate
  length : D → D
  length-[] : length []                     ≡ zero
  length-∷  : ( d ds : D) → length (d ∷ ds) ≡ succ (length ds)
{-# ATP axiom length-[] #-}
{-# ATP axiom length-∷ #-}

postulate
  _++_  : D → D → D
  ++-[] : (ds : D) → [] ++ ds            ≡ ds
  ++-∷  : (d ds es : D) → (d ∷ ds) ++ es ≡ d ∷ (ds ++ es)
{-# ATP axiom ++-[] #-}
{-# ATP axiom ++-∷ #-}

-- List transformations

postulate
  map    : D → D → D
  map-[] : (f : D ) → map f []           ≡ []
  map-∷  : (f d ds : D) → map f (d ∷ ds) ≡ f ∙ d ∷ map f ds
{-# ATP axiom map-[] #-}
{-# ATP axiom map-∷ #-}

postulate
  reverse    : D → D
  reverse-[] : reverse []                    ≡ []
  reverse-∷  : (d ds : D) → reverse (d ∷ ds) ≡ reverse ds ++ d ∷ []
{-# ATP axiom reverse-[] #-}
{-# ATP axiom reverse-∷ #-}

postulate
  replicate : D → D → D
  replicate-0 : (d : D) → replicate zero d       ≡ []
  replicate-S : (d e : D) → replicate (succ e) d ≡ d ∷ replicate e d
{-# ATP axiom replicate-0 #-}
{-# ATP axiom replicate-S #-}

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

-- The LTC list data type
data List : D → Set where
  nil  : List []
  cons : (d : D){ds : D} → (dsL : List ds) → List (d ∷ ds)

-- Induction principle for List
indList : (P : D → Set) →
          P [] →
          ((d : D){ds : D} → List ds → P ds → P (d ∷ ds)) →
          {ds : D} → List ds → P ds
indList P p[] iStep nil               = p[]
indList P p[] iStep (cons d {ds} dsL) = iStep d dsL (indList P p[] iStep dsL)


Minor changes.

Minor changes.

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

-- Based on (Vene, 2000).

module Functors where

infixr 1 _+_
infixr 2 _×_

data Bool : Set where
  false true : Bool

data _+_  (A B : Set) : Set where
  inl : A → A + B
  inr : B → A + B

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

-- The terminal object.
data ⊤ : Set where
   <> : ⊤

postulate
  -- The least fixed-point.

  -- Haskell definitions:

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  μ    : (Set → Set) → Set
  In   : {F : Set → Set} → F (μ F) → μ F
  unIn : {F : Set → Set} → μ F → F (μ F)

postulate
  -- The greatest fixed-point.

  -- Haskell definitions:

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  ν    : (Set → Set) → Set
  Wrap : {F : Set → Set} → F (ν F) → ν F
  out  : {F : Set → Set} → ν F → F (ν F)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = ⊤ + X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = ⊤ + A × X

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = μ IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = μ NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl <>)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = μ (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl <>)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = ν IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conaturals type is a greatest fixed-point.
Conat : Set
Conat = ν NatF

zeroC : Conat
zeroC = Wrap (inl <>)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- TODO: The conat destructor.
pred : Conat → ⊤ + Conat
pred cn with out cn
... | inl _ = inl <>
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = ν (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl <>)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = ν (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

------------------------------------------------------------------------------
-- References
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.

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

module Functors where

-- The carrier of the initial algebra is (up to isomorphism) a
-- fixed-point of the functor (Vene 2000, p).

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

data Bool : Set where
  false true : Bool

data _⊎_  (A B : Set) : Set where
  inl : A → A ⊎ B
  inr : B → A ⊎ B

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

-- The terminal object.
data One : Set where
   one : One

postulate
  -- The least fixed-point.

  -- Haskell definitions:

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  μ    : (Set → Set) → Set
  In   : {F : Set → Set} → F (μ F) → μ F
  unIn : {F : Set → Set} → μ F → F (μ F)

postulate
  -- The greatest fixed-point.

  -- Haskell definitions:

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  ν    : (Set → Set) → Set
  Wrap : {F : Set → Set} → F (ν F) → ν F
  out  : {F : Set → Set} → ν F → F (ν F)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = One ⊎ X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = One ⊎ (A × X)

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = μ IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = μ NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl one)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = μ (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl one)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = ν IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conaturals type is a greatest fixed-point.
Conat : Set
Conat = ν NatF

zeroC : Conat
zeroC = Wrap (inl one)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- TODO: The conat destructor.
pred : Conat → One ⊎ Conat
pred cn with out cn
... | inl _ = inl one
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = ν (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl one)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = ν (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

------------------------------------------------------------------------------
-- References
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.


Inline Structure module

Inline Structure module

Old-commit-hash: a1f90eeec3bbf0ee39c738ae1cb8b8557443544c

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
  -- Delta-observational equivalence: these asserts that two changes
  -- give the same result when applied to a base value.
  _≙_ : ∀ dx dy → Set a
  dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

  -- _≙_ is indeed an equivalence relation:
  ≙-refl : ∀ {dx} → dx ≙ dx
  ≙-refl = refl

  ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
  ≙-symm ≙ = sym ≙

  ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
  ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

  -- TODO: we want to show that all functions of interest respect
  -- delta-observational equivalence, so that two d.o.e. changes can be
  -- substituted for each other freely.
  --
  -- * That should be be true for
  --   functions using changes parametrically.
  --
  -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
  --   this is proved below on both contexts at once by fun-change-respects.
  --
  -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
  --   it by definition, and ⊟ doesn't take change arguments - we will only
  --   need a proof for compose, when we define it.
  --
  -- Stating the general result, though, seems hard, we should
  -- rather have lemmas proving that certain classes of functions respect this
  -- equivalence.

module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
  {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

  module FC = FunctionChanges A B {{CA}} {{CB}}
  open FC using (changeAlgebra; incrementalization)
  open FC.FunctionChange

  fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
    df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
  fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
    where
      open ≡-Reasoning
      -- This type signature just expands the goal manually a bit.
      lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
      -- Informally: use incrementalization on both sides and then apply
      -- congruence.
      lemma =
        begin
          f x ⊞ apply df₁ x dx₁
        ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
          (f ⊞ df₁) (x ⊞ dx₁)
        ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
          (f ⊞ df₁) (x ⊞ dx₂)
        ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
          (f ⊞ df₂) (x ⊞ dx₂)
        ≡⟨ incrementalization f df₂ x dx₂ ⟩
          f x ⊞ apply df₂ x dx₂
        ∎

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence
------------------------------------------------------------------------
module Base.Change.Equivalence where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit

module Structure where

  module _ {a ℓ} {A : Set a} {{ca : ChangeAlgebra ℓ A}} {x : A} where
    -- Delta-observational equivalence: these asserts that two changes
    -- give the same result when applied to a base value.
    _≙_ : ∀ dx dy → Set a
    dx ≙ dy = x ⊞ dx ≡ x ⊞ dy

    -- _≙_ is indeed an equivalence relation:
    ≙-refl : ∀ {dx} → dx ≙ dx
    ≙-refl = refl

    ≙-symm : ∀ {dx dy} → dx ≙ dy → dy ≙ dx
    ≙-symm ≙ = sym ≙

    ≙-trans : ∀ {dx dy dz} → dx ≙ dy → dy ≙ dz → dx ≙ dz
    ≙-trans ≙₁ ≙₂ = trans ≙₁ ≙₂

    -- TODO: we want to show that all functions of interest respect
    -- delta-observational equivalence, so that two d.o.e. changes can be
    -- substituted for each other freely.
    --
    -- * That should be be true for
    --   functions using changes parametrically.
    --
    -- * Moreover, d.o.e. should be respected by contexts [ ] x dx and df x [ ];
    --   this is proved below on both contexts at once by fun-change-respects.
    --
    -- * Finally, change algebra operations should respect d.o.e. But ⊞ respects
    --   it by definition, and ⊟ doesn't take change arguments - we will only
    --   need a proof for compose, when we define it.
    --
    -- Stating the general result, though, seems hard, we should
    -- rather have lemmas proving that certain classes of functions respect this
    -- equivalence.

  module _ {a} {b} {c} {d} {A : Set a} {B : Set b}
    {{CA : ChangeAlgebra c A}} {{CB : ChangeAlgebra d B}} where

    module FC = FunctionChanges A B {{CA}} {{CB}}
    open FC using (changeAlgebra; incrementalization)
    open FC.FunctionChange

    fun-change-respects : ∀ {x : A} {dx₁ dx₂ : Δ x} {f : A → B} {df₁ df₂} →
      df₁ ≙ df₂ → dx₁ ≙ dx₂ → apply df₁ x dx₁ ≙ apply df₂ x dx₂
    fun-change-respects {x} {dx₁} {dx₂} {f} {df₁} {df₂} df₁≙df₂ dx₁≙dx₂ = lemma
      where
        open ≡-Reasoning
        -- This type signature just expands the goal manually a bit.
        lemma : f x ⊞ apply df₁ x dx₁ ≡ f x ⊞ apply df₂ x dx₂
        -- Informally: use incrementalization on both sides and then apply
        -- congruence.
        lemma =
          begin
            f x ⊞ apply df₁ x dx₁
          ≡⟨ sym (incrementalization f df₁ x dx₁) ⟩
            (f ⊞ df₁) (x ⊞ dx₁)
          ≡⟨ cong (f ⊞ df₁) dx₁≙dx₂ ⟩
            (f ⊞ df₁) (x ⊞ dx₂)
          ≡⟨ cong (λ f → f (x ⊞ dx₂)) df₁≙df₂ ⟩
            (f ⊞ df₂) (x ⊞ dx₂)
          ≡⟨ incrementalization f df₂ x dx₂ ⟩
            f x ⊞ apply df₂ x dx₂
          ∎


Fix some concrete non-sense about the division

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)

open import Function

open import Relation.Binary.PropositionalEquality.NP
open import Relation.Nullary

record ]0,1]-ops (]0,1] : Set) (_≤E_ : ]0,1] → ]0,1] → Set) : Set where
  constructor mk
  field
    1E : ]0,1]
    _+E_ : ]0,1] → ]0,1] → ]0,1]
    _·E_ : ]0,1] → ]0,1] → ]0,1]
    _/E_<_> : (x y : ]0,1]) → x ≤E y → ]0,1]

module [0,1] {]0,1] _≤E_} (]0,1]R : ]0,1]-ops ]0,1] _≤E_) where

  open ]0,1]-ops ]0,1]R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   _I : ]0,1] → [0,1]

  data _≤I_ : [0,1] → [0,1] → Set where
    z≤n : ∀ {n} → 0I ≤I n
    E≤E : ∀ {x y} → x ≤E y → (x I) ≤I (y I)

  1I : [0,1]
  1I = 1E I

  Pos : [0,1] → Set
  Pos 0I    = ⊥
  Pos (_ I) = ⊤

  _<_> : (x : [0,1]) → Pos x → ]0,1]
  0I < () >
  (x I) < pos > = x

  _+I_ : [0,1] → [0,1] → [0,1]
  0I +I x = x
  x I +I 0I = x I
  x I +I x₁ I = (x +E x₁) I

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  (x I) ·I 0I = 0I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  -- 1/I1+_ : ℕ → [0,1]

  _/I_<_,_> : (x y : [0,1]) → x ≤I y → Pos y → [0,1]
  _  /I 0I < _ , () >
  0I /I _  < _ , _ > = 0I
  (x I) /I (y I) < E≤E pf , _ > = (x /E y < pf >)I

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  postulate
    +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
    +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)

    ≤I-refl : {x : [0,1]} → x ≤I x

    ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
    ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
    ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z

module Univ {]0,1] _≤E_} (]0,1]R : ]0,1]-ops ]0,1] _≤E_)
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1]R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP P []       = 0I
  sumP P (x ∷ xs) = (P x) +I (sumP P xs)

  module Prob (P : U → [0,1])
              (sumP≡1 : sumP P allU ≡ 1I) where

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then P x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    _⊆_ : Event → Event → Set
    A ⊆ B = ∀ x → T(A x) → T(B x)

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    postulate
      Pr-mono : ∀ {A B} → A ⊆ B → Pr[ A ] ≤I Pr[ B ]

    ∪-lem : ∀ {A} B → A ⊆ (A ∪ B)
    ∪-lem {A} _ x with A x
    ... | true = id
    ... | false = λ()

    ∩-lem : ∀ A {B} → (A ∩ B) ⊆ B
    ∩-lem A x with A x
    ... | true  = id
    ... | false = λ()

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < Pr-mono (∩-lem A) , pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (P x) (sA₁ xs) (P x +I sA₂ xs)
                                | +I-sym (P x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (P x))
                                = ≤I-pres (P x) (≤I-mono (P x) (go xs))
      ... | true  | false rewrite +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (P x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (P x)
                                | +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)

module Prob where

open import Data.Bool
open import Data.Nat
open import Data.Vec

open import Function

open import Relation.Binary.PropositionalEquality.NP
open import Relation.Nullary

record ]0,1]-ops (]0,1] : Set) : Set where
  field
    1E : ]0,1]
    _+E_ : ]0,1] → ]0,1] → ]0,1]
    _·E_ : ]0,1] → ]0,1] → ]0,1]
    1/E_ : ]0,1] → ]0,1]

module [0,1] {]0,1]}(]0,1]R : ]0,1]-ops ]0,1]) where

  open ]0,1]-ops ]0,1]R public

  infixl 6 _+I_
  infix 4 _≤I_

  data [0,1] : Set where
   0I : [0,1]
   _I : ]0,1] → [0,1]

  1I : [0,1]
  1I = 1E I

  Pos : [0,1] → Set
  Pos x = ¬ (x ≡ 0I)

  _<_> : (x : [0,1]) → Pos x → ]0,1]
  0I < pos > with pos refl
  ... | ()
  (x I) < pos > = x

  _+I_ : [0,1] → [0,1] → [0,1]
  0I +I x = x
  x I +I 0I = x I
  x I +I x₁ I = (x +E x₁) I

  _·I_ : [0,1] → [0,1] → [0,1]
  0I ·I y = 0I
  (x I) ·I 0I = 0I
  (x I) ·I (x₁ I) = (x ·E x₁) I

  1/I_ : ]0,1] → [0,1]
  1/I x = (1/E x) I

  _/I_ : [0,1] → ]0,1] → [0,1]
  x /I y = x ·I (1/I y)

  +I-identity : (x : [0,1]) → x ≡ 0I +I x
  +I-identity x = refl

  postulate
    +I-sym : (x y : [0,1]) → x +I y ≡ y +I x
    +I-assoc : (x y z : [0,1]) → x +I y +I z ≡ x +I (y +I z)

    _≤I_ : [0,1] → [0,1] → Set
    ≤I-refl : {x : [0,1]} → x ≤I x

    ≤I-trans : {x y z : [0,1]} → x ≤I y → y ≤I z → x ≤I z
    ≤I-mono  : (x : [0,1]){y z : [0,1]} → y ≤I z → y ≤I z +I x
    ≤I-pres  : (x : [0,1]){y z : [0,1]} → y ≤I z → x +I y ≤I x +I z

module Univ ( ]0,1] : Set)(]0,1]R : ]0,1]-ops ]0,1])
            (U : Set)
            (size-1 : ℕ)
            (allU : Vec U (suc size-1))
            (x∈allU : (x : U) → x ∈ allU)  where

  open [0,1] ]0,1]R

  sumP : {n : ℕ} → (U → [0,1]) → Vec U n → [0,1]
  sumP P []       = 0I
  sumP P (x ∷ xs) = (P x) +I (sumP P xs)

  module Prob (P : U → [0,1])
              (sumP≡1 : sumP P allU ≡ 1I) where

    Event : Set
    Event = U → Bool

    pr_∋_ : Event → U → [0,1]
    pr A ∋ x = if A x then P x else 0I

    _∪_ : Event → Event → Event
    A₁ ∪ A₂ = λ x → A₁ x ∨ A₂ x

    _∩_ : Event → Event → Event
    A₁ ∩ A₂ = λ x → A₁ x ∧ A₂ x

    ℂ[_] : Event → Event
    ℂ[ A ] = not ∘ A

    Pr[_] : Event → [0,1]
    Pr[ A ] = sumP (pr_∋_ A) allU

    Pr[_∣_]<_> : (A B : Event)(pf : Pos Pr[ B ]) → [0,1]
    Pr[ A ∣ B ]< pr > = Pr[ A ∩ B ] /I Pr[ B ] < pr >

    _ind_ : (A B : Event) → Set
    A ind B = Pr[ A ] ·I Pr[ B ] ≡ Pr[ A ∩ B ]

    union-bound : (A₁ A₂ : Event) → Pr[ (A₁ ∪ A₂) ] ≤I Pr[ A₁ ] +I Pr[ A₂ ]
    union-bound A₁ A₂ = go allU where
      sA₁ : {n : ℕ} → Vec U n → [0,1]
      sA₁ = λ xs → sumP (pr_∋_ A₁) xs
      sA₂ : {n : ℕ} → Vec U n → [0,1]
      sA₂ = sumP (pr_∋_ A₂)
      go : {n : ℕ}(xs : Vec U n) → sumP (pr_∋_ (A₁ ∪ A₂)) xs ≤I sumP (pr_∋_ A₁) xs +I sumP (pr_∋_ A₂) xs
      go [] = ≤I-refl
      go (x ∷ xs) with A₁ x | A₂ x
      ... | true  | true  rewrite +I-assoc (P x) (sA₁ xs) (P x +I sA₂ xs)
                                | +I-sym (P x) (sA₂ xs)
                                | sym (+I-assoc (sA₁ xs) (sA₂ xs) (P x))
                                = ≤I-pres (P x) (≤I-mono (P x) (go xs))
      ... | true  | false rewrite +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | true  rewrite sym (+I-assoc (sA₁ xs) (P x) (sA₂ xs))
                                | +I-sym (sA₁ xs) (P x)
                                | +I-assoc (P x) (sA₁ xs) (sA₂ xs)
                                = ≤I-pres (P x) (go xs)
      ... | false | false = go xs

    module RandomVar (V : Set) (_==V_ : V → V → Bool) where
       RV : Set
       RV = U → V

       _^-1_ : RV → V → Event
       RV ^-1 v = λ x → RV x ==V v

       _≡r_ : RV → V → Event
       RV ≡r v = RV ^-1 v

       -- sugar, socker et sucre
       Pr[_≡_] : RV → V → [0,1]
       Pr[ X ≡ v ] = Pr[ X ≡r v ]

       -- ∀ (a b) . Pr[X = a and Y = b] = Pr[X = a] · Pr[Y = b]
       _indRV_ : RV → RV → Set
       X indRV Y = (a b : V) → (X ^-1 a) ind (Y ^-1 b)


Cleaning

Cleaning

{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.DarkwingDuck.Primitive
module Spire.DarkwingDuck.Derived where

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

ISet : Set → Set
ISet I = I → Set

Enum : Set
Enum = List String

Tag : Enum → Set
Tag xs = Elem String xs

proj₁ : ∀{A B} → Σ A B → A
proj₁ = elimPair _ (λ a b → a)

proj₂ : ∀{A B} (ab : Σ A B) → B (proj₁ ab)
proj₂ = elimPair _ (λ a b → b)

BranchesM : Enum → Set
BranchesM E = (P : Tag E → Set) → Set

Branches : (E : Enum) → BranchesM E
Branches = elimList BranchesM
  (λ P → ⊤)
  (λ l E ih P → Σ (P here) (λ _ → ih (λ t → P (there t))))

Case : (E : Enum) → Tag E → Set
Case E t = (P : Tag E → Set) (cs : Branches E P) → P t

case' : (E : Enum) (t : Tag E) → Case E t
case' = elimElem String Case
  (λ l E P c,cs → elimPair (λ _ → P here) (λ a b → a) c,cs)
  (λ l E t ih P c,cs → ih (λ t → P (there t)) (elimPair (λ _ → Branches E (λ t → P (there t))) (λ a b → b) c,cs))

case : (E : Enum) (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case E P cs t = case' E t P cs

Scope  : Tel → Set
Scope = elimTel (λ _ → Set) ⊤ (λ A B ih → Σ A ih)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranchesM : Enum → Set
CurriedBranchesM E = (P : Tag E → Set) (X : Set) → Set

CurriedBranches : (E : Enum) → CurriedBranchesM E
CurriedBranches = elimList CurriedBranchesM
  (λ P X → X)
  (λ l E ih P X → P here → ih (λ t → P (there t)) X)

CurryBranches : Enum → Set
CurryBranches E = (P : Tag E → Set) (X : Set) → UncurriedBranches E P X → CurriedBranches E P X

curryBranches : (E : Enum) → CurryBranches E
curryBranches = elimList CurryBranches
  (λ P X f → f tt)
  (λ l E ih P X f c → ih (λ t → P (there t)) X (λ cs → f (c , cs)))

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

UncurriedScope : (T : Tel) (X : Scope T → Set) → Set
UncurriedScope T X = (xs : Scope T) → X xs

CurriedScope : (T : Tel) (X : Scope T → Set) → Set
CurriedScope = elimTel
  (λ T → (X : Scope T → Set) → Set)
  (λ X → X tt)
  (λ A B ih X → (a : A) → ih a (λ b → X (a , b)))

CurryScope : Tel → Set
CurryScope T = (X : Scope T → Set) → UncurriedScope T X → CurriedScope T X

curryScope : (T : Tel) → CurryScope T
curryScope = elimTel CurryScope
  (λ X f → f tt)
  (λ A B ih X f a → ih a (λ b → X (a , b)) (λ b → f (a , b)))

UncurryScope : Tel → Set
UncurryScope T = (X : Scope T → Set) → CurriedScope T X → UncurriedScope T X

uncurryScope : (T : Tel) → UncurryScope T
uncurryScope = elimTel UncurryScope
  (λ X x → elimUnit X x)
  (λ A B ih X f → elimPair X (λ a b → ih a (λ b → X (a , b)) (f a) b))

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

UncurriedFunc : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedFunc I D X = (i : I) → Func I D X i → X i

CurriedFunc : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedFunc I = elimDesc
  (λ _ → (X : ISet I) → Set)
  (λ i X → X i)
  (λ i D ih X → (x : X i) → ih X )
  (λ A B ih X → (a : A) → ih a X)

curryFunc : (I : Set) (D : Desc I) (X : ISet I)
  → UncurriedFunc I D X → CurriedFunc I D X
curryFunc I = elimDesc
  (λ D → (X : ISet I) → UncurriedFunc I D X → CurriedFunc I D X)
  (λ i X cn → cn i refl)
  (λ i D ih X cn x → ih X (λ j xs → cn j (x , xs)))
  (λ A B ih X cn a → ih a X (λ j xs → cn j (a , xs)))

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

UncurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedFunc I D X)
  → Set
UncurriedHyps I D X P cn =
  (i : I) (xs : Func I D X i) (ihs : Hyps I D X P i xs) → P i (cn i xs)

CurriedHypsM : (I : Set) (D : Desc I) → Set
CurriedHypsM I D = (X : ISet I) (P : (i : I) → X i → Set) (cn : UncurriedFunc I D X) → Set

CurriedHyps : (I : Set) (D : Desc I) → CurriedHypsM I D
CurriedHyps I = elimDesc (CurriedHypsM I)
  (λ i X P cn → P i (cn i refl))
  (λ i D ih X P cn → (x : X i) → P i x → ih X P (λ j xs → cn j (x , xs)))
  (λ A B ih X P cn → (a : A) → ih a X P (λ j xs → cn j (a , xs)))

UncurryHyps : (I : Set) (D : Desc I) → Set
UncurryHyps I D = (X : ISet I) (P : (i : I) → X i → Set) (cn : UncurriedFunc I D X)
  → CurriedHyps I D X P cn → UncurriedHyps I D X P cn

uncurryHyps : (I : Set) (D : Desc I) → UncurryHyps I D
uncurryHyps I = elimDesc
  (UncurryHyps I)
  (λ j X P cn pf →
    elimEq _ (λ u → pf))
  (λ j D ih X P cn pf i →
    elimPair _ (λ x xs ih,ihs →
      ih X P (λ j ys → cn j (x , ys)) (pf x (proj₁ ih,ihs)) i xs (proj₂ ih,ihs)))
  (λ A B ih X P cn pf i →
    elimPair _ (λ a xs → ih a X P (λ j ys → cn j (a , ys)) (pf a) i xs))

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

record Data : Set where
  field
    N : String
    P : Tel
    I : Scope P → Tel
    E : Enum
    B : (p : Scope P) → Branches E (λ _ → Desc (Scope (I p)))

  PS : Set
  PS = Scope P

  IS : PS → Set
  IS p = Scope (I p)

  C : (p : PS) → Tag E → Desc (IS p)
  C p = case E (λ _ → Desc (IS p)) (B p)

  D : (p : PS) → Desc (IS p)
  D p = Arg (Tag E) (C p)

  F : (p : PS) → IS p → Set
  F p = μ N PS IS p (D p)

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

Decl :
  (N : String)
  (P : Tel)
  (I : CurriedScope P (λ _ → Tel))
  (E : Enum)
  (B : let I = uncurryScope P (λ _ → Tel) I
      in CurriedScope P λ A → Branches E (λ _ → Desc (Scope (I A))))
  → Data
Decl N P I E B = record
  { N = N
  ; P = P
  ; I = uncurryScope P _ I
  ; E = E
  ; B = uncurryScope P _ B
  }

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

End[_] : (I : Tel)
  → CurriedScope I (λ _ → Desc (Scope I))
End[_] I = curryScope I _ End

Rec[_] : (I : Tel)
  → CurriedScope I (λ _ → Desc (Scope I) → Desc (Scope I))
Rec[_] I = curryScope I _ Rec

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

FormUncurried : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → UncurriedScope (Data.I R p) λ i
  → Set
FormUncurried = Data.F

Form : (R : Data)
  → CurriedScope (Data.P R) λ p
  → CurriedScope (Data.I R p) λ i
  → Set
Form R =
  curryScope (Data.P R) (λ p → CurriedScope (Data.I R p) λ i → Set) λ p →
  curryScope (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → CurriedFunc (Data.IS R p) (Data.D R p) (Data.F R p)
injUncurried R p t = curryFunc (Data.IS R p) (Data.C R p t)
  (Data.F R p)
  (λ i xs → init (t , xs))

inj : (R : Data)
  → CurriedScope (Data.P R) λ p
  → CurriedFunc (Data.IS R p) (Data.D R p) (Data.F R p)
inj R = curryScope (Data.P R)
  (λ p → CurriedFunc (Data.IS R p) (Data.D R p) (Data.F R p))
  (injUncurried R)

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

indCurried : (ℓ : String) (P : Set) (I : P → Set) (p : P) (D : Desc (I p))
  (M : (i : I p) → μ ℓ P I p D i → Set)
  (f : CurriedHyps (I p) D (μ ℓ P I p D) M (λ _ → init))
  (i : I p)
  (x : μ ℓ P I p D i)
  → M i x
indCurried ℓ P I p D M f i x =
  ind ℓ P I p D M (uncurryHyps (I p) D (μ ℓ P I p D) M (λ _ → init) f) i x

SumCurriedHyps : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M in
  CurriedHyps (Data.IS R p) (Data.C R p t) (Data.F R p) unM (λ i xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
  → let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
  in UncurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x))
elimUncurried R p M cs = let
    unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
  in
  curryScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x) λ i x →
  indCurried (Data.N R) (Data.PS R) (Data.IS R) p (Data.D R p) unM
    (case (Data.E R) (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → CurriedScope (Data.P R) λ p
  → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
  → let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
  in CurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x))
elim R = curryScope (Data.P R)
  (λ p → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
    → let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
    in CurriedBranches (Data.E R)
       (SumCurriedHyps R p M)
       (CurriedScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x)))
  (λ p M → curryBranches (Data.E R) _ _
    (elimUncurried R p M))

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

{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.DarkwingDuck.Primitive
module Spire.DarkwingDuck.Derived where

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

ISet : Set → Set
ISet I = I → Set

Enum : Set
Enum = List String

Tag : Enum → Set
Tag xs = Elem String xs

proj₁ : ∀{A B} → Σ A B → A
proj₁ = elimPair _ (λ a b → a)

proj₂ : ∀{A B} (ab : Σ A B) → B (proj₁ ab)
proj₂ = elimPair _ (λ a b → b)

Branches : (E : List String) (P : Tag E → Set) → Set
Branches = elimList (λ E → (P : Tag E → Set) → Set)
  (λ P → ⊤)
  (λ l E ih P → Σ (P here) (λ _ → ih (λ t → P (there t))))

case' : (E : List String) (t : Tag E) (P : Tag E → Set) (cs : Branches E P) → P t
case' = elimElem String (λ E t → (P : Tag E → Set) (cs : Branches E P) → P t)
  (λ l E P c,cs → elimPair (λ _ → P here) (λ a b → a) c,cs)
  (λ l E t ih P c,cs → ih (λ t → P (there t)) (elimPair (λ _ → Branches E (λ t → P (there t))) (λ a b → b) c,cs))

case : {E : List String} (P : Tag E → Set) (cs : Branches E P) (t : Tag E) → P t
case P cs t = case' _ t P cs

Scope  : Tel → Set
Scope = elimTel (λ _ → Set) ⊤ (λ A B ih → Σ A ih)

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

UncurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
UncurriedBranches E P X = Branches E P → X

CurriedBranches : (E : Enum) (P : Tag E → Set) (X : Set)
  → Set
CurriedBranches = elimList
  (λ E → (P : Tag E → Set) (X : Set) → Set)
  (λ P X → X)
  (λ l E ih P X → P here → ih (λ t → P (there t)) X)

CurryBranches : Enum → Set
CurryBranches E = (P : Tag E → Set) (X : Set) → UncurriedBranches E P X → CurriedBranches E P X

curryBranches : (E : Enum) → CurryBranches E
curryBranches = elimList CurryBranches
  (λ P X f → f tt)
  (λ l E ih P X f c → ih (λ t → P (there t)) X (λ cs → f (c , cs)))

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

UncurriedScope : (T : Tel) (X : Scope T → Set) → Set
UncurriedScope T X = (xs : Scope T) → X xs

CurriedScope : (T : Tel) (X : Scope T → Set) → Set
CurriedScope = elimTel
  (λ T → (X : Scope T → Set) → Set)
  (λ X → X tt)
  (λ A B ih X → (a : A) → ih a (λ b → X (a , b)))

CurryScope : Tel → Set
CurryScope T = (X : Scope T → Set) → UncurriedScope T X → CurriedScope T X

curryScope : (T : Tel) → CurryScope T
curryScope = elimTel CurryScope
  (λ X f → f tt)
  (λ A B ih X f a → ih a (λ b → X (a , b)) (λ b → f (a , b)))

UncurryScope : Tel → Set
UncurryScope T = (X : Scope T → Set) → CurriedScope T X → UncurriedScope T X

uncurryScope : (T : Tel) → UncurryScope T
uncurryScope = elimTel UncurryScope
  (λ X x → elimUnit X x)
  (λ A B ih X f → elimPair X (λ a b → ih a (λ b → X (a , b)) (f a) b))

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

UncurriedFunc : (I : Set) (D : Desc I) (X : ISet I) → Set
UncurriedFunc I D X = (i : I) → Func I D X i → X i

CurriedFunc : (I : Set) (D : Desc I) (X : ISet I) → Set
CurriedFunc I = elimDesc
  (λ _ → (X : ISet I) → Set)
  (λ i X → X i)
  (λ i D ih X → (x : X i) → ih X )
  (λ A B ih X → (a : A) → ih a X)

curryFunc : (I : Set) (D : Desc I) (X : ISet I)
  → UncurriedFunc I D X → CurriedFunc I D X
curryFunc I = elimDesc
  (λ D → (X : ISet I) → UncurriedFunc I D X → CurriedFunc I D X)
  (λ i X cn → cn i refl)
  (λ i D ih X cn x → ih X (λ j xs → cn j (x , xs)))
  (λ A B ih X cn a → ih a X (λ j xs → cn j (a , xs)))

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

UncurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedFunc I D X)
  → Set
UncurriedHyps I D X P cn =
  (i : I) (xs : Func I D X i) (ihs : Hyps I D X P i xs) → P i (cn i xs)

CurriedHyps : (I : Set) (D : Desc I) (X : ISet I)
  (P : (i : I) → X i → Set)
  (cn : UncurriedFunc I D X)
  → Set
CurriedHyps I = elimDesc
  (λ D → (X : ISet I) (P : (i : I) → X i → Set) (cn : UncurriedFunc I D X) → Set)
  (λ i X P cn → P i (cn i refl))
  (λ i D ih X P cn → (x : X i) → P i x → ih X P (λ j xs → cn j (x , xs)))
  (λ A B ih X P cn → (a : A) → ih a X P (λ j xs → cn j (a , xs)))

UncurryHyps : (I : Set) (D : Desc I) → Set
UncurryHyps I D = (X : ISet I) (P : (i : I) → X i → Set) (cn : UncurriedFunc I D X)
  → CurriedHyps I D X P cn → UncurriedHyps I D X P cn

uncurryHyps : (I : Set) (D : Desc I) → UncurryHyps I D
uncurryHyps I = elimDesc
  (UncurryHyps I)
  (λ j X P cn pf →
    elimEq _ (λ u → pf))
  (λ j D ih X P cn pf i →
    elimPair _ (λ x xs ih,ihs →
      ih X P (λ j ys → cn j (x , ys)) (pf x (proj₁ ih,ihs)) i xs (proj₂ ih,ihs)))
  (λ A B ih X P cn pf i →
    elimPair _ (λ a xs → ih a X P (λ j ys → cn j (a , ys)) (pf a) i xs))

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

record Data : Set where
  field
    N : String
    P : Tel
    I : Scope P → Tel
    E : Enum
    B : (p : Scope P) → Branches E (λ _ → Desc (Scope (I p)))

  PS : Set
  PS = Scope P

  IS : PS → Set
  IS p = Scope (I p)

  C : (p : PS) → Tag E → Desc (IS p)
  C p = case (λ _ → Desc (IS p)) (B p)

  D : (p : PS) → Desc (IS p)
  D p = Arg (Tag E) (C p)

  F : (p : PS) → IS p → Set
  F p = μ N PS IS p (D p)

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

Decl :
  (N : String)
  (P : Tel)
  (I : CurriedScope P (λ _ → Tel))
  (E : Enum)
  (B : let I = uncurryScope P (λ _ → Tel) I
      in CurriedScope P λ A → Branches E (λ _ → Desc (Scope (I A))))
  → Data
Decl N P I E B = record
  { N = N
  ; P = P
  ; I = uncurryScope P _ I
  ; E = E
  ; B = uncurryScope P _ B
  }

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

End[_] : (I : Tel)
  → CurriedScope I (λ _ → Desc (Scope I))
End[_] I = curryScope I _ End

Rec[_] : (I : Tel)
  → CurriedScope I (λ _ → Desc (Scope I) → Desc (Scope I))
Rec[_] I = curryScope I _ Rec

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

FormUncurried : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → UncurriedScope (Data.I R p) λ i
  → Set
FormUncurried = Data.F

Form : (R : Data)
  → CurriedScope (Data.P R) λ p
  → CurriedScope (Data.I R p) λ i
  → Set
Form R =
  curryScope (Data.P R) (λ p → CurriedScope (Data.I R p) λ i → Set) λ p →
  curryScope (Data.I R p) (λ i → Set) λ i →
  FormUncurried R p i

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

injUncurried : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → CurriedFunc (Data.IS R p) (Data.D R p) (Data.F R p)
injUncurried R p t = curryFunc (Data.IS R p) (Data.C R p t)
  (Data.F R p)
  (λ i xs → init (t , xs))

inj : (R : Data)
  → CurriedScope (Data.P R) λ p
  → CurriedFunc (Data.IS R p) (Data.D R p) (Data.F R p)
inj R = curryScope (Data.P R)
  (λ p → CurriedFunc (Data.IS R p) (Data.D R p) (Data.F R p))
  (injUncurried R)

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

indCurried : (ℓ : String) (P : Set) (I : P → Set) (p : P) (D : Desc (I p))
  (M : (i : I p) → μ ℓ P I p D i → Set)
  (f : CurriedHyps (I p) D (μ ℓ P I p D) M (λ _ → init))
  (i : I p)
  (x : μ ℓ P I p D i)
  → M i x
indCurried ℓ P I p D M f i x =
  ind ℓ P I p D M (uncurryHyps (I p) D (μ ℓ P I p D) M (λ _ → init) f) i x

SumCurriedHyps : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
  → Tag (Data.E R) → Set
SumCurriedHyps R p M t =
  let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M in
  CurriedHyps (Data.IS R p) (Data.C R p t) (Data.F R p) unM (λ i xs → init (t , xs))

elimUncurried : (R : Data)
  → UncurriedScope (Data.P R) λ p
  → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
  → let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
  in UncurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x))
elimUncurried R p M cs = let
    unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
  in
  curryScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x) λ i x →
  indCurried (Data.N R) (Data.PS R) (Data.IS R) p (Data.D R p) unM
    (case (SumCurriedHyps R p M) cs)
    i x

elim : (R : Data)
  → CurriedScope (Data.P R) λ p
  → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
  → let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
  in CurriedBranches (Data.E R)
     (SumCurriedHyps R p M)
     (CurriedScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x))
elim R = curryScope (Data.P R)
  (λ p → (M : CurriedScope (Data.I R p) (λ i → Data.F R p i → Set))
    → let unM = uncurryScope (Data.I R p) (λ i → Data.F R p i → Set) M
    in CurriedBranches (Data.E R)
       (SumCurriedHyps R p M)
       (CurriedScope (Data.I R p) (λ i → (x : Data.F R p i) → unM i x)))
  (λ p M → curryBranches (Data.E R) _ _
    (elimUncurried R p M))

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


Fixed indentation.

Fixed indentation.

------------------------------------------------------------------------------
-- The alternating bit protocol (ABP)
------------------------------------------------------------------------------

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

-- This module define the ABP following the presentation in Dybjer and
-- Sander (1989).
--
-- References:
--
-- • Dybjer, Peter and Sander, Herbert P. (1989). A Functional
--   Programming Approach to the Speciﬁcation and Veriﬁcation of
--   Concurrent Systems. In: Formal Aspects of Computing 1,
--   pp. 303–319.

module FOTC.Program.ABP.ABP where

open import FOTC.Base
open import FOTC.Base.Loop
open import FOTC.Base.List
open import FOTC.Data.Bool
open import FOTC.Data.Stream
open import FOTC.Program.ABP.Fair
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- ABP equations

postulate
  send ack out corrupt : D → D
  await                : D → D → D → D → D

postulate send-eq : ∀ b i is ds →
                    send b · (i ∷ is) · ds ≡ < i , b > ∷ await b i is ds
{-# ATP axiom send-eq #-}

postulate
  await-ok≡ : ∀ b b' i is ds →
              b ≡ b' →
              await b i is (ok b' ∷ ds) ≡ send (not b) · is · ds

  await-ok≢ : ∀ b b' i is ds →
              b ≢ b' →
              await b i is (ok b' ∷ ds) ≡ < i , b > ∷ await b i is ds

  await-error : ∀ b i is ds →
                await b i is (error ∷ ds) ≡ < i , b > ∷ await b i is ds
{-# ATP axiom await-ok≡ await-ok≢ await-error #-}

postulate
  ack-ok≡ : ∀ b b' i bs →
            b ≡ b' →
            ack b · (ok < i , b' > ∷ bs) ≡ b ∷ ack (not b) · bs

  ack-ok≢ : ∀ b b' i bs →
            b ≢ b' →
            ack b · (ok < i , b' > ∷ bs) ≡ not b ∷ ack b · bs

  ack-error : ∀ b bs → ack b · (error ∷ bs) ≡ not b ∷ ack b · bs
{-# ATP axiom ack-ok≡ ack-ok≢ ack-error #-}

postulate
  out-ok≡ : ∀ b b' i bs →
            b ≡ b' →
            out b · (ok < i , b' > ∷ bs) ≡ i ∷ out (not b) · bs

  out-ok≢ : ∀ b b' i bs →
            b ≢ b' →
            out b · (ok < i , b' > ∷ bs) ≡ out b · bs

  out-error : ∀ b bs → out b · (error ∷ bs) ≡ out b · bs
{-# ATP axiom out-ok≡ out-ok≢ out-error #-}

postulate
  corrupt-T : ∀ os x xs →
              corrupt (T ∷ os) · (x ∷ xs) ≡ ok x ∷ corrupt os · xs
  corrupt-F : ∀ os x xs →
              corrupt (F ∷ os) · (x ∷ xs) ≡ error ∷ corrupt os · xs
{-# ATP axiom corrupt-T corrupt-F #-}

postulate has hbs hcs hds : D → D → D → D → D → D → D

postulate has-eq : ∀ f₁ f₂ f₃ g₁ g₂ is →
                   has f₁ f₂ f₃ g₁ g₂ is ≡ f₁ · is · (hds f₁ f₂ f₃ g₁ g₂ is)
{-# ATP axiom has-eq #-}

postulate hbs-eq : ∀ f₁ f₂ f₃ g₁ g₂ is →
                   hbs f₁ f₂ f₃ g₁ g₂ is ≡ g₁ · (has f₁ f₂ f₃ g₁ g₂ is)
{-# ATP axiom hbs-eq #-}

postulate hcs-eq : ∀ f₁ f₂ f₃ g₁ g₂ is →
                   hcs f₁ f₂ f₃ g₁ g₂ is ≡ f₂ · (hbs f₁ f₂ f₃ g₁ g₂ is)
{-# ATP axiom hcs-eq #-}

postulate hds-eq : ∀ f₁ f₂ f₃ g₁ g₂ is →
                   hds f₁ f₂ f₃ g₁ g₂ is ≡ g₂ · (hcs f₁ f₂ f₃ g₁ g₂ is)
{-# ATP axiom hds-eq #-}

postulate
  transfer    : D → D → D → D → D → D → D
  transfer-eq : ∀ f₁ f₂ f₃ g₁ g₂ is →
                transfer f₁ f₂ f₃ g₁ g₂ is ≡ f₃ · (hbs f₁ f₂ f₃ g₁ g₂ is)
{-# ATP axiom transfer-eq #-}

postulate
  abpTransfer : D → D → D → D → D
  abpTransfer-eq :
    ∀ b os₁ os₂ is →
      abpTransfer b os₁ os₂ is ≡
        transfer (send b) (ack b) (out b) (corrupt os₁) (corrupt os₂) is
{-# ATP axiom abpTransfer-eq #-}

------------------------------------------------------------------------------
-- ABP relations

-- Start state for the ABP.
S : D → D → D → D → D → D → D → D → D → Set
S b is os₁ os₂ as bs cs ds js =
  as ≡ send b · is · ds
  ∧ bs ≡ corrupt os₁ · as
  ∧ cs ≡ ack b · bs
  ∧ ds ≡ corrupt os₂ · cs
  ∧ js ≡ out b · bs
{-# ATP definition S #-}

-- State for the ABP.
S' : D → D → D → D → D → D → D → D → D → D → Set
S' b i' is' os₁' os₂' as' bs' cs' ds' js' =
  as' ≡ await b i' is' ds'  -- Typo in ds'.
  ∧ bs' ≡ corrupt os₁' · as'
  ∧ cs' ≡ ack (not b) · bs'
  ∧ ds' ≡ corrupt os₂' · (b ∷ cs')
  ∧ js' ≡ out (not b) · bs'
{-# ATP definition S' #-}

-- Auxiliary bisimulation.
B : D → D → Set
B is js = ∃[ b ] ∃[ os₁ ] ∃[ os₂ ] ∃[ as ] ∃[ bs ] ∃[ cs ] ∃[ ds ]
            Stream is
            ∧ Bit b
            ∧ Fair os₁
            ∧ Fair os₂
            ∧ S b is os₁ os₂ as bs cs ds js
{-# ATP definition B #-}