Explore.Product: typo in a name

Explore.Product: typo in a name

{-# OPTIONS --without-K #-}
{- The main definitions are the following:

  * exploreΣ
  * exploreΣ-ind
  * adequate-sumΣ
-}

open import Level.NP
open import Type hiding (★)
open import Function.NP
import Function.Related as FR
import Function.Inverse.NP as FI
open FI using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Function.Related.TypeIsomorphisms.NP
open import Data.Bool using (true ; false ; _∧_ ; if_then_else_)
open import Data.Product
open import Data.Fin
open import Relation.Binary.PropositionalEquality.NP using (_≡_ ; module ≡-Reasoning)
open import Category.Monad.Continuation.Alias

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM
open import Explore.Explorable

module Explore.Product where

module _ {m A} {B : A → ★₀} where

    exploreΣ : Explore m A → (∀ {x} → Explore m (B x)) → Explore m (Σ A B)
    exploreΣ exploreᴬ exploreᴮ z op = exploreᴬ z op ⟨,⟩ exploreᴮ z op

    module _ {eᴬ : Explore m A} {eᴮ : ∀ {x} → Explore m (B x)} where

        exploreΣ-ind : ∀ {p} → ExploreInd p eᴬ → (∀ {x} → ExploreInd p (eᴮ {x})) → ExploreInd p (exploreΣ eᴬ eᴮ)
        exploreΣ-ind Peᴬ Peᴮ P Pz P∙ Pf =
          Peᴬ (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ (λ x → Peᴮ {x} (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ (curry Pf x))

module _ {A}{B : A → ★₀}{eᴬ : Explore ₀ A}{eᴮ : ∀ {x} → Explore ₀ (B x)} where
   exploreΣ-adq : AdequateExplore eᴬ → (∀ {x} → AdequateExplore (eᴮ {x})) → AdequateExplore (exploreΣ eᴬ eᴮ)
   exploreΣ-adq aᴬ aᴮ F ε _⊕_ f F-proof
     = F (big⊕ᴬ (λ a → big⊕ᴮ (λ b → f (a , b))))
     ↔⟨ aᴬ F _ _ _ F-proof ⟩
         Σ A (F ∘ (λ a → big⊕ᴮ (λ b → f (a , b))))
     ↔⟨ second-iso (λ _ → aᴮ F _ _ _ F-proof) ⟩
       Σ A (λ a → Σ (B a) (λ b → F (f (a , b))))
     ↔⟨ FI.sym Σ-assoc ⟩
       Σ (Σ A B) (F ∘ f)
     ∎
     where open FR.EquationalReasoning
           big⊕ᴬ = eᴬ ε _⊕_
           big⊕ᴮ = λ {x} → eᴮ {x} ε _⊕_

module _ {A} {B : A → ★₀} {sumᴬ : Sum A} {sumᴮ : ∀ {x} → Sum (B x)} where

    private
        sumᴬᴮ = sumᴬ ⟨,⟩ (λ {x} → sumᴮ {x})

    adequate-sumΣ : AdequateSum sumᴬ → (∀ {x} → AdequateSum (sumᴮ {x})) → AdequateSum sumᴬᴮ
    adequate-sumΣ asumᴬ asumᴮ f = Fin (sumᴬᴮ f)
                                ↔⟨ FI.id ⟩
                                  Fin (sumᴬ (λ a → sumᴮ (λ b → f (a , b))))
                                ↔⟨ asumᴬ _ ⟩
                                  Σ A (λ a → Fin (sumᴮ (λ b → f (a , b))))
                                ↔⟨ second-iso (λ _ → asumᴮ _) ⟩
                                  Σ A (λ a → Σ (B a) (λ b → Fin (f (a , b))))
                                ↔⟨ FI.sym Σ-assoc ⟩
                                  Σ (Σ A B) (Fin ∘ f)
                                ∎
      where open FR.EquationalReasoning

-- From now on, these are derived definitions for convenience and pedagogical reasons

explore× : ∀ {m A B} → Explore m A → Explore m B → Explore m (A × B)
explore× exploreᴬ exploreᴮ = exploreΣ exploreᴬ exploreᴮ

explore×-ind : ∀ {m p A B} {eᴬ : Explore m A} {eᴮ : Explore m B}
               → ExploreInd p eᴬ → ExploreInd p eᴮ
               → ExploreInd p (explore× eᴬ eᴮ)
explore×-ind Peᴬ Peᴮ = exploreΣ-ind Peᴬ Peᴮ

sumΣ : ∀ {A} {B : A → ★₀} → Sum A → (∀ {x} → Sum (B x)) → Sum (Σ A B)
sumΣ = _⟨,⟩_

sum× : ∀ {A B} → Sum A → Sum B → Sum (A × B)
sum× = _⟨,⟩′_

{-
μΣ : ∀ {A} {B : A → ★ _} → Explorable A → (∀ {x} → Explorable (B x)) → Explorable (Σ A B)
μΣ μA μB = mk _ (exploreΣ-ind (explore-ind μA) (explore-ind μB))
                (adequate-sumΣ (adequate-sum μA) (adequate-sum μB))

infixr 4 _×-μ_
_×-μ_ : ∀ {A B} → Explorable A → Explorable B → Explorable (A × B)
μA ×-μ μB = μΣ μA μB

_×-cmp_ : ∀ {A B : ★₀ } → Cmp A → Cmp B → Cmp (A × B)
(ca ×-cmp cb) (a , b) (a' , b') = ca a a' ∧ cb b b'

×-unique : ∀ {A B}(μA : Explorable A)(μB : Explorable B)(cA : Cmp A)(cB : Cmp B)
           → Unique cA (count μA) → Unique cB (count μB) → Unique (cA ×-cmp cB) (count (μA ×-μ μB))
×-unique μA μB cA cB uA uB (x , y) = count (μA ×-μ μB) ((cA ×-cmp cB) (x , y)) ≡⟨ explore-ext μA _ (λ x' → help (cA x x')) ⟩
                                     count μA (cA x) ≡⟨ uA x ⟩
                                     1 ∎
  where
    open ≡-Reasoning
    help : ∀ b → count μB (λ y' → b ∧ cB y y') ≡ (if b then 1 else 0)
    help true = uB y
    help false = sum-zero μB
-}

module _ {ℓ} {A} {B : A → _} {eᴬ : Explore (ₛ ℓ) A} {eᴮ : ∀ {x} → Explore (ₛ ℓ) (B x)} where
  focusΣ : Focus eᴬ → (∀ {x} → Focus (eᴮ {x})) → Focus (exploreΣ eᴬ (λ {x} → eᴮ {x}))
  focusΣ fᴬ fᴮ ((x , y) , z) = fᴬ (x , fᴮ (y , z))

  lookupΣ : Lookup eᴬ → (∀ {x} → Lookup (eᴮ {x})) → Lookup (exploreΣ eᴬ (λ {x} → eᴮ {x}))
  lookupΣ lookupᴬ lookupᴮ d = uncurry (lookupᴮ ∘ lookupᴬ d)

  -- can also be derived from explore-ind
  reifyΣ : Reify eᴬ → (∀ {x} → Reify (eᴮ {x})) → Reify (exploreΣ eᴬ (λ {x} → eᴮ {x}))
  reifyΣ reifyᴬ reifyᴮ f = reifyᴬ (reifyᴮ ∘ curry f)

module _ {ℓ} {A B} {eᴬ : Explore (ₛ ℓ) A} {eᴮ : Explore (ₛ ℓ) B} where
  focus× : Focus eᴬ → Focus eᴮ → Focus (explore× eᴬ eᴮ)
  focus× fᴬ fᴮ = focusΣ {eᴬ = eᴬ} {eᴮ = eᴮ} fᴬ fᴮ
  lookup× : Lookup eᴬ → Lookup eᴮ → Lookup (explore× eᴬ eᴮ)
  lookup× fᴬ fᴮ = lookupΣ {eᴬ = eᴬ} {eᴮ = eᴮ} fᴬ fᴮ

module Operators where
    infixr 4 _×ᵉ_ _×ⁱ_ _×ˢ_
    _×ᵉ_ = explore×
    _×ⁱ_ = explore×-ind
    _×ᵃ_ = adequate-sumΣ
    _×ˢ_ = sum×
    _×ᶠ_ = focus×
    _×ˡ_ = lookup×

-- Those are here only for pedagogical use
private
    proj₁-explore : ∀ {m A} {B : A → ★ _} → Explore m (Σ A B) → Explore m A
    proj₁-explore = EM.map _ proj₁

    proj₂-explore : ∀ {m A B} → Explore m (A × B) → Explore m B
    proj₂-explore = EM.map _ proj₂

    sum'Σ : ∀ {A} {B : A → ★₀} → Sum A → (∀ x → Sum (B x)) → Sum (Σ A B)
    sum'Σ sumᴬ sumᴮ f = sumᴬ (λ x₀ →
                          sumᴮ x₀ (λ x₁ →
                            f (x₀ , x₁)))

    explore×' : ∀ {A B} → Explore₀ A → Explore _ B → Explore _ (A × B)
    explore×' exploreᴬ exploreᴮ z op f = exploreᴬ z op (λ x → exploreᴮ z op (curry f x))

    explore×-ind' : ∀ {A B} {eᴬ : Explore _ A} {eᴮ : Explore _ B}
                    → ExploreInd₀ eᴬ → ExploreInd₀ eᴮ → ExploreInd₀ (explore×' eᴬ eᴮ)
    explore×-ind' Peᴬ Peᴮ P Pz P∙ Pf =
      Peᴬ (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ (Peᴮ (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ ∘ curry Pf)

    -- liftM2 _,_ in the continuation monad
    sum×' : ∀ {A B} → Sum A → Sum B → Sum (A × B)
    sum×' sumᴬ sumᴮ f = sumᴬ λ x₀ →
                          sumᴮ λ x₁ →
                            f (x₀ , x₁)
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
{- The main definitions are the following:

  * exploreΣ
  * exploreΣ-ind
  * adequate-sumΣ
-}

open import Level.NP
open import Type hiding (★)
open import Function.NP
import Function.Related as FR
import Function.Inverse.NP as FI
open FI using (_↔_; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from)
open import Function.Related.TypeIsomorphisms.NP
open import Data.Bool using (true ; false ; _∧_ ; if_then_else_)
open import Data.Product
open import Data.Fin
open import Relation.Binary.PropositionalEquality.NP using (_≡_ ; module ≡-Reasoning)
open import Category.Monad.Continuation.Alias

open import Explore.Core
open import Explore.Properties
import Explore.Monad as EM
open import Explore.Explorable

module Explore.Product where

module _ {m A} {B : A → ★₀} where

    exploreΣ : Explore m A → (∀ {x} → Explore m (B x)) → Explore m (Σ A B)
    exploreΣ exploreᴬ exploreᴮ z op = exploreᴬ z op ⟨,⟩ exploreᴮ z op

    module _ {eᴬ : Explore m A} {eᴮ : ∀ {x} → Explore m (B x)} where

        exploreΣ-ind : ∀ {p} → ExploreInd p eᴬ → (∀ {x} → ExploreInd p (eᴮ {x})) → ExploreInd p (exploreΣ eᴬ eᴮ)
        exploreΣ-ind Peᴬ Peᴮ P Pz P∙ Pf =
          Peᴬ (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ (λ x → Peᴮ {x} (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ (curry Pf x))

module _ {A}{B : A → ★₀}{eᴬ : Explore ₀ A}{eᴮ : ∀ {x} → Explore ₀ (B x)} where
   explore⊎-adq : AdequateExplore eᴬ → (∀ {x} → AdequateExplore (eᴮ {x})) → AdequateExplore (exploreΣ eᴬ eᴮ)
   explore⊎-adq aᴬ aᴮ F ε _⊕_ f F-proof
     = F (big⊕ᴬ (λ a → big⊕ᴮ (λ b → f (a , b))))
     ↔⟨ aᴬ F _ _ _ F-proof ⟩
         Σ A (F ∘ (λ a → big⊕ᴮ (λ b → f (a , b))))
     ↔⟨ second-iso (λ _ → aᴮ F _ _ _ F-proof) ⟩
       Σ A (λ a → Σ (B a) (λ b → F (f (a , b))))
     ↔⟨ FI.sym Σ-assoc ⟩
       Σ (Σ A B) (F ∘ f)
     ∎
     where open FR.EquationalReasoning
           big⊕ᴬ = eᴬ ε _⊕_
           big⊕ᴮ = λ {x} → eᴮ {x} ε _⊕_

module _ {A} {B : A → ★₀} {sumᴬ : Sum A} {sumᴮ : ∀ {x} → Sum (B x)} where

    private
        sumᴬᴮ = sumᴬ ⟨,⟩ (λ {x} → sumᴮ {x})

    adequate-sumΣ : AdequateSum sumᴬ → (∀ {x} → AdequateSum (sumᴮ {x})) → AdequateSum sumᴬᴮ
    adequate-sumΣ asumᴬ asumᴮ f = Fin (sumᴬᴮ f)
                                ↔⟨ FI.id ⟩
                                  Fin (sumᴬ (λ a → sumᴮ (λ b → f (a , b))))
                                ↔⟨ asumᴬ _ ⟩
                                  Σ A (λ a → Fin (sumᴮ (λ b → f (a , b))))
                                ↔⟨ second-iso (λ _ → asumᴮ _) ⟩
                                  Σ A (λ a → Σ (B a) (λ b → Fin (f (a , b))))
                                ↔⟨ FI.sym Σ-assoc ⟩
                                  Σ (Σ A B) (Fin ∘ f)
                                ∎
      where open FR.EquationalReasoning

-- From now on, these are derived definitions for convenience and pedagogical reasons

explore× : ∀ {m A B} → Explore m A → Explore m B → Explore m (A × B)
explore× exploreᴬ exploreᴮ = exploreΣ exploreᴬ exploreᴮ

explore×-ind : ∀ {m p A B} {eᴬ : Explore m A} {eᴮ : Explore m B}
               → ExploreInd p eᴬ → ExploreInd p eᴮ
               → ExploreInd p (explore× eᴬ eᴮ)
explore×-ind Peᴬ Peᴮ = exploreΣ-ind Peᴬ Peᴮ

sumΣ : ∀ {A} {B : A → ★₀} → Sum A → (∀ {x} → Sum (B x)) → Sum (Σ A B)
sumΣ = _⟨,⟩_

sum× : ∀ {A B} → Sum A → Sum B → Sum (A × B)
sum× = _⟨,⟩′_

{-
μΣ : ∀ {A} {B : A → ★ _} → Explorable A → (∀ {x} → Explorable (B x)) → Explorable (Σ A B)
μΣ μA μB = mk _ (exploreΣ-ind (explore-ind μA) (explore-ind μB))
                (adequate-sumΣ (adequate-sum μA) (adequate-sum μB))

infixr 4 _×-μ_
_×-μ_ : ∀ {A B} → Explorable A → Explorable B → Explorable (A × B)
μA ×-μ μB = μΣ μA μB

_×-cmp_ : ∀ {A B : ★₀ } → Cmp A → Cmp B → Cmp (A × B)
(ca ×-cmp cb) (a , b) (a' , b') = ca a a' ∧ cb b b'

×-unique : ∀ {A B}(μA : Explorable A)(μB : Explorable B)(cA : Cmp A)(cB : Cmp B)
           → Unique cA (count μA) → Unique cB (count μB) → Unique (cA ×-cmp cB) (count (μA ×-μ μB))
×-unique μA μB cA cB uA uB (x , y) = count (μA ×-μ μB) ((cA ×-cmp cB) (x , y)) ≡⟨ explore-ext μA _ (λ x' → help (cA x x')) ⟩
                                     count μA (cA x) ≡⟨ uA x ⟩
                                     1 ∎
  where
    open ≡-Reasoning
    help : ∀ b → count μB (λ y' → b ∧ cB y y') ≡ (if b then 1 else 0)
    help true = uB y
    help false = sum-zero μB
-}

module _ {ℓ} {A} {B : A → _} {eᴬ : Explore (ₛ ℓ) A} {eᴮ : ∀ {x} → Explore (ₛ ℓ) (B x)} where
  focusΣ : Focus eᴬ → (∀ {x} → Focus (eᴮ {x})) → Focus (exploreΣ eᴬ (λ {x} → eᴮ {x}))
  focusΣ fᴬ fᴮ ((x , y) , z) = fᴬ (x , fᴮ (y , z))

  lookupΣ : Lookup eᴬ → (∀ {x} → Lookup (eᴮ {x})) → Lookup (exploreΣ eᴬ (λ {x} → eᴮ {x}))
  lookupΣ lookupᴬ lookupᴮ d = uncurry (lookupᴮ ∘ lookupᴬ d)

  -- can also be derived from explore-ind
  reifyΣ : Reify eᴬ → (∀ {x} → Reify (eᴮ {x})) → Reify (exploreΣ eᴬ (λ {x} → eᴮ {x}))
  reifyΣ reifyᴬ reifyᴮ f = reifyᴬ (reifyᴮ ∘ curry f)

module _ {ℓ} {A B} {eᴬ : Explore (ₛ ℓ) A} {eᴮ : Explore (ₛ ℓ) B} where
  focus× : Focus eᴬ → Focus eᴮ → Focus (explore× eᴬ eᴮ)
  focus× fᴬ fᴮ = focusΣ {eᴬ = eᴬ} {eᴮ = eᴮ} fᴬ fᴮ
  lookup× : Lookup eᴬ → Lookup eᴮ → Lookup (explore× eᴬ eᴮ)
  lookup× fᴬ fᴮ = lookupΣ {eᴬ = eᴬ} {eᴮ = eᴮ} fᴬ fᴮ

module Operators where
    infixr 4 _×ᵉ_ _×ⁱ_ _×ˢ_
    _×ᵉ_ = explore×
    _×ⁱ_ = explore×-ind
    _×ᵃ_ = adequate-sumΣ
    _×ˢ_ = sum×
    _×ᶠ_ = focus×
    _×ˡ_ = lookup×

-- Those are here only for pedagogical use
private
    proj₁-explore : ∀ {m A} {B : A → ★ _} → Explore m (Σ A B) → Explore m A
    proj₁-explore = EM.map _ proj₁

    proj₂-explore : ∀ {m A B} → Explore m (A × B) → Explore m B
    proj₂-explore = EM.map _ proj₂

    sum'Σ : ∀ {A} {B : A → ★₀} → Sum A → (∀ x → Sum (B x)) → Sum (Σ A B)
    sum'Σ sumᴬ sumᴮ f = sumᴬ (λ x₀ →
                          sumᴮ x₀ (λ x₁ →
                            f (x₀ , x₁)))

    explore×' : ∀ {A B} → Explore₀ A → Explore _ B → Explore _ (A × B)
    explore×' exploreᴬ exploreᴮ z op f = exploreᴬ z op (λ x → exploreᴮ z op (curry f x))

    explore×-ind' : ∀ {A B} {eᴬ : Explore _ A} {eᴮ : Explore _ B}
                    → ExploreInd₀ eᴬ → ExploreInd₀ eᴮ → ExploreInd₀ (explore×' eᴬ eᴮ)
    explore×-ind' Peᴬ Peᴮ P Pz P∙ Pf =
      Peᴬ (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ (Peᴮ (λ e → P (λ _ _ _ → e _ _ _)) Pz P∙ ∘ curry Pf)

    -- liftM2 _,_ in the continuation monad
    sum×' : ∀ {A B} → Sum A → Sum B → Sum (A × B)
    sum×' sumᴬ sumᴮ f = sumᴬ λ x₀ →
                          sumᴮ λ x₁ →
                            f (x₀ , x₁)
-- -}
-- -}
-- -}


Cosmetic changes.

Cosmetic changes.

Ignore-this: 6da64a122b3e8c86cd742cb4cbe5f7d3

darcs-hash:20110220153706-3bd4e-46ea9e1fdf44b254cfbd61801079a9df91fe3438.gz

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

module Draft.Mirror.PropertiesI where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesI
open import Draft.Mirror.ListTree.Closures

open import LTC.Data.List
open import LTC.Data.List.PropertiesI using ( reverse-[x]≡[x] )

open import LTC.Relation.Binary.EqReasoning

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

-- TODO: To remove the postulate
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

-- mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
-- mirror-Tree (treeT d nilLT) =
--   subst Tree (sym (mirror-eq d [])) (treeT d helper₂)
--     where
--       helper₁ : rev (map mirror []) [] ≡ []
--       helper₁ =
--         begin
--           rev (map mirror []) []
--           ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
--                    (map-[] mirror)
--                    refl
--           ⟩
--           rev [] []
--             ≡⟨ rev-[] [] ⟩
--           []
--         ∎

--       helper₂ : ListTree (rev (map mirror []) [])
--       helper₂ = subst ListTree (sym helper₁) nilLT

-- mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
--   subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d helper)

--   where
--     helper : ListTree (reverse (map mirror (t ∷ ts)))
--     helper = rev-ListTree (map-ListTree mirror {!!} (consLT Tt LTts)) nilLT

mutual
  mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
  mirror² (treeT d nilLT) =
    begin
      mirror · (mirror · (node d []))
        ≡⟨ subst (λ x → mirror · (mirror · (node d [])) ≡ mirror · x )
                 (mirror-eq d [])
                 refl
        ⟩
      mirror · node d (reverse (map mirror []))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror [])) ≡
                        mirror · node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      mirror · node d (reverse [])
        ≡⟨ subst (λ x → mirror · node d (reverse []) ≡ mirror · node d x)
                 (rev-[] [])
                 refl
        ⟩
      mirror · node d []
        ≡⟨ mirror-eq d [] ⟩
      node d (reverse (map mirror []))
        ≡⟨ subst (λ x → node d (reverse (map mirror [])) ≡
                        node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      node d (reverse [])
        ≡⟨ subst (λ x → node d (reverse []) ≡ node d x)
                 (rev-[] [])
                 refl
        ⟩
      node d []
    ∎

  mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
    begin
      mirror · (mirror · node d (t ∷ ts))
        ≡⟨ subst (λ x → mirror · (mirror · node d (t ∷ ts)) ≡ mirror · x)
                 (mirror-eq d (t ∷ ts))
                 refl
        ⟩
      mirror · node d (reverse (map mirror (t ∷ ts)))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror (t ∷ ts))) ≡
                        x)
                 (mirror-eq d (reverse (map mirror (t ∷ ts))))
                 refl
        ⟩
      node d (reverse (map mirror (reverse (map mirror (t ∷ ts)))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (reverse (map mirror (t ∷ ts))))) ≡
                      node d x)
               (helper (consLT Tt LTts))
               refl
      ⟩
      node d (t ∷ ts)
    ∎

  helper : ∀ {ts} → ListTree ts →
           reverse (map mirror (reverse (map mirror ts))) ≡ ts
  helper nilLT =
    begin
      reverse (map mirror (reverse (map mirror [])))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror []))) ≡
                        reverse (map mirror (reverse x)))
                 (map-[] mirror)
                 refl
        ⟩
      reverse (map mirror (reverse []))
        ≡⟨ subst (λ x → reverse (map mirror (reverse [])) ≡
                        reverse (map mirror x))
                 (rev-[] [])
                 refl
        ⟩
      reverse (map mirror [])
        ≡⟨ subst (λ x → reverse (map mirror []) ≡
                        reverse x)
                 (map-[] mirror)
                 refl
        ⟩
      reverse []
        ≡⟨ rev-[] [] ⟩
      []
    ∎

  helper (consLT {t} {ts} Tt LTts) =
    begin
      reverse (map mirror (reverse (map mirror (t ∷ ts))))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror (t ∷ ts)))) ≡
                        reverse (map mirror (reverse x)))
                 (map-∷ mirror t ts)
                 refl
        ⟩
      reverse (map mirror (reverse (mirror · t ∷ map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (mirror · t ∷ map mirror ts))) ≡
                        reverse (map mirror x))
                 (reverse-∷ (mirror-Tree Tt) (map-ListTree mirror mirror-Tree LTts))
                 refl
        ⟩
      reverse (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror · t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror
                   mirror-Tree
                   (rev-ListTree (map-ListTree mirror mirror-Tree LTts) nilLT)
                   (consLT (mirror-Tree Tt) nilLT))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror · t ∷ [])))) ≡
                        x)
                 (reverse-++-commute (map-ListTree mirror
                                           mirror-Tree
                                           (rev-ListTree (map-ListTree mirror
                                                                       mirror-Tree
                                                                       LTts)
                                                         nilLT))
                             (map-ListTree mirror
                                           mirror-Tree
                                           (consLT (mirror-Tree Tt) nilLT)))
                 refl
        ⟩
      reverse (map mirror (mirror · t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (mirror · t ∷ [])) ++ n₁ ≡
                        reverse x ++ n₁)
                 (map-∷ mirror (mirror · t) [])
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁ ≡
                        reverse (mirror · (mirror · t) ∷ x) ++ n₁)
                 (map-[] mirror)
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ []) ++ n₁ ≡
                        x ++ n₁)
                 (reverse-[x]≡[x] (mirror · (mirror · t)))
                 refl
        ⟩
      (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ ++-∷ (mirror · (mirror · t)) [] n₁ ⟩
      mirror · (mirror · t) ∷ [] ++ n₁
        ≡⟨ subst (λ x →  mirror · (mirror · t) ∷ [] ++ n₁ ≡
                         mirror · (mirror · t) ∷ x)
                 (++-leftIdentity LTn₁)
                 refl
        ⟩
      mirror · (mirror · t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror · (mirror · t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² Tt)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (helper LTts)
                 refl
        ⟩
      t ∷ ts
    ∎
      where
        n₁ : D
        n₁ = reverse (map mirror (reverse (map mirror ts)))

        LTn₁ : ListTree n₁
        LTn₁ = rev-ListTree (map-ListTree mirror
                                          mirror-Tree
                                          (rev-ListTree (map-ListTree mirror
                                                                      mirror-Tree
                                                                      LTts)
                                                        nilLT))
                            nilLT

------------------------------------------------------------------------------
-- Properties of the mirror function
------------------------------------------------------------------------------

module Draft.Mirror.PropertiesI where

open import LTC.Base

open import Draft.Mirror.Mirror
open import Draft.Mirror.ListTree.PropertiesI
open import Draft.Mirror.ListTree.Closures

open import LTC.Data.List
open import LTC.Data.List.PropertiesI using ( reverse-[x]≡[x] )

open import LTC.Relation.Binary.EqReasoning

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

-- TODO: To remove the postulate
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

-- mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
-- mirror-Tree (treeT d nilLT) =
--   subst Tree (sym (mirror-eq d [])) (treeT d aux₂)
--     where
--       aux₁ : rev (map mirror []) [] ≡ []
--       aux₁ =
--         begin
--           rev (map mirror []) []
--           ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
--                    (map-[] mirror)
--                    refl
--           ⟩
--           rev [] []
--             ≡⟨ rev-[] [] ⟩
--           []
--         ∎

--       aux₂ : ListTree (rev (map mirror []) [])
--       aux₂ = subst ListTree (sym aux₁) nilLT

-- mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
--   subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d aux)

--   where
--     aux : ListTree (reverse (map mirror (t ∷ ts)))
--     aux = rev-ListTree (map-ListTree mirror {!!} (consLT Tt LTts)) nilLT

mutual
  mirror² : ∀ {t} → Tree t → mirror · (mirror · t) ≡ t
  mirror² (treeT d nilLT) =
    begin
      mirror · (mirror · (node d []))
        ≡⟨ subst (λ x → mirror · (mirror · (node d [])) ≡ mirror · x )
                 (mirror-eq d [])
                 refl
        ⟩
      mirror · node d (reverse (map mirror []))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror [])) ≡
                        mirror · node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      mirror · node d (reverse [])
        ≡⟨ subst (λ x → mirror · node d (reverse []) ≡ mirror · node d x)
                 (rev-[] [])
                 refl
        ⟩
      mirror · node d []
        ≡⟨ mirror-eq d [] ⟩
      node d (reverse (map mirror []))
        ≡⟨ subst (λ x → node d (reverse (map mirror [])) ≡
                        node d (reverse x))
                 (map-[] mirror)
                 refl
        ⟩
      node d (reverse [])
        ≡⟨ subst (λ x → node d (reverse []) ≡ node d x)
                 (rev-[] [])
                 refl
        ⟩
      node d []
    ∎

  mirror² (treeT d (consLT {t} {ts} Tt LTts)) =
    begin
      mirror · (mirror · node d (t ∷ ts))
        ≡⟨ subst (λ x → mirror · (mirror · node d (t ∷ ts)) ≡ mirror · x)
                 (mirror-eq d (t ∷ ts))
                 refl
        ⟩
      mirror · node d (reverse (map mirror (t ∷ ts)))
        ≡⟨ subst (λ x → mirror · node d (reverse (map mirror (t ∷ ts))) ≡
                        x)
                 (mirror-eq d (reverse (map mirror (t ∷ ts))))
                 refl
        ⟩
      node d (reverse (map mirror (reverse (map mirror (t ∷ ts)))))
      ≡⟨ subst (λ x → node d (reverse (map mirror (reverse (map mirror (t ∷ ts))))) ≡
                      node d x)
               (helper (consLT Tt LTts))
               refl
      ⟩
      node d (t ∷ ts)
    ∎

  helper : ∀ {ts} → ListTree ts →
           reverse (map mirror (reverse (map mirror ts))) ≡ ts
  helper nilLT =
    begin
      reverse (map mirror (reverse (map mirror [])))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror []))) ≡
                        reverse (map mirror (reverse x)))
                 (map-[] mirror)
                 refl
        ⟩
      reverse (map mirror (reverse []))
        ≡⟨ subst (λ x → reverse (map mirror (reverse [])) ≡
                        reverse (map mirror x))
                 (rev-[] [])
                 refl
        ⟩
      reverse (map mirror [])
        ≡⟨ subst (λ x → reverse (map mirror []) ≡
                        reverse x)
                 (map-[] mirror)
                 refl
        ⟩
      reverse []
        ≡⟨ rev-[] [] ⟩
      []
    ∎

  helper (consLT {t} {ts} Tt LTts) =
    begin
      reverse (map mirror (reverse (map mirror (t ∷ ts))))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (map mirror (t ∷ ts)))) ≡
                        reverse (map mirror (reverse x)))
                 (map-∷ mirror t ts)
                 refl
        ⟩
      reverse (map mirror (reverse (mirror · t ∷ map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (reverse (mirror · t ∷ map mirror ts))) ≡
                        reverse (map mirror x))
                 (reverse-∷ (mirror-Tree Tt) (map-ListTree mirror mirror-Tree LTts))
                 refl
        ⟩
      reverse (map mirror (reverse (map mirror ts) ++ (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror · t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror
                   mirror-Tree
                   (rev-ListTree (map-ListTree mirror mirror-Tree LTts) nilLT)
                   (consLT (mirror-Tree Tt) nilLT))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror · t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror · t ∷ [])))) ≡
                        x)
                 (reverse-++-commute (map-ListTree mirror
                                           mirror-Tree
                                           (rev-ListTree (map-ListTree mirror
                                                                       mirror-Tree
                                                                       LTts)
                                                         nilLT))
                             (map-ListTree mirror
                                           mirror-Tree
                                           (consLT (mirror-Tree Tt) nilLT)))
                 refl
        ⟩
      reverse (map mirror (mirror · t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → reverse (map mirror (mirror · t ∷ [])) ++ n₁ ≡
                        reverse x ++ n₁)
                 (map-∷ mirror (mirror · t) [])
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ map mirror []) ++ n₁ ≡
                        reverse (mirror · (mirror · t) ∷ x) ++ n₁)
                 (map-[] mirror)
                 refl
        ⟩
      reverse (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ subst (λ x → reverse (mirror · (mirror · t) ∷ []) ++ n₁ ≡
                        x ++ n₁)
                 (reverse-[x]≡[x] (mirror · (mirror · t)))
                 refl
        ⟩
      (mirror · (mirror · t) ∷ []) ++ n₁
        ≡⟨ ++-∷ (mirror · (mirror · t)) [] n₁ ⟩
      mirror · (mirror · t) ∷ [] ++ n₁
        ≡⟨ subst (λ x →  mirror · (mirror · t) ∷ [] ++ n₁ ≡
                         mirror · (mirror · t) ∷ x)
                 (++-leftIdentity LTn₁)
                 refl
        ⟩
      mirror · (mirror · t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror · (mirror · t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² Tt)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (helper LTts)
                 refl
        ⟩
      t ∷ ts
    ∎
      where
        n₁ : D
        n₁ = reverse (map mirror (reverse (map mirror ts)))

        LTn₁ : ListTree n₁
        LTn₁ = rev-ListTree (map-ListTree mirror
                                          mirror-Tree
                                          (rev-ListTree (map-ListTree mirror
                                                                      mirror-Tree
                                                                      LTts)
                                                        nilLT))
                            nilLT


Simplified a proof.

Simplified a proof.

Ignore-this: 61c45ca949212bfeb3a46a5b703dcc1d

darcs-hash:20120219133102-3bd4e-d3939af7e4c1da1b94a3e84a18f59c8e2e66db74.gz

------------------------------------------------------------------------------
-- Properties related with the group commutator
------------------------------------------------------------------------------

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

module GroupTheory.Commutator.PropertiesI where

open import GroupTheory.Base
open import GroupTheory.Commutator
open import GroupTheory.PropertiesI
open import GroupTheory.Relation.Binary.EqReasoning

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

-- From: A. G. Kurosh. The Theory of Groups, vol. 1. Chelsea Publising
-- Company, 2nd edition, 1960. p. 99.
commutatorInverse : ∀ a b → ⟦ a , b ⟧ · ⟦ b , a ⟧ ≡ ε
commutatorInverse a b =
  a ⁻¹ · b ⁻¹ · a · b · (b ⁻¹ · a ⁻¹ · b · a)
    ≡⟨ assoc (a ⁻¹ · b ⁻¹ · a) b (b ⁻¹ · a ⁻¹ · b · a) ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · b · a))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · b · a)) ≡
                    a ⁻¹ · b ⁻¹ · a · (b · t))
             (assoc (b ⁻¹ · a ⁻¹) b a)
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · a · (b · t))
             (assoc (b ⁻¹) (a ⁻¹) (b · a))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · (a ⁻¹ · (b · a))))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · (a ⁻¹ · (b · a)))) ≡
                    a ⁻¹ · b ⁻¹ · a · t)
             (sym (assoc b (b ⁻¹) (a ⁻¹ · (b · a))))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (b · b ⁻¹ · (a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · b ⁻¹ · (a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · a · (t · (a ⁻¹ · (b · a))))
             (rightInverse b)
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (ε · (a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (ε · (a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · a · t)
             (leftIdentity (a ⁻¹ · (b · a)))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (a ⁻¹ · (b · a))
    ≡⟨ assoc (a ⁻¹ · b ⁻¹) a (a ⁻¹ · (b · a)) ⟩
  a ⁻¹ · b ⁻¹ · (a · (a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · (a · (a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · t)
             (sym (assoc a (a ⁻¹) (b · a)))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · (a · a ⁻¹ · (b · a))
    ≡⟨ ·-rightCong (·-leftCong (rightInverse a)) ⟩
  a ⁻¹ · b ⁻¹ · (ε · (b · a))
    ≡⟨ ·-rightCong (leftIdentity (b · a)) ⟩
  a ⁻¹ · b ⁻¹ · (b · a)
    ≡⟨ assoc (a ⁻¹) (b ⁻¹) (b · a) ⟩
  a ⁻¹ · (b ⁻¹ · (b · a))
     ≡⟨ ·-rightCong (sym (assoc (b ⁻¹) b a)) ⟩
  a ⁻¹ · ((b ⁻¹ · b) · a)
     ≡⟨ ·-rightCong (·-leftCong (leftInverse b)) ⟩
  a ⁻¹ · (ε · a)
     ≡⟨ ·-rightCong (leftIdentity a) ⟩
  a ⁻¹ · a
     ≡⟨ leftInverse a ⟩
  ε ∎

------------------------------------------------------------------------------
-- Properties related with the group commutator
------------------------------------------------------------------------------

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

module GroupTheory.Commutator.PropertiesI where

open import GroupTheory.Base
open import GroupTheory.Commutator
open import GroupTheory.PropertiesI
open import GroupTheory.Relation.Binary.EqReasoning

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

-- From: A. G. Kurosh. The Theory of Groups, vol. 1. Chelsea Publising
-- Company, 2nd edition, 1960. p. 99.
commutatorInverse : ∀ a b → ⟦ a , b ⟧ · ⟦ b , a ⟧ ≡ ε
commutatorInverse a b =
  a ⁻¹ · b ⁻¹ · a · b · (b ⁻¹ · a ⁻¹ · b · a)
    ≡⟨ assoc (a ⁻¹ · b ⁻¹ · a) b (b ⁻¹ · a ⁻¹ · b · a) ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · b · a))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · b · a)) ≡
                    a ⁻¹ · b ⁻¹ · a · (b · t))
             (assoc (b ⁻¹ · a ⁻¹) b a)
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · a · (b · t))
             (assoc (b ⁻¹) (a ⁻¹) (b · a))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · (a ⁻¹ · (b · a))))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · (a ⁻¹ · (b · a)))) ≡
                    a ⁻¹ · b ⁻¹ · a · t)
             (sym (assoc b (b ⁻¹) (a ⁻¹ · (b · a))))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (b · b ⁻¹ · (a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (b · b ⁻¹ · (a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · a · (t · (a ⁻¹ · (b · a))))
             (rightInverse b)
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (ε · (a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · a · (ε · (a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · a · t)
             (leftIdentity (a ⁻¹ · (b · a)))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · a · (a ⁻¹ · (b · a))
    ≡⟨ assoc (a ⁻¹ · b ⁻¹) a (a ⁻¹ · (b · a)) ⟩
  a ⁻¹ · b ⁻¹ · (a · (a ⁻¹ · (b · a)))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · (a · (a ⁻¹ · (b · a))) ≡
                    a ⁻¹ · b ⁻¹ · t)
             (sym (assoc a (a ⁻¹) (b · a)))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · (a · a ⁻¹ · (b · a))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · (a · a ⁻¹ · (b · a)) ≡
                    a ⁻¹ · b ⁻¹ · (t · (b · a)))
             (rightInverse a)
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · (ε · (b · a))
    ≡⟨ subst (λ t → a ⁻¹ · b ⁻¹ · (ε · (b · a)) ≡
                    a ⁻¹ · b ⁻¹ · t)
             (leftIdentity (b · a))
             refl
    ⟩
  a ⁻¹ · b ⁻¹ · (b · a)
    ≡⟨ assoc (a ⁻¹) (b ⁻¹) (b · a) ⟩
  a ⁻¹ · (b ⁻¹ · (b · a))
     ≡⟨ ·-rightCong (sym (assoc (b ⁻¹) b a)) ⟩
  a ⁻¹ · ((b ⁻¹ · b) · a)
     ≡⟨ ·-rightCong (·-leftCong (leftInverse b)) ⟩
  a ⁻¹ · (ε · a)
     ≡⟨ ·-rightCong (leftIdentity a) ⟩
  a ⁻¹ · a
     ≡⟨ leftInverse a ⟩
  ε ∎


Multiplicative: adapt to the termination checker who became less smart

{-# 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.Core
open import Control.Protocol.End
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 = λ()

infixr 4 _⊸_
_⊸_ : (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: (λ m → ⊗-assoc (recv P) (recv Q) (R m)) ] ]
                                            {- This use to work (and should) with older versions of Agda (11-Dec 2013)
                                            λ { (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: (λ 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}(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
                → View-∘-proto (send 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 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 P Q R = ⅋-∘ {send P} {Q m} {send R} (coe (⅋-recvR (send P) Q) pq m) qr
    ⅋-∘ pq (inr m , qr) | recvR-sendR P Q R = ⅋-sendR (send P) m (⅋-∘ {send 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.Core
open import Control.Protocol.End
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}(P : MP → Proto)(Q : MQ → Proto)(R : MR → Proto)
                → View-∘-proto (send 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 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 P Q R = ⅋-∘ {send P} {Q m} {send R} (coe (⅋-recvR (send P) Q) pq m) qr
    ⅋-∘ pq (inr m , qr) | recvR-sendR P Q R = ⅋-sendR (send P) m (⅋-∘ {send 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)

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


fix copattern error in CPAd-CPA

fix copattern error in CPAd-CPA

{-# OPTIONS --without-K --copatterns #-}

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.One
open import Control.Strategy renaming (run to runStrategy; map to mapStrategy)

open import Function

open import Relation.Binary.PropositionalEquality

import Game.IND-CPA-dagger
import Game.IND-CPA

module Game.Transformation.CPAd-CPA
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

module CPA† = Game.IND-CPA-dagger PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc
module CPA  = Game.IND-CPA        PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc

R-transform : CPA†.R → CPA.R
R-transform (rₐ , rₖ , rₑ , _ , _) = rₐ , rₖ , rₑ , _

module _ (A : CPA.Adversary) where
  open CPA†.Adversary
  module A = CPA.Adversary A

  A† : CPA†.Adversary
  m  A† = A.m
  b′ A† rₐ pk c₀ c₁ = A.b′ rₐ pk c₀

  lemma : ∀ b t r
          → CPA.EXP  b   A  (R-transform r)
          ≡ CPA†.EXP b t A† r
  lemma _ _ _ = refl

  -- If we are able to do the transformation, then we get the same advantage
  correct : ∀ b r
            → CPA.EXP  b A          (R-transform r)
            ≡ CPA†.EXP b (not b) A† r
  correct _ _ = refl

-- -}

{-# OPTIONS --without-K --copatterns #-}

open import Type
open import Data.Bit
open import Data.Maybe
open import Data.Product
open import Data.One
open import Control.Strategy renaming (run to runStrategy; map to mapStrategy)

open import Function

open import Relation.Binary.PropositionalEquality

import Game.IND-CPA-dagger
import Game.IND-CPA

module Game.Transformation.CPAd-CPA
  (PubKey    : ★)
  (SecKey    : ★)
  (Message   : ★)
  (CipherText : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : PubKey → Message → Rₑ → CipherText)
  (Dec    : SecKey → CipherText → Message)

where

module CPA† = Game.IND-CPA-dagger PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc
module CPA  = Game.IND-CPA        PubKey SecKey Message CipherText Rₑ Rₖ Rₐ 𝟙 KeyGen Enc

{-
f : (Message × Message) × (CipherText → DecRound Bit)
  → (Message × Message) × (CipherText → CipherText → DecRound Bit)
f (m , g) = m , λ c _ → g c
-}

R-transform : CPA†.R → CPA.R
R-transform (rₐ , rₖ , rₑ , _ , _) = rₐ , rₖ , rₑ , _

module _ (A : CPA.Adversary) where
  open CPA.Adversary

  A† : CPA†.Adversary
  m  A† = m A
  b′ A† rₐ pk c₀ c₁ = b′ A rₐ pk c₀

  lemma : ∀ b t r
          → CPA.EXP  b   A  (R-transform r)
          ≡ CPA†.EXP b t A† r
  lemma _ _ _ = refl

  -- If we are able to do the transformation, then we get the same advantage
  correct : ∀ b r
            → CPA.EXP  b A          (R-transform r)
            ≡ CPA†.EXP b (not b) A† r
  correct _ _ = refl

-- -}


first proof is made!

first proof is made!

module peano where

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

_+_ : ℕ → ℕ → ℕ

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

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

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


Nicer notation for Data.Indexed

Nicer notation for Data.Indexed

open import Level           using (_⊔_; suc; Level)
open import Function.NP     using (id; const; _∘_; _∘′_; _ˢ_; _⟨_⟩°_)
open import Data.Sum        using (_⊎_; inj₁; inj₂)
open import Data.Bool       using (Bool; true; false)
open import Data.Unit       using (⊤)
open import Data.List       using (List; []; _∷_)
open import Data.Maybe      using (Maybe; nothing; just)
open import Data.Empty      using (⊥)
open import Data.Product.NP using (∃; _,_; _×_)

module Data.Indexed {i} {Ix : Set i} where

★° : ∀ ℓ → Set _
★° ℓ = Ix → Set ℓ

★₀° : Set _
★₀° = Ix → Set

★₁° : Set _
★₁° = Ix → Set₂

∀° : ∀ {f} (F : ★° f) → Set _
∀° F = ∀ {x} → F x

∃° : ∀ {f} (F : ★° f) → Set _
∃° F = ∃[ x ] F x

pure° : ∀ {a} {A : Set a} → A → (Ix → A)
pure° = const

-- an alias for pure°
K° : ∀ {a} (A : Set a) → ★° _
K° = pure°

Cmp° : (F : ★° _) (i j : Ix) → Set
Cmp° F i j = F i → F j → Bool

Π° : ∀ {f g} (F : ★° f) (G : ∀ {i} → F i → ★° g) → ★° _
Π° F G i = (x : F i) → G x i

-- this version used to work (type-checking its uses) better than that
infixr 0 _→°_
_→°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° (f ⊔ g)
F →° G = Π° F (const G)
-- expanded: (F →° G) i = F i → G i

infixr 0 _↦°_
_↦°_ : ∀ {f g} (F : ★° f) (G : ★° g) → Set _
(F ↦° G) = ∀°(F →° G)

id° : ∀ {f} {F : ★° f} → F ↦° F
id° = id

_∘°_ : ∀ {f g h} {F : ★° f} {G : ★° g} {H : ★° h} → G ↦° H → F ↦° G → F ↦° H
f ∘° g = f ∘ g

infixr 0 _$°_ _$°′_

_$°_ : ∀ {f g} {F : ★° f} {G : ∀ {i} → F i → ★° g}
        → Π° F G ↦° Π° F G
_$°_ = id

_$°′_ : ∀ {f g} {F : ★° f} {G : ★° g}
        → ∀° ((F →° G) →° F →° G)
_$°′_ = id

infixl 4 _⊛°_

_⊛°_ : ∀ {a b} {A : Set a} {B : Set b}
         → (Ix → A → B) → ((Ix → A) → (Ix → B))
_⊛°_ = _ˢ_

liftA° : ∀ {a b} {A : Set a} {B : Set b}
          → (A → B) → ((Ix → A) → (Ix → B))
liftA° = _∘′_
-- liftA° f x = pure° f ⊛° x

liftA₂° : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
           → (A → B → C)
           → ((Ix → A) → (Ix → B) → (Ix → C))
liftA₂° f x y = x ⟨ f ⟩° y
-- liftA₂° f x y = pure° f ⊛° x ⊛° y

List° : ∀ {a} → ★° a → ★° a
List° = liftA° List

[]° : ∀ {f} {F : ★° f} → ∀°(List° F)
[]° = []

_∷°_ : ∀ {f} {F : ★° f} → ∀°(F →° List° F →° List° F)
_∷°_ = _∷_

Maybe° : ∀ {a} → ★° a → ★° a
Maybe° = liftA° Maybe

nothing° : ∀ {f} {F : ★° f} → ∀°(Maybe° F)
nothing° = nothing

just° : ∀ {f} {F : ★° f} → ∀°(F →° Maybe° F)
just° = just

infixr 2 _×°_
_×°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° _
_×°_ = liftA₂° _×_

_,°_ : ∀ {f g} {F : ★° f} {G : ★° g} → ∀° (F →° G →° F ×° G)
_,°_ = _,_

pack° : ∀ {f} {F : ★° f} → (x : Ix) → F x → ∃° F
pack° = _,_

infixr 1 _⊎°_

_⊎°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° _
_⊎°_ = liftA₂° _⊎_

inj₁° : ∀ {f g} {F : ★° f} {G : ★° g} → F ↦° F ⊎° G
inj₁° = inj₁

inj₂° : ∀ {f g} {F : ★° f} {G : ★° g} → G ↦° F ⊎° G
inj₂° = inj₂

⊤° : ★° _
⊤° = pure° ⊤

⊥° : ★° _
⊥° = pure° ⊥

¬° : ∀ {ℓ} → ★° ℓ → ★° _
¬° F = F →° ⊥°

-- This is the type of |map| functions, the fmap function on Ix-indexed
-- functors.
Map° : ∀ {a a' b b'} (F : ★° a → ★° a')
                     (G : ★° b → ★° b') → Set _
Map° F G = ∀ {A B} → (A ↦° B) → F A ↦° G B

map°-K° : ∀ {a a' b b'}
            {F : Set a → Set a'}
            {G : Set b → Set b'}
            (fmap : ∀ {A B} → (A → B) → F A → G B)
            {A B} → (K° A ↦° K° B) → K° (F A) ↦° K° (G B)
map°-K° fmap f {i} = fmap (f {i})

open import Level           using (_⊔_; suc; Level)
open import Function.NP     using (id; const; _∘_; _∘′_; _ˢ_; _⟨_⟩°_)
open import Data.Sum        using (_⊎_; inj₁; inj₂)
open import Data.Bool       using (Bool; true; false)
open import Data.Unit       using (⊤)
open import Data.List       using (List; []; _∷_)
open import Data.Maybe      using (Maybe; nothing; just)
open import Data.Empty      using (⊥)
open import Data.Product.NP using (∃; _,_; _×_)

module Data.Indexed {i} {Ix : Set i} where

|Set| : ∀ ℓ → Set _
|Set| ℓ = Ix → Set ℓ

|Set₀| : Set _
|Set₀| = Ix → Set

|Set₁| : Set _
|Set₁| = Ix → Set₂

|∀| : ∀ {f} (F : |Set| f) → Set _
|∀| F = ∀ {x} → F x

|∃| : ∀ {f} (F : |Set| f) → Set _
|∃| F = ∃[ x ] F x

|pure| : ∀ {a} {A : Set a} → A → (Ix → A)
|pure| = const

-- an alias for |pure|
|K| : ∀ {a} (A : Set a) → |Set| _
|K| = |pure|

|Cmp| : (F : |Set| _) (i j : Ix) → Set
|Cmp| F i j = F i → F j → Bool

|Π| : ∀ {f g} (F : |Set| f) (G : ∀ {i} → F i → |Set| g) → |Set| _
|Π| F G i = (x : F i) → G x i

-- this version used to work (type-checking its uses) better than that
infixr 0 _|→|_
_|→|_ : ∀ {f g} (F : |Set| f) (G : |Set| g) → |Set| (f ⊔ g)
F |→| G = |Π| F (const G)
-- expanded: (F |→| G) i = F i → G i

infixr 0 _|↦|_
_|↦|_ : ∀ {f g} (F : |Set| f) (G : |Set| g) → Set _
(F |↦| G) = |∀|(F |→| G)

|id| : ∀ {f} {F : |Set| f} → F |↦| F
|id| = id

_|∘|_ : ∀ {f g h} {F : |Set| f} {G : |Set| g} {H : |Set| h} → G |↦| H → F |↦| G → F |↦| H
f |∘| g = f ∘ g

infixr 0 _|$|_ _|$′|_

_|$|_ : ∀ {f g} {F : |Set| f} {G : ∀ {i} → F i → |Set| g}
        → |Π| F G |↦| |Π| F G
_|$|_ = id

_|$′|_ : ∀ {f g} {F : |Set| f} {G : |Set| g}
        → |∀| ((F |→| G) |→| F |→| G)
_|$′|_ = id

infixl 4 _|⊛|_

_|⊛|_ : ∀ {a b} {A : Set a} {B : Set b}
         → (Ix → A → B) → ((Ix → A) → (Ix → B))
_|⊛|_ = _ˢ_

|liftA| : ∀ {a b} {A : Set a} {B : Set b}
          → (A → B) → ((Ix → A) → (Ix → B))
-- |liftA| f x = |pure| f |⊛| x
|liftA| = _∘′_

|liftA2| : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
           → (A → B → C)
           → ((Ix → A) → (Ix → B) → (Ix → C))
|liftA2| f x y = x ⟨ f ⟩° y
-- |liftA2| f x y = |pure| f |⊛| x |⊛| y

|List| : ∀ {a} → |Set| a → |Set| a
|List| = |liftA| List

|[]| : ∀ {f} {F : |Set| f} → |∀|(|List| {f} F) -- Agda could not infer this {f}
|[]| = []

_|∷|_ : ∀ {f} {F : |Set| f}
         → |∀|(F |→| |List| F |→| |List| F)
_|∷|_ = _∷_

|Maybe| : ∀ {a} → |Set| a → |Set| a
|Maybe| = |liftA| Maybe

|nothing| : ∀ {f} {F : |Set| f} → |∀|(|Maybe| {f} F) -- Agda could not infer this {f}
|nothing| = nothing

|just| : ∀ {f} {F : |Set| f} → |∀|(F |→| |Maybe| F)
|just| = just

infixr 2 _|×|_
_|×|_ : ∀ {f g} (F : |Set| f) (G : |Set| g) → |Set| _
_|×|_ = |liftA2| _×_
-- or alternatively:
-- (F |×| G) i = F i × G i

_|,|_ : ∀ {f g} {F : |Set| f} {G : |Set| g} → |∀| (F |→| G |→| F |×| G)
_|,|_ = _,_

pack : ∀ {f} {F : |Set| f} → (x : Ix) → F x → |∃| F
pack = _,_

infixr 1 _|⊎|_

_|⊎|_ : ∀ {f g} (F : |Set| f) (G : |Set| g) → |Set| _
_|⊎|_ = |liftA2| _⊎_

|inj₁| : ∀ {f g} {F : |Set| f} {G : |Set| g} → F |↦| F |⊎| G
|inj₁| = inj₁

|inj₂| : ∀ {f g} {F : |Set| f} {G : |Set| g} → G |↦| F |⊎| G
|inj₂| = inj₂

|⊤| : |Set| _
|⊤| = |pure| ⊤

|⊥| : |Set| _
|⊥| = |pure| ⊥

|¬| : ∀ {ℓ} → |Set| ℓ → |Set| _
|¬| F = F |→| |⊥|

-- This is the type of |map| functions, the fmap function on Ix-indexed
-- functors.
|Map| : ∀ {a a' b b'} (F : |Set| a → |Set| a')
                      (G : |Set| b → |Set| b') → Set _
|Map| F G = ∀ {A B} → (A |↦| B) → F A |↦| G B

|map|-|K| : ∀ {a a' b b'}
              {F : Set a → Set a'}
              {G : Set b → Set b'}
              (fmap : ∀ {A B} → (A → B) → F A → G B)
              {A B} → (|K| A |↦| |K| B) → |K| (F A) |↦| |K| (G B)
|map|-|K| fmap f {i} x = fmap (f {i}) x