Control/Protocol.agda

Control/Protocol.agda

-- {-# OPTIONS --without-K #-}
open import Coinduction
open import Function.NP
open import Type
open import Level.NP
open import Data.Product.NP renaming (map to ×-map; proj₁ to fst; proj₂ to snd)
open import Data.Zero
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.One using (𝟙)
open import Data.Two hiding (_≟_)
open import Data.Nat hiding (_⊔_)
open import Data.LR
open Data.Two.Indexed

open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; !_; _∙_; refl; subst; J; ap; coe; coe!; J-orig; _≢_)

open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences

module Control.Protocol where

data InOut : ★ where
  In Out : InOut

dualᴵᴼ : InOut → InOut
dualᴵᴼ In  = Out
dualᴵᴼ Out = In

dualᴵᴼ-involutive : ∀ io → dualᴵᴼ (dualᴵᴼ io) ≡ io
dualᴵᴼ-involutive In = refl
dualᴵᴼ-involutive Out = refl

dualᴵᴼ-equiv : Is-equiv dualᴵᴼ
dualᴵᴼ-equiv = self-inv-is-equiv dualᴵᴼ-involutive

dualᴵᴼ-inj : ∀ {x y} → dualᴵᴼ x ≡ dualᴵᴼ y → x ≡ y
dualᴵᴼ-inj = Is-equiv.injective dualᴵᴼ-equiv

{-
module UniversalProtocols ℓ {U : ★_(ₛ ℓ)}(U⟦_⟧ : U → ★_ ℓ) where
-}
module _ ℓ where
  U = ★_ ℓ
  U⟦_⟧ = id
  data Proto_ : ★_(ₛ ℓ) where
    end : Proto_
    com : (io : InOut){M : U}(P : U⟦ M ⟧ → Proto_) → Proto_
{-
module U★ ℓ = UniversalProtocols ℓ {★_ ℓ} id
open U★
-}

Proto : ★₁
Proto = Proto_ ₀
Proto₀ = Proto
Proto₁ = Proto_ ₁

pattern recv P = com In  P
pattern send P = com Out P

module _ {{_ : FunExt}} where
    com= : ∀ io {M₀ M₁}(M= : M₀ ≡ M₁)
                {P₀ : M₀ → Proto}{P₁ : M₁ → Proto}(P= : ∀ m₀ → P₀ m₀ ≡ P₁ (coe M= m₀))
           → com io P₀ ≡ com io P₁
    com= io refl P= = ap (com io) (λ= P=)

    module _ io {M₀ M₁}(M≃ : M₀ ≃ M₁)
             {P₀ : M₀ → Proto}{P₁ : M₁ → Proto}
             (P= : ∀ m₀ → P₀ m₀ ≡ P₁ (–> M≃ m₀))
             {{_ : UA}} where
        com≃ : com io P₀ ≡ com io P₁
        com≃ = com= io (ua M≃) λ m → P= m ∙ ap P₁ (! coe-β M≃ m)

    module _ io {M N}(P : M × N → Proto)
             where
        com₂ : Proto
        com₂ = com io λ m → com io λ n → P (m , n)

    {- Proving this would be awesome...
    module _ io
             {M₀ M₁ N₀ N₁ : ★}
             (M×N≃ : (M₀ × N₀) ≃ (M₁ × N₁))
             {P₀ : M₀ × N₀ → Proto}{P₁ : M₁ × N₁ → Proto}
             (P= : ∀ m,n₀ → P₀ m,n₀ ≡ P₁ (–> M×N≃ m,n₀))
             {{_ : UA}} where
        com₂≃ : com₂ io P₀ ≡ com₂ io P₁
        com₂≃ = {!com=!}
    -}

    -- send= : ∀ {M₀ M₁}(M= : M₀ ≡ M₁){P₀ : M₀ → Proto}{P₁ : M₁ → Proto}(P= : ∀ m₀ → P₀ m₀ ≡ P₁ (coe M= m₀)) → send P₀ ≡ send P₁
    send= = com= Out
    send≃ = com≃ Out

    -- recv= : ∀ {M₀ M₁}(M= : M₀ ≡ M₁){P₀ : M₀ → Proto}{P₁ : M₁ → Proto}(P= : ∀ m₀ → P₀ m₀ ≡ P₁ (coe M= m₀)) → recv P₀ ≡ recv P₁
    recv= = com= In
    recv≃ = com≃ In

    com=′ : ∀ io {M}{P₀ P₁ : M → Proto}(P= : ∀ m → P₀ m ≡ P₁ m) → com io P₀ ≡ com io P₁
    com=′ io = com= io refl

    send=′ : ∀ {M}{P₀ P₁ : M → Proto}(P= : ∀ m → P₀ m ≡ P₁ m) → send P₀ ≡ send P₁
    send=′ = send= refl

    recv=′ : ∀ {M}{P₀ P₁ : M → Proto}(P= : ∀ m → P₀ m ≡ P₁ m) → recv P₀ ≡ recv P₁
    recv=′ = recv= refl

pattern recvE M P = com In  {M} P
pattern sendE M P = com Out {M} P

module ProtoRel (_≈ᴵᴼ_ : InOut → InOut → ★) where
    infix 0 _≈ᴾ_
    data _≈ᴾ_ : Proto → Proto → ★₁ where
      end : end ≈ᴾ end
      com : ∀ {io₀ io₁} (io : io₀ ≈ᴵᴼ io₁){M P Q} → (∀ (m : M) → P m ≈ᴾ Q m) → com io₀ P ≈ᴾ com io₁ Q

module ProtoRelImplicit {_≈ᴵᴼ_ : InOut → InOut → ★} = ProtoRel _≈ᴵᴼ_
open ProtoRelImplicit hiding (_≈ᴾ_)
open ProtoRel _≡_ public renaming (_≈ᴾ_ to _≡ᴾ_) using ()

data View-≡ᴾ : (P Q : Proto) → P ≡ᴾ Q → ★₁ where
  end : View-≡ᴾ end end end
  ≡-Σ : ∀ {M P Q} (p≡q : (m : M) → P m ≡ᴾ Q m) → View-≡ᴾ (send P) (send Q) (com refl p≡q)
  ≡-Π : ∀ {M P Q} (p≡q : (m : M) → P m ≡ᴾ Q m) → View-≡ᴾ (recv P) (recv Q) (com refl p≡q)

view-≡ᴾ : ∀ {P Q} (p≡q : P ≡ᴾ Q) → View-≡ᴾ P Q p≡q
view-≡ᴾ end = end
view-≡ᴾ (com {In}  refl _) = ≡-Π _
view-≡ᴾ (com {Out} refl _) = ≡-Σ _

recv☐ : {M : ★}(P : ..(_ : M) → Proto) → Proto
recv☐ P = recv (λ { [ m ] → P m })

send☐ : {M : ★}(P : ..(_ : M) → Proto) → Proto
send☐ P = send (λ { [ m ] → P m })

source-of : Proto → Proto
source-of end       = end
source-of (com _ P) = send λ m → source-of (P m)

{-
dual : Proto → Proto
dual end      = end
dual (send P) = recv λ m → dual (P m)
dual (recv P) = send λ m → dual (P m)
-}

dual : Proto → Proto
dual end        = end
dual (com io P) = com (dualᴵᴼ io) λ m → dual (P m)

data IsSource : Proto → ★₁ where
  end : IsSource end
  com : ∀ {M P} (PT : (m : M) → IsSource (P m)) → IsSource (send P)

data IsSink : Proto → ★₁ where
  end : IsSink end
  com : ∀ {M P} (PT : (m : M) → IsSink (P m)) → IsSink (recv P)

data Proto☐ : Proto → ★₁ where
  end : Proto☐ end
  com : ∀ q {M P} (P☐ : ∀ (m : ☐ M) → Proto☐ (P m)) → Proto☐ (com q P)

record End_ ℓ : ★_ ℓ where
  constructor end

End : ∀ {ℓ} → ★_ ℓ
End = End_ _

module _ {{_ : UA}} where
    End-uniq : End ≡ 𝟙
    End-uniq = ua (equiv _ _ (λ _ → refl) (λ _ → refl))

⟦_⟧ᴵᴼ : InOut → ∀{ℓ}(M : ★_ ℓ)(P : M → ★_ ℓ) → ★_ ℓ
⟦_⟧ᴵᴼ In  = Π
⟦_⟧ᴵᴼ Out = Σ

⟦_⟧ : ∀ {ℓ} → Proto_ ℓ → ★_ ℓ
⟦ end     ⟧ = End
⟦ com q P ⟧ = ⟦ q ⟧ᴵᴼ _ λ m → ⟦ P m ⟧

⟦_⊥⟧ : Proto → ★
⟦ P ⊥⟧ = ⟦ dual P ⟧

ℛ⟦_⟧ : ∀{ℓ}(P : Proto_ ℓ) (p q : ⟦ P ⟧) → ★_ ℓ
ℛ⟦ end    ⟧ p q = End
ℛ⟦ recv P ⟧ p q = ∀ m → ℛ⟦ P m ⟧ (p m) (q m)
ℛ⟦ send P ⟧ p q = Σ (fst p ≡ fst q) λ e → ℛ⟦ P (fst q) ⟧ (subst (⟦_⟧ ∘ P) e (snd p)) (snd q)

ℛ⟦_⟧-refl : ∀ {ℓ}(P : Proto_ ℓ) → Reflexive ℛ⟦ P ⟧
ℛ⟦ end    ⟧-refl     = end
ℛ⟦ recv P ⟧-refl     = λ m → ℛ⟦ P m ⟧-refl
ℛ⟦ send P ⟧-refl {x} = refl , ℛ⟦ P (fst x) ⟧-refl

ℛ⟦_⟧-sym : ∀ {ℓ}(P : Proto_ ℓ) → Symmetric ℛ⟦ P ⟧
ℛ⟦ end    ⟧-sym p          = end
ℛ⟦ recv P ⟧-sym p          = λ m → ℛ⟦ P m ⟧-sym (p m)
ℛ⟦ send P ⟧-sym (refl , q) = refl , ℛ⟦ P _ ⟧-sym q    -- TODO HoTT

ℛ⟦_⟧-trans : ∀ {ℓ}(P : Proto_ ℓ) → Transitive ℛ⟦ P ⟧
ℛ⟦ end    ⟧-trans p          q          = end
ℛ⟦ recv P ⟧-trans p          q          = λ m → ℛ⟦ P m ⟧-trans (p m) (q m)
ℛ⟦ send P ⟧-trans (refl , p) (refl , q) = refl , ℛ⟦ P _ ⟧-trans p q    -- TODO HoTT

send′ : ★ → Proto → Proto
send′ M P = send λ (_ : M) → P

recv′ : ★ → Proto → Proto
recv′ M P = recv λ (_ : M) → P

module send/recv-𝟘 (P : 𝟘 → Proto){{_ : FunExt}}{{_ : UA}} where
    P⊤ : Proto
    P⊤ = recvE 𝟘 P

    P0 : Proto
    P0 = sendE 𝟘 P

    P0-empty : ⟦ P0 ⟧ ≡ 𝟘
    P0-empty = ua (equiv fst (λ()) (λ()) (λ { (() , _) }))

    P⊤-uniq : ⟦ P⊤ ⟧ ≡ 𝟙
    P⊤-uniq = Π𝟘-uniq _

open send/recv-𝟘 (λ _ → end) public

≡ᴾ-refl : ∀ P → P ≡ᴾ P
≡ᴾ-refl end       = end
≡ᴾ-refl (com q P) = com refl λ m → ≡ᴾ-refl (P m)

≡ᴾ-reflexive : ∀ {P Q} → P ≡ Q → P ≡ᴾ Q
≡ᴾ-reflexive refl = ≡ᴾ-refl _

≡ᴾ-sym : Symmetric _≡ᴾ_
≡ᴾ-sym end = end
≡ᴾ-sym (com refl r) = com refl λ m → ≡ᴾ-sym (r m)

≡ᴾ-trans : Transitive _≡ᴾ_
≡ᴾ-trans end qr = qr
≡ᴾ-trans (com refl x) (com refl x₁) = com refl (λ m → ≡ᴾ-trans (x m) (x₁ m))

!ᴾ = ≡ᴾ-sym
_∙ᴾ_ = ≡ᴾ-trans

dual-involutive : ∀ P → dual (dual P) ≡ᴾ P
dual-involutive end       = end
dual-involutive (com q P) = com (dualᴵᴼ-involutive q) λ m → dual-involutive (P m)

module _ {{_ : FunExt}} where
    ≡ᴾ-sound : ∀ {P Q} → P ≡ᴾ Q → P ≡ Q
    ≡ᴾ-sound end            = refl
    ≡ᴾ-sound (com refl P≡Q) = ap (com _) (λ= λ m → ≡ᴾ-sound (P≡Q m))

    ≡ᴾ-cong : ∀ {P Q} (f : Proto → Proto) → P ≡ᴾ Q → f P ≡ᴾ f Q
    ≡ᴾ-cong f P≡Q = ≡ᴾ-reflexive (ap f (≡ᴾ-sound P≡Q))

    dual-equiv : Is-equiv dual
    dual-equiv = self-inv-is-equiv (≡ᴾ-sound ∘ dual-involutive)

    dual-inj : ∀ {P Q} → dual P ≡ dual Q → P ≡ Q
    dual-inj = Is-equiv.injective dual-equiv

source-of-idempotent : ∀ P → source-of (source-of P) ≡ᴾ source-of P
source-of-idempotent end       = end
source-of-idempotent (com _ P) = com refl λ m → source-of-idempotent (P m)

source-of-dual-oblivious : ∀ P → source-of (dual P) ≡ᴾ source-of P
source-of-dual-oblivious end       = end
source-of-dual-oblivious (com _ P) = com refl λ m → source-of-dual-oblivious (P m)

sink-of : Proto → Proto
sink-of = dual ∘ source-of

Sink : Proto → ★
Sink P = ⟦ sink-of P ⟧

sink : ∀ P → Sink P
sink end         = _
sink (com _ P) x = sink (P x)

module _ {{_ : FunExt}} where
    sink-contr : ∀ P s → sink P ≡ s
    sink-contr end       s = refl
    sink-contr (com _ P) s = λ= λ m → sink-contr (P m) (s m)

    Sink-is-contr : ∀ P → Is-contr (Sink P)
    Sink-is-contr P = sink P , sink-contr P

    𝟙≃Sink : ∀ P → 𝟙 ≃ Sink P
    𝟙≃Sink P = Is-contr-to-Is-equiv.𝟙≃ (Sink-is-contr P)

Log : Proto → ★
Log P = ⟦ source-of P ⟧

_>>=_ : (P : Proto) → (Log P → Proto) → Proto
end     >>= Q = Q _
com q P >>= Q = com q λ m → P m >>= λ ms → Q (m , ms)

_>>_ : Proto → Proto → Proto
P >> Q = P >>= λ _ → Q

replicateᴾ : ℕ → Proto → Proto
replicateᴾ 0       P = end
replicateᴾ (suc n) P = P >> replicateᴾ n P

++Log : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
++Log end       _        ys = ys
++Log (com q P) (x , xs) ys = x , ++Log (P x) xs ys

>>=-right-unit : ∀ P → (P >> end) ≡ᴾ P
>>=-right-unit end       = end
>>=-right-unit (com q P) = com refl λ m → >>=-right-unit (P m)

>>=-assoc : ∀ (P : Proto)(Q : Log P → Proto)(R : Log (P >>= Q) → Proto)
            → P >>= (λ x → Q x >>= (λ y → R (++Log P x y))) ≡ᴾ ((P >>= Q) >>= R)
>>=-assoc end       Q R = ≡ᴾ-refl (Q _ >>= R)
>>=-assoc (com q P) Q R = com refl λ m → >>=-assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

data Accept? : ★ where
  accept reject : Accept?
data Is-accept : Accept? → ★ where
  accept : Is-accept accept

module _ {A : ★} (Aᴾ : A → Proto) where
    extend-send : Proto → Proto
    extend-send end      = end
    extend-send (send P) = send [inl: (λ m → extend-send (P m)) ,inr: Aᴾ ]
    extend-send (recv P) = recv λ m → extend-send (P m)

    extend-recv : Proto → Proto
    extend-recv end      = end
    extend-recv (recv P) = recv [inl: (λ m → extend-recv (P m)) ,inr: Aᴾ ]
    extend-recv (send P) = send λ m → extend-recv (P m)

