Before changing SetLLRem

Before changing SetLLRem

module WellFormedLF where

open import Common
open import LinLogic
open import SetLL
open import SetLLRem hiding (drsize)
open import LinFun
open import Data.Product

--data IndexLF : ∀{u} → {i : Size} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → LFun {u} {i} {j} {rll} {ll} → Set where
--  ↓    : {i : Size} → {j : Size< ↑ i} → ∀{u rll ll} → (lf : LFun {u} {i} {j} {rll} {ll}) → IndexLF lf
--  _←⊂_ : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{u rll pll ell ll ind elf prf lf}
--         → IndexLF elf
--         → IndexLF (_⊂_ {u} {i} {j} {k} {pll} {ll} {ell} {rll} {ind} elf {{prf}} lf)
--  _⊂→_ : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{u rll pll ell ll ind elf prf lf}
--         → IndexLF lf
--         → IndexLF (_⊂_ {u} {i} {j} {k} {pll} {ll} {ell} {rll} {ind} elf {{prf}} lf)
--  tr   : {i : Size} → {j : Size< ↑ i} → ∀{u ll orll rll} → {{ltr : LLTr orll ll}} → {lf : LFun {u} {i} {j} {rll} {orll}}
--         → IndexLF lf → IndexLF (tr {{ltr = ltr}} lf)
--

--  _←⊂_ : {i : Size} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → (lf : LFun {u} {i} {j} {rll} {ll}) → IndexLF lf

--                                       ↓ probably the subtrees that contain all the inputs.
-- We need to keep truck of all the latest subtrees that are outputs of coms. We can then check whether a transformation permutates them. If so , the tr is acceptable.
-- transformations inside a subtree are acceptable.
-- tranformations between two subtrees are only acceptable if the next com depends on both of them.
-- If more than one subtree depends on a specific subtree, but the two do not depend on each other, we first separate the elements for the first subtree and then for the other.
-- Since these coms can be independently executed, there can be tranformations of one subtree that can not be done while the others are ready. --> We remove the separation transformation and consider that
-- the unexecuted transformations are done on those separated elements.

-- > The input tree contains subtrees that represent exactly the input of the coms it can execute.

-- 2 TWO
-- We need three structures.
-- THe first is used to identify inputs from the same com. When a tranformation splits these coms, we also split the set into two sets. Next we track all the inputs that are part of the tranformation, be it sets of inputs of a specific com or individual inputs. From all these sets, at least one item from each set needs to be the input of the next com.
-- The set of coms that are used to allow for commutation of inputs.

