-⊗⅋-dual +dual-⅋ +dual-⊗

-⊗⅋-dual +dual-⅋ +dual-⊗

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd) using (∃;Σ;_×_;_,_;first;second)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.One using (𝟙)
open import Data.LR
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; subst; ap; coe; coe!)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol
open import Control.Protocol.Additive
open import Control.Protocol.Sequence

module Control.Protocol.Multiplicative 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) ]

_⊗_ : 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) ]

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

_⊸_ : (P Q : Proto) → Proto
P ⊸ Q = dual P ⅋ Q

_o-o_ : (P Q : Proto) → Proto
P o-o Q = (P ⊸ Q) ⊗ (Q ⊸ 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)
                ∙ ! &≡×

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

  -- source-⅋ : source-of P ⅋ source-of Q ≡

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

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

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

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

  ⅋-id = fwd

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

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

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

module _ {{_ : FunExt}} where
    ⊗-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

  module _ {{_ : FunExt}} where
    ×→⊗→× : ×→⊗ 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 ⟧)
-}

module _ {{_ : FunExt}}{{_ : UA}} where
    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)
                                                                ,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)

    ⊸-apply : ∀ {P Q} → ⟦ dual P ⅋ Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
    ⊸-apply {P} {Q} pq p = ⅋-apply (dual P) Q pq (subst ⟦_⟧ (! (dual-involutive P)) p)

    o-o-apply : ∀ P Q → ⟦ P o-o Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
    o-o-apply P Q Po-oQ p = ⊸-apply {P} {Q} (⊗-fst (P ⊸ Q) (Q ⊸ 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)

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

data View-∘-proto : (P Q R : Proto) → ★₁ where
  sendLL : ∀ {M N}(P : M → Proto)(Q : N → Proto) R
           → View-∘-proto (send P) (send Q) R
  recvLL : ∀ {M} (P : M → Proto) Q R
           → View-∘-proto (recv P) Q R
  recvR-sendR : ∀ {MP MQ MR}ioP(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
                → View-∘-proto (com ioP P) (recv Q) (send R)
  recvRR : ∀ {MP MQ MR}(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
           → View-∘-proto (send P) (recv Q) (recv R)
  endL : ∀ Q R → View-∘-proto end Q R
  sendLM : ∀ {MP}(P : MP → Proto)R → View-∘-proto (send P) end R
  recvL-sendR : ∀ {MP MQ}(P : MP → Proto)(Q : MQ → Proto)
                → View-∘-proto (send P) (recv Q) end

view-∘-proto : ∀ P Q R → View-∘-proto P Q R
view-∘-proto end      Q        R        = endL Q R
view-∘-proto (recv P) Q        R        = recvLL P Q R
view-∘-proto (send P) end      R        = sendLM P R
view-∘-proto (send P) (recv Q) end      = recvL-sendR P Q
view-∘-proto (send P) (recv Q) (recv R) = recvRR P Q R
view-∘-proto (send P) (recv Q) (send R) = recvR-sendR Out P Q R
view-∘-proto (send P) (send Q) R        = sendLL P Q R

module _ {{_ : FunExt}}{{_ : UA}} where
    ⅋-∘ : ∀ {P Q R} → ⟦ P ⅋ Q ⟧ → ⟦ dual Q ⅋ R ⟧ → ⟦ P ⅋ R ⟧
    ⅋-∘ {P} {Q} {R} pq qr with view-∘-proto P Q R
    ⅋-∘ (inl m , pq) qr | sendLL P Q R = ⅋-sendL R m (⅋-∘ {P m} {send Q} {R} pq qr)
    ⅋-∘ (inr m , pq) qr | sendLL P Q R = ⅋-∘ {send P} {Q m} pq (qr m)
    ⅋-∘ pq qr           | recvLL P Q M = λ m → ⅋-∘ {P m} (pq m) qr
    ⅋-∘ pq (inl m , qr) | recvR-sendR ioP P Q R = ⅋-∘ {com ioP P} {Q m} {send R} (coe (⅋-recvR (com ioP P) Q) pq m) qr
    ⅋-∘ pq (inr m , qr) | recvR-sendR ioP P Q R = ⅋-sendR (com ioP P) m (⅋-∘ {com ioP P} {recv Q} {R m} pq qr)
    ⅋-∘ pq qr           | recvRR P Q R = λ m → ⅋-∘ {send P} {recv Q} {R m} pq (qr m)
    ⅋-∘ pq qr           | endL Q R = ⊸-apply {Q} {R} qr pq
    ⅋-∘ (m , pq) qr     | sendLM P R = ⅋-sendL R m (par (P m) R pq qr)
    ⅋-∘ pq (m , qr)     | recvL-sendR P Q = ⅋-∘ {send P} {Q m} {end} (pq m) (coe! (ap ⟦_⟧ (⅋-endR (dual (Q m)))) qr)

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

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd) using (∃;Σ;_×_;_,_;first;second)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.One using (𝟙)
open import Data.LR
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; !_; _∙_; refl; subst; ap; coe; coe!)
open import Function.Extensionality
open import HoTT
open Equivalences

open import Control.Protocol
open import Control.Protocol.Additive
open import Control.Protocol.Sequence

module Control.Protocol.Multiplicative 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) ]

_⊗_ : 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) ]

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

_⊸_ : (P Q : Proto) → Proto
P ⊸ Q = dual P ⅋ Q

_o-o_ : (P Q : Proto) → Proto
P o-o Q = (P ⊸ Q) ⊗ (Q ⊸ 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)
                ∙ ! &≡×

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

  -- source-⅋ : source-of P ⅋ source-of Q ≡

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

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

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

  ⅋-id = fwd

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

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

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

module _ {{_ : FunExt}} where
    ⊗-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

  module _ {{_ : FunExt}} where
    ×→⊗→× : ×→⊗ 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 ⟧)
-}