module _ {A : ★} (Aᴾ : A → Proto) where
    dual-extend-send : ∀ P → dual (extend-send Aᴾ P) ≡ᴾ extend-recv (dual ∘ Aᴾ) (dual P)
    dual-extend-send end      = end
    dual-extend-send (recv P) = com refl (λ m → dual-extend-send (P m))
    dual-extend-send (send P) = com refl [inl: (λ m → dual-extend-send (P m))
                                         ,inr: (λ x → ≡ᴾ-refl (dual (Aᴾ x))) ]

data Abort : ★ where abort : Abort

Abortᴾ : Abort → Proto
Abortᴾ _ = end

add-abort : Proto → Proto
add-abort = extend-send Abortᴾ

telecom : ∀ P → ⟦ P ⟧ → ⟦ P ⊥⟧ → Log P
telecom end      _       _       = _
telecom (recv P) p       (m , q) = m , telecom (P m) (p m) q
telecom (send P) (m , p) q       = m , telecom (P m) p (q m)

liftᴾ : ∀ a {ℓ} → Proto_ ℓ → Proto_ (a ⊔ ℓ)
liftᴾ a end        = end
liftᴾ a (com io P) = com io λ m → liftᴾ a (P (lower {ℓ = a} m))

lift-proc : ∀ a {ℓ} (P : Proto_ ℓ) → ⟦ P ⟧ → ⟦ liftᴾ a P ⟧
lift-proc a {ℓ} end      end     = end
lift-proc a {ℓ} (send P) (m , p) = lift m , lift-proc a (P m) p
lift-proc a {ℓ} (recv P) p       = λ { (lift m) → lift-proc _ (P m) (p m) }

module MonomorphicSky (P : Proto₀) where
  Cloud : Proto₀
  Cloud = recv λ (t   : ⟦ P  ⟧) →
          recv λ (u   : ⟦ P ⊥⟧) →
          send λ (log : Log P)  →
          end
  cloud : ⟦ Cloud ⟧
  cloud t u = telecom P t u , _

module PolySky where
  Cloud : Proto_ ₁
  Cloud = recv λ (P : Proto₀) →
          liftᴾ ₁ (MonomorphicSky.Cloud P)
  cloud : ⟦ Cloud ⟧
  cloud P = lift-proc ₁ (MonomorphicSky.Cloud P) (MonomorphicSky.cloud P)

module PolySky' where
  Cloud : Proto_ ₁
  Cloud = recv λ (P   : Proto₀) →
          recv λ (t   : Lift ⟦ P  ⟧)  →
          recv λ (u   : Lift ⟦ P ⊥⟧)  →
          send λ (log : Lift (Log P)) →
          end
  cloud : ⟦ Cloud ⟧
  cloud P (lift t) (lift u) = lift (telecom P t u) , _

data Choreo (I : ★) : ★₁ where
  _-[_]→_⁏_ : (A : I) (M : ★) (B : I) (ℂ : ..(m : M) → Choreo I) → Choreo I
  _-[_]→★⁏_ : (A : I) (M : ★)         (ℂ :   (m : M) → Choreo I) → Choreo I
  end       : Choreo I