module _ where

  open import Data.Vec

  mutual
    data Descendant {u} : Set (lsuc u) where
      orig  : Descendant
      dec  : ℕ → ∀{i ll} → SetLLD {i} {u} ll → Descendant

    data SetLLD {i : Size} {u} : LinLogic i {u} → Set (lsuc u) where
      ↓     : ∀{ll} →  Descendant {u}              → SetLLD ll
      _←∧   : ∀{rs ls} → SetLLD ls            → SetLLD (ls ∧ rs)
      ∧→_   : ∀{rs ls} → SetLLD rs            → SetLLD (ls ∧ rs)
      _←∧→_ : ∀{rs ls} → SetLLD ls → SetLLD rs → SetLLD (ls ∧ rs)
      _←∨   : ∀{rs ls} → SetLLD ls            → SetLLD (ls ∨ rs)
      ∨→_   : ∀{rs ls} → SetLLD rs            → SetLLD (ls ∨ rs)
      _←∨→_ : ∀{rs ls} → SetLLD ls → SetLLD rs → SetLLD (ls ∨ rs)
      _←∂   : ∀{rs ls} → SetLLD ls            → SetLLD (ls ∂ rs)
      ∂→_   : ∀{rs ls} → SetLLD rs            → SetLLD (ls ∂ rs)
      _←∂→_ : ∀{rs ls} → SetLLD ls → SetLLD rs → SetLLD (ls ∂ rs)

  data MSetLLD {i : Size} {u} : LinLogic i {u} → Set (lsuc u) where
    ∅   : ∀{ll}             → MSetLLD ll
    ¬∅  : ∀{ll} → SetLLD ll → MSetLLD ll

  -- TODO We shouldn't need this. When issue agda #2409 is resolved, remove this.
  drsize : ∀{i u ll} → {j : Size< ↑ i} → SetLLD {i} {u} ll → SetLLD {j} ll
  drsize (↓ mm)          = (↓ mm)
  drsize (x ←∧)     = (drsize x) ←∧
  drsize (∧→ x)     = ∧→ (drsize x)
  drsize (x ←∧→ x₁) = (drsize x ←∧→ drsize x₁)
  drsize (x ←∨)     = (drsize x) ←∨
  drsize (∨→ x)     = ∨→ (drsize x)
  drsize (x ←∨→ x₁) = (drsize x ←∨→ drsize x₁)
  drsize (x ←∂)     = (drsize x) ←∂
  drsize (∂→ x)     = ∂→ (drsize x)
  drsize (x ←∂→ x₁) = (drsize x ←∂→ drsize x₁)

  fillAllLowerD : ∀{i u} → ∀ ll → SetLLD {i} {u} ll
  fillAllLowerD ∅ = ↓ orig
  fillAllLowerD (τ x) = ↓ orig
  fillAllLowerD (ll ∧ ll₁) = (fillAllLowerD ll) ←∧→ fillAllLowerD ll₁
  fillAllLowerD (ll ∨ ll₁) = (fillAllLowerD ll) ←∨→ fillAllLowerD ll₁
  fillAllLowerD (ll ∂ ll₁) = (fillAllLowerD ll) ←∂→ fillAllLowerD ll₁
  fillAllLowerD (call x) = ↓ orig

  compose : ∀{u i} → {j : Size< ↑ i} → ∀ {oll ll} → SetLLD {i} {u} oll → SetLLRem {_} {j} oll ll → SetLLD ll → SetLLD oll
  compose sdo sr (↓ x) = {!!}
  compose sdo sr (sd ←∧) = {!!}
  compose sdo sr (∧→ sd) = {!!}
  compose sdo sr (sd ←∧→ sd₁) = {!!}
  compose sdo sr (sd ←∨) = {!!}
  compose sdo sr (∨→ sd) = {!!}
  compose sdo sr (sd ←∨→ sd₁) = {!!}
  compose sdo sr (sd ←∂) = {!!}
  compose sdo sr (∂→ sd) = {!!}
  compose sdo sr (sd ←∂→ sd₁) = {!!}

  findNextCom : ∀{u i} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → LFun {rll = rll} {ll = ll} → SetLLD ll
  findNextCom {u} {i = pi} {ll = oll} lf = {!!} where
    findNextCom` : ∀{pi} → {oll : LinLogic pi {u}} → {i : Size< ↑ pi} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → LFun {rll = rll} {ll = ll} → SetLLRem oll ll → SetLLRem oll rll × SetLLD oll
    findNextCom` {oll = oll} I sr = (sr , fillAllLowerD oll)
    findNextCom` (_⊂_ {pll = pll} {ll = ll} {ell = ell} {ind = ind} lf₁ lf₂) sr with (findNextCom` lf₁ (fillAllLowerRem pll))
    ... | (r₁ , r₂) with (findNextCom` lf₂ (fillAllLowerRem (replLL ll ind ell)))
    ... | (g₁ , g₂) = {!!}
    findNextCom` (tr lf₁) sr = {!!}
    findNextCom` (obs lf₁) sr = {!!}
    findNextCom` (com df lf₁) sr = {!!}
    findNextCom` (call x lf₁) sr = {!!}

module WellFormedLF where

open import Common
open import LinLogic
open import SetLL

--data IndexLF : ∀{u} → {i : Size} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → LFun {u} {i} {j} {rll} {ll} → Set where
--  ↓    : {i : Size} → {j : Size< ↑ i} → ∀{u rll ll} → (lf : LFun {u} {i} {j} {rll} {ll}) → IndexLF lf
--  _←⊂_ : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{u rll pll ell ll ind elf prf lf}
--         → IndexLF elf
--         → IndexLF (_⊂_ {u} {i} {j} {k} {pll} {ll} {ell} {rll} {ind} elf {{prf}} lf)
--  _⊂→_ : {i : Size} → {j : Size< ↑ i} → {k : Size< ↑ j} → ∀{u rll pll ell ll ind elf prf lf}
--         → IndexLF lf
--         → IndexLF (_⊂_ {u} {i} {j} {k} {pll} {ll} {ell} {rll} {ind} elf {{prf}} lf)
--  tr   : {i : Size} → {j : Size< ↑ i} → ∀{u ll orll rll} → {{ltr : LLTr orll ll}} → {lf : LFun {u} {i} {j} {rll} {orll}}
--         → IndexLF lf → IndexLF (tr {{ltr = ltr}} lf)
--

--  _←⊂_ : {i : Size} → {j : Size< ↑ i} → {rll : LinLogic j {u}} → {ll : LinLogic i {u}} → (lf : LFun {u} {i} {j} {rll} {ll}) → IndexLF lf

--                                       ↓ probably the subtrees that contain all the inputs.
-- We need to keep truck of all the latest subtrees that are outputs of coms. We can then check whether a transformation permutates them. If so , the tr is acceptable.
-- transformations inside a subtree are acceptable.
-- tranformations between two subtrees are only acceptable if the next com depends on both of them.
-- If more than one subtree depends on a specific subtree, but the two do not depend on each other, we first separate the elements for the first subtree and then for the other.
-- Since these coms can be independently executed, there can be tranformations of one subtree that can not be done while the others are ready. --> We remove the separation transformation and consider that
-- the unexecuted transformations are done on those separated elements.

-- > The input tree contains subtrees that represent exactly the input of the coms it can execute.

-- 2 TWO
-- We need three structures.
-- THe first is used to identify inputs from the same com. When a tranformation splits these coms, we also split the set into two sets. Next we track all the inputs that are part of the tranformation, be it sets of inputs of a specific com or individual inputs. From all these sets, at least one item from each set needs to be the input of the next com.
-- The set of coms that are used to allow for commutation of inputs.

module _ where

  open import Data.Vec

  data Ancestor : Set where
    orig  : Ancestor
    anc   : ℕ → Ancestor → Ancestor
    manc  : ℕ → ∀{n} → Vec Ancestor n → Ancestor → Ancestor

  data SetLLD {i : Size} {u} : LinLogic i {u} → Set (lsuc u) where
    ↓     : ∀{ll} →  Ancestor               → SetLLD ll
    _←∧   : ∀{rs ls} → SetLLD ls            → SetLLD (ls ∧ rs)
    ∧→_   : ∀{rs ls} → SetLLD rs            → SetLLD (ls ∧ rs)
    _←∧→_ : ∀{rs ls} → SetLLD ls → SetLLD rs → SetLLD (ls ∧ rs)
    _←∨   : ∀{rs ls} → SetLLD ls            → SetLLD (ls ∨ rs)
    ∨→_   : ∀{rs ls} → SetLLD rs            → SetLLD (ls ∨ rs)
    _←∨→_ : ∀{rs ls} → SetLLD ls → SetLLD rs → SetLLD (ls ∨ rs)
    _←∂   : ∀{rs ls} → SetLLD ls            → SetLLD (ls ∂ rs)
    ∂→_   : ∀{rs ls} → SetLLD rs            → SetLLD (ls ∂ rs)
    _←∂→_ : ∀{rs ls} → SetLLD ls → SetLLD rs → SetLLD (ls ∂ rs)

  data MSetLLD {i : Size} {u} : LinLogic i {u} → Set (lsuc u) where
    ∅   : ∀{ll}             → MSetLLD ll
    ¬∅  : ∀{ll} → SetLLD ll → MSetLLD ll

  -- TODO We shouldn't need this. When issue agda #2409 is resolved, remove this.
  drsize : ∀{i u ll} → {j : Size< ↑ i} → SetLLD {i} {u} ll → SetLLD {j} ll
  drsize (↓ mm)          = (↓ mm)
  drsize (x ←∧)     = (drsize x) ←∧
  drsize (∧→ x)     = ∧→ (drsize x)
  drsize (x ←∧→ x₁) = (drsize x ←∧→ drsize x₁)
  drsize (x ←∨)     = (drsize x) ←∨
  drsize (∨→ x)     = ∨→ (drsize x)
  drsize (x ←∨→ x₁) = (drsize x ←∨→ drsize x₁)
  drsize (x ←∂)     = (drsize x) ←∂
  drsize (∂→ x)     = ∂→ (drsize x)
  drsize (x ←∂→ x₁) = (drsize x ←∂→ drsize x₁)

  fillAllLowerD : ∀{i u} → ∀ ll → SetLLD {i} {u} ll
  fillAllLowerD ll = {!!}


Fixed an theorem.

Fixed an theorem.

Ignore-this: a7c05b0bdd220240bb7c76cb5a83c29e

darcs-hash:20120303194550-3bd4e-12021126bfb9a318cdc8105eeab0d45f82ee7a8f.gz

------------------------------------------------------------------------------
-- FOL theorems
------------------------------------------------------------------------------

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

-- This module contains some examples showing the use of the ATPs for
-- proving FOL theorems.

module FOL.TheoremsATP where

open import FOL.Base

------------------------------------------------------------------------------
-- We postulate some formulae and propositional functions.
postulate
  A     : Set
  A¹ B¹ : D → Set
  A²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
{-
      φ(x)
  -----------  ∀-intro
    ∀x.φ(x)

    ∀x.φ(x)
  -----------  ∀-elim
     φ(t)

      φ(t)
  -----------  ∃-intro
    ∃x.φ(x)

   ∃x.φ(x)   φ(x) → ψ
 ----------------------  ∃-elim
           ψ
-}

postulate
  -- TODO: 2012-03-02. Fix? the universal introduction
  ∀-intro : (∀ x → A¹ x) → ∀ x → A¹ x
  ∀-elim  : (∀ x → A¹ x) → (t : D) → A¹ t
  -- It is necessary to assume a non-empty domain. See
  -- FOL.NonEmptyDomain.TheoremsI/ATP.∃I.
  --
  -- TODO: 2012-02-28. Fix the existential introduction rule.
  -- ∃-intro : ((t : D) → A¹ t) → ∃ A¹
  ∃-elim'  : ∃ A¹ → ((x : D) → A¹ x → A) → A
-- {-# ATP prove ∀-intro #-}
{-# ATP prove ∀-elim #-}
-- {-# ATP prove ∃-intro #-}
{-# ATP prove ∃-elim' #-}

-- Generalization of De Morgan's laws.
postulate
  gDM₁ : ¬ (∀ x → A¹ x) ↔ (∃[ x ] ¬ (A¹ x))
  gDM₂ : ¬ (∃ A¹)       ↔ (∀ x → ¬ (A¹ x))
  gDM₃ : (∀ x → A¹ x)   ↔ ¬ (∃[ x ] ¬ (A¹ x))
  gDM₄ : ∃ A¹           ↔ ¬ (∀ x → ¬ (A¹ x))
{-# ATP prove gDM₁ #-}
{-# ATP prove gDM₂ #-}
{-# ATP prove gDM₃ #-}
{-# ATP prove gDM₄ #-}

-- The order of quantifiers of the same sort is irrelevant.
postulate
  ∀-ord : (∀ x y → A² x y) ↔ (∀ y x → A² x y)
  ∃-ord : (∃[ x ] ∃[ y ] A² x y) ↔ (∃[ y ] ∃[ x ] A² x y)
{-# ATP prove ∀-ord #-}
{-# ATP prove ∃-ord #-}

-- Quantification over a variable that does not occur can be erased or
-- added.
postulate
  -- TODO: 2012-02-03. The ATPs are not proving the theorem.
  -- ∀-erase-add : ((x : D) → A) ↔ A
  ∃-erase-add : (∃[ x ] A ∧ A¹ x) ↔ A ∧ (∃[ x ] A¹ x)
-- {-# ATP prove ∀-erase-add #-}
{-# ATP prove ∃-erase-add #-}

-- Distributes laws for the quantifiers.
postulate
  ∀-dist : (∀ x → A¹ x ∧ B¹ x) ↔ ((∀ x → A¹ x) ∧ (∀ x → B¹ x))
  ∃-dist : (∃[ x ] A¹ x ∨ B¹ x) ↔ (∃ A¹ ∨ ∃ B¹)
{-# ATP prove ∀-dist #-}
{-# ATP prove ∃-dist #-}

-- Interchange of quantifiers.
-- The related theorem ∀x∃y.Axy → ∃y∀x.Axy is not (classically) valid.
postulate ∃∀ : ∃[ x ] (∀ y → A² x y) → ∀ y → ∃[ x ] A² x y
{-# ATP prove ∃∀ #-}

-- ∃ in terms of ∀ and ¬.
postulate
  ∃→¬∀¬ : ∃[ x ] A¹ x → ¬ (∀ {x} → ¬ A¹ x)
  ∃¬→¬∀ : ∃[ x ] ¬ A¹ x → ¬ (∀ {x} → A¹ x)
{-# ATP prove ∃→¬∀¬ #-}
{-# ATP prove ∃¬→¬∀ #-}

-- ∀ in terms of ∃ and ¬.
postulate
  ∀→¬∃¬ : (∀ {x} → A¹ x) → ¬ (∃[ x ] ¬ A¹ x)
  ∀¬→¬∃ : (∀ {x} → ¬ A¹ x) → ¬ (∃[ x ] A¹ x)
{-# ATP prove ∀→¬∃¬ #-}
{-# ATP prove ∀¬→¬∃ #-}

------------------------------------------------------------------------------
-- FOL theorems
------------------------------------------------------------------------------

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

-- This module contains some examples showing the use of the ATPs for
-- proving FOL theorems.

module FOL.TheoremsATP where

open import FOL.Base

------------------------------------------------------------------------------
-- We postulate some formulae and propositional functions.
postulate
  A     : Set
  A¹ B¹ : D → Set
  A²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
{-
      φ(x)
  -----------  ∀-intro
    ∀x.φ(x)

    ∀x.φ(x)
  -----------  ∀-elim
     φ(t)

      φ(t)
  -----------  ∃-intro
    ∃x.φ(x)

   ∃x.φ(x)   φ(x) → ψ
 ----------------------  ∃-elim
           ψ
-}

postulate
  -- TODO: 2012-03-02. Fix? the universal introduction
  ∀-intro : (∀ x → A¹ x) → ∀ x → A¹ x
  ∀-elim  : (∀ x → A¹ x) → (t : D) → A¹ t
  -- It is necessary to assume a non-empty domain. See
  -- FOL.NonEmptyDomain.TheoremsI/ATP.∃I.
  --
  -- TODO: 2012-02-28. Fix the existential introduction rule.
  -- ∃-intro : ((t : D) → A¹ t) → ∃ A¹
  ∃-elim'  : ∃ A¹ → ((x : D) → A¹ x → A) → A
-- {-# ATP prove ∀-intro #-}
{-# ATP prove ∀-elim #-}
-- {-# ATP prove ∃-intro #-}
{-# ATP prove ∃-elim' #-}

-- Generalization of De Morgan's laws.
postulate
  gDM₁ : ¬ (∀ x → A¹ x) ↔ (∃[ x ] ¬ (A¹ x))
  gDM₂ : ¬ (∃ A¹)       ↔ (∀ x → ¬ (A¹ x))
  gDM₃ : (∀ x → A¹ x)   ↔ ¬ (∃[ x ] ¬ (A¹ x))
  gDM₄ : ∃ A¹           ↔ ¬ (∀ x → ¬ (A¹ x))
{-# ATP prove gDM₁ #-}
{-# ATP prove gDM₂ #-}
{-# ATP prove gDM₃ #-}
{-# ATP prove gDM₄ #-}

-- The order of quantifiers of the same sort is irrelevant.
postulate
  ∀-ord : (∀ x y → A² x y) ↔ (∀ y x → A² x y)
  ∃-ord : (∃[ x ] ∃[ y ] A² x y) ↔ (∃[ y ] ∃[ x ] A² x y)
{-# ATP prove ∀-ord #-}
{-# ATP prove ∃-ord #-}

-- Quantification over a variable that does not occur can be erased or
-- added.
postulate
  -- TODO: 2012-02-03. The ATPs are not proving the theorem.
  -- ∀-erase-add : ((x : D) → A) ↔ A
  ∃-erase-add : (∃[ x ] A ∧ A¹ x) ↔ A ∧ (∃[ x ] A¹ x)
-- {-# ATP prove ∀-erase-add #-}
{-# ATP prove ∃-erase-add #-}

-- Distributes laws for the quantifiers.
postulate
  ∀-dist : ∀ x → A¹ x ∧ B¹ x ↔ ((∀ x → A¹ x) ∧ (∀ x → B¹ x))
  ∃-dist : (∃[ x ] A¹ x ∨ B¹ x) ↔ (∃ A¹ ∨ ∃ B¹)
{-# ATP prove ∀-dist #-}
{-# ATP prove ∃-dist #-}

-- Interchange of quantifiers.
-- The related theorem ∀x∃y.Axy → ∃y∀x.Axy is not (classically) valid.
postulate ∃∀ : ∃[ x ] (∀ y → A² x y) → ∀ y → ∃[ x ] A² x y
{-# ATP prove ∃∀ #-}

-- ∃ in terms of ∀ and ¬.
postulate
  ∃→¬∀¬ : ∃[ x ] A¹ x → ¬ (∀ {x} → ¬ A¹ x)
  ∃¬→¬∀ : ∃[ x ] ¬ A¹ x → ¬ (∀ {x} → A¹ x)
{-# ATP prove ∃→¬∀¬ #-}
{-# ATP prove ∃¬→¬∀ #-}

-- ∀ in terms of ∃ and ¬.
postulate
  ∀→¬∃¬ : (∀ {x} → A¹ x) → ¬ (∃[ x ] ¬ A¹ x)
  ∀¬→¬∃ : (∀ {x} → ¬ A¹ x) → ¬ (∃[ x ] A¹ x)
{-# ATP prove ∀→¬∃¬ #-}
{-# ATP prove ∀¬→¬∃ #-}


Strong-Fiat-Shamir: some progress and re-org

open import Type
open import Function.NP
open import Data.Maybe
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum using (_⊎_)
open import Data.List.NP renaming (map to mapᴸ)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Control.Strategy using (Strategy; module TranscriptRun; done; ask)

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}
  (any-W : W)
  {RS : ★}
  (L? : ∀ w Y → Dec (L w Y))
  (Λ? : Decidable (_≡_ {A = Λ}))
  (Eps  : ★)
  (ε[_] : Eps → ★)
  (ε0 : Eps)
  (ε[0] : ε[ ε0 ] ≡ 𝟘)
  where

module _ {R : ★} where
    _≋_ : (f g : R → 𝟚) → ★₁
    f ≋ g = (Σ R (✓ ∘ f)) ≡ (Σ R (✓ ∘ g))

    _≈_ : (f g : R → 𝟚) → ★₁
    f ≈ g = ∃₂ λ ε₀ ε₁ →
            (Σ R (✓ ∘ f) ⊎ ε[ ε₀ ]) ≡ (Σ R (✓ ∘ g) ⊎ ε[ ε₁ ])

    ≋→≈ : ∀ {f g} → f ≋ g → f ≈ g
    ≋→≈ f≋g = ε0 , ε0 , ap (flip _⊎_ ε[ ε0 ]) f≋g

{-
Random-Oracle-List : ★
Random-Oracle-List = List (Q × Resp)
-}

module Game-Types (Q Resp : ★)(Prf : Λ → ★) where
  Random-Oracle : ★
  Random-Oracle = Q → Resp

  data Adversary-Query : ★ where
    query-H : (q : Q) → Adversary-Query
    query-create-proof : (w : W)(Y : Λ) → Adversary-Query

  Challenger-Resp : Adversary-Query → ★
  Challenger-Resp (query-H s) = Resp
  Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

  Adversary : ★ → ★
  Adversary = Strategy Adversary-Query Challenger-Resp

  Transcript = List (Σ Adversary-Query Challenger-Resp)

  Prfs : ★
  Prfs = List (Σ Λ Prf)

record Proof-System (RP : ★)(Prf : Λ → ★) : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : (Y : Λ)(π : Prf Y) → 𝟚

  Complete : ★
  Complete = ∀ rp {w Y} → L w Y → Verify Y (Prove rp w Y) ≡ 1₂

  -- Not in the paper but...
  Sound : ★
  Sound = ∀ rp {w Y} → Verify Y (Prove rp w Y) ≡ 1₂ → L w Y

record Simulator (Q : ★)(Resp : ★){Prf RP}(PF : Proof-System RP Prf) : ★ where
  open Proof-System PF
  open Game-Types Q Resp Prf

  field
    -- Computing the compound patch to the random oracle
    H-patch  : RS → Transcript → Random-Oracle → Random-Oracle

    -- Simulate does not patch itself but H-patch does
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : ∀ rs t Y → Verify Y (Simulate rs t Y) ≡ 1₂

  open Proof-System PF public
  open Game-Types Q Resp Prf public

module Is-Zero-Knowledge
  {RP Prf Q Resp}
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (PF : Proof-System RP Prf)
  (open Proof-System PF)
  (sim : Simulator Q Resp PF)
  (open Simulator sim)
  (ro : Random-Oracle)
  where

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H-patch rs t ro q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    ... | yes p = just (Simulate rs t Y)
    ... | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    -- β = 0₂ is real
    -- β = 1₂ is simulated
    Experiment : ∀ {Output} → 𝟚 → Adversary Output → RS → Output × Transcript
    Experiment β adv rs = runT (challenger β rs) adv []

    EXP₀ EXP₁ : Adversary 𝟚 → RS → 𝟚
    EXP₀ Adv = fst ∘ Experiment 0₂ Adv
    EXP₁ Adv = fst ∘ Experiment 1₂ Adv

    -- Too strong
    IsZK = ∀ Adv → EXP₀ Adv ≈ EXP₁ Adv

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Simulation-Sound-Extractability
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp : ★)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
           where
    open Proof-System PF
    open Game-Types Q Resp Prf

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π _                                  = 0₂

    HistoryForExtractor = List (Prfs × Transcript)

    ExtractorServerPart =
         (past-history : HistoryForExtractor) {- previous invocations of Adv -}
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Prfs → (init-transcript : Transcript)
                     → ExtractorServerPart
                     × Strategy 𝟙 (const (Prfs × Transcript)) (List W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    valid-witnesses? : List W → List Λ → 𝟚
    valid-witnesses? [] [] = 1₂
    valid-witnesses? (w ∷ ws) (prf ∷ prfs) = valid-witness? w prf ∧ valid-witnesses? ws prfs
    valid-witnesses? _ _ = 0₂

    open TranscriptRun

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

        K-winning-prfs : Prfs → 𝟚
        K-winning-prfs []   = 1₂
        K-winning-prfs prfs = any K-winning-prf prfs

    module Game
        (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
        (sim : Simulator Q Resp PF)
        (open Is-Zero-Knowledge L-to-Prf PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Prfs)
        (w : RA)(rs : RS)(ro : Q → Resp)(K' : Extractor) where

        initial-result = Experiment ro 1₂ (Adv w) rs

        initial-prfs : Prfs
        initial-prfs = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-intial-run : 𝟚
        K-winning-intial-run = K-winning-prfs initial-transcript initial-prfs

        -- Second run

        K = K' initial-prfs initial-transcript

        Kf = fst K
        Ks = snd K

        ws = fst (runT (λ h _ → runT (λ t q → Kf (mapᴸ snd h) t q) (Adv w) []) Ks [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witnesses? ws (mapᴸ fst initial-prfs)

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RP RΣP : ★}
  (any-RΣP : RΣP)
  where

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  (v ⇄ p) r Y c = Σ-Protocol.Σ-game (v , p) r Y c

  Correct : Σ-Protocol → ★
  Correct (v , p) = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Prover p
    in v Y (mk (get-A r Y) c (get-f r Y c)) ≡ 1₂

  record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : ★ where
    open Σ-Protocol Σ-proto
    field
      Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
      Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
      -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
      -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  -- A pair of "Σ-Transcript"s such that the commitment is shared
  -- and the challenges are different.
  record Σ-Transcript² Y : ★ where
    constructor mk
    field
      -- The commitment is shared
      get-A         : Commitment

      -- The challenges...
      get-c₀ get-c₁ : Challenge

      -- ...are different
      c₀≢c₁         : get-c₀ ≢ get-c₁

      -- The proofs are arbitrary
      get-f₀ get-f₁ : Σ-Prf Y

  record Special-Soundness : ★ where
    field
      Extract    : ∀ {Y}(t : Σ-Transcript² Y) → W
      Extract-ok : ∀ {Y}(t : Σ-Transcript² Y) → L (Extract t) Y

  module Fiat-Shamir-Transformation
              (Σ-proto : Σ-Protocol)
              (shvzk : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              where

      open Σ-Protocol Σ-proto
      open Special-Honest-Verifier-Zero-Knowledge shvzk

      FS-Prf : Λ → ★
      FS-Prf Y = Challenge × Σ-Prf Y

      sFS : (H : (Λ × Commitment) → Challenge) → Proof-System RΣP FS-Prf
      sFS H = record { Prove = sFS-Prove ; Verify = sFS-Verify }
        where
          sFS-Prove : RΣP → W → (Y : Λ) → FS-Prf Y
          sFS-Prove r w Y = let c = H (Y , get-A r Y) in c , get-f r Y c
          sFS-Verify : ∀ Y → Challenge × Σ-Prf Y → 𝟚
          sFS-Verify Y (c , π) = Σ-verifier Y (mk (Simulate Y c π) c π)

      -- The weak fiat-shamir is like the strong one but the H function do not get to see
      -- the statement, hence the 'snd'
      wFS : (H : Commitment → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      wFS H = sFS (H ∘ snd)

  module Theorem1
              (Σ-proto : Σ-Protocol)
              -- (Σ-correct : Correct Σ-proto)
              (shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              (ssound  : Special-Soundness)
              (open Σ-Protocol Σ-proto)
              (H : (Λ × Commitment) → Challenge)
              where
      module SHVZK = Special-Honest-Verifier-Zero-Knowledge shvzk

      module FST = Fiat-Shamir-Transformation Σ-proto shvzk
      open FST using (FS-Prf)

      Q = Λ × Commitment
      Resp = Challenge

      sFS : Proof-System RΣP FS-Prf
      sFS = FST.sFS H
      module SFS = Proof-System sFS

      FS-Prf? : {Y Y' : Λ} → FS-Prf Y → FS-Prf Y' → 𝟚
      FS-Prf? π π' = {!!}

      open Simulation-Sound-Extractability sFS FS-Prf? Q Resp

      L-to-FS-Prf : ∀ {w Y} → L w Y → FS-Prf Y
      L-to-FS-Prf {w} w∈Y = SFS.Prove any-RΣP w _

      FS-Random-Oracle = (Λ × Commitment) → Challenge
      FS-Patch = FS-Random-Oracle → FS-Random-Oracle

      open Special-Soundness ssound
      open Game-Types Q Resp FS-Prf

      module _ (rnd-c : Λ → Challenge)(rnd-Σ-Prf : ∀ Y → Σ-Prf Y) where

        module _ (rs : RS) where
        {-
          Σ-t² : ∀{Y} → SFS.Transcript → Maybe (Σ-Transcript² Y)
          Σ-t² t = {!!}
          -}

    {-
module H-def (ro : Random-Oracle)(t : Random-Oracle-List)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q
  -}
          H-patch-1 : (q : Adversary-Query) → Challenger-Resp q → FS-Random-Oracle → FS-Random-Oracle
          H-patch-1 (query-H q) r = id
          H-patch-1 (query-create-proof w Y) r ro (Y' , c')
            = ro (Y' , case ⌊ Λ? Y Y' ⌋ 0: c' 1: SHVZK.Simulate Y (rnd-c Y) (rnd-Σ-Prf Y))

          H-patch : Transcript → FS-Patch
          H-patch []            = id
          H-patch ((q , r) ∷ t) = H-patch-1 q r ∘ H-patch t

          module _ (t : Transcript)(Y : Λ) where
              Simulate : FS-Prf Y
              Simulate = rnd-c Y , rnd-Σ-Prf Y
              -- SFS.Prove any-RΣP (maybe′ (Extract {Y}) any-W (Σ-t² t)) Y

              c : Challenge
              c = fst Simulate

              Σ-prf : Σ-Prf Y
              Σ-prf = snd Simulate

              verify-sim-spec : SFS.Verify Y Simulate ≡ 1₂
              verify-sim-spec = SHVZK.Simulate-ok Y c Σ-prf

        S : Simulator (Λ × Commitment) Challenge sFS
        S = record { H-patch = H-patch
                   ; Simulate = Simulate
                   ; verify-sim-spec = verify-sim-spec }

        open Is-Zero-Knowledge L-to-FS-Prf sFS S {!!}

        module _ Adv where
          is-zk' : EXP₀ Adv ≋ EXP₁ Adv
          is-zk' = {!!}

        is-zk : IsZK
        is-zk Adv = ≋→≈ (is-zk' Adv)

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

open import Type
open import Function.NP
open import Data.Maybe
open import Data.One
open import Data.Two
open import Data.List.NP renaming (map to mapᴸ)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Control.Strategy

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}{Prf : Λ → ★}
  {RS : ★}{Q : ★}{Resp :    ★}
  (L? : ∀ w Y → Dec (L w Y))
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
  -- (Q? : Decidable (_≡_ {A = Q}))
  where

Random-Oracle : ★
Random-Oracle = Q → Resp

State : (S A : ★) → ★
State S A = S → A × S

data Adversary-Query : ★ where
  query-H : (q : Q) → Adversary-Query
  query-create-proof : (w : W)(Y : Λ) → Adversary-Query

Challenger-Resp : Adversary-Query → ★
Challenger-Resp (query-H s) = Resp
Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

Adversary : ★ → ★
Adversary A = Strategy Adversary-Query Challenger-Resp A

Transcript = List (Σ Adversary-Query Challenger-Resp)

Prfs : ★
Prfs = List (Σ Λ Prf)

Random-Oracle-List : ★
Random-Oracle-List = List (Q × Resp)

record Proof-System (RP : ★)(Prf : Λ → ★) : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : (Y : Λ)(π : Prf Y) → 𝟚

Complete-Proof-System : {RP : ★}{Prf : Λ → ★} → Proof-System RP Prf → ★
Complete-Proof-System PS = ∀ rp w Y → Verify Y (Prove rp w Y) ≡ 1₂
  where open Proof-System PS

    {-
module H-def (ro : Random-Oracle)(t : Random-Oracle-List)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q
  -}

record Simulator {RP}(PF : Proof-System RP Prf) : ★ where
  open Proof-System PF

  field
    -- Computing the compound patch to the random oracle
    H-patch  : RS → Transcript → Random-Oracle → Random-Oracle

    -- Simulate does not patch itself but H-patch does
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : ∀ rs t Y →
                      let π = Simulate rs t Y
                      in Verify Y π ≡ 1₂

module Is-Zero-Knowledge
  {RP}
  (PF : Proof-System RP Prf)
  (sim : Simulator PF)
  where

  open Simulator sim

  module _ (ro : Random-Oracle) where

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H-patch rs t ro q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    ... | yes p = just (Simulate rs t Y)
    ... | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    -- β = 0₂ is real
    -- β = 1₂ is simulated
    Experiment : ∀ {A} → 𝟚 → RS → Adversary A → A × Transcript
    Experiment β rs adv = runT (challenger β rs) adv []

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RP RΣP : ★}
  (PF : Proof-System RP Prf)
  where
  open Proof-System PF

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  (v ⇄ p) r Y c = Σ-Protocol.Σ-game (v , p) r Y c

  Correct : Σ-Protocol → ★
  Correct (v , p) = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Prover p
    in v Y (mk (get-A r Y) c (get-f r Y c)) ≡ 1₂

  module Special-Honest-Verifier-Zero-Knowledge where

    record SHVZK (Σ-proto : Σ-Protocol) : ★ where
      open Σ-Protocol Σ-proto
      field
        Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
        Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
        -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
        -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  module Special-Soundness where

    record SpSo : ★ where
      field
        Extract : (Y : Λ)(t₀ t₁ : Σ-Transcript Y) → W
        Extract-ok : ∀ Y A c₀ c₁ f₀ f₁ → (c₀ ≢ c₁) → L (Extract Y (mk A c₀ f₀) (mk A c₁ f₁)) Y

  module Simulation-Sound-Extractability where

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-H _ , _) = 0₂
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π (query-create-proof _ _ , nothing) = 0₂

    HistoryForExtractor = List (Prfs × Transcript)

    ExtractorServerPart =
         (past-history : HistoryForExtractor) {- previous invocations of Adv -}
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Prfs → (init-transcript : Transcript)
                     → ExtractorServerPart
                     × Strategy 𝟙 (const (Prfs × Transcript)) (List W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    valid-witnesses? : List W → List Λ → 𝟚
    valid-witnesses? [] [] = 1₂
    valid-witnesses? (w ∷ ws) (prf ∷ prfs) = valid-witness? w prf ∧ valid-witnesses? ws prfs
    valid-witnesses? _ _ = 0₂

    open TranscriptRun
    open StatefulRun

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

        K-winning-prfs : Prfs → 𝟚
        K-winning-prfs []   = 1₂
        K-winning-prfs prfs = any K-winning-prf prfs

    module Game
        (sim : Simulator PF)
        (open Is-Zero-Knowledge PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Prfs)
        (w : RA)(rs : RS)(ro : Random-Oracle)(K' : Extractor) where

        initial-result = Experiment ro 1₂ rs (Adv w)

        initial-prfs : Prfs
        initial-prfs = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-intial-run : 𝟚
        K-winning-intial-run = K-winning-prfs initial-transcript initial-prfs

        -- Second run

        K = K' initial-prfs initial-transcript

        Kf = fst K
        Ks = snd K

        ws = fst (runT (λ h _ → runT (λ t q → Kf (mapᴸ snd h) t q) (Adv w) []) Ks [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witnesses? ws (mapᴸ fst initial-prfs)

  module Fiat-Shamir-Transformation
              (Σ-proto : Σ-Protocol)
              (shvzk : Special-Honest-Verifier-Zero-Knowledge.SHVZK Σ-proto)
              where

      open Σ-Protocol Σ-proto
      open Special-Honest-Verifier-Zero-Knowledge.SHVZK shvzk

      sFS : (H : (Λ × Commitment) → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      sFS H = record { Prove = sFS-Prove ; Verify = sFS-Verify }
        where
          sFS-Prove : RΣP → W → (Y : Λ) → (Challenge × Σ-Prf Y)
          sFS-Prove r w Y = let c = H (Y , get-A r Y) in c , get-f r Y c
          sFS-Verify : ∀ Y → Challenge × Σ-Prf Y → 𝟚
          sFS-Verify Y (c , π) = Σ-verifier Y (mk (Simulate Y c π) c π)

      -- The weak fiat-shamir is like the strong one but the H function do not get to see
      -- the statement, hence the 'snd'
      wFS : (H : Commitment → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      wFS H = sFS (H ∘ snd)

  module Theorem1
              (Σ-proto : Σ-Protocol)
              (shvzk : Special-Honest-Verifier-Zero-Knowledge.SHVZK Σ-proto)
              (ssound : Special-Soundness.SpSo)
              where
      open Simulation-Sound-Extractability
      {-
      S : Simulator PF
      S = record { H-patch = {!!}
                 ; Simulate = {!!}
                 ; verify-sim-spec = {!!} }
      -}

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


Added doc.

Added doc.

Ignore-this: b0f0381caf8a0f958cf0aadd900b632

darcs-hash:20120105172321-3bd4e-4cf58940f8066449afbaaf5df946f7aa92362520.gz

------------------------------------------------------------------------------
-- Arithmetic properties (using induction on the FOTC natural numbers type)
------------------------------------------------------------------------------

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

-- Usually our proofs use pattern matching instead of the induction
-- principle associated with the FOTC natural numbers. The following
-- examples show some proofs using it.

module FOTC.Data.Nat.PropertiesByInductionATP where

open import FOTC.Base
open import FOTC.Data.Nat

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

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

-- The predicate is not inside the where clause because the
-- translation of projection-like functions is not implemented.
+-rightIdentity-P : D → Set
+-rightIdentity-P i = i + zero ≡ i
{-# ATP definition +-rightIdentity-P #-}

+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity Nn = indN +-rightIdentity-P P0 is Nn
  where
  postulate P0 : +-rightIdentity-P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → +-rightIdentity-P i → +-rightIdentity-P (succ₁ i)
  {-# ATP prove is #-}

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = indN P P0 is Nm
  where
  P : D → Set
  P i = N (i + n)
  {-# ATP definition P #-}

  postulate P0 : P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  -- Metis 2.3 (release 20110926): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove is #-}

+-assoc : ∀ {m n o} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc {n = n} {o} Nm Nn No = indN P P0 is Nm
  where
  P : D → Set
  P i = i + n + o ≡ i + (n + o)
  {-# ATP definition P #-}

  postulate P0 : P zero
  -- Metis 2.3 (release 20110926): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  -- Metis 2.3 (release 20110926): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove is #-}

-- A proof without use ATPs definitions.
+-assoc' : ∀ {m n o} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc' {n = n} {o} Nm Nn No = indN P P0 is Nm
  where
  P : D → Set
  P i = i + n + o ≡ i + (n + o)

  postulate P0 : zero + n + o ≡ zero + (n + o)
  {-# ATP prove P0 #-}

  postulate
    is : ∀ {i} →
         i + n + o ≡ i + (n + o) →  -- IH.
         succ₁ i + n + o ≡ succ₁ i + (n + o)
  {-# ATP prove is #-}

x+Sy≡S[x+y] : ∀ {m} n → N m → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] n Nm = indN P P0 is Nm
  where
  P : D → Set
  P i = i + succ₁ n ≡ succ₁ (i + n)
  {-# ATP definition P #-}

  postulate P0 : P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  -- Metis 2.3 (release 20110926): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove is #-}

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} Nm Nn = indN P P0 is Nm
  where
  P : D → Set
  P i = i + n ≡ n + i
  {-# ATP definition P #-}

  postulate P0 : P zero
  -- Metis 2.3 (release 20110926): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove P0 +-rightIdentity #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  -- Metis 2.3 (release 20110926): SZS status Unknown (using timeout 180 sec).
  {-# ATP prove is x+Sy≡S[x+y] #-}

------------------------------------------------------------------------------
-- Arithmetic properties (using induction on the FOTC natural numbers type)
------------------------------------------------------------------------------

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

-- Usually our proofs use pattern matching instead of the induction
-- principle associated with the FOTC natural numbers. The following
-- examples show some proofs using it.

-- TODO: We have not tested which ATPs fail on the ATP conjectures.

module FOTC.Data.Nat.PropertiesByInductionATP where

open import FOTC.Base
open import FOTC.Data.Nat

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

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

-- The predicate is not inside the where clause because the
-- translation of projection-like functions is not implemented.
+-rightIdentity-P : D → Set
+-rightIdentity-P i = i + zero ≡ i
{-# ATP definition +-rightIdentity-P #-}

+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity Nn = indN +-rightIdentity-P P0 is Nn
  where
  postulate P0 : +-rightIdentity-P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → +-rightIdentity-P i → +-rightIdentity-P (succ₁ i)
  {-# ATP prove is #-}

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} Nm Nn = indN P P0 is Nm
  where
  P : D → Set
  P i = N (i + n)
  {-# ATP definition P #-}

  postulate P0 : P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  {-# ATP prove is #-}

+-assoc : ∀ {m n o} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc {n = n} {o} Nm Nn No = indN P P0 is Nm
  where
  P : D → Set
  P i = i + n + o ≡ i + (n + o)
  {-# ATP definition P #-}

  postulate P0 : P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  {-# ATP prove is #-}

-- A proof without use ATPs definitions.
+-assoc' : ∀ {m n o} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc' {n = n} {o} Nm Nn No = indN P P0 is Nm
  where
  P : D → Set
  P i = i + n + o ≡ i + (n + o)

  postulate P0 : zero + n + o ≡ zero + (n + o)
  {-# ATP prove P0 #-}

  postulate
    is : ∀ {i} →
         i + n + o ≡ i + (n + o) →  -- IH.
         succ₁ i + n + o ≡ succ₁ i + (n + o)
  {-# ATP prove is #-}

x+Sy≡S[x+y] : ∀ {m} n → N m → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] n Nm = indN P P0 is Nm
  where
  P : D → Set
  P i = i + succ₁ n ≡ succ₁ (i + n)
  {-# ATP definition P #-}

  postulate P0 : P zero
  {-# ATP prove P0 #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  {-# ATP prove is #-}

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} Nm Nn = indN P P0 is Nm
  where
  P : D → Set
  P i = i + n ≡ n + i
  {-# ATP definition P #-}

  postulate P0 : P zero
  {-# ATP prove P0 +-rightIdentity #-}

  postulate is : ∀ {i} → P i → P (succ₁ i)
  {-# ATP prove is x+Sy≡S[x+y] #-}


flipbased-tree: probability results for return, toss, map, zip, weaken

module flipbased-tree where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Nat.Properties
open import bintree
open import Data.Product

import flipbased

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
↺ : ∀ {a} n (A : Set a) → Set a
↺ = flip Tree

return↺ : ∀ {c a} {A : Set a} → A → ↺ c A
return↺ = leaf

runDet : ∀ {a} {A : Set a} → ↺ 0 A → A
runDet (leaf x) = x

toss : ↺ 1 Bit
toss = fork (leaf 0b) (leaf 1b)

weaken≤ : ∀ {m c a} {A : Set a} → m ≤ c → ↺ m A → ↺ c A
weaken≤ p (leaf x) = leaf x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m n = ℕ≤.trans (m≤m+n m n) (ℕ≤.reflexive (ℕ°.+-comm m n))

weaken+ : ∀ c {m a} {A : Set a} → ↺ m A → ↺ (c + m) A
weaken+ c = weaken≤ (m≤n+m _ c)

map↺ : ∀ {c a b} {A : Set a} {B : Set b} → (A → B) → ↺ c A → ↺ c B
map↺ f (leaf x) = leaf (f x)
map↺ f (fork left right) = fork (map↺ f left) (map↺ f right)

join↺ : ∀ {c₁ c₂ a} {A : Set a} → ↺ c₁ (↺ c₂ A) → ↺ (c₁ + c₂) A
join↺ {c} (leaf x)      = weaken+ c x
join↺     (fork left right) = fork (join↺ left) (join↺ right)

open flipbased ↺ toss weaken≤ leaf map↺ join↺ public

open import Data.Bool
open import Data.Bits
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

infix 4 _/2+_/2
infix 6 _/2
postulate
  [0,1] : Set
  0/1 : [0,1]
  1/1 : [0,1]
  _/2 : [0,1] → [0,1]
  _/2+_/2 : [0,1] → [0,1] → [0,1]
  _*/_ : [0,1] → [0,1] → [0,1]
-- sym _/2+_/2
-- 1 /2+ 1 /2 = 1/1
-- p /2+ p /2 = p
-- p /2+ (1- p) /2 = 1/2

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

  0/2+p/2≡p/2 : ∀ p → (0/1 /2+ p /2) ≡ p /2
  _/2+_/2-comm : ∀ x y → x /2+ y /2 ≡ y /2+ x /2
  1*q≡q : ∀ q → 1/1 */ q ≡ q
  0*q≡q : ∀ q → 0/1 */ q ≡ 0/1
  distr-*-/2+/2 : ∀ x y z → (x */ z) /2+ (y */ z) /2 ≡ (x /2+ y /2) */ z
  distr-/2-* : ∀ p q → (p /2) */ (q /2) ≡ ((p */ q) /2) /2
  0/2≡0 : 0/1 /2 ≡ 0/1

1/2^_ : ℕ → [0,1]
1/2^ zero = 1/1
1/2^ suc n = (1/2^ n)/2

1/2 : [0,1]
1/2 = 1/2^ 1
1/4 : [0,1]
1/4 = 1/2^ 2

data Pr[return↺_≡_]≡_ {a} {A : Set a} (x y : A) : [0,1] → Set a where
  Pr-≡ : x ≡ y → Pr[return↺ x ≡ y ]≡ 1/1
  Pr-≢ : x ≢ y → Pr[return↺ x ≡ y ]≡ 0/1

infix 2 Pr[_≡_]≡_
data Pr[_≡_]≡_ {a} {A : Set a} : ∀ {c} → ↺ c A → A → [0,1] → Set a where
  Pr-return : ∀ {c x y pr} (pf : Pr[return↺ x ≡ y ]≡ pr) → Pr[ return↺ {c = c} x ≡ y ]≡ pr

  Pr-fork : ∀ {c} {left right : ↺ c A} {x p q r}
            (eq : p /2+ q /2 ≡ r)
            (pf₀ : Pr[ left ≡ x ]≡ p)
            (pf₁ : Pr[ right ≡ x ]≡ q)
            → Pr[ fork left right ≡ x ]≡ r

Pr-fork′ : ∀ {c a} {A : Set a} {left right : ↺ c A} {x p q}
            → Pr[ left ≡ x ]≡ p
            → Pr[ right ≡ x ]≡ q
            → Pr[ fork left right ≡ x ]≡ (p /2+ q /2)
Pr-fork′ = Pr-fork refl

Pr-return-≡ : ∀ {c a} {A : Set a} {x : A} → Pr[ return↺ {c = c} x ≡ x ]≡ 1/1
Pr-return-≡ = Pr-return (Pr-≡ refl)

Pr-return-≢ : ∀ {c a} {A : Set a} {x y : A} → x ≢ y → Pr[ return↺ {c = c} x ≡ y ]≡ 0/1
Pr-return-≢ = Pr-return ∘ Pr-≢

import Function.Equality as F≡
import Function.Equivalence as F≈

_≈⇒_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈⇒ p₂ = ∀ {x pr} → Pr[ p₁ ≡ x ]≡ pr → Pr[ p₂ ≡ x ]≡ pr

_≈_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈ p₂ = ∀ {x pr} → (Pr[ p₁ ≡ x ]≡ pr) F≈.⇔ (Pr[ p₂ ≡ x ]≡ pr)

≈-refl : ∀ {c a} {A : Set a} → Reflexive {A = ↺ c A} _≈_
≈-refl = F≈.id

≈-sym : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → p₁ ≈ p₂ → p₂ ≈ p₁
≈-sym η = F≈.sym η

≈-trans : ∀ {c a} {A : Set a} → Transitive {A = ↺ c A} _≈_
≈-trans f g = g F≈.∘ f

fork-sym⇒ : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → fork p₁ p₂ ≈⇒ fork p₂ p₁
fork-sym⇒ (Pr-fork {p = p} {q} refl pf₁ pf₀) rewrite p /2+ q /2-comm = Pr-fork′ pf₀ pf₁

fork-sym : ∀ {c a} {A : Set a} {p₁ p₂ : ↺ c A} → fork p₁ p₂ ≈ fork p₂ p₁
fork-sym = F≈.equivalence fork-sym⇒ fork-sym⇒

Pr-fork-0 : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p}
            → Pr[ left ≡ x ]≡ 0/1
            → Pr[ right ≡ x ]≡ p
            → Pr[ fork left right ≡ x ]≡ p /2
Pr-fork-0 {p = p} eq₁ eq₂ rewrite sym (0/2+p/2≡p/2 p) = Pr-fork′ eq₁ eq₂

ex₁ : ∀ x → Pr[ toss ≡ x ]≡ 1/2
ex₁ 1b = Pr-fork-0 (Pr-return-≢ (λ ())) Pr-return-≡
ex₁ 0b = F≈.Equivalence.to fork-sym F≡.⟨$⟩ (Pr-fork-0 (Pr-return-≢ (λ ())) Pr-return-≡)

Pr-map : ∀ {c a b} {A : Set a} {B : Set b} {Alg : ↺ c A} {x pr} {f : A → B} →
  (f-inj : ∀ {x y} → f x ≡ f y → x ≡ y) →
  Pr[ Alg ≡ x ]≡ pr →
  Pr[ ⟪ f · Alg ⟫ ≡ f x ]≡ pr
Pr-map f-inj (Pr-return (Pr-≡ refl)) = Pr-return (Pr-≡ refl)
Pr-map f-inj (Pr-return (Pr-≢ x≢y)) = Pr-return (Pr-≢ (x≢y ∘ f-inj))
Pr-map f-inj (Pr-fork eq pf₀ pf₁) = Pr-fork eq (Pr-map f-inj pf₀) (Pr-map f-inj pf₁)

Pr-same : ∀ {c a} {A : Set a} {Alg : ↺ c A} {x pr₀ pr₁} →
    pr₀ ≡ pr₁ →
    Pr[ Alg ≡ x ]≡ pr₀ →
    Pr[ Alg ≡ x ]≡ pr₁
Pr-same refl = id

Pr-weaken≤ : ∀ {c₀ c₁ a} {A : Set a} {Alg : ↺ c₀ A} {x pr} →
    (c₀≤c₁ : c₀ ≤ c₁) →
    Pr[ Alg ≡ x ]≡ pr →
    Pr[ weaken≤ c₀≤c₁ Alg ≡ x ]≡ pr
Pr-weaken≤ p (Pr-return pf) = Pr-return pf
Pr-weaken≤ (s≤s c₀≤c₁) (Pr-fork eq pf₀ pf₁)
  = Pr-fork eq (Pr-weaken≤ c₀≤c₁ pf₀) (Pr-weaken≤ c₀≤c₁ pf₁)

Pr-weaken+ : ∀ {c₀} c₁ {a} {A : Set a} {Alg : ↺ c₀ A} {x pr} →
    Pr[ Alg ≡ x ]≡ pr →
    Pr[ weaken+ c₁ Alg ≡ x ]≡ pr
Pr-weaken+ c₁ = Pr-weaken≤ (m≤n+m _ c₁)

Pr-map-0 : ∀ {c a b} {A : Set a} {B : Set b} {Alg : ↺ c A} {f : A → B} {x} → (∀ y → f y ≢ x)
           → Pr[ map↺ f Alg ≡ x ]≡ 0/1
Pr-map-0 {Alg = leaf x} f-prop = Pr-return (Pr-≢ (f-prop x))
Pr-map-0 {Alg = fork Alg Alg₁} f-prop = Pr-fork (trans (0/2+p/2≡p/2 0/1) 0/2≡0)
                                                (Pr-map-0 f-prop) (Pr-map-0 f-prop)

Pr-zip : ∀ {c₀ c₁ a b} {A : Set a} {B : Set b} {Alg₀ : ↺ c₀ A} {Alg₁ : ↺ c₁ B} {x y pr₁ pr₂} →
  Pr[ Alg₀ ≡ x ]≡ pr₁ →
  Pr[ Alg₁ ≡ y ]≡ pr₂ →
  Pr[ zip↺ Alg₀ Alg₁ ≡ (x , y) ]≡ (pr₁ */ pr₂)
Pr-zip {c₀} {pr₂ = pr₂} (Pr-return {x = x} (Pr-≡ refl)) pf₂
  rewrite 1*q≡q pr₂ = Pr-weaken+ c₀ (Pr-map {f = _,_ x} (cong proj₂) pf₂)
Pr-zip {c₀} {pr₂ = pr₂} (Pr-return {x = x} (Pr-≢ pf)) pf₂
  rewrite 0*q≡q pr₂ = Pr-weaken+ c₀ (Pr-map-0 (λ y x₁ → pf (cong proj₁ x₁)))
Pr-zip (Pr-fork refl pf₁ pf₂) pf₃ = Pr-fork (distr-*-/2+/2 _ _ _) (Pr-zip pf₁ pf₃) (Pr-zip pf₂ pf₃)

ex₂ : ∀ x y → Pr[ toss ⟨,⟩ toss ≡ (x , y) ]≡ 1/4
ex₂ x y = Pr-same (trans (distr-/2-* _ _) (cong (_/2 ∘ _/2) (1*q≡q _)))
                  (Pr-zip {Alg₀ = toss} {Alg₁ = toss} (ex₁ x) (ex₁ y))

postulate
  ex₃ : ∀ {n} (x : Bits n) → Pr[ random ≡ x ]≡ 1/2^ n

module flipbased-tree where

open import Function
open import Data.Bits
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Vec

import flipbased

data Tree {a} (A : Set a) : ℕ → Set a

↺ : ∀ {a} n (A : Set a) → Set a
↺ = flip Tree

-- “↺ n A” reads like: “toss n coins and then return a value of type A”
data Tree {a} (A : Set a) where
  return↺ : ∀ {c} → A → ↺ c A
  fork    : ∀ {c} → (left right : ↺ c A) → ↺ (suc c) A

runDet : ∀ {a} {A : Set a} → ↺ 0 A → A
runDet (return↺ x) = x

toss : ↺ 1 Bit
toss = fork (return↺ 0b) (return↺ 1b)

map↺ : ∀ {c a b} {A : Set a} {B : Set b} → (A → B) → ↺ c A → ↺ c B
map↺ f (return↺ x) = return↺ (f x)
map↺ f (fork left right) = fork (map↺ f left) (map↺ f right)

weaken≤ : ∀ {m c a} {A : Set a} → m ≤ c → ↺ m A → ↺ c A
weaken≤ p (return↺ x) = return↺ x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

weaken+ : ∀ {m c a} {A : Set a} → ↺ m A → ↺ (c + m) A
weaken+ {m} {c} = weaken≤ (ℕ≤.trans (m≤m+n m c) (ℕ≤.reflexive (ℕ°.+-comm m c)))

join↺ : ∀ {c₁ c₂ a} {A : Set a} → ↺ c₁ (↺ c₂ A) → ↺ (c₁ + c₂) A
join↺ {c} (return↺ x)      = weaken+ {_} {c} x
join↺     (fork left right) = fork (join↺ left) (join↺ right)

open flipbased ↺ toss weaken≤ return↺ map↺ join↺ public

open import Data.Bool
open import Data.Bits
open import Data.Product
open import Relation.Binary.PropositionalEquality

infix 4 _/2+_/2
infix 6 _/2
postulate
  [0,1] : Set
  0/1 : [0,1]
  1/1 : [0,1]
  _/2 : [0,1] → [0,1]
  _/2+_/2 : [0,1] → [0,1] → [0,1]
-- sym _/2+_/2
-- 1 /2+ 1 /2 = 1/1
-- p /2+ p /2 = p
-- p /2+ (1- p) /2 = 1/2

1/2^_ : ℕ → [0,1]
1/2^ zero = 1/1
1/2^ suc n = (1/2^ n)/2

1/2 : [0,1]
1/2 = 1/2^ 1
1/4 : [0,1]
1/4 = 1/2^ 2

postulate
  Pr[_≡_] : ∀ {c a} {A : Set a} → ↺ c A → A → [0,1]

_≈_ : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → Set a
p₁ ≈ p₂ = ∀ x → Pr[ p₁ ≡ x ] ≡ Pr[ p₂ ≡ x ]

postulate
  fork-sym : ∀ {c a} {A : Set a} (p₁ p₂ : ↺ c A) → fork p₁ p₂ ≈ fork p₂ p₁

  Pr-return-≡ : ∀ {c a} {A : Set a} (x : A) → Pr[ return↺ {c = c} x ≡ x ] ≡ 1/1

  Pr-return-≢ : ∀ {c a} {A : Set a} {x y : A} → x ≢ y → Pr[ return↺ {c = c} x ≡ y ] ≡ 0/1

  Pr-fork : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p q}
            → Pr[ left ≡ x ] ≡ p
            → Pr[ right ≡ x ] ≡ q
            → Pr[ fork left right ≡ x ] ≡ p /2+ q /2

  0/2+p/2≡p/2 : ∀ p → (0/1 /2+ p /2) ≡ p /2

Pr-fork-0 : ∀ {c a} {A : Set a} {left right : ↺ c A} {x : A} {p}
            → Pr[ left ≡ x ] ≡ 0/1
            → Pr[ right ≡ x ] ≡ p
            → Pr[ fork left right ≡ x ] ≡ p /2
Pr-fork-0 {p = p} eq₁ eq₂ rewrite sym (0/2+p/2≡p/2 p) = Pr-fork eq₁ eq₂

ex₁ : ∀ x → Pr[ toss ≡ x ] ≡ 1/2
ex₁ 1b = Pr-fork-0 (Pr-return-≢ (λ ())) (Pr-return-≡ 1b)
ex₁ 0b rewrite fork-sym {0} (return↺ 0b) (return↺ 1b) 0b = Pr-fork-0 (Pr-return-≢ (λ ())) (Pr-return-≡ 0b)

postulate
  ex₂ : ∀ x y → Pr[ toss ⟨,⟩ toss ≡ (x , y) ] ≡ 1/2^ 2

  ex₃ : ∀ {n} (x : Bits n) → Pr[ random ≡ x ] ≡ 1/2^ n