module _ {{_ : FunExt}}{{_ : UA}} where
    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)
                                                                ,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)

    ⊸-apply : ∀ {P Q} → ⟦ dual P ⅋ Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
    ⊸-apply {P} {Q} pq p = ⅋-apply (dual P) Q pq (subst ⟦_⟧ (! (dual-involutive P)) p)

    o-o-apply : ∀ P Q → ⟦ P o-o Q ⟧ → ⟦ P ⟧ → ⟦ Q ⟧
    o-o-apply P Q Po-oQ p = ⊸-apply {P} {Q} (⊗-fst (P ⊸ Q) (Q ⊸ 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)

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

data View-∘-proto : (P Q R : Proto) → ★₁ where
  sendLL : ∀ {M N}(P : M → Proto)(Q : N → Proto) R
           → View-∘-proto (send P) (send Q) R
  recvLL : ∀ {M} (P : M → Proto) Q R
           → View-∘-proto (recv P) Q R
  recvR-sendR : ∀ {MP MQ MR}ioP(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
                → View-∘-proto (com ioP P) (recv Q) (send R)
  recvRR : ∀ {MP MQ MR}(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
           → View-∘-proto (send P) (recv Q) (recv R)
  endL : ∀ Q R → View-∘-proto end Q R
  sendLM : ∀ {MP}(P : MP → Proto)R → View-∘-proto (send P) end R
  recvL-sendR : ∀ {MP MQ}(P : MP → Proto)(Q : MQ → Proto)
                → View-∘-proto (send P) (recv Q) end

view-∘-proto : ∀ P Q R → View-∘-proto P Q R
view-∘-proto end      Q        R        = endL Q R
view-∘-proto (recv P) Q        R        = recvLL P Q R
view-∘-proto (send P) end      R        = sendLM P R
view-∘-proto (send P) (recv Q) end      = recvL-sendR P Q
view-∘-proto (send P) (recv Q) (recv R) = recvRR P Q R
view-∘-proto (send P) (recv Q) (send R) = recvR-sendR Out P Q R
view-∘-proto (send P) (send Q) R        = sendLL P Q R

module _ {{_ : FunExt}}{{_ : UA}} where
    ⅋-∘ : ∀ {P Q R} → ⟦ P ⅋ Q ⟧ → ⟦ dual Q ⅋ R ⟧ → ⟦ P ⅋ R ⟧
    ⅋-∘ {P} {Q} {R} pq qr with view-∘-proto P Q R
    ⅋-∘ (inl m , pq) qr | sendLL P Q R = ⅋-sendL R m (⅋-∘ {P m} {send Q} {R} pq qr)
    ⅋-∘ (inr m , pq) qr | sendLL P Q R = ⅋-∘ {send P} {Q m} pq (qr m)
    ⅋-∘ pq qr           | recvLL P Q M = λ m → ⅋-∘ {P m} (pq m) qr
    ⅋-∘ pq (inl m , qr) | recvR-sendR ioP P Q R = ⅋-∘ {com ioP P} {Q m} {send R} (coe (⅋-recvR (com ioP P) Q) pq m) qr
    ⅋-∘ pq (inr m , qr) | recvR-sendR ioP P Q R = ⅋-sendR (com ioP P) m (⅋-∘ {com ioP P} {recv Q} {R m} pq qr)
    ⅋-∘ pq qr           | recvRR P Q R = λ m → ⅋-∘ {send P} {recv Q} {R m} pq (qr m)
    ⅋-∘ pq qr           | endL Q R = ⊸-apply {Q} {R} qr pq
    ⅋-∘ (m , pq) qr     | sendLM P R = ⅋-sendL R m (par (P m) R pq qr)
    ⅋-∘ pq (m , qr)     | recvL-sendR P Q = ⅋-∘ {send P} {Q m} {end} (pq m) (coe! (ap ⟦_⟧ (⅋-endR (dual (Q m)))) qr)

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


Added bag-equality to Tree a la NAD

Added bag-equality to Tree a la NAD

module prefect-bintree where

open import Function
open import Data.Nat
open import Data.Bool
open import Data.Bits

data Tree {a} (A : Set a) : ℕ → Set a where
  leaf : (x : A) → Tree A zero
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Tree A n
fromFun {zero} f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : Set a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

lookup : ∀ {n a} {A : Set a} → Bits n → Tree A n → A
lookup = flip toFun

lookup' : ∀ {m n a} {A : Set a} → Bits m → Tree A (m + n) → Tree A n
lookup' [] t = t
lookup' (b ∷ bs) (fork t t₁) = lookup' bs (if b then t₁ else t)

update' : ∀ {m n a} {A : Set a} → Bits m → Tree A n → Tree A (m + n) → Tree A (m + n)
update' [] val tree = val
update' (b ∷ key) val (fork tree tree₁) = if b then fork tree (update' key val tree₁)
                                               else fork (update' key val tree) tree₁

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

open import Relation.Binary
open import Data.Star

data Swp {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  swp₁ : ∀ {n} {left right : Tree A n} →
         Swp (fork left right) (fork right left)
  swp₂ : ∀ {n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         Swp (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))

Swp★ : ∀ {a} {A : Set a} {n} (left right : Tree A n) → Set a
Swp★ = Star Swp

Swp-sym : ∀ {n a} {A : Set a} → Symmetric (Swp {A = A} {n})
Swp-sym swp₁ = swp₁
Swp-sym swp₂ = swp₂

data Rot {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  leaf : ∀ x → Rot (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : Set a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork left right} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : Set a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : Set a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)

open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (Dec ; yes ; no)

module new-approach where

  open import Data.Empty

  open import Function.Inverse
  open import Function.Related
  import Function.Equality
  import Relation.Binary.PropositionalEquality as P

  data _∈_ {a}{A : Set a}(x : A) : {n : ℕ} → Tree A n → Set a where
    here  : x ∈ leaf x
    left  : {n : ℕ}{t₁ t₂ : Tree A n} → x ∈ t₁ → x ∈ fork t₁ t₂
    right : {n : ℕ}{t₁ t₂ : Tree A n} → x ∈ t₂ → x ∈ fork t₁ t₂

  toBits : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t : Tree A n} → x ∈ t → Bits n
  toBits here = []
  toBits (left key) = 0b ∷ toBits key
  toBits (right key) = 1b ∷ toBits key

  ∈-lookup : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t : Tree A n}(path : x ∈ t) → lookup (toBits path) t ≡ x
  ∈-lookup here = refl
  ∈-lookup (left path) = ∈-lookup path
  ∈-lookup (right path) = ∈-lookup path

  lookup-∈ : ∀ {a}{A : Set a}{n : ℕ}(key : Bits n)(t : Tree A n) → lookup key t ∈ t
  lookup-∈ [] (leaf x) = here
  lookup-∈ (true ∷ key) (fork tree tree₁) = right (lookup-∈ key tree₁)
  lookup-∈ (false ∷ key) (fork tree tree₁) = left (lookup-∈ key tree)

  _≈_ : ∀ {a}{A : Set a}{n : ℕ} → Tree A n → Tree A n → Set _
  t₁ ≈ t₂ = ∀ x → (x ∈ t₁) ↔ (x ∈ t₂)

  ≈-refl : {a : _}{A : Set a}{n : ℕ}{t : Tree A n} → t ≈ t
  ≈-refl _ = Function.Inverse.id

  move : ∀ {a}{A : Set a}{n : ℕ}{t s : Tree A n}{x : A} → t ≈ s → x ∈ t → x ∈ s
  move t≈s x∈t = Inverse.to (t≈s _) Function.Equality.⟨$⟩ x∈t

  swap₀ : ∀ {a}{A : Set a}{n : ℕ}(t₁ t₂ : Tree A n) → fork t₁ t₂ ≈ fork t₂ t₁
  swap₀ t₁ t₂ = λ x → record
    { to         = →-to-⟶ swap
    ; from       = →-to-⟶ swap
    ; inverse-of = record { left-inverse-of  = swap-inv
                          ; right-inverse-of = swap-inv }
    } where
       swap : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t₁ t₂ : Tree A n} → x ∈ fork t₁ t₂ → x ∈ fork t₂ t₁
       swap (left path)  = right path
       swap (right path) = left path

       swap-inv : ∀ {a}{A : Set a}{x : A}{n : ℕ}{t₁ t₂ : Tree A n}(p : x ∈ fork t₁ t₂) → swap (swap p) ≡ p
       swap-inv (left p)  = refl
       swap-inv (right p) = refl

  _⟨fork⟩_ : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ s₁ s₂ : Tree A n} → t₁ ≈ s₁ → t₂ ≈ s₂ → fork t₁ t₂ ≈ fork s₁ s₂
  (t1≈s1 ⟨fork⟩ t2≈s2) y = record
    { to         = to
    ; from       = from
    ; inverse-of = record { left-inverse-of  = frk-linv
                          ; right-inverse-of = frk-rinv  }
    } where

        frk : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ s₁ s₂ : Tree A n}{x : A} → t₁ ≈ s₁ → t₂ ≈ s₂ → x ∈ fork t₁ t₂ → x ∈ fork s₁ s₂
        frk t1≈s1 t2≈s2 (left x∈t1) = left (move t1≈s1 x∈t1)
        frk t1≈s1 t2≈s2 (right x∈t2) = right (move t2≈s2 x∈t2)

        to = →-to-⟶ (frk t1≈s1 t2≈s2)
        from = →-to-⟶ (frk (λ x → Function.Inverse.sym (t1≈s1 x)) (λ x → Function.Inverse.sym (t2≈s2 x)))

        open Function.Equality using (_⟨$⟩_)
        open import Function.LeftInverse

        frk-linv : from LeftInverseOf to
        frk-linv (left x) = cong left (_InverseOf_.left-inverse-of (Inverse.inverse-of (t1≈s1 y)) x)
        frk-linv (right x) = cong right (_InverseOf_.left-inverse-of (Inverse.inverse-of (t2≈s2 y)) x)

        frk-rinv : from RightInverseOf to -- ∀ x → to ⟨$⟩ (from ⟨$⟩ x) ≡ x
        frk-rinv (left x) = cong left (_InverseOf_.right-inverse-of (Inverse.inverse-of (t1≈s1 y)) x)
        frk-rinv (right x) = cong right (_InverseOf_.right-inverse-of (Inverse.inverse-of (t2≈s2 y)) x)

  Rot⟶≈ : ∀ {a}{A : Set a}{n : ℕ}{t₁ t₂ : Tree A n} → Rot t₁ t₂ → t₁ ≈ t₂
  Rot⟶≈ (leaf x)        y = Function.Inverse.id
  Rot⟶≈ (fork rot rot₁) y = (Rot⟶≈ rot ⟨fork⟩ Rot⟶≈ rot₁) y
  Rot⟶≈ (krof {_} {l} {l'} {r} {r'} rot rot₁) y =
        y ∈ fork l r ↔⟨ (Rot⟶≈ rot ⟨fork⟩ Rot⟶≈ rot₁) y ⟩
        y ∈ fork r' l' ↔⟨ swap₀ r' l' y ⟩
        y ∈ fork l' r' ∎
    where open EquationalReasoning

  put : {a : _}{A : Set a}{n : ℕ} → Bits n → A → Tree A n → Tree A n
  put [] val tree = leaf val
  put (x ∷ key) val (fork tree tree₁) = if x then fork tree (put key val tree₁)
                                             else fork (put key val tree) tree₁

  -- move-me
  _∷≢_ : {n : ℕ}{xs ys : Bits n}(x : Bit) → x ∷ xs ≢ x ∷ ys → xs ≢ ys
  (x ∷≢ neg) eq = neg (cong (_∷_ x) eq)

  ∈-put : {a : _}{A : Set a}{n : ℕ}(p : Bits n){x : A}(t : Tree A n) → x ∈ put p x t
  ∈-put [] t = here
  ∈-put (true ∷ p) (fork t t₁) = right (∈-put p t₁)
  ∈-put (false ∷ p) (fork t t₁) = left (∈-put p t)

  ∈-put-≢  : {a : _}{A : Set a}{n : ℕ}(p : Bits n){x y : A}{t : Tree A n}(path : x ∈ t)
          → p ≢ toBits path → x ∈ put p y t
  ∈-put-≢ [] here neg = ⊥-elim (neg refl)
  ∈-put-≢ (true ∷ p) (left path) neg   = left path
  ∈-put-≢ (false ∷ p) (left path) neg  = left (∈-put-≢ p path (false ∷≢ neg))
  ∈-put-≢ (true ∷ p) (right path) neg  = right (∈-put-≢ p path (true ∷≢ neg))
  ∈-put-≢ (false ∷ p) (right path) neg = right path

  swap : {a : _}{A : Set a}{n : ℕ} → (p₁ p₂ : Bits n) → Tree A n → Tree A n
  swap p₁ p₂ t = put p₁ a₂ (put p₂ a₁ t)
    where
      a₁ = lookup p₁ t
      a₂ = lookup p₂ t

  swap-perm₁ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p : x ∈ t) → t ≈ swap (toBits p) (toBits p) t
  swap-perm₁ here         = ≈-refl
  swap-perm₁ (left path)  = swap-perm₁ path ⟨fork⟩ ≈-refl
  swap-perm₁ (right path) = ≈-refl ⟨fork⟩ swap-perm₁ path

  swap-comm : {a : _}{A : Set a}{n : ℕ} (p₁ p₂ : Bits n)(t : Tree A n) → swap p₂ p₁ t ≡ swap p₁ p₂ t
  swap-comm [] [] (leaf x) = refl
  swap-comm (true ∷ p₁) (true ∷ p₂) (fork t t₁) = cong (fork t) (swap-comm p₁ p₂ t₁)
  swap-comm (true ∷ p₁) (false ∷ p₂) (fork t t₁) = refl
  swap-comm (false ∷ p₁) (true ∷ p₂) (fork t t₁) = refl
  swap-comm (false ∷ p₁) (false ∷ p₂) (fork t t₁) = cong (flip fork t₁) (swap-comm p₁ p₂ t)

  swap-perm₂ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p' : Bits n)(p : x ∈ t)
             → x ∈ swap (toBits p) p' t
  swap-perm₂ _ here = here
  swap-perm₂ (true ∷ p) (left path) rewrite ∈-lookup path = right (∈-put p _)
  swap-perm₂ (false ∷ p) (left path) = left (swap-perm₂ p path)
  swap-perm₂ (true ∷ p) (right path) = right (swap-perm₂ p path)
  swap-perm₂ (false ∷ p) (right path) rewrite ∈-lookup path = left (∈-put p _)

  swap-perm₃ : {a : _}{A : Set a}{n : ℕ}{t : Tree A n}{x : A}(p₁ p₂ : Bits n)(p : x ∈ t)
              → p₁ ≢ toBits p → p₂ ≢ toBits p → x ∈ swap p₁ p₂ t
  swap-perm₃ [] [] here neg₁ neg₂ = here
  swap-perm₃ (true ∷ p₁) (true ∷ p₂) (left path) neg₁ neg₂   = left path
  swap-perm₃ (true ∷ p₁) (false ∷ p₂) (left path) neg₁ neg₂  = left (∈-put-≢ _ path (false ∷≢ neg₂))
  swap-perm₃ (false ∷ p₁) (true ∷ p₂) (left path) neg₁ neg₂  = left (∈-put-≢ _ path (false ∷≢ neg₁))
  swap-perm₃ (false ∷ p₁) (false ∷ p₂) (left path) neg₁ neg₂ = left
             (swap-perm₃ p₁ p₂ path (false ∷≢ neg₁) (false ∷≢ neg₂))
  swap-perm₃ (true ∷ p₁) (true ∷ p₂) (right path) neg₁ neg₂   = right
             (swap-perm₃ p₁ p₂ path (true ∷≢ neg₁) (true ∷≢ neg₂))
  swap-perm₃ (true ∷ p₁) (false ∷ p₂) (right path) neg₁ neg₂  = right (∈-put-≢ _ path (true ∷≢ neg₁))
  swap-perm₃ (false ∷ p₁) (true ∷ p₂) (right path) neg₁ neg₂  = right (∈-put-≢ _ path (true ∷≢ neg₂))
  swap-perm₃ (false ∷ p₁) (false ∷ p₂) (right path) neg₁ neg₂ = right path