module _ {I : ★} where
    _-[_]→ø⁏_ : ∀ (A : I)(M : ★)(ℂ : ..(m : M) → Choreo I) → Choreo I
    A -[ M ]→ø⁏ ℂ = A -[ ☐ M ]→★⁏ λ { [ m ] → ℂ m }

    _//_ : (ℂ : Choreo I) (p : I → 𝟚) → Proto
    (A -[ M ]→ B ⁏ ℂ) // p = case p A
                               0: case p B
                                    0: recv (λ { [ m ] → ℂ m // p })
                                    1: recv (λ     m   → ℂ m // p)
                               1: send (λ m → ℂ m // p)
    (A -[ M ]→★⁏   ℂ) // p = com (case p A 0: In 1: Out) λ m → ℂ m // p
    end               // p = end

    ℂObserver : Choreo I → Proto
    ℂObserver ℂ = ℂ // λ _ → 0₂

    ℂLog : Choreo I → Proto
    ℂLog ℂ = ℂ // λ _ → 1₂

    ℂLog-IsSource : ∀ ℂ → IsSource (ℂLog ℂ)
    ℂLog-IsSource (A -[ M ]→ B ⁏ ℂ) = com λ m → ℂLog-IsSource (ℂ m)
    ℂLog-IsSource (A -[ M ]→★⁏   ℂ) = com λ m → ℂLog-IsSource (ℂ m)
    ℂLog-IsSource end               = end

    ℂObserver-IsSink : ∀ ℂ → IsSink (ℂObserver ℂ)
    ℂObserver-IsSink (A -[ M ]→ B ⁏ ℂ) = com λ { [ m ] → ℂObserver-IsSink (ℂ m) }
    ℂObserver-IsSink (A -[ M ]→★⁏   ℂ) = com λ m → ℂObserver-IsSink (ℂ m)
    ℂObserver-IsSink end = end

    data R : (p q r : 𝟚) → ★ where
      R011 : R 0₂ 1₂ 1₂
      R101 : R 1₂ 0₂ 1₂
      R000 : R 0₂ 0₂ 0₂
    R° : ∀ {I : ★} (p q r : I → 𝟚) → ★
    R° p q r = ∀ i → R (p i) (q i) (r i)

    module _ {p q r : I → 𝟚} where
        choreo-merge : (ℂ : Choreo I)(pqr : R° p q r) → ⟦ ℂ // p ⟧ → ⟦ ℂ // q ⟧ → ⟦ ℂ // r ⟧
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr ℂp ℂq with p A | q A | r A | pqr A | p B | q B | r B | pqr B
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr ℂp (m , ℂq) | .0₂ |  1₂ | .1₂ | R011 |  1₂ | .0₂ | .1₂ | R101 = m , choreo-merge (ℂ m) pqr (ℂp m) ℂq
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr ℂp (m , ℂq) | .0₂ |  1₂ | .1₂ | R011 |  0₂ |  _  |  _  | _    = m , choreo-merge (ℂ m) pqr (ℂp [ m ]) ℂq
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr (m , ℂp) ℂq |  1₂ | .0₂ | .1₂ | R101 | .0₂ |  1₂ | .1₂ | R011 = m , choreo-merge (ℂ m) pqr ℂp (ℂq m)
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr (m , ℂp) ℂq |  1₂ | .0₂ | .1₂ | R101 |  _  |  0₂ |  _  | _    = m , choreo-merge (ℂ m) pqr ℂp (ℂq [ m ])
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr ℂp ℂq       | .0₂ |  0₂ | .0₂ | R000 | .0₂ |  1₂ | .1₂ | R011 = λ m → choreo-merge (ℂ m) pqr (ℂp [ m ]) (ℂq m)
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr ℂp ℂq       | .0₂ |  0₂ | .0₂ | R000 |  1₂ | .0₂ | .1₂ | R101 = λ m → choreo-merge (ℂ m) pqr (ℂp m) (ℂq [ m ])
        choreo-merge (A -[ M ]→ B ⁏ ℂ) pqr ℂp ℂq       | .0₂ |  0₂ | .0₂ | R000 |  0₂ |  0₂ | .0₂ | R000 = λ { [ m ] → choreo-merge (ℂ m) pqr (ℂp [ m ]) (ℂq [ m ]) }
        choreo-merge (A -[ M ]→★⁏ ℂ) pqr ℂp ℂq with p A | q A | r A | pqr A
        choreo-merge (A -[ M ]→★⁏ ℂ) pqr ℂp (m , ℂq) | .0₂ |  1₂ | .1₂ | R011 = m , choreo-merge (ℂ m) pqr (ℂp m) ℂq
        choreo-merge (A -[ M ]→★⁏ ℂ) pqr (m , ℂp) ℂq |  1₂ | .0₂ | .1₂ | R101 = m , choreo-merge (ℂ m) pqr ℂp (ℂq m)
        choreo-merge (A -[ M ]→★⁏ ℂ) pqr ℂp ℂq       | .0₂ |  0₂ | .0₂ | R000 = λ m → choreo-merge (ℂ m) pqr (ℂp m) (ℂq m)
        choreo-merge end pqr ℂp ℂq = _

        {-
    module _ {p q r pq qr pqr : I → 𝟚} where
        choreo-merge-assoc : (ℂ : Choreo I)(Rpqr : R° p qr pqr)(Rqr : R° q r qr)(Rpqr' : R° pq r pqr)(Rpq : R° p q pq) →
                             (ℂp : ⟦ ℂ // p ⟧) (ℂq : ⟦ ℂ // q ⟧) (ℂr : ⟦ ℂ // r ⟧)
                             → choreo-merge ℂ Rpqr ℂp (choreo-merge ℂ Rqr ℂq ℂr) ≡ choreo-merge ℂ Rpqr' (choreo-merge ℂ Rpq ℂp ℂq) ℂr
        choreo-merge-assoc = {!!}
        -}

    R-p-¬p-1 : ∀ (p : I → 𝟚) i → R (p i) (not (p i)) 1₂
    R-p-¬p-1 p i with p i
    R-p-¬p-1 p i | 1₂ = R101
    R-p-¬p-1 p i | 0₂ = R011

    choreo-bi : {p : I → 𝟚}(ℂ : Choreo I) → ⟦ ℂ // p ⟧ → ⟦ ℂ // (not ∘ p) ⟧ → ⟦ ℂLog ℂ ⟧
    choreo-bi {p} ℂ ℂp ℂ¬p = choreo-merge ℂ (R-p-¬p-1 p) ℂp ℂ¬p

choreo2 : (ℂ : Choreo 𝟚) → ⟦ ℂ // id ⟧ → ⟦ ℂ // not ⟧ → ⟦ ℂLog ℂ ⟧
choreo2 = choreo-bi

module Choreo3 where
  data 𝟛 : ★ where
    0₃ 1₃ 2₃ : 𝟛
  0₃? 1₃? 2₃? : 𝟛 → 𝟚
  0₃? 0₃ = 1₂
  0₃? _  = 0₂
  1₃? 1₃ = 1₂
  1₃? _  = 0₂
  2₃? 2₃ = 1₂
  2₃? _  = 0₂

  choreo3 : (ℂ : Choreo 𝟛) → ⟦ ℂ // 0₃? ⟧ → ⟦ ℂ // 1₃? ⟧ → ⟦ ℂ // 2₃? ⟧ → ⟦ ℂLog ℂ ⟧
  choreo3 (0₃ -[ M ]→ 0₃ ⁏ ℂ) (m , p0) p1 p2 = m , choreo3 (ℂ m) p0 (p1 [ m ]) (p2 [ m ])
  choreo3 (0₃ -[ M ]→ 1₃ ⁏ ℂ) (m , p0) p1 p2 = m , choreo3 (ℂ m) p0 (p1 m) (p2 [ m ])
  choreo3 (0₃ -[ M ]→ 2₃ ⁏ ℂ) (m , p0) p1 p2 = m , choreo3 (ℂ m) p0 (p1 [ m ]) (p2 m)
  choreo3 (1₃ -[ M ]→ 0₃ ⁏ ℂ) p0 (m , p1) p2 = m , choreo3 (ℂ m) (p0 m) p1 (p2 [ m ])
  choreo3 (1₃ -[ M ]→ 1₃ ⁏ ℂ) p0 (m , p1) p2 = m , choreo3 (ℂ m) (p0 [ m ]) p1 (p2 [ m ])
  choreo3 (1₃ -[ M ]→ 2₃ ⁏ ℂ) p0 (m , p1) p2 = m , choreo3 (ℂ m) (p0 [ m ]) p1 (p2 m)
  choreo3 (2₃ -[ M ]→ 0₃ ⁏ ℂ) p0 p1 (m , p2) = m , choreo3 (ℂ m) (p0 m) (p1 [ m ]) p2
  choreo3 (2₃ -[ M ]→ 1₃ ⁏ ℂ) p0 p1 (m , p2) = m , choreo3 (ℂ m) (p0 [ m ]) (p1 m) p2
  choreo3 (2₃ -[ M ]→ 2₃ ⁏ ℂ) p0 p1 (m , p2) = m , choreo3 (ℂ m) (p0 [ m ]) (p1 [ m ]) p2
  choreo3 (0₃ -[ M ]→★⁏    ℂ) (m , p0) p1 p2 = m , choreo3 (ℂ m) p0 (p1 m) (p2 m)
  choreo3 (1₃ -[ M ]→★⁏    ℂ) p0 (m , p1) p2 = m , choreo3 (ℂ m) (p0 m) p1 (p2 m)
  choreo3 (2₃ -[ M ]→★⁏    ℂ) p0 p1 (m , p2) = m , choreo3 (ℂ m) (p0 m) (p1 m) p2
  choreo3 end p0 p1 p2 = _

  choreo3' : (ℂ : Choreo 𝟛) → ⟦ ℂ // 0₃? ⟧ → ⟦ ℂ // 1₃? ⟧ → ⟦ ℂ // 2₃? ⟧ → ⟦ ℂLog ℂ ⟧
  choreo3' ℂ p0 p1 p2 = choreo-merge ℂ (R-p-¬p-1 0₃?) p0 (choreo-merge ℂ R-1-2-¬0 p1 p2)
     where R-1-2-¬0 : ∀ i → R (1₃? i) (2₃? i) (not (0₃? i))
           R-1-2-¬0 0₃ = R000
           R-1-2-¬0 1₃ = R101
           R-1-2-¬0 2₃ = R011

>>=-com : (P : Proto){Q : Log P → Proto}{R : Log P → Proto}
          → ⟦ P >>= Q  ⟧
          → ⟦ P >>= R ⊥⟧
          → Σ (Log P) (λ t → ⟦ Q t ⟧ × ⟦ R t ⊥⟧)
>>=-com end      p0       p1       = _ , p0 , p1
>>=-com (send P) (m , p0) p1       = first (_,_ m) (>>=-com (P m) p0 (p1 m))
>>=-com (recv P) p0       (m , p1) = first (_,_ m) (>>=-com (P m) (p0 m) p1)

>>-com : (P : Proto){Q R : Proto}
       → ⟦ P >> Q  ⟧
       → ⟦ P >> R ⊥⟧
       → Log P × ⟦ Q ⟧ × ⟦ R ⊥⟧
>>-com P p q = >>=-com P p q

module _ {{_ : FunExt}} where
    ap->>= : ∀ P {Q₀ Q₁} → (∀ {log} → ⟦ Q₀ log ⟧ ≡ ⟦ Q₁ log ⟧) → ⟦ P >>= Q₀ ⟧ ≡ ⟦ P >>= Q₁ ⟧
    ap->>= end      Q= = Q=
    ap->>= (send P) Q= = Σ=′ _ λ m → ap->>= (P m) Q=
    ap->>= (recv P) Q= = Π=′ _ λ m → ap->>= (P m) Q=

module _ {{_ : FunExt}}{{_ : UA}} where
    P2 = send′ 𝟚 end

    0₂≢1₂ : 0₂ ≢ 1₂
    0₂≢1₂ ()

    𝟘≢ : ∀ {A} (x : A) → 𝟘 ≢ A
    𝟘≢ x e = coe! e x

    𝟘≢𝟙 : 𝟘 ≢ 𝟙
    𝟘≢𝟙 = 𝟘≢ _

    𝟘≢𝟚 : 𝟘 ≢ 𝟚
    𝟘≢𝟚 = 𝟘≢ 0₂

module ClientServerV1 (Query : ★₀) (Resp : Query → ★₀) (P : Proto) where
    Client : ℕ → Proto
    Client zero    = P
    Client (suc n) = send λ (q : Query) → recv λ (r : Resp q) → Client n

    Server : ℕ → Proto
    Server zero    = P
    Server (suc n) = recv λ (q : Query) → send λ (r : Resp q) → Server n

module ClientServerV2 (Query : ★₀) (Resp : Query → ★₀) where
    ClientRound ServerRound : Proto
    ClientRound = send λ (q : Query) → recv λ (r : Resp q) → end
    ServerRound = dual ClientRound

    Client Server : ℕ → Proto
    Client n = replicateᴾ n ClientRound
    Server = dual ∘ Client

    DynamicServer StaticServer : Proto
    DynamicServer = recv λ n →
                    Server n
    StaticServer  = send λ n →
                    Server n

    module PureServer (serve : Π Query Resp) where
      server : ∀ n → ⟦ Server n ⟧
      server zero      = _
      server (suc n) q = serve q , server n

module _ {{_ : FunExt}} where
  dual-Log : ∀ P → Log (dual P) ≡ Log P
  dual-Log P = ap ⟦_⟧ (≡ᴾ-sound (source-of-dual-oblivious P))

dual->> : ∀ P Q → dual (P >> Q) ≡ᴾ dual P >> dual Q
dual->> end      Q = ≡ᴾ-refl _
dual->> (recv P) Q = com refl λ m → dual->> (P m) Q
dual->> (send P) Q = com refl λ m → dual->> (P m) Q

  {- ohoh!
  dual->>= : ∀ P (Q : Log P → Proto) → dual (P >>= Q) ≡ᴾ dual P >>= (dual ∘ Q ∘ coe (dual-Log P))
  dual->>= end Q = ≡ᴾ-refl _
  dual->>= (recv M P) Q = ProtoRel.com refl M (λ m → {!dual->>= (P m) (Q ∘ _,_ m)!})
  dual->>= (send M P) Q = ProtoRel.com refl M (λ m → {!!})
  -}

module _ {{_ : FunExt}} (P : Proto) where
    dual-replicateᴾ : ∀ n → dual (replicateᴾ n P) ≡ᴾ replicateᴾ n (dual P)
    dual-replicateᴾ zero    = end
    dual-replicateᴾ (suc n) = dual->> P (replicateᴾ n P) ∙ᴾ ≡ᴾ-cong (_>>_ (dual P)) (dual-replicateᴾ n)

_⊕_ : (l r : Proto) → Proto
l ⊕ r = send [L: l R: r ]

_&_ : (l r : Proto) → Proto
l & r = recv [L: l R: r ]

module _ {{_ : FunExt}} where
    dual-⊕ : ∀ {P Q} → dual (P ⊕ Q) ≡ dual P & dual Q
    dual-⊕ = recv=′ [L: refl R: refl ]

    dual-& : ∀ {P Q} → dual (P & Q) ≡ dual P ⊕ dual Q
    dual-& = send=′ [L: refl R: refl ]

module _ {{_ : FunExt}}{{_ : UA}} where
    &-comm : ∀ P Q → P & Q ≡ Q & P
    &-comm P Q = recv≃ LR!-equiv [L: refl R: refl ]

    ⊕-comm : ∀ P Q → P ⊕ Q ≡ Q ⊕ P
    ⊕-comm P Q = send≃ LR!-equiv [L: refl R: refl ]

module _ {P Q R S} where
    ⊕-map : (⟦ P ⟧ → ⟦ Q ⟧) → (⟦ R ⟧ → ⟦ S ⟧) → ⟦ P ⊕ R ⟧ → ⟦ Q ⊕ S ⟧
    ⊕-map f g (`L , pr) = `L , f pr
    ⊕-map f g (`R , pr) = `R , g pr

    &-map : (⟦ P ⟧ → ⟦ Q ⟧) → (⟦ R ⟧ → ⟦ S ⟧) → ⟦ P & R ⟧ → ⟦ Q & S ⟧
    &-map f g p `L = f (p `L)
    &-map f g p `R = g (p `R)

module _ {P Q} where
    ⊕→⊎ : ⟦ P ⊕ Q ⟧ → ⟦ P ⟧ ⊎ ⟦ Q ⟧
    ⊕→⊎ (`L , p) = inl p
    ⊕→⊎ (`R , q) = inr q

    ⊎→⊕ : ⟦ P ⟧ ⊎ ⟦ Q ⟧ → ⟦ P ⊕ Q ⟧
    ⊎→⊕ (inl p) = `L , p
    ⊎→⊕ (inr q) = `R , q

    ⊎→⊕→⊎ : ∀ x → ⊎→⊕ (⊕→⊎ x) ≡ x
    ⊎→⊕→⊎ (`L , _) = refl
    ⊎→⊕→⊎ (`R , _) = refl

    ⊕→⊎→⊕ : ∀ x → ⊕→⊎ (⊎→⊕ x) ≡ x
    ⊕→⊎→⊕ (inl _) = refl
    ⊕→⊎→⊕ (inr _) = refl

    ⊕≃⊎ : ⟦ P ⊕ Q ⟧ ≃ (⟦ P ⟧ ⊎ ⟦ Q ⟧)
    ⊕≃⊎ = ⊕→⊎ , record { linv = ⊎→⊕ ; is-linv = ⊎→⊕→⊎ ; rinv = ⊎→⊕ ; is-rinv = ⊕→⊎→⊕ }

    ⊕≡⊎ : {{_ : UA}} → ⟦ P ⊕ Q ⟧ ≡ (⟦ P ⟧ ⊎ ⟦ Q ⟧)
    ⊕≡⊎ = ua ⊕≃⊎

    &→× : ⟦ P & Q ⟧ → ⟦ P ⟧ × ⟦ Q ⟧
    &→× p = p `L , p `R

    ×→& : ⟦ P ⟧ × ⟦ Q ⟧ → ⟦ P & Q ⟧
    ×→& (p , q) `L = p
    ×→& (p , q) `R = q

    &→×→& : ∀ x → &→× (×→& x) ≡ x
    &→×→& (p , q) = refl

    module _ {{_ : FunExt}} where
        ×→&→× : ∀ x → ×→& (&→× x) ≡ x
        ×→&→× p = λ= λ { `L → refl ; `R → refl }

        &≃× : ⟦ P & Q ⟧ ≃ (⟦ P ⟧ × ⟦ Q ⟧)
        &≃× = &→× , record { linv = ×→& ; is-linv = ×→&→× ; rinv = ×→& ; is-rinv = &→×→& }

        &≡× : {{_ : UA}} → ⟦ P & Q ⟧ ≡ (⟦ P ⟧ × ⟦ Q ⟧)
        &≡× = ua &≃×

module _ {{_ : FunExt}}{{_ : UA}} where
    P⊤-& : ∀ P → ⟦ P⊤ & P ⟧ ≡ ⟦ P ⟧
    P⊤-& P = &≡× ∙ ap (flip _×_ ⟦ P ⟧) P⊤-uniq ∙ Σ𝟙-snd

    P0-⊕ : ∀ P → ⟦ P0 ⊕ P ⟧ ≡ ⟦ P ⟧
    P0-⊕ P = ⊕≡⊎ ∙ ap (flip _⊎_ ⟦ P ⟧) Σ𝟘-fst ∙ ⊎-comm ∙ ! ⊎𝟘-inl

    &-assoc : ∀ P Q R → ⟦ P & (Q & R) ⟧ ≡ ⟦ (P & Q) & R ⟧
    &-assoc P Q R = &≡× ∙ (ap (_×_ ⟦ P ⟧) &≡× ∙ ×-assoc ∙ ap (flip _×_ ⟦ R ⟧) (! &≡×)) ∙ ! &≡×

    ⊕-assoc : ∀ P Q R → ⟦ P ⊕ (Q ⊕ R) ⟧ ≡ ⟦ (P ⊕ Q) ⊕ R ⟧
    ⊕-assoc P Q R = ⊕≡⊎ ∙ (ap (_⊎_ ⟦ P ⟧) ⊕≡⊎ ∙ ⊎-assoc ∙ ap (flip _⊎_ ⟦ R ⟧) (! ⊕≡⊎)) ∙ ! ⊕≡⊎

module _ where

  _⅋_ : Proto → Proto → Proto
  end    ⅋ Q      = Q
  recv P ⅋ Q      = recv λ m → P m ⅋ Q
  P      ⅋ end    = P
  P      ⅋ recv Q = recv λ m → P ⅋ Q m
  send P ⅋ send Q = send [inl: (λ m → P m ⅋ send Q)
                         ,inr: (λ n → send P ⅋ Q n) ]

  module _ {{_ : FunExt}}{{_ : UA}} where
    -- absorption
    ⊤-⅋ : ∀ P → ⟦ P⊤ ⅋ P ⟧
    ⊤-⅋ P = λ()

  _⊗_ : Proto → Proto → Proto
  end    ⊗ Q      = Q
  send P ⊗ Q      = send λ m → P m ⊗ Q
  P      ⊗ end    = P
  P      ⊗ send Q = send λ m → P ⊗ Q m
  recv P ⊗ recv Q = recv [inl: (λ m → P m ⊗ recv Q)
                         ,inr: (λ n → recv P ⊗ Q n) ]

  _-o_ : (P Q : Proto) → Proto
  P -o Q = dual P ⅋ Q

  _o-o_ : (P Q : Proto) → Proto
  P o-o Q = (P -o Q) ⊗ (Q -o P)

  module _ {{_ : FunExt}} where
    ⊗-endR : ∀ P → P ⊗ end ≡ P
    ⊗-endR end      = refl
    ⊗-endR (recv _) = refl
    ⊗-endR (send P) = send=′ λ m → ⊗-endR (P m)

    ⅋-endR : ∀ P → P ⅋ end ≡ P
    ⅋-endR end      = refl
    ⅋-endR (send _) = refl
    ⅋-endR (recv P) = recv=′ λ m → ⅋-endR (P m)

  module _ {{_ : FunExt}}{{_ : UA}} where
    ⊗-sendR : ∀ P{M}(Q : M → Proto) → ⟦ P ⊗ send Q ⟧ ≡ (Σ M λ m → ⟦ P ⊗ Q m ⟧)
    ⊗-sendR end      Q = refl
    ⊗-sendR (recv P) Q = refl
    ⊗-sendR (send P) Q = (Σ=′ _ λ m → ⊗-sendR (P m) Q) ∙ ΣΣ-comm

    ⊗-comm : ∀ P Q → ⟦ P ⊗ Q ⟧ ≡ ⟦ Q ⊗ P ⟧
    ⊗-comm end      Q        = ! ap ⟦_⟧ (⊗-endR Q)
    ⊗-comm (send P) Q        = (Σ=′ _ λ m → ⊗-comm (P m) Q) ∙ ! ⊗-sendR Q P
    ⊗-comm (recv P) end      = refl
    ⊗-comm (recv P) (send Q) = Σ=′ _ λ m → ⊗-comm (recv P) (Q m)
    ⊗-comm (recv P) (recv Q) = Π≃ ⊎-comm-equiv [inl: (λ m → ⊗-comm (P m) (recv Q))
                                               ,inr: (λ m → ⊗-comm (recv P) (Q m)) ]

    ⊗-assoc : ∀ P Q R → P ⊗ (Q ⊗ R) ≡ (P ⊗ Q) ⊗ R
    ⊗-assoc end      Q        R        = refl
    ⊗-assoc (send P) Q        R        = send=′ λ m → ⊗-assoc (P m) Q R
    ⊗-assoc (recv P) end      R        = refl
    ⊗-assoc (recv P) (send Q) R        = send=′ λ m → ⊗-assoc (recv P) (Q m) R
    ⊗-assoc (recv P) (recv Q) end      = refl
    ⊗-assoc (recv P) (recv Q) (send R) = send=′ λ m → ⊗-assoc (recv P) (recv Q) (R m)
    ⊗-assoc (recv P) (recv Q) (recv R) = recv≃ ⊎-assoc-equiv
                                             λ { (inl m)       → ⊗-assoc (P m) (recv Q) (recv R)
                                               ; (inr (inl m)) → ⊗-assoc (recv P) (Q m) (recv R)
                                               ; (inr (inr m)) → ⊗-assoc (recv P) (recv Q) (R m) }

    ⅋-recvR : ∀ P{M}(Q : M → Proto) → ⟦ P ⅋ recv Q ⟧ ≡ (Π M λ m → ⟦ P ⅋ Q m ⟧)
    ⅋-recvR end      Q = refl
    ⅋-recvR (send P) Q = refl
    ⅋-recvR (recv P) Q = (Π=′ _ λ m → ⅋-recvR (P m) Q) ∙ ΠΠ-comm

    ⅋-comm : ∀ P Q → ⟦ P ⅋ Q ⟧ ≡ ⟦ Q ⅋ P ⟧
    ⅋-comm end      Q        = ! ap ⟦_⟧ (⅋-endR Q)
    ⅋-comm (recv P) Q        = (Π=′ _ λ m → ⅋-comm (P m) Q) ∙ ! ⅋-recvR Q P
    ⅋-comm (send P) end      = refl
    ⅋-comm (send P) (recv Q) = Π=′ _ λ m → ⅋-comm (send P) (Q m)
    ⅋-comm (send P) (send Q) = Σ≃ ⊎-comm-equiv [inl: (λ m → ⅋-comm (P m) (send Q))
                                               ,inr: (λ m → ⅋-comm (send P) (Q m)) ]

    ⅋-assoc : ∀ P Q R → P ⅋ (Q ⅋ R) ≡ (P ⅋ Q) ⅋ R
    ⅋-assoc end      Q        R        = refl
    ⅋-assoc (recv P) Q        R        = recv=′ λ m → ⅋-assoc (P m) Q R
    ⅋-assoc (send P) end      R        = refl
    ⅋-assoc (send P) (recv Q) R        = recv=′ λ m → ⅋-assoc (send P) (Q m) R
    ⅋-assoc (send P) (send Q) end      = refl
    ⅋-assoc (send P) (send Q) (recv R) = recv=′ λ m → ⅋-assoc (send P) (send Q) (R m)
    ⅋-assoc (send P) (send Q) (send R) = send≃ ⊎-assoc-equiv
                                             λ { (inl m)       → ⅋-assoc (P m) (send Q) (send R)
                                               ; (inr (inl m)) → ⅋-assoc (send P) (Q m) (send R)
                                               ; (inr (inr m)) → ⅋-assoc (send P) (send Q) (R m) }

  module _ {P Q R}{{_ : FunExt}} where
    dist-⊗-⊕′ : (Q ⊕ R) ⊗ P ≡ (Q ⊗ P) ⊕ (R ⊗ P)
    dist-⊗-⊕′ = send=′ [L: refl R: refl ]

    dist-⅋-&′ : (Q & R) ⅋ P ≡ (Q ⅋ P) & (R ⅋ P)
    dist-⅋-&′ = recv=′ [L: refl R: refl ]

    module _ {{_ : UA}} where
        dist-⊗-⊕ : ⟦ P ⊗ (Q ⊕ R) ⟧ ≡ ⟦ (P ⊗ Q) ⊕ (P ⊗ R) ⟧
        dist-⊗-⊕ = ⊗-comm P (Q ⊕ R)
                 ∙ ap ⟦_⟧ dist-⊗-⊕′
                 ∙ ⊕≡⊎
                 ∙ ⊎= (⊗-comm Q P) (⊗-comm R P)
                 ∙ ! ⊕≡⊎

        dist-⅋-& : ⟦ P ⅋ (Q & R) ⟧ ≡ ⟦ (P ⅋ Q) & (P ⅋ R) ⟧
        dist-⅋-& = ⅋-comm P (Q & R)
                 ∙ ap ⟦_⟧ dist-⅋-&′
                 ∙ &≡×
                 ∙ ×= (⅋-comm Q P) (⅋-comm R P)
                 ∙ ! &≡×

  -- P ⟦⊗⟧ Q ≃ ⟦ P ⊗ Q ⟧
  -- but potentially more convenient
  _⟦⊗⟧_ : Proto → Proto → ★
  end    ⟦⊗⟧ Q      = ⟦ Q ⟧
  send P ⟦⊗⟧ Q      = ∃ λ m → P m ⟦⊗⟧ Q
  P      ⟦⊗⟧ end    = ⟦ P ⟧
  P      ⟦⊗⟧ send Q = ∃ λ m → P ⟦⊗⟧ Q m
  recv P ⟦⊗⟧ recv Q = (Π _ λ m → P m    ⟦⊗⟧ recv Q)
                    × (Π _ λ n → recv P ⟦⊗⟧ Q n)

  module _ {{_ : FunExt}}{{_ : UA}} where
    ⟦⊗⟧-correct : ∀ P Q → P ⟦⊗⟧ Q ≡ ⟦ P ⊗ Q ⟧
    ⟦⊗⟧-correct end      Q        = refl
    ⟦⊗⟧-correct (send P) Q        = Σ=′ _ λ m → ⟦⊗⟧-correct (P m) Q
    ⟦⊗⟧-correct (recv P) end      = refl
    ⟦⊗⟧-correct (recv P) (send Q) = Σ=′ _ λ n → ⟦⊗⟧-correct (recv P) (Q n)
    ⟦⊗⟧-correct (recv P) (recv Q) = ! dist-×-Π
                                  ∙ Π=′ (_ ⊎ _) λ { (inl m)  → ⟦⊗⟧-correct (P m) (recv Q)
                                                  ; (inr n) → ⟦⊗⟧-correct (recv P) (Q n) }

  -- an alternative, potentially more convenient
  _⟦⅋⟧_ : Proto → Proto → ★
  end    ⟦⅋⟧ Q      = ⟦ Q ⟧
  recv P ⟦⅋⟧ Q      = ∀ m → P m ⟦⅋⟧ Q
  P      ⟦⅋⟧ end    = ⟦ P ⟧
  P      ⟦⅋⟧ recv Q = ∀ n → P ⟦⅋⟧ Q n
  send P ⟦⅋⟧ send Q = (∃ λ m → P m    ⟦⅋⟧ send Q)
                    ⊎ (∃ λ n → send P ⟦⅋⟧ Q n)

  module _ {{_ : FunExt}}{{_ : UA}} where
    ⟦⅋⟧-correct : ∀ P Q → P ⟦⅋⟧ Q ≡ ⟦ P ⅋ Q ⟧
    ⟦⅋⟧-correct end      Q        = refl
    ⟦⅋⟧-correct (recv P) Q        = Π=′ _ λ m → ⟦⅋⟧-correct (P m) Q
    ⟦⅋⟧-correct (send P) end      = refl
    ⟦⅋⟧-correct (send P) (recv Q) = Π=′ _ λ n → ⟦⅋⟧-correct (send P) (Q n)
    ⟦⅋⟧-correct (send P) (send Q) = ! dist-⊎-Σ
                                  ∙ Σ=′ (_ ⊎ _) λ { (inl m) → ⟦⅋⟧-correct (P m) (send Q)
                                                  ; (inr n) → ⟦⅋⟧-correct (send P) (Q n) }

                                                  {-
    -- sends can be pulled out of tensor
    source->>=-⊗ : ∀ P Q R → (source-of P >>= Q) ⊗ R ≡ source-of P >>= λ log → (Q log ⊗ R)
    source->>=-⊗ end       Q R = refl
    source->>=-⊗ (com _ P) Q R = send=′ λ m → source->>=-⊗ (P m) (Q ∘ _,_ m) R

    -- consequence[Q = const end]: ∀ P R → source-of P ⊗ R ≡ source-of P >> R

    -- recvs can be pulled out of par
    sink->>=-⅋ : ∀ P Q R → (sink-of P >>= Q) ⅋ R ≡ sink-of P >>= λ log → (Q log ⅋ R)
    sink->>=-⅋ end       Q R = refl
    sink->>=-⅋ (com _ P) Q R = recv=′ λ m → sink->>=-⅋ (P m) (Q ∘ _,_ m) R

    -- consequence[Q = const end]: ∀ P R → sink-of P ⅋ R ≡ sink-of P >> R

  Log-⅋-× : ∀ {P Q} → Log (P ⅋ Q) → Log P × Log Q
  Log-⅋-× {end}   {Q}      q           = end , q
  Log-⅋-× {recv P}{Q}      (m , p)     = first  (_,_ m) $ Log-⅋-× {P m} {Q} p
  Log-⅋-× {send P}{end}    (m , p)     = (m , p) , end
  Log-⅋-× {send P}{recv Q} (m , p)     = second (_,_ m) $ Log-⅋-× {send P} {Q m} p
  Log-⅋-× {send P}{send Q} (inl m , p) = first  (_,_ m) $ Log-⅋-× {P m} {send Q} p
  Log-⅋-× {send P}{send Q} (inr m , p) = second (_,_ m) $ Log-⅋-× {send P} {Q m} p

  module _ {{_ : FunExt}} where
    ⊗⅋-dual : ∀ P Q → dual (P ⅋ Q) ≡ dual P ⊗ dual Q
    ⊗⅋-dual end Q = refl
    ⊗⅋-dual (recv P) Q = com=′ _ λ m → ⊗⅋-dual (P m) _
    ⊗⅋-dual (send P) end = refl
    ⊗⅋-dual (send P) (recv Q) = com=′ _ λ n → ⊗⅋-dual (send P) (Q n)
    ⊗⅋-dual (send P) (send Q) = com=′ _
      [inl: (λ m → ⊗⅋-dual (P m) (send Q))
      ,inr: (λ n → ⊗⅋-dual (send P) (Q n))
      ]

  data View-⅋-proto : Proto → Proto → ★₁ where
    end-X     : ∀ Q → View-⅋-proto end Q
    recv-X    : ∀ {M}(P : M → Proto)Q → View-⅋-proto (recv P) Q
    send-send : ∀ {M N}(P : M → Proto)(Q : N → Proto) → View-⅋-proto (send P) (send Q)
    send-recv : ∀ {M N}(P : M → Proto)(Q : N → Proto) → View-⅋-proto (send P) (recv Q)
    send-end  : ∀ {M}(P : M → Proto) → View-⅋-proto (send P) end

  view-⅋-proto : ∀ P Q → View-⅋-proto P Q
  view-⅋-proto end      Q        = end-X Q
  view-⅋-proto (recv P) Q        = recv-X P Q
  view-⅋-proto (send P) end      = send-end P
  view-⅋-proto (send P) (recv Q) = send-recv P Q
  view-⅋-proto (send P) (send Q) = send-send P Q

  data View-⊗-proto : Proto → Proto → ★₁ where
    end-X     : ∀ Q → View-⊗-proto end Q
    send-X    : ∀ {M}(P : M → Proto)Q → View-⊗-proto (send P) Q
    recv-recv : ∀ {M N}(P : M → Proto)(Q : N → Proto) → View-⊗-proto (recv P) (recv Q)
    recv-send : ∀ {M N}(P : M → Proto)(Q : N → Proto) → View-⊗-proto (recv P) (send Q)
    recv-end  : ∀ {M}(P : M → Proto) → View-⊗-proto (recv P) end

  view-⊗-proto : ∀ P Q → View-⊗-proto P Q
  view-⊗-proto end      Q        = end-X Q
  view-⊗-proto (send P) Q        = send-X P Q
  view-⊗-proto (recv P) end      = recv-end P
  view-⊗-proto (recv P) (recv Q) = recv-recv P Q
  view-⊗-proto (recv P) (send Q) = recv-send P Q

  -- the terminology used for the constructor follows the behavior of the combined process
  data View-⅋ : ∀ P Q → ⟦ P ⅋ Q ⟧ → ★₁ where
    sendL' : ∀ {M N}(P : M → Proto)(Q : N → Proto)(m  : M )(p : ⟦ P m ⅋ send Q ⟧) → View-⅋ (send P) (send Q) (inl m  , p)
    sendR' : ∀ {M N}(P : M → Proto)(Q : N → Proto)(n : N)(p : ⟦ send P ⅋ Q n ⟧) → View-⅋ (send P) (send Q) (inr n , p)
    recvL' : ∀ {M} (P : M → Proto) Q (p : ((m : M) → ⟦ P m ⅋ Q ⟧)) → View-⅋ (recv P) Q p
    recvR' : ∀ {M N} (P : M → Proto) (Q : N → Proto)(p : (n : N) → ⟦ send P ⅋ Q n ⟧) → View-⅋ (send P) (recv Q) p
    endL   : ∀ Q (p : ⟦ Q ⟧) → View-⅋ end Q p
    send'  : ∀ {M}(P : M → Proto)(m : M)(p : ⟦ P m ⟧) → View-⅋ (send P) end (m , p)

  view-⅋ : ∀ P Q (p : ⟦ P ⅋ Q ⟧) → View-⅋ P Q p
  view-⅋ end Q p = endL Q p
  view-⅋ (recv P) Q p = recvL' P Q p
  view-⅋ (send P) end (m , p) = send' P m p
  view-⅋ (send P) (recv Q) p = recvR' P Q p
  view-⅋ (send P) (send Q) (inl x , p) = sendL' P Q x p
  view-⅋ (send P) (send Q) (inr y , p) = sendR' P Q y p

  {-
  -- use coe (... ⅋-assoc P Q R)
  ⅋-assoc : ∀ P Q R → ⟦ P ⅋ (Q ⅋ R) ⟧ → ⟦ (P ⅋ Q) ⅋ R ⟧
  ⅋-assoc end      Q        R         s                 = s
  ⅋-assoc (recv P) Q        R         s m               = ⅋-assoc (P m) _ _ (s m)
  ⅋-assoc (send P) end      R         s                 = s
  ⅋-assoc (send P) (recv Q) R         s m               = ⅋-assoc (send P) (Q m) _ (s m)
  ⅋-assoc (send P) (send Q) end       s                 = s
  ⅋-assoc (send P) (send Q) (recv R)  s m               = ⅋-assoc (send P) (send Q) (R m) (s m)
  ⅋-assoc (send P) (send Q) (send R) (inl m , s)       = inl (inl m) , ⅋-assoc (P m) (send Q) (send R) s
  ⅋-assoc (send P) (send Q) (send R) (inr (inl m) , s) = inl (inr m) , ⅋-assoc (send P) (Q m) (send R) s
  ⅋-assoc (send P) (send Q) (send R) (inr (inr m) , s) = inr m       , ⅋-assoc (send P) (send Q) (R m) s

  -- use coe (⅋-endR P) instead
  ⅋-rend : ∀ P → ⟦ P ⅋ end ⟧  → ⟦ P ⟧
  ⅋-rend end      p = p
  ⅋-rend (send _) p = p
  ⅋-rend (recv P) p = λ m → ⅋-rend (P m) (p m)

  -- use coe! (⅋-endR P) instead
  ⅋-rend! : ∀ P  → ⟦ P ⟧ → ⟦ P ⅋ end ⟧
  ⅋-rend! end      p = p
  ⅋-rend! (send _) p = p
  ⅋-rend! (recv P) p = λ m → ⅋-rend! (P m) (p m)

  -- use coe! (⅋-recvR P Q) instead
  ⅋-isendR : ∀ {N} P Q → ⟦ P ⅋ recv Q ⟧ → (n : N) → ⟦ P ⅋ Q n ⟧
  ⅋-isendR end Q s n = s n
  ⅋-isendR (recv P) Q s n = λ m → ⅋-isendR (P m) Q (s m) n
  ⅋-isendR (send P) Q s n = s n

  -- see ⅋-recvR
  ⅋-recvR : ∀ {M} P Q → ((m : M) → ⟦ P ⅋ Q m ⟧) → ⟦ P ⅋ recv Q ⟧
  ⅋-recvR end      Q s = s
  ⅋-recvR (recv P) Q s = λ x → ⅋-recvR (P x) Q (λ m → s m x)
  ⅋-recvR (send P) Q s = s
  -}

  module _ {{_ : FunExt}}{{_ : UA}} where

    ⅋-sendR : ∀ {M}P{Q : M → Proto}(m : M) → ⟦ P ⅋ Q m ⟧ → ⟦ P ⅋ send Q ⟧
    ⅋-sendR end      m p = m , p
    ⅋-sendR (send P) m p = inr m , p
    ⅋-sendR (recv P) m p = λ x → ⅋-sendR (P x) m (p x)

    ⅋-sendL : ∀ {M}{P : M → Proto} Q (m : M) → ⟦ P m ⅋ Q ⟧ → ⟦ send P ⅋ Q ⟧
    ⅋-sendL {M} {P} Q m pq = coe (⅋-comm Q (send P)) (⅋-sendR Q m (coe (⅋-comm (P m) Q) pq))

    ⅋-id : ∀ P → ⟦ dual P ⅋ P ⟧
    ⅋-id end      = end
    ⅋-id (recv P) = λ x → ⅋-sendL (P x) x (⅋-id (P x))
    ⅋-id (send P) = λ x → ⅋-sendR (dual (P x)) x (⅋-id (P x))

  data View-∘ : ∀ P Q R → ⟦ P ⅋ Q ⟧ → ⟦ dual Q ⅋ R ⟧ → ★₁ where
    sendLL : ∀ {M N}(P : M → Proto)(Q : N → Proto) R (m : M)(p : ⟦ P m ⅋ send Q ⟧)(q : ⟦ dual (send Q) ⅋ R ⟧)
             → View-∘ (send P) (send Q) R (inl m , p) q
    recvLL : ∀ {M} (P : M → Proto) Q R
               (p : ((m : M) → ⟦ P m ⅋ Q ⟧))(q : ⟦ dual Q ⅋ R ⟧)
             → View-∘ (recv P) Q R p q
    recvR-sendR : ∀ {MP MQ MR}ioP(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
                    (mR : MR)(p : ⟦ com ioP P ⅋ recv Q ⟧)(q : ⟦ dual (recv Q) ⅋ R mR ⟧)
                    → View-∘ (com ioP P) (recv Q) (send R) p (inr mR , q)

    recvRR : ∀ {MP MQ MR}(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
               (p : ⟦ send P ⅋ recv Q ⟧)(q : (m : MR) → ⟦ dual (recv Q) ⅋ R m ⟧)
             → View-∘ (send P) (recv Q) (recv R) p q
    sendR-recvL : ∀ {MP MQ}(P : MP → Proto)(Q : MQ → Proto)R(m : MQ)
                    (p : ⟦ send P ⅋ Q m ⟧)(q : (m : MQ) → ⟦ dual (Q m) ⅋ R ⟧)
                  → View-∘ (send P) (send Q) R (inr m , p) q
    recvR-sendL : ∀ {MP MQ MR}(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
                    (p : (m : MQ) → ⟦ send P ⅋ Q m ⟧)(m : MQ)(q : ⟦ dual (Q m) ⅋ send R ⟧)
                  → View-∘ (send P) (recv Q) (send R) p (inl m , q)
    endL : ∀ Q R
           → (q : ⟦ Q ⟧)(qr : ⟦ dual Q ⅋ R ⟧)
           → View-∘ end Q R q qr
    sendLM : ∀ {MP}(P : MP → Proto)R
               (m : MP)(p : ⟦ P m ⟧)(r : ⟦ R ⟧)
             → View-∘ (send P) end R (m , p) r
    recvL-sendR : ∀ {MP MQ}(P : MP → Proto)(Q : MQ → Proto)
                    (m : MQ)(p : ∀ m → ⟦ send P ⅋ Q m ⟧)(q : ⟦ dual (Q m) ⟧)
                  → View-∘ (send P) (recv Q) end p (m , q)

  view-∘ : ∀ P Q R (pq : ⟦ P ⅋ Q ⟧)(qr : ⟦ dual Q ⅋ R ⟧) → View-∘ P Q R pq qr
  view-∘ P Q R pq qr = view-∘-view (view-⅋ P Q pq) (view-⅋ (dual Q) R qr)
   where
    view-∘-view : ∀ {P Q R}{pq : ⟦ P ⅋ Q ⟧}{qr : ⟦ dual Q ⅋ R ⟧} → View-⅋ P Q pq → View-⅋ (dual Q) R qr → View-∘ P Q R pq qr
    view-∘-view (sendL' _ _ _ _) _                 = sendLL _ _ _ _ _ _
    view-∘-view (recvL' _ _ _)   _                 = recvLL _ _ _ _ _
    view-∘-view (sendR' _ _ _ _) _                 = sendR-recvL _ _ _ _ _ _
    view-∘-view (recvR' _ _ _)   (sendL' ._ _ _ _) = recvR-sendL _ _ _ _ _ _
    view-∘-view (recvR' _ _ _)   (sendR' ._ _ _ _) = recvR-sendR _ _ _ _ _ _ _
    view-∘-view (recvR' _ _ _)   (recvR' ._ _ _)   = recvRR _ _ _ _ _
    view-∘-view (recvR' _ _ _)   (send' ._ _ _)    = recvL-sendR _ _ _ _ _
    view-∘-view (endL _ _)       _                 = endL _ _ _ _
    view-∘-view (send' _ _ _)    _                 = sendLM _ _ _ _ _

  ⅋-apply : ∀ P Q → ⟦ P ⅋ Q ⟧ → ⟦ dual P ⟧ → ⟦ Q ⟧
  ⅋-apply end      Q        s           p       = s
  ⅋-apply (recv P) Q        s           (m , p) = ⅋-apply (P m) Q (s m) p
  ⅋-apply (send P) end      s           p       = _
  ⅋-apply (send P) (recv Q) s           p n     = ⅋-apply (send P) (Q n) (s n) p
  ⅋-apply (send P) (send Q) (inl m , s) p       = ⅋-apply (P m) (send Q) s (p m)
  ⅋-apply (send P) (send Q) (inr m , s) p       = m , ⅋-apply (send P) (Q m) s p

  {-
  -- see dist-⅋-&
  dist-⅋-fst : ∀ P Q R → ⟦ P ⅋ (Q & R) ⟧ → ⟦ P ⅋ Q ⟧
  dist-⅋-fst (recv P) Q R p = λ m → dist-⅋-fst (P m) Q R (p m)
  dist-⅋-fst (send P) Q R p = p `L
  dist-⅋-fst end      Q R p = p `L

  -- see dist-⅋-&
  dist-⅋-snd : ∀ P Q R → ⟦ P ⅋ (Q & R) ⟧ → ⟦ P ⅋ R ⟧
  dist-⅋-snd (recv P) Q R p = λ m → dist-⅋-snd (P m) Q R (p m)
  dist-⅋-snd (send P) Q R p = p `R
  dist-⅋-snd end      Q R p = p `R

  -- see dist-⅋-&
  dist-⅋-× : ∀ P Q R → ⟦ P ⅋ (Q & R) ⟧ → ⟦ P ⅋ Q ⟧ × ⟦ P ⅋ R ⟧
  dist-⅋-× P Q R p = dist-⅋-fst P Q R p , dist-⅋-snd P Q R p

  -- see dist-⅋-&
  dist-⅋-& : ∀ P Q R → ⟦ P ⅋ (Q & R) ⟧ → ⟦ (P ⅋ Q) & (P ⅋ R) ⟧
  dist-⅋-& P Q R p = ×→& (dist-⅋-× P Q R p)

  -- see dist-⅋-&
  factor-,-⅋ : ∀ P Q R → ⟦ P ⅋ Q ⟧ → ⟦ P ⅋ R ⟧ → ⟦ P ⅋ (Q & R) ⟧
  factor-,-⅋ end      Q R pq pr = ×→& (pq , pr)
  factor-,-⅋ (recv P) Q R pq pr = λ m → factor-,-⅋ (P m) Q R (pq m) (pr m)
  factor-,-⅋ (send P) Q R pq pr = [L: pq R: pr ]

  -- see dist-⅋-&
  factor-×-⅋ : ∀ P Q R → ⟦ P ⅋ Q ⟧ × ⟦ P ⅋ R ⟧ → ⟦ P ⅋ (Q & R) ⟧
  factor-×-⅋ P Q R (p , q) = factor-,-⅋ P Q R p q

  -- see dist-⅋-&
  factor-&-⅋ : ∀ P Q R → ⟦ (P ⅋ Q) & (P ⅋ R) ⟧ → ⟦ P ⅋ (Q & R) ⟧
  factor-&-⅋ P Q R p = factor-×-⅋ P Q R (&→× p)

  -- see dist-⅋-&
  module _ {{_ : FunExt}} where
    dist-⅋-fst-factor-&-, : ∀ P Q R (pq : ⟦ P ⅋ Q ⟧)(pr : ⟦ P ⅋ R ⟧)
                            → dist-⅋-fst P Q R (factor-,-⅋ P Q R pq pr) ≡ pq
    dist-⅋-fst-factor-&-, (recv P) Q R pq pr = λ= λ m → dist-⅋-fst-factor-&-, (P m) Q R (pq m) (pr m)
    dist-⅋-fst-factor-&-, (send P) Q R pq pr = refl
    dist-⅋-fst-factor-&-, end      Q R pq pr = refl

    dist-⅋-snd-factor-&-, : ∀ P Q R (pq : ⟦ P ⅋ Q ⟧)(pr : ⟦ P ⅋ R ⟧)
                            → dist-⅋-snd P Q R (factor-,-⅋ P Q R pq pr) ≡ pr
    dist-⅋-snd-factor-&-, (recv P) Q R pq pr = λ= λ m → dist-⅋-snd-factor-&-, (P m) Q R (pq m) (pr m)
    dist-⅋-snd-factor-&-, (send P) Q R pq pr = refl
    dist-⅋-snd-factor-&-, end      Q R pq pr = refl

    factor-×-⅋-linv-dist-⅋-× : ∀ P Q R → (factor-×-⅋ P Q R) LeftInverseOf (dist-⅋-× P Q R)
    factor-×-⅋-linv-dist-⅋-× (recv P) Q R p = λ= λ m → factor-×-⅋-linv-dist-⅋-× (P m) Q R (p m)
    factor-×-⅋-linv-dist-⅋-× (send P) Q R p = λ= λ { `L → refl ; `R → refl }
    factor-×-⅋-linv-dist-⅋-× end      Q R p = λ= λ { `L → refl ; `R → refl }

    module _ P Q R where
        factor-×-⅋-rinv-dist-⅋-× : (factor-×-⅋ P Q R) RightInverseOf (dist-⅋-× P Q R)
        factor-×-⅋-rinv-dist-⅋-× (x , y) = pair×= (dist-⅋-fst-factor-&-, P Q R x y) (dist-⅋-snd-factor-&-, P Q R x y)

        dist-⅋-×-≃ : ⟦ P ⅋ (Q & R) ⟧ ≃ (⟦ P ⅋ Q ⟧ × ⟦ P ⅋ R ⟧)
        dist-⅋-×-≃ = dist-⅋-× P Q R
                   , record { linv = factor-×-⅋ P Q R; is-linv = factor-×-⅋-linv-dist-⅋-× P Q R
                            ; rinv = factor-×-⅋ P Q R; is-rinv = factor-×-⅋-rinv-dist-⅋-× }

        dist-⅋-&-≃ : ⟦ P ⅋ (Q & R) ⟧ ≃ ⟦ (P ⅋ Q) & (P ⅋ R) ⟧
        dist-⅋-&-≃ = dist-⅋-×-≃ ≃-∙ ≃-! &≃×
  -}

module _ {{_ : FunExt}}{{_ : UA}} where
  ⊗-pair : ∀ {P Q} → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P ⊗ Q ⟧
  ⊗-pair {end}    {Q}      p q       = q
  ⊗-pair {send P} {Q}      (m , p) q = m , ⊗-pair {P m} p q
  ⊗-pair {recv P} {end}    p end     = p
  ⊗-pair {recv P} {send Q} p (m , q) = m , ⊗-pair {recv P} {Q m} p q
  ⊗-pair {recv P} {recv Q} p q       = [inl: (λ m → ⊗-pair {P m}    {recv Q} (p m) q)
                                       ,inr: (λ n → ⊗-pair {recv P} {Q n}    p     (q n)) ]

  ⊗-fst : ∀ P Q → ⟦ P ⊗ Q ⟧ → ⟦ P ⟧
  ⊗-fst end      Q        pq       = _
  ⊗-fst (send P) Q        (m , pq) = m , ⊗-fst (P m) Q pq
  ⊗-fst (recv P) end      pq       = pq
  ⊗-fst (recv P) (send Q) (_ , pq) = ⊗-fst (recv P) (Q _) pq
  ⊗-fst (recv P) (recv Q) pq       = λ m → ⊗-fst (P m) (recv Q) (pq (inl m))

  ⊗-snd : ∀ P Q → ⟦ P ⊗ Q ⟧ → ⟦ Q ⟧
  ⊗-snd end      Q        pq       = pq
  ⊗-snd (send P) Q        (_ , pq) = ⊗-snd (P _) Q pq
  ⊗-snd (recv P) end      pq       = end
  ⊗-snd (recv P) (send Q) (m , pq) = m , ⊗-snd (recv P) (Q m) pq
  ⊗-snd (recv P) (recv Q) pq       = λ m → ⊗-snd (recv P) (Q m) (pq (inr m))

  ⊗-pair-fst : ∀ P Q (p : ⟦ P ⟧)(q : ⟦ Q ⟧) → ⊗-fst P Q (⊗-pair {P} {Q} p q) ≡ p
  ⊗-pair-fst end      Q        p q       = refl
  ⊗-pair-fst (send P) Q        (m , p) q = pair= refl (⊗-pair-fst (P m) Q p q)
  ⊗-pair-fst (recv P) end      p q       = refl
  ⊗-pair-fst (recv P) (send Q) p (m , q) = ⊗-pair-fst (recv P) (Q m) p q
  ⊗-pair-fst (recv P) (recv Q) p q       = λ= λ m → ⊗-pair-fst (P m) (recv Q) (p m) q

  ⊗-pair-snd : ∀ P Q (p : ⟦ P ⟧)(q : ⟦ Q ⟧) → ⊗-snd P Q (⊗-pair {P} {Q} p q) ≡ q
  ⊗-pair-snd end      Q        p q       = refl
  ⊗-pair-snd (send P) Q        (m , p) q = ⊗-pair-snd (P m) Q p q
  ⊗-pair-snd (recv P) end      p q       = refl
  ⊗-pair-snd (recv P) (send Q) p (m , q) = pair= refl (⊗-pair-snd (recv P) (Q m) p q)
  ⊗-pair-snd (recv P) (recv Q) p q       = λ= λ m → ⊗-pair-snd (recv P) (Q m) p (q m)

  module _ P Q where
    ⊗→× : ⟦ P ⊗ Q ⟧ → ⟦ P ⟧ × ⟦ Q ⟧
    ⊗→× pq = ⊗-fst P Q pq , ⊗-snd P Q pq

    ×→⊗ : ⟦ P ⟧ × ⟦ Q ⟧ → ⟦ P ⊗ Q ⟧
    ×→⊗ (p , q) = ⊗-pair {P} {Q} p q

    ×→⊗→× : ×→⊗ RightInverseOf ⊗→×
    ×→⊗→× = λ { (x , y) → pair×= (⊗-pair-fst P Q x y) (⊗-pair-snd P Q x y) }

    ⊗→×-has-rinv : Rinv ⊗→×
    ⊗→×-has-rinv = record { rinv = ×→⊗ ; is-rinv = ×→⊗→× }

  {- WRONG
  ⊗→×→⊗ : (×→⊗ P Q) LeftInverseOf (⊗→× P Q)
  ⊗≃×   : ⟦ P ⊗ Q ⟧ ≃ ⟦ P ⟧ × ⟦ Q ⟧
  ⟦⊗⟧≡× : P ⟦⊗⟧ Q ≡ (⟦ P ⟧ × ⟦ Q ⟧)
  -}

  -o-apply : ∀ {P Q} → ⟦ dual P ⅋ Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
  -o-apply {P} {Q} pq p = ⅋-apply (dual P) Q pq (subst ⟦_⟧ (≡.sym (≡ᴾ-sound (dual-involutive P))) p)

  o-o-apply : ∀ P Q → ⟦ P o-o Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
  o-o-apply P Q Po-oQ p = -o-apply {P} {Q} (⊗-fst (P -o Q) (Q -o P) Po-oQ) p

  o-o-comm : ∀ P Q → ⟦ P o-o Q ⟧ ≡ ⟦ Q o-o P ⟧
  o-o-comm P Q = ⊗-comm (dual P ⅋ Q) (dual Q ⅋ P)

  -- left-biased “strategy”
  par : ∀ P Q → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P ⅋ Q ⟧
  par (recv P) Q p       q = λ m → par (P m) Q (p m) q
  par (send P) Q (m , p) q = ⅋-sendL Q m (par (P m) Q p q)
  par end      Q end     q = q

  ⅋-∘ : ∀ P Q R → ⟦ P ⅋ Q ⟧ → ⟦ dual Q ⅋ R ⟧ → ⟦ P ⅋ R ⟧
  ⅋-∘ P Q R pq qr = ⅋-∘-view (view-∘ P Q R pq qr)
   where
    ⅋-∘-view : ∀ {P Q R}{pq : ⟦ P ⅋ Q ⟧}{qr : ⟦ dual Q ⅋ R ⟧} → View-∘ P Q R pq qr → ⟦ P ⅋ R ⟧
    ⅋-∘-view (sendLL P Q R m p qr)          = ⅋-sendL R m (⅋-∘ (P m) (send Q) R p qr)
    ⅋-∘-view (recvLL P Q R p qr)            = λ m → ⅋-∘ (P m) Q R (p m) qr
    ⅋-∘-view (recvR-sendR ioP P Q R m pq q) = ⅋-sendR (com ioP P) m (⅋-∘ (com ioP P) (recv Q) (R m) pq q)
    ⅋-∘-view (recvRR P Q R pq q)            = λ m → ⅋-∘ (send P) (recv Q) (R m) pq (q m)
    ⅋-∘-view (sendR-recvL P Q R m p q)      = ⅋-∘ (send P) (Q m) R p (q m)
    ⅋-∘-view (recvR-sendL P Q R p m q)      = ⅋-∘ (send P) (Q m) (send R) (p m) q
    ⅋-∘-view (endL Q R pq qr)               = -o-apply {Q} {R} qr pq
    ⅋-∘-view (sendLM P R m pq qr)           = ⅋-sendL R m (par (P m) R pq qr)
    ⅋-∘-view (recvL-sendR P Q m pq qr)      = ⅋-∘ (send P) (Q m) end (pq m) (coe! (ap ⟦_⟧ (⅋-endR (dual (Q m)))) qr)

    {-
  mutual
    ⅋-comm : ∀ P Q → ⟦ P ⅋ Q ⟧ → ⟦ Q ⅋ P ⟧
    ⅋-comm P Q p = ⅋-comm-view (view-⅋ P Q p)

    ⅋-comm-view : ∀ {P Q} {pq : ⟦ P ⅋ Q ⟧} → View-⅋ P Q pq → ⟦ Q ⅋ P ⟧
    ⅋-comm-view (sendL' P Q m p) = ⅋-sendR (send Q) m (⅋-comm (P m) (send Q) p)
    ⅋-comm-view (sendR' P Q n p) = inl n , ⅋-comm (send P) (Q n) p
    ⅋-comm-view (recvL' P Q pq)  = ⅋-recvR Q P λ m → ⅋-comm (P m) Q (pq m)
    ⅋-comm-view (recvR' P Q pq)  = λ n → ⅋-comm (send P) (Q n) (pq n)
    ⅋-comm-view (endL Q pq)      = ⅋-rend! Q pq
    ⅋-comm-view (send P m pq)    = m , pq
  -}

  switchL' : ∀ P Q R (pq : ⟦ P ⅋ Q ⟧) (r : ⟦ R ⟧) → ⟦ P ⅋ (Q ⊗ R) ⟧
  switchL' end      Q        R        q  r = ⊗-pair {Q} {R} q r
  switchL' (send P) end      R        p  r = par (send P) R p r
  switchL' (send P) (send Q) R        (inl m , pq) r = inl m , switchL' (P m) (send Q) R pq r
  switchL' (send P) (send Q) R        (inr m , pq) r = inr m , switchL' (send P) (Q m) R pq r
  switchL' (send P) (recv Q) end      pq r = pq
  switchL' (send P) (recv Q) (send R) pq (m , r) = inr m , switchL' (send P) (recv Q) (R m) pq r
  switchL' (send P) (recv Q) (recv R) pq r (inl m) = switchL' (send P) (Q m) (recv R) (pq m) r
  switchL' (send P) (recv Q) (recv R) pq r (inr m) = switchL' (send P) (recv Q) (R m) pq (r m)
  switchL' (recv P) Q R pq r = λ m → switchL' (P m) Q R (pq m) r

  switchL : ∀ P Q R → ⟦ (P ⅋ Q) ⊗ R ⟧ → ⟦ P ⅋ (Q ⊗ R) ⟧
  switchL P Q R pqr = switchL' P Q R (⊗-fst (P ⅋ Q) R pqr) (⊗-snd (P ⅋ Q) R pqr)

  -- multiplicative mix (left-biased)
  mmix : ∀ P Q → ⟦ P ⊗ Q ⟧ → ⟦ P ⅋ Q ⟧
  mmix P Q pq = par P Q (⊗-fst P Q pq) (⊗-snd P Q pq)

  -- additive mix (left-biased)
  amix : ∀ P Q → ⟦ P & Q ⟧ → ⟦ P ⊕ Q ⟧
  amix P Q pq = (`L , pq `L)

{-
A `⊗ B 'times', context chooses how A and B are used
A `⅋ B 'par', "we" chooses how A and B are used
A `⊕ B 'plus', select from A or B
A `& B 'with', offer choice of A or B
`! A   'of course!', server accept
`? A   'why not?', client request
`1     unit for `⊗
`⊥     unit for `⅋
`0     unit for `⊕
`⊤     unit for `&
-}
data CLL : ★ where
  `1 `⊤ `0 `⊥ : CLL
  _`⊗_ _`⅋_ _`⊕_ _`&_ : (A B : CLL) → CLL
  -- `!_ `?_ : (A : CLL) → CLL

_⊥ : CLL → CLL
`1 ⊥ = `⊥
`⊥ ⊥ = `1
`0 ⊥ = `⊤
`⊤ ⊥ = `0
(A `⊗ B)⊥ = A ⊥ `⅋ B ⊥
(A `⅋ B)⊥ = A ⊥ `⊗ B ⊥
(A `⊕ B)⊥ = A ⊥ `& B ⊥
(A `& B)⊥ = A ⊥ `⊕ B ⊥
{-
(`! A)⊥ = `?(A ⊥)
(`? A)⊥ = `!(A ⊥)
-}

CLL-proto : CLL → Proto
CLL-proto `1       = end  -- TODO
CLL-proto `⊥       = end  -- TODO
CLL-proto `0       = send′ 𝟘 end -- Alt: send λ()
CLL-proto `⊤       = recv′ 𝟘 end -- Alt: recv λ()
CLL-proto (A `⊗ B) = CLL-proto A ⊗ CLL-proto B
CLL-proto (A `⅋ B) = CLL-proto A ⅋ CLL-proto B
CLL-proto (A `⊕ B) = CLL-proto A ⊕ CLL-proto B
CLL-proto (A `& B) = CLL-proto A & CLL-proto B

{- The point of this could be to devise a particular equivalence
   relation for processes. It could properly deal with ⅋. -}

module Commitment {Secret Guess : ★} {R : ..(_ : Secret) → Guess → ★} where
    Commit : Proto
    Commit = send☐ λ (s : Secret) →
             recv  λ (g : Guess)  →
             send  λ (_ : S⟨ s ⟩) →
             end

    commit : (s : Secret)  → ⟦ Commit ⟧
    commit s = [ s ] , λ g → S[ s ] , _

    decommit : (g : Guess) → ⟦ dual Commit ⟧
    decommit g = λ { [ m ] → g , _ }

open import Relation.Nullary
open import Relation.Nullary.Decidable
{-
test-sim : Sim (𝟘 ×' end) end
test-sim = end
-}

-- Prove knowledge of a discrete log
-- Adapted here to have precise types
module Shnorr-protocol
    (G ℤq : ★)
    (g    : G)
    (_^_  : G  → ℤq → G)
    (_·_  : G  → G  → G)
    (_+_  : ℤq → ℤq → ℤq)
    (_*_  : ℤq → ℤq → ℤq)
    (_≟_  : (x y : G) → Dec (x ≡ y))
    where
    module Real where
        Prover : Proto
        Prover = send λ (gʳ : G)  → -- commitment
                 recv λ (c  : ℤq) → -- challenge
                 send λ (s  : ℤq) → -- response
                 end

        Verifier : Proto
        Verifier = dual Prover

        -- he is honest but its type does not say it
        prover : (x r : ℤq) → ⟦ Prover ⟧
        prover x r = (g ^ r) , λ c → (r + (c * x)) , _

        Honest-Prover : ..(x : ℤq) (y : S⟨ g ^ x ⟩) → Proto
        Honest-Prover x y
          = send☐ λ (r  : ℤq)                → -- ideal commitment
            send  λ (gʳ : S⟨ g ^ r ⟩)        → -- real  commitment
            recv  λ (c  : ℤq)                → -- challenge
            send  λ (s  : S⟨ r + (c * x) ⟩)  → -- response
            recv  λ (_  : Dec ((g ^ unS s) ≡ (unS gʳ · (unS y ^ c)))) →
            end

        Honest-Verifier : ..(x : ℤq) (y : S⟨ g ^ x ⟩) → Proto
        Honest-Verifier x y = dual (Honest-Prover x y)

        honest-prover : (x r : ℤq) → ⟦ Honest-Prover x S[ g ^ x ] ⟧
        honest-prover x r = [ r ] , S[ g ^ r ] , λ c → S[ r + (c * x) ] , _
        -- agsy can do it

        honest-verifier : ..(x : ℤq) (y : S⟨ g ^ x ⟩) (c : ℤq) → ⟦ Honest-Verifier x y ⟧
        honest-verifier x y c = λ { [ r ] → λ gʳ → c , λ s → (g ^ unS s) ≟ (unS gʳ · (unS y ^ c)) , _ }

        honest-prover→prover : ..(x : ℤq)(y : S⟨ g ^ x ⟩) → ⟦ Honest-Prover x y ⟧ → ⟦ Prover ⟧
        honest-prover→prover x y ([ r ] , gʳ , p) = unS gʳ , λ c → case p c of λ { (s , _) → unS s , _ }

        {-
        sim-honest-prover : ..(x : ℤq)(y : S⟨ g ^ x ⟩) → Sim (dual (Honest-Prover x y)) Prover
        sim-honest-prover x y = recvL (λ { [ r ] →
                                recvL λ gʳ →
                                sendR (unS gʳ) (
                                recvR λ c →
                                sendL c (recvL λ s → sendR (unS s) (sendL {!!} {!!}) )) })
                                -}

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


A tiny universe for explorations

A tiny universe for explorations

open import Level.NP
open import Type
open import Data.One
open import Data.Two
open import Data.Product
open import Explore.Type
open import Explore.One
open import Explore.Two
open import Explore.Product

module Explore.Universe where

open Operators

{-
open import FunUniverse.Data
-}
data Ty : ★ where
  𝟙′ 𝟚′ : Ty
  _×′_  : Ty → Ty → Ty

El : Ty → ★
El 𝟙′ = 𝟙
El 𝟚′ = 𝟚
El (u₀ ×′ u₁) = El u₀ × El u₁
--El (u ^′ x) = {!Vec (El u) x!}

module _ {ℓ} where

    exploreU : ∀ u → Explore ℓ (El u)
    exploreU 𝟙′ = 𝟙ᵉ
    exploreU 𝟚′ = 𝟚ᵉ
    exploreU (u ×′ u₁) = exploreU u ×ᵉ exploreU u₁
    --exploreU (u ^′ x) = {!!}

    exploreU-ind : ∀ u → ExploreInd ℓ (exploreU u)
    exploreU-ind 𝟙′ = 𝟙ⁱ
    exploreU-ind 𝟚′ = 𝟚ⁱ
    exploreU-ind (u ×′ u₁) = exploreU-ind u ×ⁱ exploreU-ind u₁
    --exploreU-ind (u ^′ x) = {!!}

module _ {ℓ} where
    lookupU : ∀ u → Lookup {ℓ} (exploreU {ₛ ℓ} u)
    lookupU 𝟙′ = 𝟙ˡ
    lookupU 𝟚′ = 𝟚ˡ
    lookupU (u ×′ u₁) = lookup× {_} {_} {_} {exploreU u} {exploreU u₁} (lookupU u) (lookupU u₁)
    --lookupU (u ^′ x) = {!!}

error: pathspec 'lib/Explore/Universe.agda' did not match any file(s) known to git


thrm statement

thrm statement

open import Nat
open import Prelude
open import List
open import core

module expandability where
  mutual
    expandability-synth : (Γ : ·ctx) (e : ė) (t : τ̇) →
                          Γ ⊢ e => t →
                          Σ[ e' ∈ ë ] Σ[ Δ ∈ ·ctx ]
                            (Γ ⊢ e ⇒ t ~> e' ⊣ Δ)
    expandability-synth = {!!}

    expandability-ana : (Γ : ·ctx) (e : ė) (t : τ̇) →
                         Γ ⊢ e => t →
                          Σ[ e' ∈ ë ] Σ[ Δ ∈ ·ctx ] Σ[ t' ∈ τ̇ ]
                            (Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ)
    expandability-ana = {!!}

error: pathspec 'expandability.agda' did not match any file(s) known to git


Try using agda

Try using agda

module hierarchy where

data Bool : Set where
  true  : Bool
  false : Bool

_and_ : Bool → Bool → Bool
true and true = true
true and false = false
false and true = false
false and false = false

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

_==_ : ℕ → ℕ → Bool
zero == zero   = true
suc n == suc m = true
_ == _         = false

data List (A : Set) : Set where
  []   : List A
  _::_ : A → List A → List A

_∈_ : ℕ → List ℕ → Bool
x ∈ []      = false
x ∈ (y :: ys) with x == y
...              | true  = true
...              | false = x ∈ ys

_⊂_ : List ℕ → List ℕ → Bool
[] ⊂ ys      = true
(x :: xs) ⊂ ys with x ∈ ys
...               | true  = xs ⊂ ys
...               | false = false

_++_ : List ℕ → List ℕ → List ℕ
[] ++ ys        = ys
(x :: xs) ++ ys with (x ∈ ys)
...               | true  = xs ++ ys
...               | false = x :: (xs ++ ys)

data Arrow : Set where
  _⇒_ : List ℕ → ℕ → Arrow

SingleClosure : Arrow → List ℕ → List ℕ
SingleClosure (ts ⇒ h) ps with ts ⊂ ps
...                     | true  = h :: ps
...                     | false = ps

Closure' : List Arrow → List ℕ → List ℕ
Closure' [] roots = roots
Closure' (c :: cs) roots = (SingleClosure c roots) ++ (Closure' cs roots)

Closure : List Arrow → List ℕ → List ℕ
Closure arrows roots with (Closure' arrows roots) ⊂ roots
...                     | true = roots
...                     | false = Closure arrows (Closure' arrows roots)

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
_ , [] ⊢ _ = false
thms , p :: premises ⊢ conc = true

error: pathspec 'hierarchy.agda' did not match any file(s) known to git


Agda model for Desc.

Agda model for Desc.

{-# OPTIONS --type-in-type
            --no-termination-check
            --no-positivity-check #-}

module Desc where

import Data.Product
import Data.Unit
import Data.Empty

open import Data.Product
open import Data.Unit
open import Data.Empty

-- Bringing in an hand-made Prop universe

data PROP : Set where
  All : (S : Set) -> (S -> PROP) -> PROP
  And : PROP -> PROP -> PROP
  Trivial : PROP
  Absurd : PROP

Prf : PROP -> Set
Prf Absurd = ⊥
Prf Trivial = ⊤
Prf (All S P) = (x : S) -> Prf (P x)
Prf (And A B) = Σ (Prf A)  (\ _ -> Prf B)

-- Then, we build Desc in Set
-- it's all Set in Set here

-- Desc code:
data Desc : Set where
  Done : Desc
  Arg : (X : Set) -> (X -> Desc) -> Desc
  Ind : (X : Set) -> Desc -> Desc

descOp : Desc -> Set -> Set
descOp Done _ = ⊤
descOp (Arg A f) D = Σ A (\ a -> descOp (f a) D)
descOp (Ind H x) D =  Σ (H -> D) (\ _ -> descOp x D)

-- Followed by Mu:

data Mu (X : Desc) : Set where
  Con : descOp X (Mu X) -> Mu X

-- All of this is fully-furnished with:
--   * boxOp
--   * mapBoxOp
--   * elimOp

boxOp : (d : Desc) -> (D : Set) -> (bp : D -> PROP) -> (v : descOp d D) -> Set
boxOp Done _ _ _ =  ⊤
boxOp (Arg A f) d p v =  boxOp (f (proj₁ v)) d p (proj₂ v)
boxOp (Ind H x) d p v =  Prf ( All H (\y -> p (proj₁ v y)))
                      × boxOp x d p (proj₂ v)

mapBoxOp : (d : Desc) -> (D : Set) -> (bp : D -> PROP) ->
           (Prf (All D (\y -> bp y))) -> (v : descOp d D) ->
           (boxOp d D bp v)
mapBoxOp Done _ _ _ _ =  tt
mapBoxOp (Arg a f) d bp p v =  mapBoxOp (f (proj₁ v)) d bp p (proj₂ v)
mapBoxOp (Ind H x) d bp p v =  (\ y -> p (proj₁ v y)) ,  mapBoxOp x d bp p (proj₂ v)

-- On the Ind case, the Pig code is saying something along those lines:
-- mapBoxOp (Ind H x) d bp p v =  (\ y -> p (proj₁ v y)) ,  mapBoxOp x d bp p (p?! (proj₂ v))

elimOp : (d : Desc) -> (bp : Mu d -> PROP) ->
         (Prf (All (descOp d (Mu d)) (\ x -> (All (boxOp d (Mu d) bp x) (\ _ -> bp (Con x)))))) ->
         (v : Mu d) -> Prf (bp v)
elimOp d bp p (Con v) =  p v (mapBoxOp d (Mu d) bp (\x -> elimOp d bp p x) v)

error: pathspec 'models/Desc.agda' did not match any file(s) known to git


Added test for various arguments.

Added test for various arguments.

Ignore-this: 65825db26b50cc5e4fee1e0addff3694

darcs-hash:20111015073300-3bd4e-ded95ccd196a59d7ddb9b17c8ff7eec76aeacd2d.gz

error: pathspec 'Test/Succeed/VariousArguments.agda' did not match any file(s) known to git


Forgot a file.

Forgot a file.

module functions where

open import level
open import eq
open import product

{- Note that the Agda standard library has an interesting generalization
   of the following basic composition operator, with more dependent typing. -}

_∘_ : ∀{ℓ ℓ' ℓ''}{A : Set ℓ}{B : Set ℓ'}{C : Set ℓ''} →
      (B → C) → (A → B) → (A → C)
f ∘ g = λ x → f (g x)

∘-assoc : ∀{ℓ ℓ' ℓ'' ℓ'''}{A : Set ℓ}{B : Set ℓ'}{C : Set ℓ''}{D : Set ℓ'''}
           (f : C → D)(g : B → C)(h : A → B) → (f ∘ g) ∘ h ≡ f ∘ (g ∘ h)
∘-assoc f g h = refl

id : ∀{ℓ}{A : Set ℓ} → A → A
id = λ x → x

∘-id : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}(f : A → B) → f ∘ id ≡ f
∘-id f = refl

id-∘ : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}(f : A → B) → id ∘ f ≡ f
id-∘ f = refl

extensionality : {ℓ₁ ℓ₂ : Level} → Set (lsuc ℓ₁ ⊔ lsuc ℓ₂)
extensionality {ℓ₁}{ℓ₂} = ∀{A : Set ℓ₁}{B : Set ℓ₂}{f g : A → B} → (∀{a : A} → f a ≡ g a) → f ≡ g

record Iso {ℓ₁ ℓ₂ : Level} (A : Set ℓ₁) (B : Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
 constructor isIso
 field
   l-inv : A → B
   r-inv : B → A
   l-cancel : r-inv ∘ l-inv ≡ id
   r-cancel : l-inv ∘ r-inv ≡ id

curry : ∀{ℓ₁ ℓ₂ ℓ₃}{A : Set ℓ₁}{B : Set ℓ₂}{C : Set ℓ₃} → ((A × B) → C) → (A → B → C)
curry f x y = f (x , y)

uncurry : ∀{ℓ₁ ℓ₂ ℓ₃}{A : Set ℓ₁}{B : Set ℓ₂}{C : Set ℓ₃} → (A → B → C) → ((A × B) → C)
uncurry f (x , y) = f x y

error: pathspec 'functions.agda' did not match any file(s) known to git


Nand: all computations based on nands

Nand: all computations based on nands

-- http://en.wikipedia.org/wiki/NAND_logic
open import Type
open import FunUniverse.Core
open import Level.NP
--open import FunUniverse.Rewiring

module FunUniverse.Nand {t} {T : ★_ t} {funU : FunUniverse T} (rewiring : Rewiring funU) where

open FunUniverse funU
open Rewiring rewiring

module FromNand (nand : `𝟚 `× `𝟚 `→ `𝟚) where
  not : `𝟚 `→ `𝟚
  not  = dup ⁏ nand

  and or nor xor xnor : `𝟚 `× `𝟚 `→ `𝟚

  and  = nand ⁏ not
  or   = < not × not > ⁏ nand
  nor  = or ⁏ not
  xor  = < dup × dup > ⁏ inner2 (nand ⁏ dup) ⁏ < nand × nand > ⁏ nand
  xnor = xor ⁏ not

  -- xnor is _==_

  module _ {A B C D E}
    (f : A `× B `→ D)
    (g : A `× C `→ E) where

    dispatch : A `× B `× C `→ D `× E
    dispatch = first dup ⁏ inner2 swap ⁏ < f × g >

  --fork c e0 e1 = (not c ∧ e0) ∨ (c ∧ e1)
  fork : `𝟚 `× `𝟚 `× `𝟚 `→ `𝟚
  fork = dispatch (< not × id > ⁏ and) and ⁏ or

error: pathspec 'FunUniverse/Nand.agda' did not match any file(s) known to git


Implement modal logic

Implement modal logic

This doesn't belong here, but it reuses @Toxaris modular library.

Old-commit-hash: 2f12ca949c8cb58e2b65b773607282bafbccb5c9

module ModalLogic where

-- Implement Frank Pfenning's lambda calculus based on modal logic S4, as
-- described in "A Modal Analysis of Staged Computation".

open import Denotational.Notation

data BaseType : Set where
  Base : BaseType
  Next : BaseType → BaseType

data Type : Set where
  base : BaseType → Type
  _⇒_ : Type → Type → Type
  □_ : Type → Type

-- Reuse contexts, variables and weakening from Tillmann's library.
open import Syntactic.Contexts Type

-- No semantics for these types.

data Term : Context → Context → Type → Set where
  abs : ∀ {τ₁ τ₂ Γ Δ} → (t : Term (τ₁ • Γ) Δ τ₂) → Term Γ Δ (τ₁ ⇒ τ₂)
  app : ∀ {τ₁ τ₂ Γ Δ} → (t₁ : Term Γ Δ (τ₁ ⇒ τ₂)) (t₂ : Term Γ Δ τ₁) → Term Γ Δ τ₂
  ovar : ∀ {Γ Δ τ} → (x : Var Γ τ) → Term Γ Δ τ
  mvar : ∀ {Γ Δ τ} → (u : Var Δ τ) → Term Γ Δ τ
  -- Note the builtin weakening
  box : ∀ {Γ Δ τ} → Term ∅ Δ τ → Term Γ Δ (□ τ)
  let-box_in-_ : ∀ {τ₁ τ₂ Γ Δ} → (e₁ : Term Γ Δ (□ τ₁)) → (e₂ : Term Γ (τ₁ • Δ) τ₂) → Term Γ Δ τ₂

-- Lemma 1 includes weakening.
-- Most of the proof can be generated by C-c C-a, but syntax errors must then be fixed.

weaken : ∀ {Γ₁ Γ₂ Δ₁ Δ₂ τ} → (Γ′ : Γ₁ ≼ Γ₂) → (Δ′ : Δ₁ ≼ Δ₂) → Term Γ₁ Δ₁ τ → Term Γ₂ Δ₂ τ
weaken Γ′ Δ′ (abs {τ₁} t) = abs (weaken (keep τ₁ • Γ′) Δ′ t)
weaken Γ′ Δ′ (app t t₁) = app (weaken Γ′ Δ′ t) (weaken Γ′ Δ′ t₁)
weaken Γ′ Δ′ (ovar x) = ovar (lift Γ′ x)
weaken Γ′ Δ′ (mvar u) = mvar (lift Δ′ u)
weaken Γ′ Δ′ (box t) = box (weaken ∅ Δ′ t)
weaken Γ′ Δ′ (let-box_in-_ {τ₁} t t₁) =
  let-box weaken Γ′ Δ′ t in-
          weaken Γ′ (keep τ₁ • Δ′) t₁

error: pathspec 'ModalLogic.agda' did not match any file(s) known to git


Add file for choreography

Add file for choreography

-- {-# 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 → ? × ?
-- -}
-- -}
-- -}
-- -}
-- -}

error: pathspec 'Control/Protocol/Choreography.agda' did not match any file(s) known to git


ZK/GroupHom.agda

ZK/GroupHom.agda

open import Type using (Type)
open import Function using (flip)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum.NP
open import Data.Bool.Base using (Bool) renaming (T to ✓)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _≢_; idp; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import ZK.Types using (Cyclic-group; module Cyclic-group
                           ; Cyclic-group-properties; module Cyclic-group-properties)
import ZK.SigmaProtocol.KnownStatement

module ZK.GroupHom where
postulate
  G+ G* : Type
  -- grp-G+-comm : Abelian-Group G+
  grp-G+ : Group G+
  -- grp-G* : Group G*
  grp-G*-comm : Abelian-Group G*
module _
--     {G+ G* : Type} (grp-G+ : Group G+) (grp-G* : Group G*)

    {C : Type} -- ℤ
    (φ : G+ → G*) -- For instance φ(x) = g^x
    (y : G*)
    (_==_ : G* → G* → Bool)
    (_^_ : G* → C → G*)
    (_⊗_ : G+ → C → G+)

    (_−ᶜ_ : C → C → C)
    {-
    -- Coprime m n ↔ GCD m n 1
    (Coprime : (m n : C) → Type)
    (_<_ : C → C → Type)
    (≢-< : ∀ {c₀ c₁} → c₀ ≢ c₁ → (c₀ < c₁) ⊎ (c₁ < c₀))

    (ℓ : C)
    (u : G+)(φu : φ u ≡ y ^ ℓ)
    (<-coprime : ∀ {c₀ c₁} → c₁ < c₀ → Coprime (c₀ −ᶜ c₁) ℓ)
    (egcd : (m n : C) → C × C)
    -- (egcd-coprime : ∀ m n → let a , b = egcd m n in {!!})
    -}
    (modinv : C → C)
    where

  -- grp-G+ = Abelian-Group.grp grp-G+-comm
  -- open Additive-Abelian-Group grp-G+-comm
  open Additive-Group grp-G+
  grp-G* = Abelian-Group.grp grp-G*-comm
  -- open Multiplicative-Group grp-G*
  open Multiplicative-Abelian-Group grp-G*-comm

  Commitment = G*
  Challenge  = C
  Response   = G+
  Witness    = G+
  Randomness = G+
  _∈y : Witness → Type
  x ∈y = φ x ≡ y

  open ZK.SigmaProtocol.KnownStatement Commitment Challenge Response Randomness Witness _∈y public

  prover : Prover
  prover a x = (φ a) , response
     where response : Challenge → Response
           response c = (a + (x ⊗ c))

  verifier : Verifier
  verifier (mk A c s) = (φ s) == (A * (y ^ c))

  Schnorr : Σ-Protocol
  Schnorr = (prover , verifier)

  -- The simulator shows why it is so important for the
  -- challenge to be picked once the commitment is known.
  -- To fake a transcript, the challenge and response can
  -- be arbitrarily chosen. However to be indistinguishable
  -- from a valid proof they need to be picked at random.
  simulator : Simulator
  simulator c s = A
      where
        -- Compute A, such that the verifier accepts!
        A = (φ s) / (y ^ c)

  -- The extractor shows the importance of never reusing a
  -- commitment. If the prover answers to two different challenges
  -- comming from the same commitment then the knowledge of the
  -- prover (the witness) can be extracted.
  extractor : Extractor verifier
  extractor t² = x'
      module Witness-extractor where
        open Transcript² t²
        rd = get-f₀ − get-f₁
        cd = get-c₀ −ᶜ get-c₁
        {-
        ab = egcd cd ℓ
        a = fst ab
        b = snd ab
        x' = u ⊗ a + rd ⊗ b
        -}
        x' = rd ⊗ modinv cd

  module Proofs
    (φ-hom : GroupHomomorphism grp-G+ grp-G* φ)
    (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
    (==-✓ : ∀ {x y} → ✓ (x == y) → x ≡ y)
    (φ⁻¹ : G* → G+)
    .(φ∘φ⁻¹ : ∀ y → φ (φ⁻¹ y) ≡ y)
    (φ-inj : ∀ {x y} → φ x ≡ φ y → x ≡ y)
    (φ-hom-iterated : ∀ {x c} → φ (x ⊗ c) ≡ φ x ^ c)
    (^--  : ∀ {b x y} → b ^(x −ᶜ y) ≡ (b ^ x) / (b ^ y))
    (left-*-to-right-/ : ∀ {x y c} → x ⊗ c ≡ y → x ≡ y ⊗ modinv c)
     where
    open ≡-Reasoning
    open GroupHomomorphismProp grp-G+ grp-G* {φ} φ-hom

    correct : Correct Schnorr
    correct x a c w
      = ✓-== (φ(a + (x ⊗ c))
           ≡⟨ φ-hom ⟩
              A * (φ(x ⊗ c))
           ≡⟨ ap (λ z → A * z) φ-hom-iterated ⟩
              A * ((φ x) ^ c)
           ≡⟨ ap (λ z → A * (z ^ c)) w ⟩
              A * (y ^ c)
           ∎)
      where
        A = φ a

    shvzk : Special-Honest-Verifier-Zero-Knowledge Schnorr
    shvzk = record { simulator = simulator
                   ; correct-simulator = λ _ _ → ✓-== /-* }

    module _ (t² : Transcript² verifier) where
      private
        x = φ⁻¹ y

      open Transcript² t² renaming (get-A to A; get-c₀ to c₀; get-c₁ to c₁
                                   ;get-f₀ to f₀; get-f₁ to f₁)
      open Witness-extractor t²

      .φxcd≡φrd : _
      φxcd≡φrd = φ(x ⊗ cd)
                 ≡⟨ φ-hom-iterated ⟩
                   (φ x) ^ (c₀ −ᶜ c₁)
                 ≡⟨ ap₂ _^_ (φ∘φ⁻¹ y) idp ⟩
                   y ^ (c₀ −ᶜ c₁)
                 ≡⟨ ^-- ⟩
                   (y ^ c₀) / (y ^ c₁)
                 ≡⟨ ! cancels-/ ⟩
                   (A * (y ^ c₀)) / (A * (y ^ c₁))
                 ≡⟨ /= (! ==-✓ verify₀) (! ==-✓ verify₁) ⟩
                   (φ f₀) / (φ f₁)
                 ≡⟨ ! f-−-/ ⟩
                   φ rd
                 ∎

      .xcd≡rd : _
      xcd≡rd = φ-inj φxcd≡φrd

      -- The extracted x is correct
      .extractor-ok : φ x' ≡ y
      extractor-ok = ! ap φ (left-*-to-right-/ xcd≡rd) ∙ φ∘φ⁻¹ y

    special-soundness : Special-Soundness Schnorr
    special-soundness = record { extractor = extractor
                               ; extract-valid-witness = extractor-ok }

    special-Σ-protocol : Special-Σ-Protocol
    special-Σ-protocol = record { Σ-protocol = Schnorr ; correct = correct ; shvzk = shvzk ; ssound = special-soundness }
-- -}
-- -}
-- -}
-- -}

error: pathspec 'ZK/GroupHom.agda' did not match any file(s) known to git


add hello world app

add hello world app

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/nfjinjing/chu2.git/'


lib/HoTT.agda

lib/HoTT.agda

{-# OPTIONS --without-K #-}
module HoTT where

open import Type
open import Level.NP
open import Function.NP
open import Function.Extensionality
open import Data.Zero using (𝟘)
open import Data.One using (𝟙)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])
open import Relation.Binary using (Reflexive; Symmetric; Transitive)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; ap; coe; coe!; !_; _∙_; J) renaming (subst to tr; refl to idp; cong₂ to ap₂)

import Function.Inverse.NP as Inv
open Inv using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Function.Related.TypeIsomorphisms.NP hiding (Σ-assoc)

-- Contractible
module _ {a}(A : ★_ a) where
    Is-contr : ★_ a
    Is-contr = Σ A λ x → ∀ y → x ≡ y

module _ {a}{b}{A : ★_ a}{B : A → ★_ b} where
    pair= : ∀ {x y : Σ A B} → (p : fst x ≡ fst y) → tr B p (snd x) ≡ snd y → x ≡ y
    pair= idp = ap (_,_ _)
    snd= : ∀ {x : A} {y y' : B x} → y ≡ y' → _≡_ {A = Σ A B} (x , y) (x , y')
    snd= = pair= idp
module _ {a}{b}{A : ★_ a}{B : ★_ b} where
    pair×= : ∀ {x x' : A}(p : x ≡ x')
               {y y' : B}(q : y ≡ y')
             → (x , y) ≡ (x' , y')
    pair×= idp q = snd= q

module _ {a}(A : ★_ a){b}{B₀ B₁ : A → ★_ b}(B : (x : A) → B₀ x ≡ B₁ x){{_ : FunExt}} where
    Σ=′ : Σ A B₀ ≡ Σ A B₁
    Σ=′ = ap (Σ A) (λ= B)

    Π=′ : Π A B₀ ≡ Π A B₁
    Π=′ = ap (Π A) (λ= B)

module _ {{_ : FunExt}} where
    Σ= : ∀ {a}{A₀ A₁ : ★_ a}{b}{B₀ : A₀ → ★_ b}{B₁ : A₁ → ★_ b}
           (A : A₀ ≡ A₁)(B : (x : A₀) → B₀ x ≡ B₁ (coe A x))
         → Σ A₀ B₀ ≡ Σ A₁ B₁
    Σ= idp B = Σ=′ _ B

    Π= : ∀ {a}{A₀ A₁ : ★_ a}{b}{B₀ : A₀ → ★_ b}{B₁ : A₁ → ★_ b}
           (A : A₀ ≡ A₁)(B : (x : A₀) → B₀ x ≡ B₁ (coe A x))
         → Π A₀ B₀ ≡ Π A₁ B₁
    Π= idp B = Π=′ _ B

module _ {a}{A₀ A₁ : ★_ a}{b}{B₀ B₁ : ★_ b}(A= : A₀ ≡ A₁)(B= : B₀ ≡ B₁) where
    ×= : (A₀ × B₀) ≡ (A₁ × B₁)
    ×= = ap₂ _×_ A= B=

    ⊎= : (A₀ ⊎ B₀) ≡ (A₁ ⊎ B₁)
    ⊎= = ap₂ _⊎_ A= B=

module Equivalences where

  module _ {a b}{A : ★_ a}{B : ★_ b} where
    _LeftInverseOf_ : (B → A) → (A → B) → ★_ a
    linv LeftInverseOf f = ∀ x → linv (f x) ≡ x

    _RightInverseOf_ : (B → A) → (A → B) → ★_ b
    rinv RightInverseOf f = ∀ x → f (rinv x) ≡ x

    record Linv (f : A → B) : ★_(a ⊔ b) where
      field
        linv : B → A
        is-linv : ∀ x → linv (f x) ≡ x

    record Rinv (f : A → B) : ★_(a ⊔ b) where
      field
        rinv : B → A
        is-rinv : ∀ x → f (rinv x) ≡ x

    record Is-equiv (f : A → B) : ★_(a ⊔ b) where
      field
        linv : B → A
        is-linv : ∀ x → linv (f x) ≡ x
        rinv : B → A
        is-rinv : ∀ x → f (rinv x) ≡ x

      injective : ∀ {x y} → f x ≡ f y → x ≡ y
      injective {x} {y} p = !(is-linv x) ∙ ap linv p ∙ is-linv y

      surjective : ∀ y → ∃ λ x → f x ≡ y
      surjective y = rinv y , is-rinv y

  module _ {a b}{A : ★_ a}{B : ★_ b}{f : A → B}(fᴱ : Is-equiv f) where
      open Is-equiv fᴱ
      inv : B → A
      inv = linv ∘ f ∘ rinv

      inv-is-equiv : Is-equiv inv
      inv-is-equiv = record { linv = f
                         ; is-linv = λ x → ap f (is-linv (rinv x)) ∙ is-rinv x
                         ; rinv = f
                         ; is-rinv = λ x → ap linv (is-rinv (f x)) ∙ is-linv x }

  module _ {a}{A : ★_ a}{f : A → A}(f-inv : f LeftInverseOf f) where
      self-inv-is-equiv : Is-equiv f
      self-inv-is-equiv = record { linv = f ; is-linv = f-inv ; rinv = f ; is-rinv = f-inv }

  module _ {a}{A : ★_ a} where
    idᴱ : Is-equiv {A = A} id
    idᴱ = self-inv-is-equiv λ _ → idp

  module _ {a b c}{A : ★_ a}{B : ★_ b}{C : ★_ c}{g : B → C}{f : A → B} where
    _∘ᴱ_ : Is-equiv g → Is-equiv f → Is-equiv (g ∘ f)
    gᴱ ∘ᴱ fᴱ = record { linv = F.linv ∘ G.linv ; is-linv = λ x → ap F.linv (G.is-linv (f x)) ∙ F.is-linv x
                      ; rinv = F.rinv ∘ G.rinv ; is-rinv = λ x → ap g (F.is-rinv _) ∙ G.is-rinv x }
      where
        module G = Is-equiv gᴱ
        module F = Is-equiv fᴱ

  module _ {a b} where
    infix 4 _≃_
    _≃_ : ★_ a → ★_ b → ★_(a ⊔ b)
    A ≃ B = Σ (A → B) Is-equiv

  module _ {a b}{A : ★_ a}{B : ★_ b} where
    –> : (e : A ≃ B) → (A → B)
    –> e = fst e

    <– : (e : A ≃ B) → (B → A)
    <– e = Is-equiv.linv (snd e)

    <–-inv-l : (e : A ≃ B) (a : A)
              → (<– e (–> e a) ≡ a)
    <–-inv-l e a = Is-equiv.is-linv (snd e) a

    {-
    <–-inv-r : (e : A ≃ B) (b : B)
                → (–> e (<– e b) ≡ b)
    <–-inv-r e b = Is-equiv.is-rinv (snd e) b
    -}

    -- Equivalences are "injective"
    equiv-inj : (e : A ≃ B) {x y : A}
                → (–> e x ≡ –> e y → x ≡ y)
    equiv-inj e {x} {y} p = ! (<–-inv-l e x) ∙ ap (<– e) p ∙ <–-inv-l e y

  module _ {a b}{A : ★_ a}{B : ★_ b}
           {f : A → B}(g : B → A)
           (f-g : (y : B) → f (g y) ≡ y)
           (g-f : (x : A) → g (f x) ≡ x) where
    is-equiv : Is-equiv f
    is-equiv = record { linv = g ; is-linv = g-f ; rinv = g ; is-rinv = f-g }

  module _ {a b}{A : ★_ a}{B : ★_ b}
           (f : A → B)(g : B → A)
           (f-g : (y : B) → f (g y) ≡ y)
           (g-f : (x : A) → g (f x) ≡ x) where
    equiv : A ≃ B
    equiv = f , is-equiv g f-g g-f

  module _ {ℓ} where
    ≃-refl : Reflexive (_≃_ {ℓ})
    ≃-refl = _ , idᴱ

    ≃-sym : Symmetric (_≃_ {ℓ})
    ≃-sym (_ , fᴱ) = _ , inv-is-equiv fᴱ

    ≃-trans : Transitive (_≃_ {ℓ})
    ≃-trans (_ , p) (_ , q) = _ , q ∘ᴱ p

    ≃-! = ≃-sym
    _≃-∙_ = ≃-trans

  module _ {a}{A : ★_ a} where
    Paths : ★_ a
    Paths = Σ A λ x → Σ A λ y → x ≡ y

    id-path : A → Paths
    id-path x = x , x , idp

    fst-rinv-id-path : ∀ p → id-path (fst p) ≡ p
    fst-rinv-id-path (x , y , p) = snd= (pair= p (J (λ {y} p → tr (_≡_ x) p idp ≡ p) idp p))

    id-path-is-equiv : Is-equiv id-path
    id-path-is-equiv = record { linv = fst
                              ; is-linv = λ x → idp
                              ; rinv = fst
                              ; is-rinv = fst-rinv-id-path }

    ≃-Paths : A ≃ Paths
    ≃-Paths = id-path , id-path-is-equiv

  module _ {a b}{A : ★_ a}{B : ★_ b}(f : A → B) where
    hfiber : (y : B) → ★_(a ⊔ b)
    hfiber y = Σ A λ x → f x ≡ y

    Is-equiv-alt : ★_(a ⊔ b)
    Is-equiv-alt = (y : B) → Is-contr (hfiber y)

  module Is-contr-to-Is-equiv {a}{A : ★_ a}(A-contr : Is-contr A) where
    const-is-equiv : Is-equiv (λ (_ : 𝟙) → fst A-contr)
    const-is-equiv = record { linv = _ ; is-linv = λ _ → idp ; rinv = _ ; is-rinv = snd A-contr }
    𝟙≃ : 𝟙 ≃ A
    𝟙≃ = _ , const-is-equiv
  module Is-equiv-to-Is-contr {a}{A : ★_ a}(f : 𝟙 → A)(f-is-equiv : Is-equiv f) where
    open Is-equiv f-is-equiv
    A-contr : Is-contr A
    A-contr = f _ , is-rinv

  module _ {a}{A : ★_ a}{b}{B : ★_ b} where
    iso-to-equiv : (A ↔ B) → (A ≃ B)
    iso-to-equiv iso = to iso , record { linv = from iso ; is-linv = Inverse.left-inverse-of iso
                                       ; rinv = from iso ; is-rinv = Inverse.right-inverse-of iso }

    equiv-to-iso : (A ≃ B) → (A ↔ B)
    equiv-to-iso (f , f-is-equiv) = inverses f (fᴱ.linv ∘ f ∘ fᴱ.rinv)
                                             (λ x → ap fᴱ.linv (fᴱ.is-rinv (f x)) ∙ fᴱ.is-linv x)
                                             (λ x → ap f (fᴱ.is-linv (fᴱ.rinv x)) ∙ fᴱ.is-rinv x)
      where module fᴱ = Is-equiv f-is-equiv

    {-
    iso-to-equiv-to-iso : (iso : A ↔ B) → equiv-to-iso (iso-to-equiv iso) ≡ iso
    iso-to-equiv-to-iso iso = {!!}
      where module Iso = Inverse iso

    iso-to-equiv-is-equiv : Is-equiv iso-to-equiv
    iso-to-equiv-is-equiv = record { linv = equiv-to-iso ; is-linv = {!!} ; rinv = {!!} ; is-rinv = {!!} }
    -}
open Equivalences

module _ {ℓ}{A : ★_ ℓ} where
    coe!-inv-r : ∀ {B}(p : A ≡ B) y → coe p (coe! p y) ≡ y
    coe!-inv-r idp y = idp

    coe!-inv-l : ∀ {B}(p : A ≡ B) x → coe! p (coe p x) ≡ x
    coe!-inv-l idp x = idp

    coe-equiv : ∀ {B} → A ≡ B → A ≃ B
    coe-equiv p = equiv (coe p) (coe! p) (coe!-inv-r p) (coe!-inv-l p)

postulate
  UA : ★
module _ {ℓ}{A B : ★_ ℓ}{{_ : UA}} where
  postulate
    ua : (A ≃ B) → (A ≡ B)
    coe-equiv-β : (e : A ≃ B) → coe-equiv (ua e) ≡ e
    ua-η : (p : A ≡ B) → ua (coe-equiv p) ≡ p

  ua-equiv : (A ≃ B) ≃ (A ≡ B)
  ua-equiv = equiv ua coe-equiv ua-η coe-equiv-β

  coe-β : (e : A ≃ B) (a : A) → coe (ua e) a ≡ –> e a
  coe-β e a = ap (λ e → –> e a) (coe-equiv-β e)

module _ {{_ : UA}}{{_ : FunExt}}{a}{A₀ A₁ : ★_ a}{b}{B₀ : A₀ → ★_ b}{B₁ : A₁ → ★_ b} where
    Σ≃ : (A : A₀ ≃ A₁)(B : (x : A₀) → B₀ x ≡ B₁ (–> A x))
         → Σ A₀ B₀ ≡ Σ A₁ B₁
    Σ≃ A B = Σ= (ua A) λ x → B x ∙ ap B₁ (! coe-β A x)

    Π≃ : (A : A₀ ≃ A₁)(B : (x : A₀) → B₀ x ≡ B₁ (–> A x))
         → Π A₀ B₀ ≡ Π A₁ B₁
    Π≃ A B = Π= (ua A) λ x → B x ∙ ap B₁ (! coe-β A x)

module _ {{_ : UA}}{{_ : FunExt}}{A : ★}{B C : A → ★} where
    Σ⊎-split : (Σ A (λ x → B x ⊎ C x)) ≡ (Σ A B ⊎ Σ A C)
    Σ⊎-split = ua (equiv (λ { (x , inl y) → inl (x , y)
                            ; (x , inr y) → inr (x , y) })
                         (λ { (inl (x , y)) → x , inl y
                            ; (inr (x , y)) → x , inr y })
                         (λ { (inl (x , y)) → idp
                            ; (inr (x , y)) → idp })
                         (λ { (x , inl y) → idp
                            ; (x , inr y) → idp }))

module _ {{_ : UA}}{{_ : FunExt}}{A B : ★}{C : A → ★}{D : B → ★} where
    dist-⊎-Σ : (Σ (A ⊎ B) [inl: C ,inr: D ]) ≡ (Σ A C ⊎ Σ B D)
    dist-⊎-Σ = ua (iso-to-equiv Σ⊎-distrib)
    dist-×-Π : (Π (A ⊎ B) [inl: C ,inr: D ]) ≡ (Π A C × Π B D)
    dist-×-Π = ua (iso-to-equiv (Π×-distrib (λ fg → λ= fg)))

module _ {A : ★}{B : A → ★}{C : (x : A) → B x → ★} where
    Σ-assoc-equiv : (Σ A (λ x → Σ (B x) (C x))) ≃ (Σ (Σ A B) (uncurry C))
    Σ-assoc-equiv = equiv (λ x → (fst x , fst (snd x)) , snd (snd x))
                          (λ x → fst (fst x) , snd (fst x) , snd x)
                          (λ y → idp)
                          (λ y → idp)

    Σ-assoc : {{_ : UA}} → (Σ A (λ x → Σ (B x) (C x))) ≡ (Σ (Σ A B) (uncurry C))
    Σ-assoc = ua Σ-assoc-equiv

module _ {A B : ★} where
    ×-comm-equiv : (A × B) ≃ (B × A)
    ×-comm-equiv = equiv swap swap (λ y → idp) (λ x → idp)

    ×-comm : {{_ : UA}} → (A × B) ≡ (B × A)
    ×-comm = ua ×-comm-equiv

    ⊎-comm-equiv : (A ⊎ B) ≃ (B ⊎ A)
    ⊎-comm-equiv = equiv [inl: inr ,inr: inl ]
                         [inl: inr ,inr: inl ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]

    ⊎-comm : {{_ : UA}} → (A ⊎ B) ≡ (B ⊎ A)
    ⊎-comm = ua ⊎-comm-equiv

module _ {A B : ★}{C : A → B → ★} where
    ΠΠ-comm-equiv : ((x : A)(y : B) → C x y) ≃ ((y : B)(x : A) → C x y)
    ΠΠ-comm-equiv = equiv flip flip (λ _ → idp) (λ _ → idp)

    ΠΠ-comm : {{_ : UA}} → ((x : A)(y : B) → C x y) ≡ ((y : B)(x : A) → C x y)
    ΠΠ-comm = ua ΠΠ-comm-equiv

    ΣΣ-comm-equiv : (Σ A λ x → Σ B λ y → C x y) ≃ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm-equiv = equiv (λ { (x , y , z) → y , x , z })
                          (λ { (x , y , z) → y , x , z })
                          (λ _ → idp)
                          (λ _ → idp)

    ΣΣ-comm : {{_ : UA}} → (Σ A λ x → Σ B λ y → C x y) ≡ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm = ua ΣΣ-comm-equiv

module _ {A B C : ★} where
    ×-assoc : {{_ : UA}} → (A × (B × C)) ≡ ((A × B) × C)
    ×-assoc = Σ-assoc

    ⊎-assoc-equiv : (A ⊎ (B ⊎ C)) ≃ ((A ⊎ B) ⊎ C)
    ⊎-assoc-equiv = equiv [inl: inl ∘ inl ,inr: [inl: inl ∘ inr ,inr: inr ] ]
                          [inl: [inl: inl ,inr: inr ∘ inl ] ,inr: inr ∘ inr ]
                          [inl: [inl: (λ x → idp) ,inr: (λ x → idp) ] ,inr: (λ x → idp) ]
                          [inl: (λ x → idp) ,inr: [inl: (λ x → idp) ,inr: (λ x → idp) ] ]

    ⊎-assoc : {{_ : UA}} → (A ⊎ (B ⊎ C)) ≡ ((A ⊎ B) ⊎ C)
    ⊎-assoc = ua ⊎-assoc-equiv

module _ {{_ : UA}}{{_ : FunExt}}(A : 𝟘 → ★) where
    Π𝟘-uniq : Π 𝟘 A ≡ 𝟙
    Π𝟘-uniq = ua (equiv _ (λ _ ()) (λ _ → idp) (λ _ → λ= (λ())))

module _ {{_ : UA}}(A : 𝟙 → ★) where
    Π𝟙-uniq : Π 𝟙 A ≡ A _
    Π𝟙-uniq = ua (equiv (λ f → f _) (λ x _ → x) (λ _ → idp) (λ _ → idp))

module _ {{_ : UA}}(A : ★) where
    Π𝟙-uniq′ : (𝟙 → A) ≡ A
    Π𝟙-uniq′ = Π𝟙-uniq (λ _ → A)

module _ {{_ : UA}}{{_ : FunExt}}(A : ★) where
    Π𝟘-uniq′ : (𝟘 → A) ≡ 𝟙
    Π𝟘-uniq′ = Π𝟘-uniq (λ _ → A)

module _ {{_ : FunExt}}(F G : 𝟘 → ★) where
    -- also by Π𝟘-uniq twice
    Π𝟘-uniq' : Π 𝟘 F ≡ Π 𝟘 G
    Π𝟘-uniq' = Π=′ 𝟘 (λ())

module _ {A : 𝟘 → ★} where
    Σ𝟘-fst-equiv : Σ 𝟘 A ≃ 𝟘
    Σ𝟘-fst-equiv = equiv fst (λ()) (λ()) (λ { (() , _) })

    Σ𝟘-fst : {{_ : UA}} → Σ 𝟘 A ≡ 𝟘
    Σ𝟘-fst = ua Σ𝟘-fst-equiv

module _ {A : 𝟙 → ★} where
    Σ𝟙-snd-equiv : Σ 𝟙 A ≃ A _
    Σ𝟙-snd-equiv = equiv snd (_,_ _) (λ _ → idp) (λ _ → idp)

    Σ𝟙-snd : {{_ : UA}} → Σ 𝟙 A ≡ A _
    Σ𝟙-snd = ua Σ𝟙-snd-equiv

module _ {A : ★} where
    ⊎𝟘-inl-equiv : A ≃ (A ⊎ 𝟘)
    ⊎𝟘-inl-equiv = equiv inl [inl: id ,inr: (λ()) ] [inl: (λ _ → idp) ,inr: (λ()) ] (λ _ → idp)

    ⊎𝟘-inl : {{_ : UA}} → A ≡ (A ⊎ 𝟘)
    ⊎𝟘-inl = ua ⊎𝟘-inl-equiv
-- -}
-- -}
-- -}
-- -}

error: pathspec 'lib/HoTT.agda' did not match any file(s) known to git


beginning of some simpler proof management

module tactic where

open import Type
open import Search.Type
open import Search.Searchable
open import Search.Searchable.Product

open import Data.Unit
open import Data.Product
open import Function
open import Relation.Binary.PropositionalEquality.NP

module _ {R S} (sum-R : Sum R)(sum-R-ext : SumExt sum-R)(sum-S : Sum S) where
  su-× : ∀ {f : R → R}{g : S → S} → SumStableUnder sum-R f → SumStableUnder sum-S g
       → SumStableUnder (sum-R ×-sum sum-S) (map f g)
  su-× {f}{g} su-f su-g F
    = (sum-R ×-sum sum-S) F
    ≡⟨ sum-R-ext (λ x → su-g (λ y → F ( x , y))) ⟩
      (sum-R ×-sum sum-S) (F ∘ map id g)
    ≡⟨ su-f (λ x → sum-S (λ y → F (map id g (x , y)))) ⟩
      (sum-R ×-sum sum-S) (F ∘ map f g)
    ∎ where open ≡-Reasoning

module _ {R}(sum-R : Sum R) where
  su-id : SumStableUnder sum-R id
  su-id f = refl

  su-∘ : ∀ {f g} → SumStableUnder sum-R f → SumStableUnder sum-R g → SumStableUnder sum-R (f ∘ g)
  su-∘ {f} su-f su-g F = trans (su-f F) (su-g (F ∘ f))

module _ {R R' S'}(sum-R : Sum R)(sum-R' : Sum R')(sum-S' : Sum S')(sum-R'-ext : SumExt sum-R')
           (h : R' → R')(su-h : SumStableUnder sum-R' h)
           (to : R' → S' → R)(sum-same : ∀ f → sum-R f ≡ sum-R' (λ r' → sum-S' (f ∘ to r'))) where

  principle : ∀ {f g} → (∀ r' → sum-S' (f ∘ to r') ≡ sum-S' (g ∘ to (h r'))) → sum-R f ≡ sum-R g
  principle {f}{g} prf
    = sum-R f
    ≡⟨ sum-same f ⟩
      sum-R' (λ r' → sum-S' (λ s' → f (to r' s')))
    ≡⟨ sum-R'-ext (λ r' → prf r') ⟩
      sum-R' (λ r' → sum-S' (λ s' → g (to (h r') s')))
    ≡⟨ sym (su-h (λ r' → sum-S' (λ s' → g (to r' s')))) ⟩
      sum-R' (λ r' → sum-S' (λ s' → g (to r' s')))
    ≡⟨ sym (sum-same g) ⟩
      sum-R g
    ∎
    where open ≡-Reasoning

error: pathspec 'tactic.agda' did not match any file(s) known to git