ANormalDTerm: remove bad experiments

ANormalDTerm: remove bad experiments

module Thesis.ANormalDTerm where

open import Thesis.ANormal

ΔΔ : Context → Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δt τ • ΔΔ Γ
Δτ = Δt

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = ⟦ ΔΔ Δ ⟧Context

-- [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set
-- [ ∅ ]Δ ∅ from ∅ to ∅ = ⊤
-- [ τ • Δ ]Δ dv • dρ from v1 • ρ1 to (v2 • ρ2) = [ τ ]τ dv from v1 to v2 × [ Δ ]Δ dρ from ρ1 to ρ2

data [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set where
  v∅ : [ ∅ ]Δ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Δ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Δ ]Δ dρ from ρ1 to ρ2) →
    [ τ • Δ ]Δ (dv • dρ) from (v1 • ρ1) to (v2 • ρ2)

derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
derive-dvar this = this
derive-dvar (that x) = that (derive-dvar x)

fromtoDeriveDVar : ∀ {Δ τ} → (x : Var Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dvar x ⟧Var dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveDVar this (dvv v• dρρ) = dvv
fromtoDeriveDVar (that x) (dvv v• dρρ) = fromtoDeriveDVar x dρρ

-- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
-- a result of type (Δt τ).
data DTerm : (Δ : Context) (τ : Type) → Set where
  dvar : ∀ {Δ τ} (x : Var (ΔΔ Δ) (Δt τ)) →
    DTerm Δ τ
  dlett : ∀ {Δ τ σ τ₁} →
    (f : Var Δ (σ ⇒ τ₁)) →
    (x : Var Δ σ) →
    (t : Term (τ₁ • Δ) τ) →
    (df : Var (ΔΔ Δ) (Δτ (σ ⇒ τ₁))) →
    (dx : Var (ΔΔ Δ) (Δτ σ)) →
    (dt : DTerm (τ₁ • Δ) τ) →
    DTerm Δ τ

data DFun (Δ : Context) : (τ : Type) → Set where
  dterm : ∀ {τ} → DTerm Δ τ → DFun Δ τ
  dabs : ∀ {σ τ} → DFun (σ • Δ) τ → DFun Δ (σ ⇒ τ)

derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ
derive-dterm (var x) = dvar (derive-dvar x)
derive-dterm (lett f x t) =
  dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

⟦_⟧DTerm : ∀ {Δ τ} → DTerm Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦ dvar x ⟧DTerm ρ dρ = ⟦ x ⟧Var dρ
⟦ dlett f x t df dx dt ⟧DTerm ρ dρ =
  let v = (⟦ x ⟧Var ρ)
  in
    ⟦ dt ⟧DTerm
      (⟦ f ⟧Var ρ v • ρ)
      (⟦ df ⟧Var dρ v (⟦ dx ⟧Var dρ) • dρ)

fromtoDeriveDTerm : ∀ {Δ τ} → (t : Term Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dterm t ⟧DTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDeriveDTerm (var x) dρρ = fromtoDeriveDVar x dρρ
fromtoDeriveDTerm (lett f x t) dρρ =
  let fromToF = fromtoDeriveDVar f dρρ
      fromToX = fromtoDeriveDVar x dρρ
      fromToFX = fromToF _ _ _ fromToX
  in fromtoDeriveDTerm t (fromToFX v• dρρ)

derive-dfun : ∀ {Δ σ} → (t : Fun Δ σ) → DFun Δ σ
derive-dfun (term t) = dterm (derive-dterm t)
derive-dfun (abs f) = dabs (derive-dfun f)

⟦_⟧DFun : ∀ {Δ τ} → DFun Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦ dterm t ⟧DFun = ⟦ t ⟧DTerm
⟦ dabs df ⟧DFun ρ dρ = λ v dv → ⟦ df ⟧DFun (v • ρ) (dv • dρ)

fromtoDeriveDFun : ∀ {Δ τ} → (f : Fun Δ τ) →
  ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
  [ τ ]τ (⟦ derive-dfun f ⟧DFun ρ1 dρ) from (⟦ f ⟧Fun ρ1) to (⟦ f ⟧Fun ρ2)
fromtoDeriveDFun (term t) = fromtoDeriveDTerm t
fromtoDeriveDFun (abs f) dρρ = λ dv v1 v2 dvv → fromtoDeriveDFun f (dvv v• dρρ)

module Thesis.ANormalDTerm where

open import Thesis.ANormal

{-
Try defining an alternative syntax for differential terms. We'll need this for
cache terms. Maybe?

Options:

1. use standard untyped lambda calculus as a target language. This requires much
more weakening in the syntax, which is a nuisance in proofs. Maybe use de Bruijn
levels instead?

2. use a specialized syntax as a target language.

3. use separate namespaces, environments, and so on?

Also, caching uses quite a bit of sugar on top of lambda calculus, with pairs
and what not.
-}

{-
-- To define an alternative syntax for the derivation output, let's remember that:
derive (var x) = dvar dx
derive (let y = f x in t) = let y = f x ; dy = df x dx in derive t
-}

-- Attempt 1 leads to function calls in datatype indexes. That's very very bad!
module Try1 where

-- data DTerm : (Γ : Context) (τ : Type) → Set where
--   dvar : ∀ {Γ τ} (x : Var Γ τ) →
--     DTerm (ΔΓ Γ) (Δt τ)
--   dlett : ∀ {Γ σ τ₁ τ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) → DTerm (Δt τ₁ • τ₁ • ΔΓ Γ) (Δt τ) → DTerm (ΔΓ Γ) (Δt τ)

-- derive-dterm : ∀ {Γ τ} → Term Γ τ → DTerm (ΔΓ Γ) (Δt τ)
-- derive-dterm (var x) = dvar x
-- derive-dterm (lett f x t) = dlett f x (derive-dterm t)

-- Case split on dt FAILS!
-- ⟦_⟧DTerm : ∀ {Γ τ} → DTerm (ΔΓ Γ) (Δt τ) → ⟦ ΔΓ Γ ⟧Context → ⟦ Δt τ ⟧Type
-- ⟦ dt ⟧DTerm ρ = {!dt!}

ΔΔ : Context → Context
ΔΔ ∅ = ∅
ΔΔ (τ • Γ) = Δt τ • ΔΔ Γ
Δτ = Δt

ChΔ : ∀ (Δ : Context) → Set
ChΔ Δ = ⟦ ΔΔ Δ ⟧Context

-- changeStructureΔ : ∀ Δ → ChangeStructure ⟦ Δ ⟧Context
-- changeStructureΔ = {!!}
-- ch_from_to_ {{changeStructureΔ Δ}}
-- [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set
-- [ ∅ ]Δ ∅ from ∅ to ∅ = ⊤
-- [ τ • Δ ]Δ dv • dρ from v1 • ρ1 to (v2 • ρ2) = [ τ ]τ dv from v1 to v2 × [ Δ ]Δ dρ from ρ1 to ρ2

-- Δ is bound to the change type! Not good!
data [_]Δ_from_to_ : ∀ Δ → ChΔ Δ → (ρ1 ρ2 : ⟦ Δ ⟧Context) → Set where
  v∅ : [ ∅ ]Δ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Δ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Δ ]Δ dρ from ρ1 to ρ2) →
    [ τ • Δ ]Δ (dv • dρ) from (v1 • ρ1) to (v2 • ρ2)

module Try3 where
  derive-dvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔ Δ) (Δτ σ)
  derive-dvar this = this
  derive-dvar (that x) = that (derive-dvar x)

  fromtoDeriveDVar : ∀ {Δ τ} → (x : Var Δ τ) →
    ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ derive-dvar x ⟧Var dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
  fromtoDeriveDVar this (dvv v• dρρ) = dvv
  fromtoDeriveDVar (that x) (dvv v• dρρ) = fromtoDeriveDVar x dρρ

  -- A DTerm evaluates in normal context Δ, change context (ΔΔ Δ), and produces
  -- a result of type (Δt τ).
  data DTerm : (Δ : Context) (τ : Type) → Set where
    dvar : ∀ {Δ τ} (x : Var (ΔΔ Δ) (Δt τ)) →
      DTerm Δ τ
    dlett : ∀ {Δ τ σ τ₁} →
      (f : Var Δ (σ ⇒ τ₁)) →
      (x : Var Δ σ) →
      (t : Term (τ₁ • Δ) τ) →
      (df : Var (ΔΔ Δ) (Δτ (σ ⇒ τ₁))) →
      (dx : Var (ΔΔ Δ) (Δτ σ)) →
      (dt : DTerm (τ₁ • Δ) τ) →
      DTerm Δ τ

  data DFun (Δ : Context) : (τ : Type) → Set where
    dterm : ∀ {τ} → DTerm Δ τ → DFun Δ τ
    dabs : ∀ {σ τ} → DFun (σ • Δ) τ → DFun Δ (σ ⇒ τ)

  derive-dterm : ∀ {Δ σ} → (t : Term Δ σ) → DTerm Δ σ
  derive-dterm (var x) = dvar (derive-dvar x)
  derive-dterm (lett f x t) =
    dlett f x t (derive-dvar f) (derive-dvar x) (derive-dterm t)

  ⟦_⟧DTerm : ∀ {Δ τ} → DTerm Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
  ⟦ dvar x ⟧DTerm ρ dρ = ⟦ x ⟧Var dρ
  ⟦ dlett f x t df dx dt ⟧DTerm ρ dρ =
    let v = (⟦ x ⟧Var ρ)
    in
      ⟦ dt ⟧DTerm
        (⟦ f ⟧Var ρ v • ρ)
        (⟦ df ⟧Var dρ v (⟦ dx ⟧Var dρ) • dρ)

  fromtoDeriveDTerm : ∀ {Δ τ} → (t : Term Δ τ) →
    ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ derive-dterm t ⟧DTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
  fromtoDeriveDTerm (var x) dρρ = fromtoDeriveDVar x dρρ
  fromtoDeriveDTerm (lett f x t) dρρ =
    let fromToF = fromtoDeriveDVar f dρρ
        fromToX = fromtoDeriveDVar x dρρ
        fromToFX = fromToF _ _ _ fromToX
    in fromtoDeriveDTerm t (fromToFX v• dρρ)

  derive-dfun : ∀ {Δ σ} → (t : Fun Δ σ) → DFun Δ σ
  derive-dfun (term t) = dterm (derive-dterm t)
  derive-dfun (abs f) = dabs (derive-dfun f)

  ⟦_⟧DFun : ∀ {Δ τ} → DFun Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
  ⟦ dterm t ⟧DFun = ⟦ t ⟧DTerm
  ⟦ dabs df ⟧DFun ρ dρ = λ v dv → ⟦ df ⟧DFun (v • ρ) (dv • dρ)

  fromtoDeriveDFun : ∀ {Δ τ} → (f : Fun Δ τ) →
    ∀ {dρ ρ1 ρ2} → [ Δ ]Δ dρ from ρ1 to ρ2 →
    [ τ ]τ (⟦ derive-dfun f ⟧DFun ρ1 dρ) from (⟦ f ⟧Fun ρ1) to (⟦ f ⟧Fun ρ2)
  fromtoDeriveDFun (term t) = fromtoDeriveDTerm t
  fromtoDeriveDFun (abs f) dρρ = λ dv v1 v2 dvv → fromtoDeriveDFun f (dvv v• dρρ)