module prefect-bintree where

open import Function
open import Data.Nat
open import Data.Bool
open import Data.Bits

data Tree {a} (A : Set a) : ℕ → Set a where
  leaf : (x : A) → Tree A zero
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : Set a} → (Bits n → A) → Tree A n
fromFun {zero} f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : Set a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

lookup : ∀ {n a} {A : Set a} → Bits n → Tree A n → A
lookup = flip toFun

lookup' : ∀ {m n a} {A : Set a} → Bits m → Tree A (m + n) → Tree A n
lookup' [] t = t
lookup' (b ∷ bs) (fork t t₁) = lookup' bs (if b then t₁ else t)

{-
update' : ∀ {m n a} {A : Set a} → Bits m → Tree A n → Tree A (m + n) → Tree A (m + n)
update' = ?
-}

map : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

open import Relation.Binary
open import Data.Star

data Swp {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  swp₁ : ∀ {n} {left right : Tree A n} →
         Swp (fork left right) (fork right left)
  swp₂ : ∀ {n} {t₀₀ t₀₁ t₁₀ t₁₁ : Tree A n} →
         Swp (fork (fork t₀₀ t₀₁) (fork t₁₀ t₁₁)) (fork (fork t₁₁ t₀₁) (fork t₁₀ t₀₀))

Swp★ : ∀ {a} {A : Set a} {n} (left right : Tree A n) → Set a
Swp★ = Star Swp

Swp-sym : ∀ {n a} {A : Set a} → Symmetric (Swp {A = A} {n})
Swp-sym swp₁ = swp₁
Swp-sym swp₂ = swp₂

data Rot {a} {A : Set a} : ∀ {n} (left right : Tree A n) → Set a where
  leaf : ∀ x → Rot (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : Set a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork left right} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : Set a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : Set a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)


LamportOneBit: verifkey-is-hash-sig and sign-both-reveals-signkey

{-# OPTIONS --without-K #-}
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP hiding (map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP

module Crypto.Sig.LamportOneBit
          (#secret : ℕ)
          (#digest : ℕ)
          (hash    : Bits #secret → Bits #digest)
          where

#signkey   = 2* #secret
#verifkey  = 2* #digest
#signature = #secret

Digest     = Bits #digest
Secret     = Bits #secret
SignKey    = Bits #signkey
Signature  = Bits #signature
VerifKey   = Bits #verifkey

module signkey (sk : SignKey) where
  skL = take #secret sk
  skH = drop #secret sk
  vkL = hash skL
  vkH = hash skH
  skP = skL , skH

-- Derive the public key by hashing each secret
verif-key : SignKey → VerifKey
verif-key = map2* #secret #digest hash

module verifkey (vk : VerifKey) where
  vkL = take #digest vk
  vkH = drop #digest vk

-- Key generation
key-gen : SignKey → VerifKey × SignKey
key-gen sk = vk , sk
  module key-gen where
    vk = verif-key sk

-- Sign a single bit message
sign : SignKey → Bit → Signature
sign sk b = take2* _ b sk

-- Verify the signature of a single bit message
verify : VerifKey → Bit → Signature → Bit
verify vk b sig = take2* _ b vk == hash sig

verifkey-is-hash-sig : ∀ sk b → take2* _ b (verif-key sk) ≡ hash (sign sk b)
verifkey-is-hash-sig sk 0b = take-++ #digest (hash (take #secret sk)) _
verifkey-is-hash-sig sk 1b = drop-++ #digest (hash (take #secret sk)) _

verify-correct-sig : ∀ sk b → verify (verif-key sk) b (sign sk b) ≡ 1b
verify-correct-sig sk b = ==-reflexive (verifkey-is-hash-sig sk b)

sign-both-reveals-signkey : ∀ sk → sign sk 0b ++ sign sk 1b ≡ sk
sign-both-reveals-signkey = take-drop-lem #secret

import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits

module Assuming-injectivity (hash-inj : Injective hash) where

  -- If one considers the hash function injective, then, so is verif-key
  verif-key-inj : ∀ {sk1 sk2} → verif-key sk1 ≡ verif-key sk2 → sk1 ≡ sk2
  verif-key-inj {sk1} {sk2} e
    = take-drop= #secret sk1 sk2
        (hash-inj (++-inj₁ e))
        (hash-inj (++-inj₂ sk1.vkL sk2.vkL e))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2

  -- Therefor under this assumption, different secret keys means different public keys
  verif-key-corrolary : ∀ {sk1 sk2} → sk1 ≢ sk2 → verif-key sk1 ≢ verif-key sk2
  verif-key-corrolary {sk1} {sk2} sk≢ vk= = sk≢ (verif-key-inj vk=)

  -- If one considers the hash function injective then there is
  -- only one signing key which can sign correctly all (0 and 1)
  -- the messages
  signkey-uniqness :
        ∀ sk1 sk2 →
          (∀ b → verify (verif-key sk1) b (sign sk2 b) ≡ 1b) →
          sk1 ≡ sk2
  signkey-uniqness sk1 sk2 e
    = take-drop= #secret sk1 sk2 (lemmaL (e 0b)) (lemmaH (e 1b))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2
      lemmaL : verify (verif-key sk1) 0b (sign sk2 0b) ≡ 1b →
              sk1.skL ≡ sk2.skL
      lemmaL e0
        rewrite take-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e0)
              = refl

      lemmaH : verify (verif-key sk1) 1b (sign sk2 1b) ≡ 1b →
               sk1.skH ≡ sk2.skH
      lemmaH e1
        rewrite drop-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e1)
              = refl

module Assuming-invertibility
         (unhash : Digest → Secret)
         (unhash-hash : ∀ x → unhash (hash x) ≡ x)
         (hash-unhash : ∀ x → hash (unhash x) ≡ x)
         where

  -- EXERCISES
  {-
  recover-signkey : VerifKey → SignKey
  recover-signkey = {!!}

  recover-signkey-correct : ∀ sk → recover-signkey (verif-key sk) ≡ sk
  recover-signkey-correct = {!!}

  forgesig : VerifKey → Bit → Signature
  forgesig = {!!}

  forgesig-correct : ∀ vk b → verify vk b (forgesig vk b) ≡ 1b
  forgesig-correct = {!!}
  -}

-- -}

{-# OPTIONS --without-K #-}
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP hiding (map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP

module Crypto.Sig.LamportOneBit
          (#secret : ℕ)
          (#digest : ℕ)
          (hash    : Bits #secret → Bits #digest)
          where

#signkey   = 2* #secret
#verifkey  = 2* #digest
#signature = #secret

Digest     = Bits #digest
Secret     = Bits #secret
SignKey    = Bits #signkey
Signature  = Bits #signature
VerifKey   = Bits #verifkey

module signkey (sk : SignKey) where
  skL = take #secret sk
  skH = drop #secret sk
  vkL = hash skL
  vkH = hash skH

-- Derive the public key by hashing each secret
verif-key : SignKey → VerifKey
verif-key = map2* #secret #digest hash

module verifkey (vk : VerifKey) where
  vkL = take #digest vk
  vkH = drop #digest vk

-- Key generation
key-gen : SignKey → VerifKey × SignKey
key-gen sk = vk , sk
  module key-gen where
    vk = verif-key sk

-- Sign a single bit message
sign : SignKey → Bit → Signature
sign sk b = take2* _ b sk

-- Verify the signature of a single bit message
verify : VerifKey → Bit → Signature → Bit
verify vk b sig = take2* _ b vk == hash sig

verify-correct-sig : ∀ sk b → verify (verif-key sk) b (sign sk b) ≡ 1b
verify-correct-sig sk 0b = ==-reflexive (take-++ #digest (hash (take #secret sk)) _)
verify-correct-sig sk 1b = ==-reflexive (drop-++ #digest (hash (take #secret sk)) _)

import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits

module Assuming-injectivity (hash-inj : Injective hash) where

  -- If one considers the hash function injective, then, so is verif-key
  verif-key-inj : ∀ {sk1 sk2} → verif-key sk1 ≡ verif-key sk2 → sk1 ≡ sk2
  verif-key-inj {sk1} {sk2} e
    = take-drop= #secret sk1 sk2
        (hash-inj (++-inj₁ e))
        (hash-inj (++-inj₂ sk1.vkL sk2.vkL e))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2

  -- Therefor under this assumption, different secret keys means different public keys
  verif-key-corrolary : ∀ {sk1 sk2} → sk1 ≢ sk2 → verif-key sk1 ≢ verif-key sk2
  verif-key-corrolary {sk1} {sk2} sk≢ vk= = sk≢ (verif-key-inj vk=)

  -- If one considers the hash function injective then there is
  -- only one signing key which can sign correctly all (0 and 1)
  -- the messages
  signkey-uniqness :
        ∀ sk1 sk2 →
          (∀ b → verify (verif-key sk1) b (sign sk2 b) ≡ 1b) →
          sk1 ≡ sk2
  signkey-uniqness sk1 sk2 e
    = take-drop= #secret sk1 sk2 (lemmaL (e 0b)) (lemmaH (e 1b))
    where
      module sk1 = signkey sk1
      module sk2 = signkey sk2
      lemmaL : verify (verif-key sk1) 0b (sign sk2 0b) ≡ 1b →
              sk1.skL ≡ sk2.skL
      lemmaL e0
        rewrite take-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e0)
              = refl

      lemmaH : verify (verif-key sk1) 1b (sign sk2 1b) ≡ 1b →
               sk1.skH ≡ sk2.skH
      lemmaH e1
        rewrite drop-++ #digest sk1.vkL sk1.vkH
              | hash-inj (==⇒≡ e1)
              = refl

module Assuming-invertibility
         (unhash : Digest → Secret)
         (unhash-hash : ∀ x → unhash (hash x) ≡ x)
         (hash-unhash : ∀ x → hash (unhash x) ≡ x)
         where

  -- EXERCISES
  {-
  recover-signkey : VerifKey → SignKey
  recover-signkey = {!!}

  recover-signkey-correct : ∀ sk → recover-signkey (verif-key sk) ≡ sk
  recover-signkey-correct = {!!}

  forgesig : VerifKey → Bit → Signature
  forgesig = {!!}

  forgesig-correct : ∀ vk b → verify vk b (forgesig vk b) ≡ 1b
  forgesig-correct = {!!}
  -}

-- -}


Field.Solver: some progress but far from done...

import Algebra.Field as Field

open import Relation.Binary.PropositionalEquality.NP as ≡

open import Level
open import Data.Nat as Nat using (ℕ) renaming (suc to 1+_)
open import Data.One
open import Data.Product

open import Function

module Algebra.Field.Solver where

data R-Op : Set where
  [+] [*] [-] : R-Op

data F-Op : Set where
  [+] [*] [-] [/] : F-Op

data Tm (F Op Var : Set) : Set where
  op  : (o : Op) (t₁ t₂ : Tm F Op Var) → Tm F Op Var
  con : F → Tm F Op Var
  var : Var → Tm F Op Var

infixl 6 _:+_ _:-_
infixl 7 _:*_ _:/_
pattern _:+_ x y = op [+] x y
pattern _:*_ x y = op [*] x y
pattern _:-_ x y = op [-] x y
pattern _:/_ x y = op [/] x y

R-include : R-Op → F-Op
R-include [+] = [+]
R-include [*] = [*]
R-include [-] = [-]

module _ {F Op Var : Set}(evalOp : Op → F → F → F)(ρ : Var → F) where
  eval : Tm F Op Var → F
  eval (op o t u) = evalOp o (eval t) (eval u)
  eval (con x) = x
  eval (var x) = ρ x

module _ {F Var : Set}(evF : Tm F F-Op Var → Set) where
  Assumptions : Tm F F-Op Var → Set
  Assumptions (op [+] t u) = Assumptions t × Assumptions u
  Assumptions (op [*] t u) = Assumptions t × Assumptions u
  Assumptions (op [-] t u) = Assumptions t × Assumptions u
  Assumptions (op [/] t u) = Assumptions t × Assumptions u × evF u
  Assumptions (con x) = Lift 𝟙
  Assumptions (var x) = Lift 𝟙

module _
  {Var : Set}
  {F : Set}
  (𝔽 : Field.Field-Ops F)
  where

  open Field.Field-Ops 𝔽

  F-Op-eval : F-Op → F → F → F
  F-Op-eval [+] x y = x + y
  F-Op-eval [*] x y = x * y
  F-Op-eval [-] x y = x − y
  F-Op-eval [/] x y = x / y

  R-Op-eval : R-Op → F → F → F
  R-Op-eval o = F-Op-eval (R-include o)

  evalF : (ρ : Var → F) → Tm F F-Op Var → F
  evalR : (ρ : Var → F) → Tm F R-Op Var → F
  evalF = eval F-Op-eval
  evalR = eval R-Op-eval

  private
      TmF = Tm F F-Op Var
      TmR = Tm F R-Op Var

  infix 2 _/_:[_,_]
  record Div (evF : TmF → F)(evR : TmR → F)(t : TmF) : Set where
    constructor _/_:[_,_]
    field
      N : TmR
      D : TmR
      .non-zero-D : evR D ≢ 0#
      .is-correct : evF t ≡ evR N / evR D

  module _ (FS : Field.Field-Struct 𝔽)(ρ : Var → F) where
    open Field.Field-Struct FS

    private
      Div' = Div (evalF ρ) (evalR ρ)
      evF = evalF ρ

    NonZeroF : TmF → Set
    NonZeroF x = evF x ≢ 0#

    _+Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :+ u)
    (N / D :[ nD , ok ]) +Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* D₁ :+ N₁ :* D / D :* D₁
       :[ no-zero-divisor nD nD₁ , += ok ok₁ ∙ +-quotient nD nD₁ ]

    _*Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :* u)
    (N / D :[ nD , ok ]) *Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* N₁ / D :* D₁
       :[ no-zero-divisor nD nD₁ , *= ok ok₁ ∙ *-quotient nD nD₁ ]

    _−Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :- u)
    (N / D :[ nD , ok ]) −Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* D₁ :- N₁ :* D / D :* D₁
       :[ no-zero-divisor nD nD₁ , −= ok ok₁ ∙ −-quotient nD nD₁ ]

    _/Div_:[_] : ∀ {t u} → Div' t → Div' u → evF u ≢ 0# → Div' (t :/ u)
    (N / D :[ nD , ok ]) /Div (N₁ / D₁ :[ nD₁ , ok₁ ]) :[ u≢0 ]
      = (N :* D₁) / (D :* N₁)
      :[ no-zero-divisor nD nN₁ , /= ok ok₁ ∙ /-quotient nN₁ nD nD₁ ]
      where .nN₁ : evalR ρ N₁ ≢ 0#
            nN₁ p = u≢0 (ok₁ ∙ *= p idp ∙ 0*-zero)

    -- con-Div and var-Div are basically the same but not so convenient to unify
    con-Div : ∀ x → Div' (con x)
    var-Div : ∀ x → Div' (var x)

    con-Div x = con x / con 1# :[ 1≢0 , ! /1-id ]
    var-Div x = var x / con 1# :[ 1≢0 , ! /1-id ]

    to-ring : ∀ (t : TmF) → Assumptions NonZeroF t → Div' t
    to-ring (op [+] t u) (at , au)       = to-ring t at +Div to-ring u au
    to-ring (op [*] t u) (at , au)       = to-ring t at *Div to-ring u au
    to-ring (op [-] t u) (at , au)       = to-ring t at −Div to-ring u au
    to-ring (op [/] t u) (at , au , u≢0) = to-ring t at /Div to-ring u au :[ u≢0 ]
    to-ring (con x) _                    = con-Div x
    to-ring (var x) _                    = var-Div x

{-
    Eqn : Set _
    Eqn = TmF × TmF

    divR : ∀ {t} → Div' t → TmR
    divR (N / D :[ nD , ok ]) = {!!}

    to-ring' : ∀ (t : TmF) → Assumptions t → TmR
    to-ring' t a = {!!}
    -}

open import Relation.Binary
module _
  {F : Set}
  (𝔽 : Field.Field F)
  (_≟R_ : Decidable {A = F} _≡_)

  where
  open import Algebra using (RawRing)
  open import Algebra.RingSolver.AlmostCommutativeRing

  private
    module 𝔽 = Field.Field 𝔽

  open 𝔽
  R : AlmostCommutativeRing _ _
  R = record
        { Carrier = F
        ; _≈_ = _≡_
        ; _+_ = _+_
        ; _*_ = _*_
        ; -_ = 0−_
        ; 0# = 0#
        ; 1# = 1#
        ; isAlmostCommutativeRing =
          record
            { isCommutativeSemiring =
              record
              { +-isCommutativeMonoid =
                record
                { isSemigroup =
                  record
                  { isEquivalence = ≡.isEquivalence
                  ; assoc = λ _ _ _ → +-assoc
                  ; ∙-cong = += }
                ; identityˡ = λ _ → 0+-identity
                ; comm = λ _ _ → +-comm }
              ; *-isCommutativeMonoid =
                record
                { isSemigroup =
                  record
                  { isEquivalence = ≡.isEquivalence
                  ; assoc = λ _ _ _ → *-assoc
                  ; ∙-cong = *= }
                ; identityˡ = λ _ → 1*-identity
                ; comm = λ _ _ → *-comm }
              ; distribʳ = λ _ _ _ → *-+-distrʳ
              ; zeroˡ = λ _ → 0*-zero
              }
            ; -‿cong = 0−=
            ; -‿*-distribˡ = λ _ _ → ! 0−-*-distr
            ; -‿+-comm = λ _ _ → ! 0−-+-distr
            }
        }
  import Algebra.RingSolver
  import Algebra.RingSolver.Simple

{- I try first with the RingSolver.Simple, otherwise here is what we need

  Coeff : RawRing _
  Coeff = {!!}

  morphism : Coeff -Raw-AlmostCommutative⟶ R
  morphism = {!!}

  _coeff≟_ : Decidable (Induced-equivalence morphism)
  x coeff≟ y = {!!}

  module RS = Algebra.RingSolver Coeff R morphism _coeff≟_
-}

  module RS = Algebra.RingSolver.Simple R _≟R_

  import Relation.Binary.Reflection as Reflection
  open Reflection (≡.setoid F) RS.var RS.⟦_⟧ RS.⟦_⟧↓ RS.correct public
      using (prove; solve; solve₁) renaming (_⊜_ to _:=_)

  test-+-comm : ∀ m n → m + n ≡ n + m
  test-+-comm m n = solve₁ 2 (λ x y → x RS.:+ y := y RS.:+ x) m n refl

  ℕ▹P : ℕ → ∀ {n} → RS.Polynomial n
  ℕ▹P 0 = RS.con 0#
  ℕ▹P 1 = RS.con 1#
  ℕ▹P (1+ x) = RS.con 1# RS.:+ ℕ▹P x

  {-
  test-0−-inverse : ∀ m → m + 0− m ≡ 0#
  test-0−-inverse m = solve₁ 1 (λ x → x RS.:+ (RS.:- x) := RS.con 0#) m refl

  test-0−-involutive : ∀ m → 0− (0− m) ≡ m
  test-0−-involutive m = solve₁ 1 (λ x → RS.:- (RS.:- x) := x) m refl

  test-2* : ∀ n → 2# * n ≡ n + n
  test-2* n = solve₁ 1 (λ x → (ℕ▹P 2 RS.:* x) := (x RS.:+ x)) n refl
  -}

  open import Data.Vec
  open import Data.Fin using (Fin)

  poly : ∀ {n} → Tm F R-Op (Fin n) → RS.Polynomial n
  poly (op [+] t u) = poly t RS.:+ poly u
  poly (op [*] t u) = poly t RS.:* poly u
  poly (op [-] t u) = poly t RS.:- poly u
  poly (con x) = RS.con x
  poly (var x) = RS.var x

  {-
  FO = 𝔽.field-ops
  FS = 𝔽.field-struct

  Expr : ℕ → Set
  Expr n = Σ (Tm F F-Op (Fin n))
    -- this is probably wrong...
    (λ t → (ρ : Fin n → F) → Assumptions (NonZeroF FO FS ρ) t)

  Sem : Set
  Sem = F

  -- this takes only the numerator in account
  ⟦_⟧ : ∀ {n} → Expr n → Vec F n → Sem
  ⟦ t , a ⟧ ρ = RS.⟦ poly (Div.N (to-ring FO FS (flip lookup ρ) t (a (flip lookup ρ)))) ⟧ ρ

  -- this takes only the numerator in account
  ⟦_⟧↓ : ∀ {n} → Expr n → Vec F n → Sem
  ⟦ t , a ⟧↓ ρ = RS.⟦ poly (Div.N (to-ring FO FS (flip lookup ρ) t (a (flip lookup ρ)))) ⟧↓ ρ

  correct : ∀ {n} (e : Expr n) ρ → ⟦ e ⟧↓ ρ ≡ ⟦ e ⟧ ρ
  correct (op o t t₁ , a) ρ = {!!}
  correct (con x , a) ρ = {!idp!}
  correct (var x , a) ρ = {!!}

  open Reflection ≡.setoid var ⟦_⟧ ⟦_⟧↓ correct public
    using (prove; solve) renaming (_⊜_ to _:=_)

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

import Algebra.Field as Field
import Algebra.RingSolver as RS

open import Relation.Binary.PropositionalEquality.NP

open import Level
open import Data.Nat as Nat using (ℕ)
open import Data.Fin
open import Data.One
open import Data.Product

open import Function

module Algebra.Field.Solver where

data R-Op : Set where
  [+] [*] [-] : R-Op

data F-Op : Set where
  [+] [*] [-] [/] : F-Op

data Tm (F Op Var : Set) : Set where
  op  : (o : Op) (t₁ t₂ : Tm F Op Var) → Tm F Op Var
  con : F → Tm F Op Var
  var : Var → Tm F Op Var

infixl 6 _:+_ _:-_
infixl 7 _:*_ _:/_
pattern _:+_ x y = op [+] x y
pattern _:*_ x y = op [*] x y
pattern _:-_ x y = op [-] x y
pattern _:/_ x y = op [/] x y

R-include : R-Op → F-Op
R-include [+] = [+]
R-include [*] = [*]
R-include [-] = [-]

module _ {F Op Var : Set}(evalOp : Op → F → F → F)(ρ : Var → F) where
  eval : Tm F Op Var → F
  eval (op o t u) = evalOp o (eval t) (eval u)
  eval (con x) = x
  eval (var x) = ρ x

module _
  {Var : Set}
  {F : Set}
  (𝔽 : Field.Field-Ops F)
  where

  module 𝔽 = Field.Field-Ops 𝔽

  F-Op-eval : F-Op → F → F → F
  F-Op-eval [+] x y = x 𝔽.+ y
  F-Op-eval [*] x y = x 𝔽.* y
  F-Op-eval [-] x y = x 𝔽.− y
  F-Op-eval [/] x y = x 𝔽./ y

  R-Op-eval : R-Op → F → F → F
  R-Op-eval o = F-Op-eval (R-include o)

  evalF : (ρ : Var → F) → Tm F F-Op Var → F
  evalR : (ρ : Var → F) → Tm F R-Op Var → F
  evalF = eval F-Op-eval
  evalR = eval R-Op-eval

  infix 2 _/_:[_,_]
  record Div ρ (t : Tm F F-Op Var) : Set where
    constructor _/_:[_,_]
    field
      N : Tm F R-Op Var
      D : Tm F R-Op Var
      .non-zero-D : evalR ρ D ≢ 𝔽.`0
      .is-correct : evalF ρ t ≡ evalR ρ N 𝔽./ evalR ρ D

  module _ (FS : Field.Field-Struct 𝔽)(ρ : Var → F) where
    open Field.Field-Struct FS

    private
      TmF = Tm F F-Op Var
      TmR = Tm F R-Op Var

      Div' = Div ρ
      ev = evalF ρ

    _+Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :+ u)
    (N / D :[ nD , ok ]) +Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* D₁ :+ N₁ :* D / D :* D₁
       :[ no-zero-divisor nD nD₁ , += ok ok₁ ∙ +-quotient nD nD₁ ]

    _*Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :* u)
    (N / D :[ nD , ok ]) *Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* N₁ / D :* D₁
       :[ no-zero-divisor nD nD₁ , *= ok ok₁ ∙ *-quotient nD nD₁ ]

    _−Div_ : ∀ {t u} → Div' t → Div' u → Div' (t :- u)
    (N / D :[ nD , ok ]) −Div (N₁ / D₁ :[ nD₁ , ok₁ ])
       = N :* D₁ :- N₁ :* D / D :* D₁
       :[ no-zero-divisor nD nD₁ , −= ok ok₁ ∙ −-quotient nD nD₁ ]

    _/Div_:[_] : ∀ {t u} → Div' t → Div' u → ev u ≢ `0 → Div' (t :/ u)
    (N / D :[ nD , ok ]) /Div (N₁ / D₁ :[ nD₁ , ok₁ ]) :[ u≢0 ]
      = (N :* D₁) / (D :* N₁)
      :[ no-zero-divisor nD nN₁ , /= ok ok₁ ∙ /-quotient nN₁ nD nD₁ ]
      where .nN₁ : evalR ρ N₁ ≢ `0
            nN₁ p = u≢0 (ok₁ ∙ *= p idp ∙ 0*-zero)

    -- con-Div and var-Div are basically the same but not so convenient to unify
    con-Div : ∀ x → Div' (con x)
    var-Div : ∀ x → Div' (var x)

    con-Div x = con x / con 𝔽.`1 :[ 1≢0 , ! /1-id ]
    var-Div x = var x / con 𝔽.`1 :[ 1≢0 , ! /1-id ]

    Assumptions : TmF → Set
    Assumptions (op [+] t u) = Assumptions t × Assumptions u
    Assumptions (op [*] t u) = Assumptions t × Assumptions u
    Assumptions (op [-] t u) = Assumptions t × Assumptions u
    Assumptions (op [/] t u) = Assumptions t × Assumptions u × ev u ≢ `0
    Assumptions (con x) = Lift 𝟙
    Assumptions (var x) = Lift 𝟙

    to-ring : ∀ (t : TmF) → Assumptions t → Div' t
    to-ring (op [+] t u) (at , au)       = to-ring t at +Div to-ring u au
    to-ring (op [*] t u) (at , au)       = to-ring t at *Div to-ring u au
    to-ring (op [-] t u) (at , au)       = to-ring t at −Div to-ring u au
    to-ring (op [/] t u) (at , au , u≢0) = to-ring t at /Div to-ring u au :[ u≢0 ]
    to-ring (con x) _                    = con-Div x
    to-ring (var x) _                    = var-Div x

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


Parser: idiom brakets

Parser: idiom brakets

open import Data.Maybe.NP as Maybe
open import Data.Nat
open import Data.Unit
open import Data.Char renaming (_==_ to _==ᶜ_)
open import Data.String as String
open import Data.List as L using (List; []; _∷_; null; filter)
open import Data.Product.NP hiding (map)
open import Data.Bool
open import Function
import Level as L
import Category.Monad as Cat
import Category.Monad.Partiality.NP as Pa

module Text.Parser where

open M? L.zero using () renaming (_=<<_ to _=<<?_; _⊛_ to _⊛?_; join to join?)

Parser : Set → Set
Parser A = List Char →? (A × List Char)

pure : ∀ {A} → A → Parser A
pure a s = just (a , s)

infixr 3 _⟨|⟩_
_⟨|⟩_ : ∀ {A} → (f g : Parser A) → Parser A
_⟨|⟩_ f g s = maybe′ just (g s) $ f s

empty : ∀ {A} → Parser A
empty _ = nothing

sat : (Char → Bool) → Parser Char
sat pred (x ∷ xs) = (if pred x then pure x else empty) xs
sat _    []       = nothing

eof : Parser ⊤
eof s = if null s then pure _ [] else empty []

-- The remaning input is dropped, you may want to first
-- combine your parser `p' with `eof': `p <* eof'
runParser : ∀ {A} → Parser A → List Char →? A
runParser p s = map? proj₁ (p s)

infixr 0 _>>=_
_>>=_ : ∀ {A B} → Parser A → (A → Parser B) → Parser B
_>>=_ pa f = maybe′ (uncurry f) nothing ∘ pa

infixl 0 _=<<_
_=<<_ : ∀ {A B} → (A → Parser B) → Parser A → Parser B
_=<<_ f pa = pa >>= f

join : ∀ {A} → Parser (Parser A) → Parser A
join = _=<<_ id

map : ∀ {A B} → (A → B) → Parser A → Parser B
map f pa = pa >>= pure ∘ f

infixl 4 _⊛_ _*>_ _<*_
_⊛_ : ∀ {A B} → Parser (A → B) → Parser A → Parser B
_⊛_ pf pa = pf >>= λ f → pa >>= λ a → pure (f a)

⟪_·_⟫ : ∀ {A B} → (A → B) → Parser A → Parser B
⟪ f · x ⟫ = map f x

⟪_·_·_⟫ : ∀ {A B C} →
            (A → B → C) → Parser A → Parser B → Parser C
⟪ f · x · y ⟫ = map f x ⊛ y

⟪_·_·_·_⟫ : ∀ {A B C D} → (A → B → C → D)
            → Parser A → Parser B → Parser C → Parser D
⟪ f · x · y · z ⟫ = map f x ⊛ y ⊛ z

_*>_ : ∀ {A B} → Parser A → Parser B → Parser B
p₁ *> p₂ = p₁ >>= const p₂

_<*_ : ∀ {A B} → Parser A → Parser B → Parser A
p₁ <* p₂ = p₁ >>= λ x → p₂ *> pure x

choices : ∀ {A} → List (Parser A) → Parser A
choices = L.foldr _⟨|⟩_ empty

{-
mutual
  many : ∀ {A} → Parser A → Parser (List A)
  many p = some p ⟨|⟩ pure []

  some : ∀ {A} → Parser A → Parser (List A)
  some p = pure _∷_ ⊛ p ⊛ many p
-}

mutual
  many : ∀ {A} → Parser A → ℕ → Parser (List A)
  many _ 0       = empty
  many p (suc n) = some p n ⟨|⟩ pure []

  some : ∀ {A} → Parser A → ℕ → Parser (List A)
  some p n = pure _∷_ ⊛ p ⊛ many p n

manySat : (Char → Bool) → Parser (List Char)
manySat p []       = pure [] []
manySat p (x ∷ xs) = if p x then map? (first (_∷_ x)) (manySat p xs) else pure [] (x ∷ xs)

someSat : (Char → Bool) → Parser (List Char)
someSat p = pure _∷_ ⊛ sat p ⊛ manySat p

char : Char → Parser ⊤
char c = sat (_==ᶜ_ c) *> pure _

private
  notElem : Char → List Char → Bool
  notElem c = null ∘ filter (_==ᶜ_ c)

  syntax notElem c cs = c `notElem` cs

  elem : Char → List Char → Bool
  elem c = not ∘ notElem c

  syntax elem c cs = c `elem` cs

oneOf : List Char → Parser Char
oneOf cs = sat (λ c → c `elem` cs)

noneOf : List Char → Parser Char
noneOf cs = sat (λ c → c `notElem` cs)

someOneOf : List Char → Parser (List Char)
someOneOf cs = someSat (λ c → c `elem` cs)

someNoneOf : List Char → Parser (List Char)
someNoneOf cs = someSat (λ c → c `notElem` cs)

manyOneOf : List Char → Parser (List Char)
manyOneOf cs = manySat (λ c → c `elem` cs)

manyNoneOf : List Char → Parser (List Char)
manyNoneOf cs = manySat (λ c → c `notElem` cs)

open import Data.Maybe.NP as Maybe
open import Data.Nat
open import Data.Unit
open import Data.Char renaming (_==_ to _==ᶜ_)
open import Data.String as String
open import Data.List as L using (List; []; _∷_; null; filter)
open import Data.Product.NP hiding (map)
open import Data.Bool
open import Function
import Level as L
import Category.Monad as Cat
import Category.Monad.Partiality.NP as Pa

module Text.Parser where

open M? L.zero using () renaming (_=<<_ to _=<<?_; _⊛_ to _⊛?_; join to join?)

Parser : Set → Set
Parser A = List Char →? (A × List Char)

pure : ∀ {A} → A → Parser A
pure a s = just (a , s)

infixr 3 _⟨|⟩_
_⟨|⟩_ : ∀ {A} → (f g : Parser A) → Parser A
_⟨|⟩_ f g s = maybe′ just (g s) $ f s

empty : ∀ {A} → Parser A
empty _ = nothing

sat : (Char → Bool) → Parser Char
sat pred (x ∷ xs) = (if pred x then pure x else empty) xs
sat _    []       = nothing

eof : Parser ⊤
eof s = if null s then pure _ [] else empty []

-- The remaning input is dropped, you may want to first
-- combine your parser `p' with `eof': `p <* eof'
runParser : ∀ {A} → Parser A → List Char →? A
runParser p s = map? proj₁ (p s)

infixr 0 _>>=_
_>>=_ : ∀ {A B} → Parser A → (A → Parser B) → Parser B
_>>=_ pa f = maybe′ (uncurry f) nothing ∘ pa

infixl 0 _=<<_
_=<<_ : ∀ {A B} → (A → Parser B) → Parser A → Parser B
_=<<_ f pa = pa >>= f

join : ∀ {A} → Parser (Parser A) → Parser A
join = _=<<_ id

map : ∀ {A B} → (A → B) → Parser A → Parser B
map f pa = pa >>= pure ∘ f

infixl 4 _⊛_ _*>_ _<*_
_⊛_ : ∀ {A B} → Parser (A → B) → Parser A → Parser B
_⊛_ pf pa = pf >>= λ f → pa >>= λ a → pure (f a)

_*>_ : ∀ {A B} → Parser A → Parser B → Parser B
p₁ *> p₂ = p₁ >>= const p₂

_<*_ : ∀ {A B} → Parser A → Parser B → Parser A
p₁ <* p₂ = p₁ >>= λ x → p₂ *> pure x

choices : ∀ {A} → List (Parser A) → Parser A
choices = L.foldr _⟨|⟩_ empty

{-
mutual
  many : ∀ {A} → Parser A → Parser (List A)
  many p = some p ⟨|⟩ pure []

  some : ∀ {A} → Parser A → Parser (List A)
  some p = pure _∷_ ⊛ p ⊛ many p
-}

mutual
  many : ∀ {A} → Parser A → ℕ → Parser (List A)
  many _ 0       = empty
  many p (suc n) = some p n ⟨|⟩ pure []

  some : ∀ {A} → Parser A → ℕ → Parser (List A)
  some p n = pure _∷_ ⊛ p ⊛ many p n

manySat : (Char → Bool) → Parser (List Char)
manySat p []       = pure [] []
manySat p (x ∷ xs) = if p x then map? (first (_∷_ x)) (manySat p xs) else pure [] (x ∷ xs)

someSat : (Char → Bool) → Parser (List Char)
someSat p = pure _∷_ ⊛ sat p ⊛ manySat p

char : Char → Parser ⊤
char c = sat (_==ᶜ_ c) *> pure _

private
  notElem : Char → List Char → Bool
  notElem c = null ∘ filter (_==ᶜ_ c)

  syntax notElem c cs = c `notElem` cs

  elem : Char → List Char → Bool
  elem c = not ∘ notElem c

  syntax elem c cs = c `elem` cs

oneOf : List Char → Parser Char
oneOf cs = sat (λ c → c `elem` cs)

noneOf : List Char → Parser Char
noneOf cs = sat (λ c → c `notElem` cs)

someOneOf : List Char → Parser (List Char)
someOneOf cs = someSat (λ c → c `elem` cs)

someNoneOf : List Char → Parser (List Char)
someNoneOf cs = someSat (λ c → c `notElem` cs)

manyOneOf : List Char → Parser (List Char)
manyOneOf cs = manySat (λ c → c `elem` cs)

manyNoneOf : List Char → Parser (List Char)
manyNoneOf cs = manySat (λ c → c `notElem` cs)


Fix Data.Fin.Logical

Fix Data.Fin.Logical

{-# OPTIONS --with-K #-}
module Data.Fin.Logical where

open import Data.Nat.Logical
open import Data.Nat.Param.Binary
-- open import Data.Fin.Param.Binary

open import Function
open import Data.Fin
open import Relation.Binary
open import Relation.Binary.Logical

private
  module ⟦ℕ⟧s = Setoid ⟦ℕ⟧-setoid

data ⟦Fin⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦★₀⟧) Fin Fin where
  ⟦zero⟧ : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} → ⟦Fin⟧ (⟦suc⟧ nᵣ) zero zero
  ⟦suc⟧  : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} {x₁ x₂} (xᵣ : ⟦Fin⟧ nᵣ x₁ x₂) → ⟦Fin⟧ (⟦suc⟧ nᵣ) (suc x₁) (suc x₂)

private
  refl : ∀ {n} → Reflexive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  refl {x = zero}  = ⟦zero⟧
  refl {x = suc _} = ⟦suc⟧ refl

  sym : ∀ {n} → Symmetric (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  sym ⟦zero⟧ = ⟦zero⟧
  sym (⟦suc⟧ xᵣ) = ⟦suc⟧ (sym xᵣ)

  trans : ∀ {n} → Transitive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  trans ⟦zero⟧ xᵣ = xᵣ
  trans (⟦suc⟧ xᵣ) (⟦suc⟧ yᵣ) = ⟦suc⟧ (trans xᵣ yᵣ)

  subst : ∀ {ℓ n} → Substitutive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl) ℓ
  subst _ ⟦zero⟧    = id
  subst P (⟦suc⟧ xᵣ) = subst (P ∘ suc) xᵣ

  isEquivalence : ∀ {n} → IsEquivalence (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  isEquivalence = record { refl = refl; sym = sym; trans = trans }

-- NOTE with-K
module Data.Fin.Logical where

open import Data.Nat.Param.Binary
open import Data.Fin.Param.Binary

open import Function
open import Data.Fin
open import Relation.Binary
open import Relation.Binary.Logical

private
  module ⟦ℕ⟧s = Setoid ⟦ℕ⟧-setoid

{-
data ⟦Fin⟧ : (⟦ℕ⟧ ⟦→⟧ ⟦★₀⟧) Fin Fin where
  ⟦zero⟧ : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} → ⟦Fin⟧ (suc nᵣ) zero zero
  ⟦suc⟧  : ∀ {n₁ n₂} {nᵣ : ⟦ℕ⟧ n₁ n₂} {x₁ x₂} (xᵣ : ⟦Fin⟧ nᵣ x₁ x₂) → ⟦Fin⟧ (suc nᵣ) (suc x₁) (suc x₂)
-}

private
  refl : ∀ {n} → Reflexive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  refl {x = zero}  = ⟦zero⟧
  refl {x = suc _} = ⟦suc⟧ refl

  sym : ∀ {n} → Symmetric (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  sym ⟦zero⟧ = ⟦zero⟧
  sym (⟦suc⟧ xᵣ) = ⟦suc⟧ (sym xᵣ)

  trans : ∀ {n} → Transitive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  trans ⟦zero⟧ xᵣ = xᵣ
  trans (⟦suc⟧ xᵣ) (⟦suc⟧ yᵣ) = ⟦suc⟧ (trans xᵣ yᵣ)

  subst : ∀ {ℓ n} → Substitutive (⟦Fin⟧ {n} ⟦ℕ⟧s.refl) ℓ
  subst _ ⟦zero⟧    = id
  subst P (⟦suc⟧ xᵣ) = subst (P ∘ suc) xᵣ

  isEquivalence : ∀ {n} → IsEquivalence (⟦Fin⟧ {n} ⟦ℕ⟧s.refl)
  isEquivalence = record { refl = refl; sym = sym; trans = trans }