module Try2 where
  -- This is literally isomorphic to the source type :-| derivation is part of erasure...
  data DTerm : (Γ : Context) (τ : Type) → Set where
    dvar : ∀ {Γ τ} (x : Var Γ τ) →
      DTerm Γ τ
  --  dlett : ∀ {Γ σ τ₁ τ} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) → DTerm (Δt τ₁ • τ₁ • ΔΓ Γ) (Δt τ) → DTerm (ΔΓ Γ) (Δt τ)

    dlett : ∀ {Γ τ σ τ₁} → (f : Var Γ (σ ⇒ τ₁)) → (x : Var Γ σ) →
      DTerm (τ₁ • Γ) τ →
      DTerm Γ τ

  derive-dterm : ∀ {Γ τ} → Term Γ τ → DTerm Γ τ
  derive-dterm (var x) = dvar x
  derive-dterm (lett f x t) = dlett f x (derive-dterm t)

  -- Incremental semantics over terms. Same results as base semantics over change
  -- terms. But less weakening.
  ⟦_⟧DTerm : ∀ {Γ τ} → DTerm Γ τ → ⟦ ΔΓ Γ ⟧Context → ⟦ Δt τ ⟧Type
  ⟦ dvar x ⟧DTerm dρ = ⟦ derive-var x ⟧Var dρ
  ⟦ dlett f x dt ⟧DTerm dρ =
    let ρ = ⟦ Γ≼ΔΓ ⟧≼ dρ
    in ⟦ dt ⟧DTerm
      ( ⟦ derive-var f ⟧Var dρ (⟦ x ⟧Var ρ) (⟦ derive-var x ⟧Var dρ)
      • ⟦ f ⟧Var ρ (⟦ x ⟧Var ρ)
      • dρ)


ZK.GroupHom.ElGamal: add proofs of equality of message (two styles)

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Type.Eq
open import Function.NP using (flip; _∘_; it)
open import Data.Product.NP
open import Data.Two hiding (_²)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (idp; _≡_; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Constructions
open import Algebra.Group.Homomorphism
import ZK.GroupHom
open import ZK.GroupHom.Types

module ZK.GroupHom.ElGamal
  (G+ G* : Type)
  (𝔾+ : Group G+)
  (𝔾* : Group G*)
  (G*-eq? : Eq? G*)
  (_^_ : G* → G+ → G*)
  (^-hom : ∀ b → GroupHomomorphism 𝔾+ 𝔾* (_^_ b))
  (g : G*)
  where

module 𝔾* = Group 𝔾*
open Additive-Group 𝔾+
open module MG = Multiplicative-Group 𝔾* hiding (_^_; _²)
module ^ b = GroupHomomorphism (^-hom b)

_² : Type → Type
A ² = A × A

-- TODO: Re-use another module
module ElGamal-encryption where
  PubKey  = G*
  PrivKey = G+
  EncRnd  = G+ {- randomness used for encryption of ct -}
  Message = G* {- plain text message -}
  CipherText = G* × G*

  module CipherText (ct : CipherText) where
    α β : G*
    α = fst ct
    β = snd ct

  pub-of : PrivKey → PubKey
  pub-of sk = g ^ sk

  enc : PubKey → Message → EncRnd → CipherText
  enc y M r = α , β
    module enc where
      α = g ^ r
      β = (y ^ r) * M

  dec : PrivKey → CipherText → Message
  dec sk (α , β) = (α ^ sk)⁻¹ * β

open ElGamal-encryption

open Product

_²-grp : {A : Type} → Group A → Group (A ²)
𝔸 ²-grp = ×-grp 𝔸 𝔸

𝕄 : Group Message
𝕄 = 𝔾*

ℂ𝕋 : Group CipherText
ℂ𝕋 = ×-grp 𝔾* 𝔾*

-- CP : (g₀ g₁ u₀ u₁ : G) (w : ℤq) → Type
-- CP g₀ g₁ u₀ u₁ w = (g₀ ^ w ≡ u₀) × (g₁ ^ w ≡ u₁)

-- CP : (g₀ g₁ u₀ u₁ : G*) (w : G+) → Type
-- CP g₀ g₁ u₀ u₁ w = ✓ (((g₀ ^ w) == u₀) ∧ ((g₁ ^ w) == u₁))

module Known-enc-rnd
         (y  : PubKey)
         (M  : Message)
         (ct : CipherText)
         where
  module ct = CipherText ct

  Valid-witness : EncRnd → Type
  Valid-witness r = enc y M r ≡ ct

  zk-hom : ZK-hom _ _ Valid-witness
  zk-hom = record
    { φ-hom = < ^-hom g , ^-hom y >-hom
    ; y = ct.α , ct.β / M
    ; φ⇒P = λ _ e → ap₂ (λ p q → fst p , q) e
                        (ap (flip _*_ M ∘ snd) e ∙ ! /-*)
    ; P⇒φ = λ _ e → ap₂ _,_ (ap fst e)
                            (*-/ ∙ ap (flip _/_ M) (ap snd e))
    }

open ≡-Reasoning

/⁻¹-* : ∀ {x y} → (x / y)⁻¹ * x ≡ y
/⁻¹-* {x} {y} =
  (x / y)⁻¹ * x        ≡⟨ ap (λ z → z * x) ⁻¹-hom′ ⟩
  y ⁻¹ ⁻¹ * x ⁻¹ * x   ≡⟨ *-assoc ⟩
  y ⁻¹ ⁻¹ * (x ⁻¹ * x) ≡⟨ ap₂ _*_ ⁻¹-involutive (fst ⁻¹-inverse) ⟩
  y * 1#               ≡⟨ *1-identity ⟩
  y                    ∎

/-⁻¹* : ∀ {x y} → x / (y ⁻¹ * x) ≡ y
/-⁻¹* {x} {y} =
  x * (y ⁻¹ * x) ⁻¹    ≡⟨ ap (_*_ x) ⁻¹-hom′ ⟩
  x * (x ⁻¹ * y ⁻¹ ⁻¹) ≡⟨ ! *-assoc ⟩
  (x * x ⁻¹) * y ⁻¹ ⁻¹ ≡⟨ *= (snd ⁻¹-inverse) ⁻¹-involutive ⟩
  1# * y               ≡⟨ 1*-identity ⟩
  y                    ∎

x⁻¹y≡1→x≡y : ∀ {x y} → x ⁻¹ * y ≡ 1# → x ≡ y
x⁻¹y≡1→x≡y e = cancels-*-left (fst ⁻¹-inverse ∙ ! e)

module Known-dec
         (y  : PubKey)
         (M  : Message)
         (ct : CipherText)
         where
  module ct = CipherText ct

  Valid-witness : PrivKey → Type
  Valid-witness sk = (g ^ sk ≡ y) × (dec sk ct ≡ M)

  zk-hom : ZK-hom _ _ Valid-witness
  zk-hom = record
    { φ-hom = < ^-hom g , ^-hom ct.α >-hom
    ; y = y , ct.β / M
    ; φ⇒P = λ x e → ap fst e , ap (λ z → z ⁻¹ * ct.β) (ap snd e) ∙ /⁻¹-*
    ; P⇒φ = λ x e → ap₂ _,_ (fst e) (! /-⁻¹* ∙ ap (_/_ ct.β) (snd e))
    }

-- Inverse of ciphertexts
_⁻¹CT : CipherText → CipherText
(α , β)⁻¹CT = α ⁻¹ , β ⁻¹

-- Division of ciphertexts
_/CT_ : CipherText → CipherText → CipherText
(α₀ , β₀) /CT (α₁ , β₁) = (α₀ / α₁) , (β₀ / β₁)

-- TODO: Move this elsewhere (Cipher.ElGamal.Homomorphic)
import Algebra.FunctionProperties.Eq as FP
open FP.Implicits
open import Algebra.Group.Abelian
module From-*-comm
         (*-comm : Commutative _*_)
         where
  private
    module 𝔾*-comm = Abelian-Group-Struct (𝔾*.grp-struct , *-comm)

  hom-enc : (y : PubKey) → GroupHomomorphism (×-grp 𝕄 𝔾+) ℂ𝕋 (uncurry (enc y))
  hom-enc y = mk λ { {M₀ , r₀} {M₁ , r₁} →
    ap₂ _,_ (^.hom _)
        (enc.β y (M₀ * M₁) (r₀ + r₁)   ≡⟨by-definition⟩
         y ^ (r₀ + r₁)     * (M₀ * M₁) ≡⟨ *= (^.hom y) idp ⟩
         (y ^ r₀ * y ^ r₁) * (M₀ * M₁) ≡⟨ 𝔾*-comm.interchange ⟩
         enc.β y M₀ r₀ * enc.β y M₁ r₁ ∎) }

  module hom-enc y = GroupHomomorphism (hom-enc y)

  -- The encryption of the inverse is the inverse of the encryption
  -- (notice that the randomnesses seems to be negated only because we give an additive notation to our G+ group)
  enc-⁻¹ : ∀ {y M r} → enc y (M ⁻¹) (0− r) ≡ enc y M r ⁻¹CT
  enc-⁻¹ = hom-enc.pres-inv _

  -- The encryption of the division is the division of the encryptions
  -- (notice that the randomnesses seems to be subtracted only because we give an additive notation to our G+ group)
  enc-/ : ∀ {y M₀ r₀ M₁ r₁} → enc y (M₀ / M₁) (r₀ − r₁) ≡ enc y M₀ r₀ /CT enc y M₁ r₁
  enc-/ = hom-enc.−-/ _

  -- Alice wants to prove to the public that she encrypted the
  -- same message for two (potentially different) recepients
  -- without revealing the content of the message or the randomness
  -- used for the encryptions.
  module Message-equality-enc
           (y₀  y₁  : PubKey)
           (ct₀ ct₁ : CipherText)
           where
    module ct₀ = CipherText ct₀
    module ct₁ = CipherText ct₁

    Witness = Message × EncRnd ²
    Statement = CipherText ²

    Valid-witness : Witness → Type
    Valid-witness (M , r₀ , r₁) = enc y₀ M r₀ ≡ ct₀ × enc y₁ M r₁ ≡ ct₁

    private
        θ : Message × EncRnd ² → (Message × EncRnd)²
        θ (M , r₀ , r₁) = ((M , r₀) , (M , r₁))

        θ-hom : GroupHomomorphism (×-grp 𝕄 (𝔾+ ²-grp)) ((×-grp 𝕄 𝔾+)²-grp) θ
        θ-hom = mk idp

    φ-hom : GroupHomomorphism _ _ _
    φ-hom = < hom-enc y₀ × hom-enc y₁ >-hom ∘-hom θ-hom

    zk-hom : ZK-hom _ _ Valid-witness
    zk-hom = record
      { φ-hom = φ-hom
      ; y = ct₀ , ct₁
      ; φ⇒P = λ _ e → ap fst e , ap snd e
      ; P⇒φ = λ x e → ap₂ _,_ (fst e) (snd e)
      }

  module From-flip-^-hom
           (flip-^-hom : ∀ x → GroupHomomorphism 𝔾* 𝔾* (flip _^_ x))
         where
    module flip-^ x = GroupHomomorphism (flip-^-hom x)

    hom-dec : (x : PrivKey) → GroupHomomorphism ℂ𝕋 𝕄 (dec x)
    hom-dec x = mk λ { {α₀ , β₀} {α₁ , β₁} →
      dec x (α₀ * α₁ , β₀ * β₁)           ≡⟨by-definition⟩
      ((α₀ * α₁) ^ x)⁻¹ * (β₀ * β₁)       ≡⟨ ap (λ z → _*_ (_⁻¹ z) (_*_ β₀ β₁)) (flip-^.hom x) ⟩
      (α₀ ^ x * α₁ ^ x)⁻¹ * (β₀ * β₁)     ≡⟨ *= 𝔾*-comm.⁻¹-hom idp ⟩
      (α₀ ^ x)⁻¹ * (α₁ ^ x)⁻¹ * (β₀ * β₁) ≡⟨ 𝔾*-comm.interchange ⟩
      dec x (α₀ , β₀) * dec x (α₁ , β₁)   ∎ }

    module hom-dec x = GroupHomomorphism (hom-dec x)

    -- Bob wants to prove to the public that he decrypted two
    -- ciphertexts which decrypt to the same message,
    -- without revealing the content of the message or his
    -- secret key.
    -- The two ciphertexts are encrypted using the same public key.
    module Message-equality-dec
         (y : PubKey)
         (ct₀ ct₁ : CipherText)
         where
      private
        module ct₀ = CipherText ct₀
        module ct₁ = CipherText ct₁

        α/ = ct₀.α / ct₁.α
        β/ = ct₀.β / ct₁.β

      Valid-witness : PrivKey → Type
      Valid-witness sk = pub-of sk ≡ y × dec sk ct₀ ≡ dec sk ct₁

      zk-hom : ZK-hom _ _ Valid-witness
      zk-hom = record
        { φ-hom = < ^-hom g , ^-hom (ct₀.α / ct₁.α) >-hom
        ; y = y , ct₀.β / ct₁.β
        ; φ⇒P = λ x e →
                  ap fst e ,
                  x/y≡1→x≡y
                  (dec x ct₀ / dec x ct₁ ≡⟨ ! hom-dec.−-/ x ⟩
                   dec x (ct₀ /CT ct₁) ≡⟨by-definition⟩
                   dec x (α/ , β/) ≡⟨ ! ap (λ z → dec x (α/ , snd z)) e ⟩
                   dec x (α/ , (α/)^ x) ≡⟨ fst ⁻¹-inverse ⟩
                   1# ∎)
        ; P⇒φ = λ x e → ap₂ _,_ (fst e)
                  (x⁻¹y≡1→x≡y
                     (dec x (α/ , β/)       ≡⟨ hom-dec.−-/ x ⟩
                      dec x ct₀ / dec x ct₁ ≡⟨ /= (snd e) idp ⟩
                      dec x ct₁ / dec x ct₁ ≡⟨ snd ⁻¹-inverse ⟩
                      1#                    ∎))
        }

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

{-# OPTIONS --without-K #-}
open import Type using (Type)
open import Function using (flip; _∘_)
open import Data.Product renaming (proj₁ to fst; proj₂ to snd)
open import Data.Two
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; ap; ap₂; !_; _∙_; module ≡-Reasoning)
open import Algebra.Group
open import Algebra.Group.Constructions
open import Algebra.Group.Homomorphism
import ZK.SigmaProtocol.KnownStatement
import ZK.GroupHom
open import ZK.GroupHom.Types

module ZK.GroupHom.ElGamal
  (G+ G* : Type)
  (𝔾+ : Group G+)
  (𝔾* : Group G*)
  (_==_ : G* → G* → 𝟚)
  (✓-== : ∀ {x y} → x ≡ y → ✓ (x == y))
  (==-✓ : ∀ {x y} → ✓ (x == y) → x ≡ y)
  (_^_ : G* → G+ → G*)
  (^-hom : ∀ b → GroupHomomorphism 𝔾+ 𝔾* (_^_ b))
  (g : G*)
  where

  open Additive-Group 𝔾+
  open Multiplicative-Group 𝔾* hiding (_^_)

-- TODO: Re-use another module
  module ElGamal-encryption where
    record CipherText : Type where
      constructor _,_
      field
        α β : G*

    PubKey  = G*
    PrivKey = G+
    EncRnd  = G+ {- randomness used for encryption of ct -}
    Message = G* {- plain text message -}

    enc : PubKey → EncRnd → Message → CipherText
    enc y r M = α , β where
      α = g ^ r
      β = (y ^ r) * M

    dec : PrivKey → CipherText → Message
    dec x ct = (α ^ x)⁻¹ * β where
      open CipherText ct

  open ElGamal-encryption

  -- CP : (g₀ g₁ u₀ u₁ : G) (w : ℤq) → Type
  -- CP g₀ g₁ u₀ u₁ w = (g₀ ^ w ≡ u₀) × (g₁ ^ w ≡ u₁)

  -- CP : (g₀ g₁ u₀ u₁ : G*) (w : G+) → Type
  -- CP g₀ g₁ u₀ u₁ w = ✓ (((g₀ ^ w) == u₀) ∧ ((g₁ ^ w) == u₁))

  module _ (y  : PubKey)
           (M  : Message)
           (ct : CipherText)
           where
    module CT = CipherText ct

    KnownEncRnd : EncRnd → Type
    KnownEncRnd r = enc y r M ≡ ct

    known-enc-rnd : GrpHom _ _ KnownEncRnd
    known-enc-rnd = record
      { 𝔾+ = 𝔾+
      ; 𝔾* = Product.×-grp 𝔾* 𝔾*
      ; _==_ = λ x y → fst x == fst y ∧ snd x == snd y
      ; ✓-== = λ e → ✓∧ (✓-== (ap fst e)) (✓-== (ap snd e))
      ; ==-✓ = λ e → let p = ✓∧× e in
                     ap₂ _,_ (==-✓ (fst p))
                             (==-✓ (snd p))
      ; φ = _
      ; φ-hom = Pair.pair-hom _ _ _ (_^_ g) (^-hom g)
                                    (_^_ y) (^-hom y)
      ; y = CT.α , CT.β / M
      ; φ⇒P = λ _ e → ap₂ (λ p q → fst p , q) e
                          (ap (flip _*_ M ∘ snd) e ∙ ! /-*)
      ; P⇒φ = λ _ e → ap₂ _,_ (ap CipherText.α e)
                              (*-/ ∙ ap (flip _/_ M) (ap CipherText.β e))
      }

    KnownDec : PrivKey → Type
    KnownDec x = (g ^ x ≡ y) × (dec x ct ≡ M)

    open ≡-Reasoning

    /⁻¹-* : ∀ {x y} → (x / y)⁻¹ * x ≡ y
    /⁻¹-* {x} {y} =
      (x / y)⁻¹ * x        ≡⟨ ap (λ z → z * x) ⁻¹-hom′ ⟩
      y ⁻¹ ⁻¹ * x ⁻¹ * x   ≡⟨ *-assoc ⟩
      y ⁻¹ ⁻¹ * (x ⁻¹ * x) ≡⟨ ap₂ _*_ ⁻¹-involutive (fst ⁻¹-inverse) ⟩
      y * 1#               ≡⟨ *1-identity ⟩
      y                    ∎

    /-⁻¹* : ∀ {x y} → x / (y ⁻¹ * x) ≡ y
    /-⁻¹* {x} {y} =
      x * (y ⁻¹ * x) ⁻¹    ≡⟨ ap (_*_ x) ⁻¹-hom′ ⟩
      x * (x ⁻¹ * y ⁻¹ ⁻¹) ≡⟨ ! *-assoc ⟩
      (x * x ⁻¹) * y ⁻¹ ⁻¹ ≡⟨ *= (snd ⁻¹-inverse) ⁻¹-involutive ⟩
      1# * y               ≡⟨ 1*-identity ⟩
      y                    ∎

    known-dec : GrpHom _ _ KnownDec
    known-dec = record
      { 𝔾+ = 𝔾+
      ; 𝔾* = Product.×-grp 𝔾* 𝔾*
      ; _==_ = λ x y → fst x == fst y ∧ snd x == snd y
      ; ✓-== = λ e → ✓∧ (✓-== (ap fst e)) (✓-== (ap snd e))
      ; ==-✓ = λ e → let p = ✓∧× e in
                     ap₂ _,_ (==-✓ (fst p))
                             (==-✓ (snd p))
      ; φ = _
      ; φ-hom = Pair.pair-hom _ _ _ (_^_ g)    (^-hom g)
                                    (_^_ CT.α) (^-hom CT.α)
      ; y = y , CT.β / M
      ; φ⇒P = λ x e → ap fst e , ap (λ z → z ⁻¹ * CT.β) (ap snd e) ∙ /⁻¹-*
      ; P⇒φ = λ x e → ap₂ _,_ (fst e) (! /-⁻¹* ∙ ap (_/_ CT.β) (snd e))
      }

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


Desc model: implicit refl, cong, cong2, reflFun, desc, and IMu

 {-# OPTIONS --type-in-type #-}

module IDesc_type_type where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
data Unit  : Set where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

cong : (A : Set)(B : Set)(f : A -> B)(x y : A) -> x == y -> f x == f y
cong A B f x .x refl = refl

cong2 : (A B C : Set)(f : A -> B -> C)(x y : A)(z t : B) ->
        x == y -> z == t -> f x z == f y t
cong2 A B C f x .x z .z refl refl = refl

-- Intensionally extensional
postulate
  reflFun : (A : Set)(B : Set)(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : (I : Set) -> IDesc I -> (I -> Set) -> Set
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu (I : Set)(R : I -> IDesc I)(i : I) : Set where
  con : desc I (R i) (\j -> IMu I R j) -> IMu I R i

--********************************************
-- Predicate: Box
--********************************************

box : (I : Set)(D : IDesc I)(P : I -> Set) -> desc I D P -> IDesc (Sigma I P)
box I (var i)     P x        = var (i , x)
box I (const X)   P x        = const X
box I (prod D D') P (d , d') = prod (box I D P d) (box I D' P d')
box I (sigma S T) P (a , b)  = box I (T a) P b
box I (pi S T)    P f        = pi S (\s -> box I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (I : Set)
            (R : I -> IDesc I)
            (P : Sigma I (IMu I R) -> Set)
            (m : (i : I)
                 (xs : desc I (R i) (IMu I R))
                 (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc I D (IMu I R)) ->
           desc (Sigma I (IMu I R)) (box I D (IMu I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (I : Set)
            (R : I -> IDesc I)
            (P : Sigma I (IMu I R) -> Set)
            (m : (i : I)
                 (xs : desc I (R i) (IMu I R))
                 (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu I R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : Set -> DescDConst -> IDesc Unit
descDChoice I lvar = const I
descDChoice _ lconst = const Set
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma Set (\S -> pi S (\s -> var Void))
descDChoice _ lsigma = sigma Set (\S -> pi S (\s -> var Void))

descD : (I : Set) -> IDesc Unit
descD I = sigma DescDConst (descDChoice I)

IDescl : (I : Set) -> Set
IDescl I = IMu Unit (\_ -> descD I) Void

varl : (I : Set)(i : I) -> IDescl I
varl I i = con (lvar ,  i)

constl : (I : Set)(X : Set) -> IDescl I
constl I X = con (lconst , X)

prodl : (I : Set)(D D' : IDescl I) -> IDescl I
prodl I D D' = con (lprod , (D , D'))

pil : (I : Set)(S : Set)(T : S -> IDescl I) -> IDescl I
pil I S T = con (lpi , ( S , T))

sigmal : (I : Set)(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal I S T = con (lsigma , ( S , T))

cases : (I : Set)
        (xs : desc Unit (descD I) (IMu Unit (λ _ -> descD I)))
        (hs : desc (Sigma Unit (IMu Unit (λ _ -> descD I)))
              (box Unit (descD I) (IMu Unit (λ _ -> descD I)) xs) (λ _ -> IDesc I)) ->
        IDesc I
cases I ( lvar , i ) hs =  var i
cases I ( lconst , X ) hs =  const X
cases I ( lprod , (D , D') ) ( d , d' ) =  prod d d'
cases I ( lpi , ( S , T ) ) hs =  pi S hs
cases I ( lsigma , ( S , T ) ) hs = sigma S hs

iso1 : (I : Set) -> IDescl I -> IDesc I
iso1 I d = induction Unit (\_ -> descD I) (\_ -> IDesc I) (\_ -> cases I) Void d

iso2 : (I : Set) -> IDesc I -> IDescl I
iso2 I (var i) = varl I i
iso2 I (const X) = constl I X
iso2 I (prod D D') = prodl I (iso2 I D) (iso2 I D')
iso2 I (pi S T) = pil I S (\s -> iso2 I (T s))
iso2 I (sigma S T) = sigmal I S (\s -> iso2 I (T s))

proof-iso1-iso2 : (I : Set) -> (D : IDesc I) -> iso1 I (iso2 I D) == D
proof-iso1-iso2 I (var i) = refl
proof-iso1-iso2 I (const x) = refl
proof-iso1-iso2 I (prod D D') with proof-iso1-iso2 I D | proof-iso1-iso2 I D'
...                             | p | q = cong2 (IDesc I)
                                                (IDesc I)
                                                (IDesc I)
                                                prod
                                                (iso1 I (iso2 I D))
                                                D
                                                (iso1 I (iso2 I D'))
                                                D' p q
proof-iso1-iso2 I (pi S T) = cong (S → IDesc I)
                                  (IDesc I)
                                  (pi S)
                                  (\x -> iso1 I (iso2 I (T x)))
                                  T
                                  (reflFun S (IDesc I)
                                             (λ s → iso1 I (iso2 I (T s)))
                                             T
                                             (\s -> proof-iso1-iso2 I (T s)))
proof-iso1-iso2 I (sigma S T) = cong (S → IDesc I)
                                     (IDesc I)
                                     (sigma S)
                                     (\x -> iso1 I (iso2 I (T x)))
                                     T
                                     (reflFun S
                                              (IDesc I)
                                              (λ s → iso1 I (iso2 I (T s)))
                                              T
                                              (\s -> proof-iso1-iso2 I (T s)))

-- induction : (I : Set)
--             (R : I -> IDesc I)
--             (P : Sigma I (IMu I R) -> Set)
--             (m : (i : I)
--                  (xs : desc I (R i) (IMu I R))
--                  (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
--                  P ( i , con xs)) ->
--             (i : I)(x : IMu I R i) -> P ( i , x )

P : (I : Set) -> Sigma Unit (IMu Unit (λ x → sigma DescDConst (descDChoice I))) → Set
P I ( Void , D ) = iso2 I (iso1 I D) == D

proof-iso2-iso1 : (I : Set) -> (D : IDescl I) -> iso2 I (iso1 I D) == D
proof-iso2-iso1 I D =  induction Unit
                                 (λ _ → descD I)
                                 (P I)
                                 (proof-iso2-iso1-casesW I)
                                 Void
                                 D
                where proof-iso2-iso1-cases : (I : Set)
                                              (xs : Sigma DescDConst
                                                    (λ s → desc Unit (descDChoice I s)
                                                    (IMu Unit (λ x → sigma DescDConst (descDChoice I)))))
                                              (hs : desc (Sigma Unit (IMu Unit (λ x → sigma DescDConst (descDChoice I))))
                                                    (box Unit (sigma DescDConst (descDChoice I))
                                                    (IMu Unit (λ x → sigma DescDConst (descDChoice I))) xs)
                                                    (P I))
                                              → P I (Void , con xs)
                      proof-iso2-iso1-cases I (lvar , i) hs = refl
                      proof-iso2-iso1-cases I (lconst , x) hs = refl
                      proof-iso2-iso1-cases I (lprod , ( D , D' )) ( p , q ) = cong2 (IDescl I)
                                          (IDescl I)
                                          (IDescl I)
                                          (prodl I)
                                          (iso2 I (iso1 I D))
                                          D
                                          (iso2 I (iso1 I D'))
                                          D' p q
                      proof-iso2-iso1-cases I (lpi , ( S , T )) hs = cong (S → IDescl I)
                                                                          (IDescl I)
                                                                          (pil I S)
                                                                          (\x -> iso2 I (iso1 I (T x)))
                                                                          T
                                                                          (reflFun S
                                                                                (IDescl I)
                                                                                (λ s → iso2 I (iso1 I (T s)))
                                                                                T
                                                                                hs)
                      proof-iso2-iso1-cases I (lsigma , ( S , T )) hs = cong (S → IDescl I)
                                                                             (IDescl I)
                                                                             (sigmal I S)
                                                                             (\x -> iso2 I (iso1 I (T x)))
                                                                             T
                                                                             (reflFun S
                                                                                (IDescl I)
                                                                                (λ s → iso2 I (iso1 I (T s)))
                                                                                T
                                                                                hs)
                      proof-iso2-iso1-casesW : (I : Set)
                                               (i : Unit)
                                               (xs : Sigma DescDConst
                                                     (λ s → desc Unit (descDChoice I s)
                                                     (IMu Unit (λ x → sigma DescDConst (descDChoice I)))))
                                               (hs : desc (Sigma Unit (IMu Unit (λ x → sigma DescDConst (descDChoice I))))
                                                     (box Unit (sigma DescDConst (descDChoice I))
                                                     (IMu Unit (λ x → sigma DescDConst (descDChoice I))) xs)
                                                     (P I))
                                                →  P I (i , con xs)
                      proof-iso2-iso1-casesW I Void = proof-iso2-iso1-cases I


Modified an test.

Modified an test.

Ignore-this: 30e5806c631a8cb97aad3bc3c86b42f2

darcs-hash:20100803031659-3bd4e-82749625a9fcb9680e9b52cf09533165cb2e04d7.gz

module Test.Succeed.DefinitionsInsideWhereClauses where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_  : D → D → D
  +-0x : (d : D) → zero + d     ≡ d
  +-Sx : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

+-rightIdentity : {n : D} → N n → n + zero ≡ n
+-rightIdentity {n} Nn = indN Q Q0 iStep Nn
  where
    Q : D → Set
    Q i = i + zero ≡ i
    {-# ATP definition Q #-}

    postulate
      Q0 : Q zero
    {-# ATP prove Q0 #-}

    postulate
      iStep : {i : D} → N i → Q i → Q (succ i)
    {-# ATP prove iStep #-}

module Test.Succeed.DefinitionsInsideWhereClauses where

infixl 6 _+_
infix  4 _≡_

postulate
  D      : Set
  zero   : D
  succ   : D → D
  _≡_    : D → D → Set

-- The LTC natural numbers type.
data N : D → Set where
  zN : N zero
  sN : {n : D} → N n → N (succ n)

-- Induction principle for N (elimination rule).
indN : (P : D → Set) →
       P zero →
       ({n : D} → N n → P n → P (succ n)) →
       {n : D} → N n → P n
indN P p0 h zN      = p0
indN P p0 h (sN Nn) = h Nn (indN P p0 h Nn)

postulate
  _+_    : D → D → D
  +-0x : (d : D) → zero + d     ≡ d
  +-Sx : (d e : D) → succ d + e ≡ succ (d + e)
{-# ATP axiom +-0x #-}
{-# ATP axiom +-Sx #-}

+-leftIdentity : {n : D} → N n → zero + n ≡ n
+-leftIdentity {n} Nn = indN P P0 iStep Nn
  where
    P : D → Set
    P i = zero + i ≡ i
    {-# ATP definition P #-}

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

    postulate
      iStep : {i : D} → N i → P i → P (succ i)
    {-# ATP prove iStep #-}


Examples: update

Examples: update

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Level.NP
open import Data.Product.NP using (_,_)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.Two hiding (_≟_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; coe)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences

open import Control.Protocol

module Control.Protocol.Examples where

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

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

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

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

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

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

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

        Verifier : Proto
        Verifier = dual Prover

        -- He is honest but its type does not say it
        -- The definition for "prover" below is derived from
        -- a well typed version.
        prover' : (x r : ℤq) → ⟦ Prover ⟧
        prover' x r = (g ^ r) , λ c → (r + (c * x)) , _

        verifier : (c : ℤq) → ⟦ Verifier ⟧
        verifier c _ = c , _

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

            Honest-Verifier : Proto
            Honest-Verifier = dual Honest-Prover

            honest-verifier' : (c : ℤq) → ⟦ Honest-Verifier ⟧
            honest-verifier' c [ r ] gʳ = c , λ s → _ ≟ _ , _

            sim-honest-prover : ⟦ Honest-Prover ⊸ Prover ⟧
            sim-honest-prover [ r ] S[ gʳ ∥ gʳ= ] = inr gʳ , λ c →
                                                    inl c  , λ { S[ s ∥ s= ] →
                                                    inr s  ,
                                                    _ ≟ _  ,
                                                    end }

            -- The next version is derived from sim-honest-prover
            honest-prover→prover' : ⟦ Honest-Prover ⟧ → ⟦ Prover ⟧
            honest-prover→prover' ([ r ] , gʳ , p) = unS gʳ , λ c → case p c of λ { (s , _) → unS s , _ }

            module _ {{_ : FunExt}}{{_ : UA}} where
                sim-honest-verifier : ⟦ Verifier ⊸ Honest-Verifier ⟧
                sim-honest-verifier = coe (⅋-comm Honest-Verifier _) sim-honest-prover

                honest-prover→prover : ⟦ Honest-Prover ⟧ → ⟦ Prover ⟧
                honest-prover→prover = ⊸-apply {Honest-Prover} sim-honest-prover

                verifier→honest-verifier : ⟦ Verifier ⟧ → ⟦ Honest-Verifier ⟧
                verifier→honest-verifier = ⊸-apply {Verifier} {Honest-Verifier} sim-honest-verifier

                honest-verifier : (c : ℤq) → ⟦ Honest-Verifier ⟧
                honest-verifier c = verifier→honest-verifier (verifier c)

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

            module _ {{_ : FunExt}}{{_ : UA}} where
                prover : ⟦ Prover ⟧
                prover = honest-prover→prover x S[ g ^ x ] honest-prover

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Level.NP
open import Data.Product.NP using (_,_)
open import Data.Sum renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_]) hiding ([_,_]′)
open import Data.Two hiding (_≟_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP using (_≡_; coe)
open import Function.Extensionality
open import HoTT
open import Data.ShapePolymorphism
open Equivalences

open import Control.Protocol
open import Control.Protocol.Lift

module Control.Protocol.Examples where

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

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

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

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

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

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

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

        Verifier : Proto
        Verifier = dual Prover

        -- He is honest but its type does not say it
        -- The definition for "prover" below is derived from
        -- a well typed version.
        prover' : (x r : ℤq) → ⟦ Prover ⟧
        prover' x r = (g ^ r) , λ c → (r + (c * x)) , _

        verifier : (c : ℤq) → ⟦ Verifier ⟧
        verifier c _ = c , _

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

            Honest-Verifier : Proto
            Honest-Verifier = dual Honest-Prover

            honest-verifier' : (c : ℤq) → ⟦ Honest-Verifier ⟧
            honest-verifier' c [ r ] gʳ = c , λ s → _ ≟ _ , _

            sim-honest-prover : ⟦ Honest-Prover ⊸ Prover ⟧
            sim-honest-prover [ r ] S[ gʳ ∥ gʳ= ] = inr gʳ , λ c →
                                                    inl c  , λ { S[ s ∥ s= ] →
                                                    inr s  ,
                                                    _ ≟ _  ,
                                                    end }

            -- The next version is derived from sim-honest-prover
            honest-prover→prover' : ⟦ Honest-Prover ⟧ → ⟦ Prover ⟧
            honest-prover→prover' ([ r ] , gʳ , p) = unS gʳ , λ c → case p c of λ { (s , _) → unS s , _ }

            module _ {{_ : FunExt}}{{_ : UA}} where
                sim-honest-verifier : ⟦ Verifier ⊸ Honest-Verifier ⟧
                sim-honest-verifier = coe (⅋-comm Honest-Verifier _) sim-honest-prover

                honest-prover→prover : ⟦ Honest-Prover ⟧ → ⟦ Prover ⟧
                honest-prover→prover = ⊸-apply {Honest-Prover} sim-honest-prover

                verifier→honest-verifier : ⟦ Verifier ⟧ → ⟦ Honest-Verifier ⟧
                verifier→honest-verifier = ⊸-apply {Verifier} {Honest-Verifier} sim-honest-verifier

                honest-verifier : (c : ℤq) → ⟦ Honest-Verifier ⟧
                honest-verifier c = verifier→honest-verifier (verifier c)

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

            module _ {{_ : FunExt}}{{_ : UA}} where
                prover : ⟦ Prover ⟧
                prover = honest-prover→prover x S[ g ^ x ] honest-prover


Drop dead experiment

Drop dead experiment

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive
open import Data.Empty

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

-- This can't be a datatype, since it wouldn't be strictly positive as it
-- appears on the left of an arrow in the function case, which then can be
-- contained in nested "fromto-validity" proofs.
sumfromto : ∀ (σ τ : Type) → (dv : SumChange2 {A = ⟦ σ ⟧Type} {B = ⟦ τ ⟧Type}) → (v1 v2 : ⟦ sum σ τ ⟧Type) → Set
sumfromto σ τ (ch₁ da) (inj₁ a1) (inj₁ a2) = [ σ ] da from a1 to a2
-- These fallback equations unfortunately don't hold definitionally, they're
-- split on multiple cases, so the pattern match is a mess.
--
-- To "case split" on validity, I typically copy-paste the pattern match from
-- fromto→⊕ and change the function name :-(.
sumfromto σ τ (ch₁ da) _ _ = ⊥
sumfromto σ τ (ch₂ db) (inj₂ b1) (inj₂ b2) = [ τ ] db from b1 to b2
sumfromto σ τ (ch₂ db) _ _ = ⊥
sumfromto σ τ (rp (inj₂ b2)) (inj₁ a1) (inj₂ b2') = b2 ≡ b2'
sumfromto σ τ (rp (inj₁ a2)) (inj₂ b1) (inj₁ a2') = a2 ≡ a2'
sumfromto σ τ (rp s) _ _ = ⊥

[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2
[ sum σ τ ] dv from v1 to v2 = sumfromto σ τ (convert dv) v1 v2

data [_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ] dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₁ a2) = ⊝-fromto a1 a2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₂ b2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₁ a2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₂ b2) = ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa rewrite fromto→⊕ da a1 a2 daa = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb rewrite fromto→⊕ db b1 b2 dbb = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = daa
fromtoDeriveConst rinj db b1 b2 dbb = dbb
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa df f1 f2 dff dg g1 g2 dgg = dff da a1 a2 daa
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb df f1 f2 dff dg g1 g2 dgg = dgg db b1 b2 dbb
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

open import Postulate.Extensionality

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da _ _ daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa = sv₁ a1 da (fromto→valid da a1 a2 daa)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb = sv₂ b1 db (fromto→valid db b1 b2 dbb)
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = svrp₂ b1 a2
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = svrp₁ a1 b2
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)
valid→fromto {sum σ τ} .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) = valid→fromto a da ada
valid→fromto {sum σ τ} .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) = valid→fromto b db bdb
valid→fromto {sum σ τ} .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) = refl
valid→fromto {sum σ τ} .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) = refl

module New.NewNew where

open import New.Changes
open import New.LangChanges
open import New.Lang
open import New.Derive
open import Data.Empty

-- module _ {ℓ₁} {ℓ₂}
--   {A : Set ℓ₁} {B : Set ℓ₂} {{CA : ChAlg A}} {{CB : ChAlg B}} where

  -- data SValid3 : A ⊎ B → Ch (A ⊎ B) → Set (ℓ₁ Level.⊔ ℓ₂) where
-- module _ {σ τ : Type} where
--   data SValid3 : Cht (sum σ τ) → (s1 s2 : ⟦ sum σ τ ⟧Type) → Set where
--     sv₁ : ∀ da a1 a2 → [ σ ] da from a1 to a2 → SValid3 (convert₁ (ch₁ da)) (inj₁ a1) (inj₁ a2)
    -- sv₁ : ∀ (a : A) (da : Ch A) (ada : valid a da) → SValid3 (inj₁ a) (convert₁ (ch₁ da))
    -- sv₂ : ∀ (b : B) (db : Ch B) (bdb : valid b db) → SValid3 (inj₂ b) (convert₁ (ch₂ db))
    -- svrp₁ : ∀ a1 b2 → SValid3 (inj₁ a1) (convert₁ (rp (inj₂ b2)))
    -- svrp₂ : ∀ b1 a2 → SValid3 (inj₂ b1) (convert₁ (rp (inj₁ a2)))

[_]_from_to_ : ∀ (τ : Type) → (dv : Cht τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

sumfromto : ∀ (σ τ : Type) → (dv : SumChange2 {A = ⟦ σ ⟧Type} {B = ⟦ τ ⟧Type}) → (v1 v2 : ⟦ sum σ τ ⟧Type) → Set
sumfromto σ τ (ch₁ da) (inj₁ a1) (inj₁ a2) = [ σ ] da from a1 to a2
-- These fallback equations unfortunately don't hold definitionally, they're
-- split on multiple cases, so the pattern match is a mess.
--
-- To "case split" on validity, I typically copy-paste the pattern match from
-- fromto→⊕ and change the function name :-(.
sumfromto σ τ (ch₁ da) _ _ = ⊥
sumfromto σ τ (ch₂ db) (inj₂ b1) (inj₂ b2) = [ τ ] db from b1 to b2
sumfromto σ τ (ch₂ db) _ _ = ⊥
sumfromto σ τ (rp (inj₂ b2)) (inj₁ a1) (inj₂ b2') = b2 ≡ b2'
sumfromto σ τ (rp (inj₁ a2)) (inj₂ b1) (inj₁ a2') = a2 ≡ a2'
sumfromto σ τ (rp s) _ _ = ⊥

[ σ ⇒ τ ] df from f1 to f2 =
  ∀ (da : Cht σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ] da from a1 to a2 → [ τ ] df a1 da from f1 a1 to f2 a2
[ int ] dv from v1 to v2 = v2 ≡ v1 + dv
[ pair σ τ ] (da , db) from (a1 , b1) to (a2 , b2) = [ σ ] da from a1 to a2 × [ τ ] db from b1 to b2
[ sum σ τ ] dv from v1 to v2 = sumfromto σ τ (convert dv) v1 v2
-- Doesn't work, the resulting datatype wouldn't be strictly positive.
-- [ sum σ τ ] dv from v1 to v2 = SValid3 dv v1 v2

data [_]Γ_from_to_ : ∀ Γ → eCh Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ] dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

⟦Γ≼ΔΓ⟧ : ∀ {Γ ρ1 ρ2 dρ} → (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
  ρ1 ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ v∅ = refl
⟦Γ≼ΔΓ⟧ (dvv v• dρρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ dρρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  ∀ {dρ ρ1 ρ2} → [ Γ ]Γ dρ from ρ1 to ρ2 →
  ⟦ t ⟧Term ρ1 ≡ ⟦ fit t ⟧Term dρ
fit-sound t dρρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ dρρ))
  (sym (weaken-sound t _))

-- Now relate this validity with ⊕. To know that nil and so on are valid, also
-- relate it to the other definition.

fromto→⊕ : ∀ {τ} dv v1 v2 →
  [ τ ] dv from v1 to v2 →
  v1 ⊕ dv ≡ v2

⊝-fromto : ∀ {τ} (v1 v2 : ⟦ τ ⟧Type) → [ τ ] v2 ⊝ v1 from v1 to v2
⊝-fromto {σ ⇒ τ} f1 f2 da a1 a2 daa rewrite sym (fromto→⊕ da a1 a2 daa) = ⊝-fromto (f1 a1) (f2 (a1 ⊕ da))
⊝-fromto {int} v1 v2 = sym (update-diff v2 v1)
⊝-fromto {pair σ τ} (a1 , b1) (a2 , b2) = ⊝-fromto a1 a2 , ⊝-fromto b1 b2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₁ a2) = ⊝-fromto a1 a2
⊝-fromto {sum σ τ} (inj₁ a1) (inj₂ b2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₁ a2) = refl
⊝-fromto {sum σ τ} (inj₂ b1) (inj₂ b2) = ⊝-fromto b1 b2

nil-fromto : ∀ {τ} (v : ⟦ τ ⟧Type) → [ τ ] nil v from v to v
nil-fromto v = ⊝-fromto v v

fromto→⊕ {σ ⇒ τ} df f1 f2 dff =
  ext (λ v → fromto→⊕ {τ} (df v (nil v)) (f1 v) (f2 v) (dff (nil v) v v (nil-fromto v)))
fromto→⊕ {int} dn n1 n2 refl = refl
fromto→⊕ {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) =
  cong₂ _,_ (fromto→⊕ _ _ _ daa) (fromto→⊕ _ _ _ dbb)
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa rewrite fromto→⊕ da a1 a2 daa = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb rewrite fromto→⊕ db b1 b2 dbb = refl
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = refl
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→⊕ {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveConst : ∀ {τ} c →
  [ τ ] ⟦ deriveConst c ⟧Term ∅ from ⟦ c ⟧Const to ⟦ c ⟧Const
fromtoDeriveConst plus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb = mn·pq=mp·nq {a1} {da} {b1} {db}
fromtoDeriveConst minus da a1 a2 daa db b1 b2 dbb rewrite daa | dbb | sym (-m·-n=-mn {b1} {db}) = mn·pq=mp·nq {a1} {da} { - b1} { - db}
fromtoDeriveConst cons da a1 a2 daa db b1 b2 dbb = daa , dbb
fromtoDeriveConst fst (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = daa
fromtoDeriveConst snd (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = dbb
fromtoDeriveConst linj da a1 a2 daa = daa
fromtoDeriveConst rinj db b1 b2 dbb = dbb
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa df f1 f2 dff dg g1 g2 dgg = dff da a1 a2 daa
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb df f1 f2 dff dg g1 g2 dgg = dgg db b1 b2 dbb
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem2 f1 df g1 dg b1 a2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (g1 b1) ((f1 ⊕ df) a2)
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl df f1 f2 dff dg g1 g2 dgg rewrite changeMatchSem-lem1 f1 df g1 dg a1 b2 | sym (fromto→⊕ df _ _ dff) | sym (fromto→⊕ dg _ _ dgg) = ⊝-fromto (f1 a1) ((g1 ⊕ dg) b2)
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromtoDeriveConst match (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

fromtoDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  ∀ {dρ ρ1 ρ2}  → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ x ⟧ΔVar ρ1 dρ) from (⟦ x ⟧Var ρ1) to (⟦ x ⟧Var ρ2)
fromtoDeriveVar this (dvv v• dρρ) = dvv
fromtoDeriveVar (that x) (dvv v• dρρ) = fromtoDeriveVar x dρρ

fromtoDerive : ∀ {Γ} τ → (t : Term Γ τ) →
  {dρ : eCh Γ} {ρ1 ρ2 : ⟦ Γ ⟧Context} → [ Γ ]Γ dρ from ρ1 to ρ2 →
    [ τ ] (⟦ t ⟧ΔTerm ρ1 dρ) from (⟦ t ⟧Term ρ1) to (⟦ t ⟧Term ρ2)
fromtoDerive τ (const c) {dρ} {ρ1} dρρ rewrite ⟦ c ⟧ΔConst-rewrite ρ1 dρ = fromtoDeriveConst c
fromtoDerive τ (var x) dρρ = fromtoDeriveVar x dρρ
fromtoDerive τ (app {σ} s t) dρρ rewrite sym (fit-sound t dρρ) =
  let fromToF = fromtoDerive (σ ⇒ τ) s dρρ
  in let fromToB = fromtoDerive σ t dρρ in fromToF _ _ _ fromToB
fromtoDerive (σ ⇒ τ) (abs t) dρρ = λ dv v1 v2 dvv →
  fromtoDerive τ t (dvv v• dρρ)

open import Postulate.Extensionality

open ≡-Reasoning

-- If df is valid, prove (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da.

-- This statement uses a ⊕ da instead of a2, which is not the style of this formalization but fits better with the other one.
-- Instead, WellDefinedFunChangeFromTo (without prime) fits this formalization.
WellDefinedFunChangeFromTo′ : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo′ f1 df = ∀ da a → [ _ ] da from a to (a ⊕ da) → WellDefinedFunChangePoint f1 df a da

fromto→WellDefined′ : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo′ f1 df
fromto→WellDefined′ {f1 = f1} {f2} {df} dff da a daa =
  begin
    (f1 ⊕ df) (a ⊕ da)
  ≡⟨⟩
    f1 (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))
  ≡⟨ (fromto→⊕
     (df (a ⊕ da) (nil (a ⊕ da))) _ _
     (dff (nil (a ⊕ da)) _ _ (nil-fromto (a ⊕ da))))
  ⟩
    f2 (a ⊕ da)
  ≡⟨ sym (fromto→⊕ _ _ _ (dff da _ _ daa)) ⟩
    f1 a ⊕ df a da
  ∎

WellDefinedFunChangeFromTo : ∀ {σ τ} (f1 : ⟦ σ ⇒ τ ⟧Type) → (df : Cht (σ ⇒ τ)) → Set
WellDefinedFunChangeFromTo f1 df = ∀ da a1 a2 → [ _ ] da from a1 to a2 → WellDefinedFunChangePoint f1 df a1 da

fromto→WellDefined : ∀ {σ τ f1 f2 df} → [ σ ⇒ τ ] df from f1 to f2 →
  WellDefinedFunChangeFromTo f1 df
fromto→WellDefined {f1 = f1} {f2} {df} dff da a1 a2 daa =
  fromto→WellDefined′ dff da a1 daa′
  where
    daa′ : [ _ ] da from a1 to (a1 ⊕ da)
    daa′ rewrite fromto→⊕ da _ _ daa = daa

-- Recursive isomorphism between the two validities.
--
-- Among other things, valid→fromto proves that a validity-preserving function,
-- with validity defined via (f1 ⊕ df) (a ⊕ da) ≡ f1 a ⊕ df a da, is also valid
-- in the "fromto" sense.
--
-- We can't hope for a better statement, since we need the equation to be
-- satisfied also by returned or argument functions.

fromto→valid : ∀ {τ} →
  ∀ dv v1 v2 → [ τ ] dv from v1 to v2 →
  valid v1 dv
valid→fromto : ∀ {τ} v (dv : Cht τ) → valid v dv → [ τ ] dv from v to (v ⊕ dv)

fromto→valid {int} = λ dv v1 v2 x → tt
fromto→valid {pair σ τ} (da , db) (a1 , b1) (a2 , b2) (daa , dbb) = (fromto→valid da _ _ daa) , (fromto→valid db _ _ dbb)
fromto→valid {σ ⇒ τ} df f1 f2 dff = λ a da ada →
  fromto→valid (df a da) (f1 a) (f2 (a ⊕ da)) (dff da a (a ⊕ da) (valid→fromto a da ada)) ,
  fromto→WellDefined′ dff da a (valid→fromto a da ada)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ a1) (inj₁ a2) daa = sv₁ a1 da (fromto→valid da a1 a2 daa)
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₁ da)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ b1) (inj₂ b2) dbb = sv₂ b1 db (fromto→valid db b1 b2 dbb)
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₁ (inj₂ db)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ b1) (inj₁ .a2) refl = svrp₂ b1 a2
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₁ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₁ a2)) (inj₂ _) (inj₂ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ a1) (inj₂ .b2) refl = svrp₁ a1 b2
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₁ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₁ _) ()
fromto→valid {sum σ τ} (inj₂ (inj₂ b2)) (inj₂ _) (inj₂ _) ()

valid→fromto {int} v dv tt = refl
valid→fromto {pair σ τ} (a , b) (da , db) (ada , bdb) = valid→fromto a da ada , valid→fromto b db bdb
valid→fromto {σ ⇒ τ} f df fdf da a1 a2 daa = body
  where
    fa1da-valid :
      valid (f a1) (df a1 da) ×
      WellDefinedFunChangePoint f df a1 da
    fa1da-valid = fdf a1 da (fromto→valid da _ _ daa)
    body : [ τ ] df a1 da from f a1 to (f ⊕ df) a2
    body rewrite sym (fromto→⊕ da _ _ daa) | proj₂ fa1da-valid = valid→fromto (f a1) (df a1 da) (proj₁ fa1da-valid)
valid→fromto {sum σ τ} .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) = valid→fromto a da ada
valid→fromto {sum σ τ} .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) = valid→fromto b db bdb
valid→fromto {sum σ τ} .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) = refl
valid→fromto {sum σ τ} .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) = refl


Assume a less stupid property of == on G

open import Data.Bool.NP as Bool hiding (check)
open import Data.Nat
open import Data.Maybe
open import Data.Product.NP
open import Data.Bits
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP

open import sum

module generic-zero-knowledge-interactive where

private
  ★ : Set₁
  ★ = Set

-- A random argument, this is only a formal notation to
-- indicate that the argument is supposed to be picked
-- at random uniformly. (do not confuse with our randomness
-- monad).
record ↺ (A : ★) : ★ where
  constructor rand
  field get : A

module M (Permutation : ★)
         (_⁻¹         : Endo Permutation)
         (sumπ        : Sum Permutation)
         (μπ          : SumProp sumπ)

         (Rₚ-xtra     : ★) -- extra prover/adversary randomness
         (sumRₚ-xtra  : Sum Rₚ-xtra)
         (μRₚ-xtra    : SumProp sumRₚ-xtra)

         (Problem     : ★)
         (_==_        : Problem → Problem → Bit)
         (==-refl     : ∀ {pb} → (pb == pb) ≡ true)
         (_∙P_        : Permutation → Endo Problem)
         (⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x)

         (Solution    : ★)
         (_∙S_        : Permutation → Endo Solution)
         (⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x)

         (check       : Problem → Solution → Bit)
         (check-∙     : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s)

         (easy-pb     : Permutation → Problem)
         (easy-sol    : Permutation → Solution)
         (check-easy  : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true)
    where

    -- prover/adversary randomness
    Rₚ : ★
    Rₚ = Permutation × Rₚ-xtra

    sumRₚ : Sum Rₚ
    sumRₚ = sumπ ×Sum sumRₚ-xtra

    μRₚ : SumProp sumRₚ
    μRₚ = μπ ×μ μRₚ-xtra

    R = Bit × Rₚ

    sumR : Sum R
    sumR = sumBit ×Sum sumRₚ

    μR : SumProp sumR
    μR = μBit ×μ μRₚ

    check-π : Problem → Solution → Rₚ → Bit
    check-π p s (π , _) = check (π ∙P p) (π ∙S s)

    otp-∙-check : let #_ = count μRₚ
                  in
                  ∀ p₀ s₀ p₁ s₁ →
                    check p₀ s₀ ≡ check p₁ s₁ →
                    #(check-π p₀ s₀) ≡ #(check-π p₁ s₁)
    otp-∙-check p₀ s₀ p₁ s₁ check-pf =
      count-ext μRₚ {f = check-π p₀ s₀} {check-π p₁ s₁} (λ π,r →
        check-π p₀ s₀ π,r ≡⟨ check-∙ p₀ s₀ (proj₁ π,r) ⟩
        check p₀ s₀       ≡⟨ check-pf ⟩
        check p₁ s₁       ≡⟨ sym (check-∙ p₁ s₁ (proj₁ π,r)) ⟩
        check-π p₁ s₁ π,r ∎)
        where open ≡-Reasoning

    #_ : (↺ (Bit × Permutation × Rₚ-xtra) → Bit) → ℕ
    # f = count μR (f ∘ rand)

    _≡#_ : (f g : ↺ (Bit × Rₚ) → Bit) → ★
    f ≡# g = # f ≡ # g

{-
    otp-∙ : let otp = λ O pb s → count μRₚ (λ { (π , _) → O (π ∙P pb) (π ∙S s) }) in
            ∀ pb₀ s₀ pb₁ s₁ →
              check pb₀ s₀ ≡ check pb₁ s₁ →
              (O : _ → _ → Bit) → otp O pb₀ s₀ ≡ otp O pb₁ s₁
    otp-∙ pb₀ s₀ pb₁ s₁ check-pf O = {!(μπ ×Sum-proj₂ μRₚ-xtra    ?!}
-}
    Answer : Bit → ★
    Answer false{-0b-} = Permutation
    Answer true {-1b-} = Solution

    answer : Permutation → Solution → ∀ b → Answer b
    answer π _ false = π
    answer _ s true  = s

    -- The prover is the advesary in the generic terminology,
    -- and the verifier is the challenger.
    DepProver : ★
    DepProver = Problem → ↺ Rₚ → (b : Bit) → Problem × Answer b

    Prover₀ : ★
    Prover₀ = Problem → ↺ Rₚ → Problem × Permutation

    Prover₁ : ★
    Prover₁ = Problem → ↺ Rₚ → Problem × Solution

    Prover : ★
    Prover = Prover₀ × Prover₁

    prover : DepProver → Prover
    prover dpr = (λ pb r → dpr pb r 0b) , (λ pb r → dpr pb r 1b)

    depProver : Prover → DepProver
    depProver (pr₀ , pr₁) pb r false = pr₀ pb r
    depProver (pr₀ , pr₁) pb r true  = pr₁ pb r

    -- Here we show that the explicit commitment step seems useless given
    -- the formalization. The verifier can "trust" the prover on the fact
    -- that any choice is going to be govern only by the problem and the
    -- randomness.
    module WithCommitment (Commitment : ★)
                          (AnswerWC   : Bit → ★)
                          (reveal     : ∀ b → Commitment → AnswerWC b → Problem × Answer b) where
        ProverWC = (Problem → Rₚ → Commitment)
                 × (Problem → Rₚ → (b : Bit) → AnswerWC b)

        depProver' : ProverWC → DepProver
        depProver' (pr₀ , pr₁) pb (rand rₚ) b = reveal b (pr₀ pb rₚ) (pr₁ pb rₚ b)

    Verif : Problem → ∀ b → Problem × Answer b → Bit
    Verif pb false{-0b-} (π∙pb , π)   = (π ∙P pb) == π∙pb
    Verif pb true {-1b-} (π∙pb , π∙s) = check π∙pb π∙s

    _⇄′_ : Problem → DepProver → Bit → ↺ Rₚ → Bit
    (pb ⇄′ pr) b (rand rₚ) = Verif pb b (pr pb (rand rₚ) b)

    _⇄_ : Problem → DepProver → ↺ (Bit × Rₚ) → Bit
    (pb ⇄ pr) (rand (b , rₚ)) = (pb ⇄′ pr) b (rand rₚ)

    _⇄''_ : Problem → Prover → ↺ (Bit × Rₚ) → Bit
    pb ⇄'' pr = pb ⇄ depProver pr

    honest : (Problem → Maybe Solution) → DepProver
    honest solve pb (rand (π , rₚ)) b = (π ∙P pb , answer π sol b)
      module Honest where
        sol : Solution
        sol with solve pb
        ...    | just sol = π ∙S sol
        ...    | nothing  = π ∙S easy-sol π

    module WithCorrectSolver (pb      : Problem)
                             (s       : Solution)
                             (check-s : check pb s ≡ true)
                             where

        -- When the honest prover has a solution, he gets accepted
        -- unconditionally by the verifier.
        honest-accepted : ∀ r → (pb ⇄ honest (const (just s))) r ≡ 1b
        honest-accepted (rand (true  , π , rₚ)) rewrite check-∙ pb s π = check-s
        honest-accepted (rand (false , π , rₚ)) = ==-refl

    honest-⅁ = λ pb s → (pb ⇄ honest (const (just s)))

    module HonestLeakZeroKnowledge (pb₀ pb₁  : Problem)
                                   (s₀ s₁    : Solution)
                                   (check-pf : check pb₀ s₀ ≡ check pb₁ s₁) where

        helper : ∀ rₚ → Bool.toℕ ((pb₀ ⇄′ honest (const (just s₀))) 0b (rand rₚ))
                      ≡ Bool.toℕ ((pb₁ ⇄′ honest (const (just s₁))) 0b (rand rₚ))
        helper (π , rₚ) rewrite ==-refl {π ∙P pb₀} | ==-refl {π ∙P pb₁} = refl

        honest-leak : honest-⅁ pb₀ s₀ ≡# honest-⅁ pb₁ s₁
        honest-leak rewrite otp-∙-check pb₀ s₀ pb₁ s₁ check-pf | sum-ext μRₚ helper = refl

    module HonestLeakZeroKnowledge' (pb       : Problem)
                                    (s₀ s₁    : Solution)
                                    (check-pf : check pb s₀ ≡ check pb s₁) where

        honest-leak : honest-⅁ pb s₀ ≡# honest-⅁ pb s₁
        honest-leak = HonestLeakZeroKnowledge.honest-leak pb pb s₀ s₁ check-pf

    -- Predicts b=b′
    cheater : ∀ b′ → DepProver
    cheater b′ pb (rand (π , _)) b = π ∙P (case b′ 0→ pb 1→ easy-pb π)
                                   , answer π (π ∙S easy-sol π) b

    -- If cheater predicts correctly, verifer accepts him
    cheater-accepted : ∀ b pb rₚ → (pb ⇄′ cheater b) b rₚ ≡ 1b
    cheater-accepted true  pb (rand (π , rₚ)) = check-easy π
    cheater-accepted false pb (rand (π , rₚ)) = ==-refl

    -- If cheater predicts incorrecty, verifier rejects him
    module CheaterRejected (pb : Problem)
                           (not-easy-sol : ∀ π → check (π ∙P pb) (π ∙S easy-sol π) ≡ false)
                           (not-easy-pb  : ∀ π → ((π ∙P pb) == (π ∙P easy-pb π)) ≡ false) where

        cheater-rejected : ∀ b rₚ → (pb ⇄′ cheater (not b)) b rₚ ≡ 0b
        cheater-rejected true  (rand (π , rₚ)) = not-easy-sol π
        cheater-rejected false (rand (π , rₚ)) = not-easy-pb π

module DLog (ℤq  : ★)
            (_⊞_ : ℤq → ℤq → ℤq)
            (⊟_  : ℤq → ℤq)
            (G   : ★)
            (g   : G)
            (_^_ : G → ℤq → G)
            (_∙_ : G → G → G)
            (⊟-⊞ : ∀ π x → (⊟ π) ⊞ (π ⊞ x) ≡ x)
            (^⊟-∙ : ∀ α β x → ((α ^ (⊟ x)) ∙ ((α ^ x) ∙ β)) ≡ β)
            -- (∙-assoc : ∀ α β γ → α ∙ (β ∙ γ) ≡ (α ∙ β) ∙ γ)
            (dist-^-⊞ : ∀ α x y → α ^ (x ⊞ y) ≡ (α ^ x) ∙ (α ^ y))
            (_==_ : G → G → Bool)
            (==-refl    : ∀ {α} → (α == α) ≡ true)
            (==-cong-∙  : ∀ {α β b} γ → α == β ≡ b → (γ ∙ α) == (γ ∙ β) ≡ b)
            (==-true    : ∀ {α β} → α == β ≡ true → α ≡ β)
            (sumℤq      : Sum ℤq)
            (μℤq        : SumProp sumℤq)
            (Rₚ-xtra    : ★) -- extra prover/adversary randomness
            (sumRₚ-xtra : Sum Rₚ-xtra)
            (μRₚ-xtra   : SumProp sumRₚ-xtra)
            (some-ℤq    : ℤq)
   where

   Permutation = ℤq
   Problem = G
   Solution = ℤq

   _⁻¹ : Endo Permutation
   π ⁻¹ = ⊟ π

   g^_ : ℤq → G
   g^ x = g ^ x

   _∙P_ : Permutation → Endo Problem
   π ∙P p = g^ π ∙ p

   ⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x
   ⁻¹-inverseP π x rewrite ^⊟-∙ g x π = refl

   _∙S_ : Permutation → Endo Solution
   π ∙S s = π ⊞ s

   ⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x
   ⁻¹-inverseS = ⊟-⊞

   check : Problem → Solution → Bit
   check p s = p == g^ s

   check-∙' : ∀ p s π b → check p s ≡ b → check (π ∙P p) (π ∙S s) ≡ b
   check-∙' p s π true  check-p-s rewrite dist-^-⊞ g π s | ==-true check-p-s = ==-refl
   check-∙' p s π false check-p-s rewrite dist-^-⊞ g π s = ==-cong-∙ (g^ π) check-p-s

   check-∙ : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s
   check-∙ p s π = check-∙' p s π (check p s) refl

   easy-sol : Permutation → Solution
   easy-sol π = some-ℤq

   easy-pb : Permutation → Problem
   easy-pb π = g^(easy-sol π)

   check-easy : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true
   check-easy π rewrite dist-^-⊞ g π (easy-sol π) = ==-refl

   open M Permutation _⁻¹ sumℤq μℤq Rₚ-xtra sumRₚ-xtra μRₚ-xtra
          Problem _==_ ==-refl _∙P_ ⁻¹-inverseP Solution _∙S_ ⁻¹-inverseS check check-∙ easy-pb easy-sol check-easy
-- -}
-- -}
-- -}
-- -}
-- -}

open import Data.Bool.NP as Bool hiding (check)
open import Data.Nat
open import Data.Maybe
open import Data.Product.NP
open import Data.Bits
open import Function.NP
open import Relation.Binary.PropositionalEquality.NP

open import sum

module generic-zero-knowledge-interactive where

private
  ★ : Set₁
  ★ = Set

-- A random argument, this is only a formal notation to
-- indicate that the argument is supposed to be picked
-- at random uniformly. (do not confuse with our randomness
-- monad).
record ↺ (A : ★) : ★ where
  constructor rand
  field get : A

module M (Permutation : ★)
         (_⁻¹         : Endo Permutation)
         (sumπ        : Sum Permutation)
         (μπ          : SumProp sumπ)

         (Rₚ-xtra     : ★) -- extra prover/adversary randomness
         (sumRₚ-xtra  : Sum Rₚ-xtra)
         (μRₚ-xtra    : SumProp sumRₚ-xtra)

         (Problem     : ★)
         (_==_        : Problem → Problem → Bit)
         (==-refl     : ∀ {pb} → (pb == pb) ≡ true)
         (_∙P_        : Permutation → Endo Problem)
         (⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x)

         (Solution    : ★)
         (_∙S_        : Permutation → Endo Solution)
         (⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x)

         (check       : Problem → Solution → Bit)
         (check-∙     : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s)

         (easy-pb     : Permutation → Problem)
         (easy-sol    : Permutation → Solution)
         (check-easy  : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true)
    where

    -- prover/adversary randomness
    Rₚ : ★
    Rₚ = Permutation × Rₚ-xtra

    sumRₚ : Sum Rₚ
    sumRₚ = sumπ ×Sum sumRₚ-xtra

    μRₚ : SumProp sumRₚ
    μRₚ = μπ ×μ μRₚ-xtra

    R = Bit × Rₚ

    sumR : Sum R
    sumR = sumBit ×Sum sumRₚ

    μR : SumProp sumR
    μR = μBit ×μ μRₚ

    check-π : Problem → Solution → Rₚ → Bit
    check-π p s (π , _) = check (π ∙P p) (π ∙S s)

    otp-∙-check : let #_ = count μRₚ
                  in
                  ∀ p₀ s₀ p₁ s₁ →
                    check p₀ s₀ ≡ check p₁ s₁ →
                    #(check-π p₀ s₀) ≡ #(check-π p₁ s₁)
    otp-∙-check p₀ s₀ p₁ s₁ check-pf =
      count-ext μRₚ {f = check-π p₀ s₀} {check-π p₁ s₁} (λ π,r →
        check-π p₀ s₀ π,r ≡⟨ check-∙ p₀ s₀ (proj₁ π,r) ⟩
        check p₀ s₀       ≡⟨ check-pf ⟩
        check p₁ s₁       ≡⟨ sym (check-∙ p₁ s₁ (proj₁ π,r)) ⟩
        check-π p₁ s₁ π,r ∎)
        where open ≡-Reasoning

    #_ : (↺ (Bit × Permutation × Rₚ-xtra) → Bit) → ℕ
    # f = count μR (f ∘ rand)

    _≡#_ : (f g : ↺ (Bit × Rₚ) → Bit) → ★
    f ≡# g = # f ≡ # g

{-
    otp-∙ : let otp = λ O pb s → count μRₚ (λ { (π , _) → O (π ∙P pb) (π ∙S s) }) in
            ∀ pb₀ s₀ pb₁ s₁ →
              check pb₀ s₀ ≡ check pb₁ s₁ →
              (O : _ → _ → Bit) → otp O pb₀ s₀ ≡ otp O pb₁ s₁
    otp-∙ pb₀ s₀ pb₁ s₁ check-pf O = {!(μπ ×Sum-proj₂ μRₚ-xtra    ?!}
-}
    Answer : Bit → ★
    Answer false{-0b-} = Permutation
    Answer true {-1b-} = Solution

    answer : Permutation → Solution → ∀ b → Answer b
    answer π _ false = π
    answer _ s true  = s

    -- The prover is the advesary in the generic terminology,
    -- and the verifier is the challenger.
    DepProver : ★
    DepProver = Problem → ↺ Rₚ → (b : Bit) → Problem × Answer b

    Prover₀ : ★
    Prover₀ = Problem → ↺ Rₚ → Problem × Permutation

    Prover₁ : ★
    Prover₁ = Problem → ↺ Rₚ → Problem × Solution

    Prover : ★
    Prover = Prover₀ × Prover₁

    prover : DepProver → Prover
    prover dpr = (λ pb r → dpr pb r 0b) , (λ pb r → dpr pb r 1b)

    depProver : Prover → DepProver
    depProver (pr₀ , pr₁) pb r false = pr₀ pb r
    depProver (pr₀ , pr₁) pb r true  = pr₁ pb r

    -- Here we show that the explicit commitment step seems useless given
    -- the formalization. The verifier can "trust" the prover on the fact
    -- that any choice is going to be govern only by the problem and the
    -- randomness.
    module WithCommitment (Commitment : ★)
                          (AnswerWC   : Bit → ★)
                          (reveal     : ∀ b → Commitment → AnswerWC b → Problem × Answer b) where
        ProverWC = (Problem → Rₚ → Commitment)
                 × (Problem → Rₚ → (b : Bit) → AnswerWC b)

        depProver' : ProverWC → DepProver
        depProver' (pr₀ , pr₁) pb (rand rₚ) b = reveal b (pr₀ pb rₚ) (pr₁ pb rₚ b)

    Verif : Problem → ∀ b → Problem × Answer b → Bit
    Verif pb false{-0b-} (π∙pb , π)   = (π ∙P pb) == π∙pb
    Verif pb true {-1b-} (π∙pb , π∙s) = check π∙pb π∙s

    _⇄′_ : Problem → DepProver → Bit → ↺ Rₚ → Bit
    (pb ⇄′ pr) b (rand rₚ) = Verif pb b (pr pb (rand rₚ) b)

    _⇄_ : Problem → DepProver → ↺ (Bit × Rₚ) → Bit
    (pb ⇄ pr) (rand (b , rₚ)) = (pb ⇄′ pr) b (rand rₚ)

    _⇄''_ : Problem → Prover → ↺ (Bit × Rₚ) → Bit
    pb ⇄'' pr = pb ⇄ depProver pr

    honest : (Problem → Maybe Solution) → DepProver
    honest solve pb (rand (π , rₚ)) b = (π ∙P pb , answer π sol b)
      module Honest where
        sol : Solution
        sol with solve pb
        ...    | just sol = π ∙S sol
        ...    | nothing  = π ∙S easy-sol π

    module WithCorrectSolver (pb      : Problem)
                             (s       : Solution)
                             (check-s : check pb s ≡ true)
                             where

        -- When the honest prover has a solution, he gets accepted
        -- unconditionally by the verifier.
        honest-accepted : ∀ r → (pb ⇄ honest (const (just s))) r ≡ 1b
        honest-accepted (rand (true  , π , rₚ)) rewrite check-∙ pb s π = check-s
        honest-accepted (rand (false , π , rₚ)) = ==-refl

    honest-⅁ = λ pb s → (pb ⇄ honest (const (just s)))

    module HonestLeakZeroKnowledge (pb₀ pb₁  : Problem)
                                   (s₀ s₁    : Solution)
                                   (check-pf : check pb₀ s₀ ≡ check pb₁ s₁) where

        helper : ∀ rₚ → Bool.toℕ ((pb₀ ⇄′ honest (const (just s₀))) 0b (rand rₚ))
                      ≡ Bool.toℕ ((pb₁ ⇄′ honest (const (just s₁))) 0b (rand rₚ))
        helper (π , rₚ) rewrite ==-refl {π ∙P pb₀} | ==-refl {π ∙P pb₁} = refl

        honest-leak : honest-⅁ pb₀ s₀ ≡# honest-⅁ pb₁ s₁
        honest-leak rewrite otp-∙-check pb₀ s₀ pb₁ s₁ check-pf | sum-ext μRₚ helper = refl

    module HonestLeakZeroKnowledge' (pb       : Problem)
                                    (s₀ s₁    : Solution)
                                    (check-pf : check pb s₀ ≡ check pb s₁) where

        honest-leak : honest-⅁ pb s₀ ≡# honest-⅁ pb s₁
        honest-leak = HonestLeakZeroKnowledge.honest-leak pb pb s₀ s₁ check-pf

    -- Predicts b=b′
    cheater : ∀ b′ → DepProver
    cheater b′ pb (rand (π , _)) b = π ∙P (case b′ 0→ pb 1→ easy-pb π)
                                   , answer π (π ∙S easy-sol π) b

    -- If cheater predicts correctly, verifer accepts him
    cheater-accepted : ∀ b pb rₚ → (pb ⇄′ cheater b) b rₚ ≡ 1b
    cheater-accepted true  pb (rand (π , rₚ)) = check-easy π
    cheater-accepted false pb (rand (π , rₚ)) = ==-refl

    -- If cheater predicts incorrecty, verifier rejects him
    module CheaterRejected (pb : Problem)
                           (not-easy-sol : ∀ π → check (π ∙P pb) (π ∙S easy-sol π) ≡ false)
                           (not-easy-pb  : ∀ π → ((π ∙P pb) == (π ∙P easy-pb π)) ≡ false) where

        cheater-rejected : ∀ b rₚ → (pb ⇄′ cheater (not b)) b rₚ ≡ 0b
        cheater-rejected true  (rand (π , rₚ)) = not-easy-sol π
        cheater-rejected false (rand (π , rₚ)) = not-easy-pb π

module DLog (ℤq  : ★)
            (_⊞_ : ℤq → ℤq → ℤq)
            (⊟_  : ℤq → ℤq)
            (G   : ★)
            (g   : G)
            (_^_ : G → ℤq → G)
            (_∙_ : G → G → G)
            (⊟-⊞ : ∀ π x → (⊟ π) ⊞ (π ⊞ x) ≡ x)
            (^⊟-∙ : ∀ α β x → ((α ^ (⊟ x)) ∙ ((α ^ x) ∙ β)) ≡ β)
            -- (∙-assoc : ∀ α β γ → α ∙ (β ∙ γ) ≡ (α ∙ β) ∙ γ)
            (dist-^-⊞ : ∀ α x y → α ^ (x ⊞ y) ≡ (α ^ x) ∙ (α ^ y))
            (_==_ : G → G → Bool)
            (==-refl  : ∀ {α} → (α == α) ≡ true)
            (==-cong  : ∀ {α β b} (f : G → G) → α == β ≡ b → f α == f β ≡ b)
            (==-true  : ∀ {α β} → α == β ≡ true → α ≡ β)
            (sumℤq      : Sum ℤq)
            (μℤq        : SumProp sumℤq)
            (Rₚ-xtra    : ★) -- extra prover/adversary randomness
            (sumRₚ-xtra : Sum Rₚ-xtra)
            (μRₚ-xtra   : SumProp sumRₚ-xtra)
            (some-ℤq    : ℤq)
   where

   Permutation = ℤq
   Problem = G
   Solution = ℤq

   _⁻¹ : Endo Permutation
   π ⁻¹ = ⊟ π

   g^_ : ℤq → G
   g^ x = g ^ x

   _∙P_ : Permutation → Endo Problem
   π ∙P p = g^ π ∙ p

   ⁻¹-inverseP : ∀ π x → π ⁻¹ ∙P (π ∙P x) ≡ x
   ⁻¹-inverseP π x rewrite ^⊟-∙ g x π = refl

   _∙S_ : Permutation → Endo Solution
   π ∙S s = π ⊞ s

   ⁻¹-inverseS : ∀ π x → π ⁻¹ ∙S (π ∙S x) ≡ x
   ⁻¹-inverseS = ⊟-⊞

   check : Problem → Solution → Bit
   check p s = p == g^ s

   check-∙' : ∀ p s π b → check p s ≡ b → check (π ∙P p) (π ∙S s) ≡ b
   check-∙' p s π true  check-p-s rewrite dist-^-⊞ g π s | ==-true check-p-s = ==-refl
   check-∙' p s π false check-p-s rewrite dist-^-⊞ g π s = ==-cong (_∙_ (g^ π)) check-p-s

   check-∙ : ∀ p s π → check (π ∙P p) (π ∙S s) ≡ check p s
   check-∙ p s π = check-∙' p s π (check p s) refl

   easy-sol : Permutation → Solution
   easy-sol π = some-ℤq

   easy-pb : Permutation → Problem
   easy-pb π = g^(easy-sol π)

   check-easy : ∀ π → check (π ∙P easy-pb π) (π ∙S easy-sol π) ≡ true
   check-easy π rewrite dist-^-⊞ g π (easy-sol π) = ==-refl

   open M Permutation _⁻¹ sumℤq μℤq Rₚ-xtra sumRₚ-xtra μRₚ-xtra
          Problem _==_ ==-refl _∙P_ ⁻¹-inverseP Solution _∙S_ ⁻¹-inverseS check check-∙ easy-pb easy-sol check-easy
-- -}
-- -}
-- -}
-- -}
-- -}


-otp-sem-sec

-otp-sem-sec

module otp-sem-sec where

import Level as L
open import Function
open import Data.Nat.NP
open import Data.Bits
open import Data.Bool
open import Data.Bool.Properties
open import Data.Vec hiding (_>>=_)
open import Data.Product.NP hiding (_⟦×⟧_)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import flipbased-implem
open ≡-Reasoning
open import Data.Unit using (⊤)
open import composable
open import vcomp
open import forkable
open import flat-funs
open import program-distance
open import one-time-semantic-security
import bit-guessing-game

module BitsExtra where
  splitAt′ : ∀ k {n} → Bits (k + n) → Bits k × Bits n
  splitAt′ k xs = case splitAt k xs of λ { (ys , zs , _) → (ys , zs) }

  vnot∘vnot : ∀ {n} → vnot {n} ∘ vnot ≗ id
  vnot∘vnot [] = refl
  vnot∘vnot (x ∷ xs) rewrite not-involutive x = cong (_∷_ x) (vnot∘vnot xs)

open BitsExtra

module CompRed {t} {T : Set t}
               {♭Funs : FlatFuns T}
               (♭ops : FlatFunsOps ♭Funs)
               (ep ep' : EncParams) where
    open FlatFunsOps ♭ops
    open AbsSemSec ♭Funs

    open EncParams ep using (|M|; |C|)
    open EncParams ep' using () renaming (|M| to |M|'; |C| to |C|')

    M = `Bits |M|
    C = `Bits |C|
    M' = `Bits |M|'
    C' = `Bits |C|'

    comp-red : (pre-E : M' `→ M)
               (post-E : C `→ C') → SemSecReduction ep' ep _
    comp-red pre-E post-E (mk A₀ A₁) = mk (A₀ >>> (pre-E *** pre-E) *** idO) (post-E *** idO >>> A₁)

module Comp (ep : EncParams) (|M|' |C|' : ℕ) where
  open EncParams ep

  ep' : EncParams
  ep' = EncParams.mk |M|' |C|' |R|e

  open EncParams ep' using () renaming (Enc to Enc'; M to M'; C to C')

  Tr = Enc → Enc'

  open FlatFunsOps fun♭Ops

  comp : (pre-E : M' → M) (post-E : C → C') → Tr
  comp pre-E post-E E = pre-E >>> E >>> {-weaken≤ |R|e≤|R|e' ∘-} map↺ post-E

module CompSec (prgDist : PrgDist) (ep : EncParams) (|M|' |C|' : ℕ) where
  open PrgDist prgDist
  open FlatFunsOps fun♭Ops
  open FunSemSec prgDist
  open AbsSemSec fun♭Funs

  open EncParams ep

  ep' : EncParams
  ep' = EncParams.mk |M|' |C|' |R|e

  open EncParams ep' using () renaming (Enc to Enc'; M to M'; C to C')

  module CompSec' (pre-E : M' → M) (post-E : C → C') where
    open SemSecReductions ep ep'
    open CompRed fun♭Ops ep ep' hiding (M; C)
    open Comp ep |M|' |C|'

    comp-pres-sem-sec : SemSecTr id (comp pre-E post-E)
    comp-pres-sem-sec = comp-red pre-E post-E , λ E A → id

  open SemSecReductions ep ep'
  open CompRed fun♭Ops ep ep' hiding (M; C)
  open CompSec' public
  module Comp' {x y z} = Comp x y z
  open Comp' hiding (Tr)
  comp-pres-sem-sec⁻¹ : ∀ pre-E pre-E⁻¹
                          (pre-E-right-inv : pre-E ∘ pre-E⁻¹ ≗ id)
                          post-E post-E⁻¹
                          (post-E-left-inv : post-E⁻¹ ∘ post-E ≗ id)
                        → SemSecTr⁻¹ id (comp pre-E post-E)
  comp-pres-sem-sec⁻¹ pre-E pre-E⁻¹ pre-E-inv post-E post-E⁻¹ post-E-inv =
    SemSecTr→SemSecTr⁻¹
      (comp pre-E⁻¹ post-E⁻¹)
      (comp pre-E post-E)
      (λ E m R → trans (post-E-inv _) (cong (λ x → run↺ (E x) R) (pre-E-inv _)))
      (comp-pres-sem-sec pre-E⁻¹ post-E⁻¹)

module PostNegSec (prgDist : PrgDist) ep where
  open EncParams ep
  open Comp ep |M| |C| hiding (Tr)
  open CompSec prgDist ep |M| |C|
  open FunSemSec prgDist
  open SemSecReductions ep ep

  post-neg : Tr
  post-neg = comp id vnot

  post-neg-pres-sem-sec : SemSecTr id post-neg
  post-neg-pres-sem-sec = comp-pres-sem-sec id vnot

  post-neg-pres-sem-sec⁻¹ : SemSecTr⁻¹ id post-neg
  post-neg-pres-sem-sec⁻¹ = comp-pres-sem-sec⁻¹ id id (λ _ → refl) vnot vnot vnot∘vnot

module Concrete k where
  open program-distance.Implem k
  module Guess' = bit-guessing-game prgDist
  module FunSemSec' = FunSemSec prgDist
  module CompSec' = CompSec prgDist