Simplify

Simplify

-- Matrices indexed by shape
module SquareMatrix where

open import Shape
open import Matrix

-- Square matrices have the same shape in both dimensions
Sq : Set → Shape → Set
Sq a shape = M a shape shape

open import SemiNearRingRecord
open import Algebra.Structures
open import Relation.Binary
open import Data.Product hiding (swap)

open import Relation.Binary.PropositionalEquality hiding (trans; sym) renaming (refl to refl-≡)
import Relation.Binary.EqReasoning as EqReasoning

-- Lifting a SNR to a to a Square matrix of some shape
Square : SemiNearRing → Shape → SemiNearRing
Square snr shape = SNR
  where
  open SemiNearRing snr

  S = Sq s shape

  infixr 60 _∙S_
  infixr 50 _+S_

  _+S_ : ∀ {r c} → M s r c → M s r c → M s r c
  One x     +S One x₁    = One (x +ₛ x₁)
  Row m m₁  +S Row n n₁  = Row (m +S n) (m₁ +S n₁)
  Col m m₁  +S Col n n₁  = Col (m +S n) (m₁ +S n₁)
  Q m00 m01
    m10 m11 +S Q n00 n01
                n10 n11 = Q (m00 +S n00) (m01 +S n01)
                            (m10 +S n10) (m11 +S n11)

  _∙S_ : ∀ {r m c} → M s r m → M s m c → M s r c
  One x     ∙S One x₁    = One (x ∙ₛ x₁)
  One x     ∙S Row n n₁  = Row (One x ∙S n) (One x ∙S n₁)
  Row m m₁  ∙S Col n n₁  = m ∙S n +S m₁ ∙S n₁
  Row m m₁  ∙S Q n00 n01
                n10 n11 = Row (m ∙S n00 +S m₁ ∙S n10) (m ∙S n01 +S m₁ ∙S n11)
  Col m m₁  ∙S One x     = Col (m ∙S One x) (m₁ ∙S One x)
  Col m m₁  ∙S Row n n₁  = Q (m ∙S n)   (m ∙S n₁)
                            (m₁ ∙S n)  (m₁ ∙S n₁)
  Q m00 m01
    m10 m11 ∙S Col n n₁  = Col (m00 ∙S n +S m01 ∙S n₁) (m10 ∙S n +S m11 ∙S n₁)
  Q m00 m01
    m10 m11 ∙S Q n00 n01
                n10 n11 = Q (m00 ∙S n00 +S m01 ∙S n10) (m00 ∙S n01 +S m01 ∙S n11)
                            (m10 ∙S n00 +S m11 ∙S n10) (m10 ∙S n01 +S m11 ∙S n11)

  0S : (r c : Shape) → M s r c
  0S L L = One 0ₛ
  0S L (B s s₁) = Row (0S L s) (0S L s₁)
  0S (B r r₁) L = Col (0S r L) (0S r₁ L)
  0S (B r r₁) (B s s₁) =
      Q (0S r s) (0S r s₁)
        (0S r₁ s) (0S r₁ s₁)

  _≃S_ : {r c : Shape} →
        M s r c → M s r c → Set
  _≃S_ {L} {L} (One x) (One x₁) = x ≃ₛ x₁
  _≃S_ {L} {(B c₁ c₂)} (Row m m₁) (Row n n₁) =
    _≃S_ m n × _≃S_ m₁ n₁
  _≃S_ {(B r₁ r₂)} {L} (Col m m₁) (Col n n₁) =
    _≃S_ m n × _≃S_ m₁ n₁
  _≃S_ {(B r₁ r₂)} {(B c₁ c₂)} (Q m00 m01 m10 m11) (Q n00 n01 n10 n11) =
    _≃S_ m00 n00 ×
    _≃S_ m01 n01 ×
    _≃S_ m10 n10 ×
    _≃S_ m11 n11

  reflS : (r c : Shape) →
    {X : M s r c} → X ≃S X
  reflS L L {X = One x} = reflₛ {x}
  reflS L (B c₁ c₂) {X = Row X Y} = reflS L c₁ , reflS L c₂
  reflS (B r₁ r₂) L {X = Col X Y} = reflS r₁ L , reflS r₂ L
  reflS (B r₁ r₂) (B c₁ c₂) {X = Q X Y Z W} =
    reflS r₁ c₁ , reflS r₁ c₂ ,
    reflS r₂ c₁ , reflS r₂ c₂

  symS : (r c : Shape) →
    {i j : M s r c} → i ≃S j → j ≃S i
  symS L L {One x} {One x₁} p = symₛ p
  symS L (B c₁ c₂) {Row i₁ i₂} {Row j₁ j₂} (p , q) = symS L c₁ p , symS L c₂ q
  symS (B r₁ r₂) L {Col i₁ i} {Col j j₁} (p , q) = symS r₁ L p , symS r₂ L q
  symS (B r r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j j₁ j₂ j₃} (p , q , x , y) =
    symS r c₁ p , symS r c₂ q ,
    symS r₂ c₁ x , symS r₂ c₂ y

  transS : (r c : Shape) →
    {i j k : M s r c} → i ≃S j → j ≃S k → i ≃S k
  transS L L {One x} {One x₁} {One x₂} p q = trans p q
  transS L (B c₁ c₂) {Row i i₁} {Row j j₁} {Row k k₁} (p , q) (p' , q') =
    transS L c₁ p p' , transS L c₂ q q'
  transS (B r₁ r₂) L {Col i i₁} {Col j j₁} {Col k k₁} (p , q) (p' , q') =
    transS r₁ L p p' , transS r₂ L q q'
  transS (B r₁ r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j₂ j j₃ j₁} {Q k k₁ k₂ k₃}
    (p , q , x , y) (p' , q' , x' , y') =
    transS r₁ c₁ p p' , transS r₁ c₂ q q' ,
    transS r₂ c₁ x x' , transS r₂ c₂ y y'

  isEquivS =
    record
      { refl = reflS shape shape
      ; sym = symS shape shape
      ; trans = transS shape shape }

  assocS : (r c : Shape) (x y z : M s r c) → ((x +S y) +S z) ≃S (x +S (y +S z))
  assocS L L (One x) (One y) (One z) = assocₛ x y z
  assocS L (B c c₁) (Row x x₁) (Row y y₁) (Row z z₁) =
    assocS L c x y z  , assocS L c₁ x₁ y₁ z₁
  assocS (B r r₁) L (Col x x₁) (Col y y₁) (Col z z₁) =
    assocS r L x y z , assocS r₁ L x₁ y₁ z₁
  assocS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (assocS r c x y z) , (assocS r c₁ x₁ y₁ z₁) ,
    (assocS r₁ c x₂ y₂ z₂) , (assocS r₁ c₁ x₃ y₃ z₃)

  <+S> : (r c : Shape) {x y u v : M s r c} →
    x ≃S y → u ≃S v → (x +S u) ≃S (y +S v)
  <+S> L L {One x} {One x₁} {One x₂} {One x₃} p q = p <+> q
  <+S> L (B c c₁) {Row x x₁} {Row y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <+S> L c p q , <+S> L c₁ p₁ q₁
  <+S> (B r r₁) L {Col x x₁} {Col y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    <+S> r L p q , <+S> r₁ L p₁ q₁
  <+S> (B r r₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃}
    (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> r c p q , <+S> r c₁ p₁ q₁ ,
    <+S> r₁ c p₂ q₂ , <+S> r₁ c₁ p₃ q₃

  isSemgroupS =
    record
      { isEquivalence = isEquivS
      ; assoc = assocS shape shape
      ; ∙-cong = <+S> shape shape }

  identSˡ : (r c : Shape) (x : M s r c) →
     0S r c +S x ≃S x
  identSˡ L L (One x) = identityˡₛ x
  identSˡ L (B c c₁) (Row x x₁) = identSˡ L c x , identSˡ L c₁ x₁
  identSˡ (B r r₁) L (Col x x₁) = identSˡ r L x , identSˡ r₁ L x₁
  identSˡ (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    identSˡ r c x , identSˡ r c₁ x₁ ,
    identSˡ r₁ c x₂ , identSˡ r₁ c₁ x₃

  commS : (r c : Shape) → (x y : M s r c) →
    (x +S y) ≃S (y +S x)
  commS L L (One x) (One x₁) = commₛ x x₁
  commS L (B c c₁) (Row x x₁) (Row y y₁) = (commS L c x y) , (commS L c₁ x₁ y₁)
  commS (B r r₁) L (Col x x₁) (Col y y₁) = (commS r L x y) , (commS r₁ L x₁ y₁)
  commS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) =
    commS r c x y , commS r c₁ x₁ y₁ ,
    commS r₁ c x₂ y₂ , commS r₁ c₁ x₃ y₃

  isCommMonS =
    record
      { isSemigroup = isSemgroupS
      ; identityˡ = identSˡ shape shape
      ; comm = commS shape shape }

  -- used to make proofs nicer later on
  setoidS : {r c : Shape} → Setoid _ _
  setoidS {r} {c} =
    record
      { Carrier = M s r c
      ; _≈_ = _≃S_ {r} {c}
      ; isEquivalence =
        record
          { refl = reflS r c ; sym = symS r c ; trans = transS r c } }

  zerolHelp : ∀ (r : Shape) {m m' c : Shape}
    (x : M s m c)
    (y : M s m' c) →
    0S r m ∙S x ≃S 0S r c →
    0S r m' ∙S y ≃S 0S r c →
    0S r m ∙S x +S 0S r m' ∙S y
    ≃S 0S r c
  zerolHelp r {m} {m'} {c} x y p q =
    let open EqReasoning setoidS
    in begin
      0S r m ∙S x +S 0S r m' ∙S y
    ≈⟨ <+S> _ _ {0S r m ∙S x} {0S r c} {0S r m' ∙S y} {0S r c} p q ⟩
      0S r c +S 0S r c
    ≈⟨ identSˡ _ _ (0S r c) ⟩
     0S r c
    ∎

  zeroSˡ : (a b c : Shape) (x : M s b c) →
    (0S a b ∙S x) ≃S 0S a c
  zeroSˡ L L L (One x) = zeroˡ x
  zeroSˡ L L (B c c₁) (Row x x₁) = (zeroSˡ L L c x) , (zeroSˡ L L c₁ x₁)
  zeroSˡ L (B b b₁) L (Col x x₁) =
    zerolHelp L x x₁ (zeroSˡ L b L x) (zeroSˡ L b₁ L x₁)
  zeroSˡ L (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    zerolHelp L x x₂ (zeroSˡ L b c x) (zeroSˡ L b₁ c x₂) ,
    zerolHelp L x₁ x₃ (zeroSˡ L b c₁ x₁) (zeroSˡ L b₁ c₁ x₃)
  zeroSˡ (B a a₁) L L (One x) =
    zeroSˡ a L L (One x) ,
    zeroSˡ a₁ L L (One x)
  zeroSˡ (B a a₁) L (B c c₁) (Row x x₁) =
    zeroSˡ a L c x ,
    zeroSˡ a L c₁ x₁ ,
    zeroSˡ a₁ L c x ,
    zeroSˡ a₁ L c₁ x₁
  zeroSˡ (B a a₁) (B b b₁) L (Col x x₁) =
    zerolHelp a x x₁ (zeroSˡ a b L x) (zeroSˡ a b₁ L x₁) ,
    zerolHelp a₁ x x₁ (zeroSˡ a₁ b L x) (zeroSˡ a₁ b₁ L x₁)
  zeroSˡ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    zerolHelp a x x₂ (zeroSˡ a b c x) (zeroSˡ a b₁ c x₂) ,
    zerolHelp a x₁ x₃ (zeroSˡ a b c₁ x₁) (zeroSˡ a b₁ c₁ x₃) ,
    zerolHelp a₁ x x₂ (zeroSˡ a₁ b c x) (zeroSˡ a₁ b₁ c x₂) ,
    zerolHelp a₁ x₁ x₃ (zeroSˡ a₁ b c₁ x₁) (zeroSˡ a₁ b₁ c₁ x₃)

  zerorHelp : ∀ r {m m' c}
    (x : M s r m)
    (x₁ : M s r m') →
    x ∙S 0S m c ≃S 0S r c →
    x₁ ∙S 0S m' c ≃S 0S r c →
    x ∙S 0S m c +S x₁ ∙S 0S m' c
    ≃S 0S r c
  zerorHelp r {m} {m'} {c} x x₁ p q =
    let open EqReasoning setoidS
    in begin
      x ∙S 0S m c +S x₁ ∙S 0S m' c
    ≈⟨ <+S> _ _ {x ∙S 0S m c} {0S r c} {x₁ ∙S 0S m' c} {0S r c} p q ⟩
      0S r c +S 0S r c
    ≈⟨ identSˡ r c (0S r c) ⟩
      0S r c
    ∎

  zeroSʳ : (a b c : Shape) (x : M s a b) →
    (x ∙S 0S b c) ≃S 0S a c
  zeroSʳ L L L (One x) = zeroʳ x
  zeroSʳ L L (B c c₁) (One x) =
    (zeroSʳ L L c (One x)) ,
    (zeroSʳ L L c₁ (One x))
  zeroSʳ L (B b b₁) L (Row x x₁) =
    zerorHelp L {c = L} x x₁ (zeroSʳ L b L x) (zeroSʳ L b₁ L x₁)
  zeroSʳ L (B b b₁) (B c c₁) (Row x x₁) =
    zerorHelp L {c = c} x x₁ (zeroSʳ L b c x) (zeroSʳ L b₁ c x₁) ,
    zerorHelp L {c = c₁} x x₁ (zeroSʳ L b c₁ x) (zeroSʳ L b₁ c₁ x₁)
  zeroSʳ (B a a₁) L L (Col x x₁) =
    zeroSʳ a L L x ,
    zeroSʳ a₁ L L x₁
  zeroSʳ (B a a₁) L (B c c₁) (Col x x₁) =
    zeroSʳ a L c x ,
    zeroSʳ a L c₁ x ,
    zeroSʳ a₁ L c x₁ ,
    zeroSʳ a₁ L c₁ x₁
  zeroSʳ (B a a₁) (B b b₁) L (Q x x₁ x₂ x₃) =
    zerorHelp a x x₁ (zeroSʳ a b L x) (zeroSʳ a b₁ L x₁) ,
    zerorHelp a₁ x₂ x₃ (zeroSʳ a₁ b L x₂) (zeroSʳ a₁ b₁ L x₃)
  zeroSʳ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    zerorHelp a x x₁ (zeroSʳ a b c x) (zeroSʳ a b₁ c x₁) ,
    zerorHelp a x x₁ (zeroSʳ a b c₁ x) (zeroSʳ a b₁ c₁ x₁) ,
    zerorHelp a₁ x₂ x₃ (zeroSʳ a₁ b c x₂) (zeroSʳ a₁ b₁ c x₃) ,
    zerorHelp a₁ x₂ x₃ (zeroSʳ a₁ b c₁ x₂) (zeroSʳ a₁ b₁ c₁ x₃)

  <∙S> : (a b c : Shape) {x y : M s a b} {u v : M s b c} →
    x ≃S y → u ≃S v → (x ∙S u) ≃S (y ∙S v)
  <∙S> L L L {One x} {One x₁} {One x₂} {One x₃} p q = p <∙> q
  <∙S> L L (B c c₁) {One x} {One x₁} {Row u u₁} {Row v v₁} p (q , q₁) =
    (<∙S> L L c {One x} {One x₁} {u} {v} p q) ,
    <∙S> L L c₁ {One x} {One x₁} {u₁} {v₁} p q₁
  <∙S> L (B b b₁) L {Row x x₁} {Row y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    -- Row x x₁ ∙S Col u u₁ ≃S Row y y₁ ∙S Col v v₁
    let
      open EqReasoning setoidS
      ih = <∙S> _ _ _ {x} {y} {u} {v} p q
      ih₁ = <∙S> _ _ _ {x₁} {y₁} {u₁} {v₁} p₁ q₁
    in begin
      Row x x₁ ∙S Col u u₁
    ≡⟨ refl-≡ ⟩
      x ∙S u +S x₁ ∙S u₁
    ≈⟨ <+S> L L {x ∙S u} {y ∙S v} {x₁ ∙S u₁} {y₁ ∙S v₁} ih ih₁ ⟩
      y ∙S v +S y₁ ∙S v₁
    ∎
  <∙S> L (B b b₁) (B c c₁) {Row x x₁} {Row y y₁} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁) (q , q₁ , q₂ , q₃) =
    (let
      ih = <∙S> L b c p q
      ih₁ = <∙S> L b₁ c p₁ q₂
    in <+S> L c ih ih₁) ,
    <+S> L c₁ (<∙S> L b c₁ p q₁) (<∙S> L b₁ c₁ p₁ q₃)
  <∙S> (B a a₁) L L {Col x x₁} {Col y y₁} {One x₂} {One x₃} (p , p₁) q =
    <∙S> a L L p q ,
    <∙S> a₁ L L p₁ q
  <∙S> (B a a₁) L (B c c₁) {Col x x₁} {Col y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <∙S> a L c p q ,
    <∙S> a L c₁ p q₁  ,
    <∙S> a₁ L c p₁ q ,
    <∙S> a₁ L c₁ p₁ q₁
  <∙S> (B a a₁) (B b b₁) L {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Col u u₁} {Col v v₁} (p , p₁ , p₂ , p₃) (q , q₁) =
    <+S> a L (<∙S> a b L p q) (<∙S> a b₁ L p₁ q₁) ,
    <+S> a₁ L (<∙S> a₁ b L p₂ q) (<∙S> a₁ b₁ L p₃ q₁ )
  <∙S> (B a a₁) (B b b₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> a c (<∙S> a b c p q) (<∙S> a b₁ c p₁ q₂) ,
    <+S> a c₁ (<∙S> a b c₁ p q₁) (<∙S> a b₁ c₁ p₁ q₃) ,
    <+S> a₁ c (<∙S> a₁ b c p₂ q) (<∙S> a₁ b₁ c p₃ q₂) ,
    <+S> a₁ c₁ (<∙S> a₁ b c₁ p₂ q₁) (<∙S> a₁ b₁ c₁ p₃ q₃)

  idemS : (r c : Shape) (x : M s r c) → x +S x ≃S x
  idemS L L (One x) = idem x
  idemS L (B c c₁) (Row x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) L (Col x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (idemS _ _ x) , (idemS _ _ x₁ , (idemS _ _ x₂  , idemS _ _ x₃))

  swapMid : {r c : Shape} (x y z w : M s r c) →
    (x +S y) +S (z +S w) ≃S (x +S z) +S (y +S w)
  swapMid {r} {c} x y z w =
    let open EqReasoning setoidS
    in begin
      (x +S y) +S (z +S w)
    ≈⟨ assocS _ _ x y (z +S w) ⟩
      x +S y +S z +S w
    ≈⟨ <+S> r c (reflS r c) (symS r c (assocS r c y z w)) ⟩
      x +S (y +S z) +S w
    ≈⟨ <+S> r c (reflS r c) (<+S> r c (commS r c y z) (reflS r c)) ⟩
      x +S (z +S y) +S w
    ≈⟨ <+S> r c (reflS r c) (assocS r c z y w) ⟩
      x +S z +S y +S w
    ≈⟨ symS r c (assocS r c x z (y +S w)) ⟩
      (x +S z) +S (y +S w)
    ∎

  distlHelp : ∀ {a b b₁ c₁}
              (x : M s a b)
              (y z : M s b c₁)
              (x₁ : M s a b₁)
              (y₁ z₁ : M s b₁ c₁) →
            (x ∙S (y +S z)) ≃S (x ∙S y +S x ∙S z) →
            (x₁ ∙S (y₁ +S z₁)) ≃S (x₁ ∙S y₁ +S x₁ ∙S z₁) →
            (x ∙S (y +S z) +S x₁ ∙S (y₁ +S z₁))
            ≃S ((x ∙S y +S x₁ ∙S y₁) +S x ∙S z +S x₁ ∙S z₁)
  distlHelp x y z x₁ y₁ z₁ p q =
    let open EqReasoning setoidS
    in begin
      x ∙S (y +S z) +S x₁ ∙S (y₁ +S z₁)
    ≈⟨ <+S> _ _ {x ∙S (y +S z)} {x ∙S y +S x ∙S z}
                {x₁ ∙S (y₁ +S z₁)} {x₁ ∙S y₁ +S x₁ ∙S z₁} p q ⟩
      (x ∙S y +S x ∙S z) +S x₁ ∙S y₁ +S x₁ ∙S z₁
    ≈⟨ swapMid (x ∙S y) (x ∙S z) (x₁ ∙S y₁) (x₁ ∙S z₁) ⟩
      (x ∙S y +S x₁ ∙S y₁) +S x ∙S z +S x₁ ∙S z₁
    ∎

  distlS : {a b c : Shape} (x : M s a b) (y z : M s b c) →
    (x ∙S (y +S z)) ≃S ((x ∙S y) +S (x ∙S z))
  distlS {L} {L} {L} (One x) (One y) (One z) = distl x y z
  distlS {L} {L} {B c c₁} (One x) (Row y y₁) (Row z z₁) =
    distlS (One x) y z ,
    distlS (One x) y₁ z₁
  distlS {L} {(B b b₁)} {L} (Row x x₁) (Col y y₁) (Col z z₁) =
    distlHelp x y z x₁ y₁ z₁ (distlS x y z) (distlS x₁ y₁ z₁)
  distlS {L} {(B b b₁)} {(B c c₁)} (Row x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distlHelp x y z x₁ y₂ z₂ (distlS x y z) (distlS x₁ y₂ z₂) ,
    distlHelp x y₁ z₁ x₁ y₃ z₃  (distlS x y₁ z₁) (distlS x₁ y₃ z₃)
  distlS {(B a a₁)} {L} {L} (Col x x₁) (One x₂) (One x₃) =
    distlS x (One x₂) (One x₃) ,
    distlS x₁ (One x₂) (One x₃)
  distlS {(B a a₁)} {L} {(B c c₁)} (Col x x₁) (Row y y₁) (Row z z₁) =
    distlS x y z ,
    distlS x y₁ z₁ ,
    distlS x₁ y z ,
    distlS x₁ y₁ z₁
  distlS {(B a a₁)} {(B b b₁)} {L} (Q x x₁ x₂ x₃) (Col y y₁) (Col z z₁) =
    distlHelp x y z x₁ y₁ z₁ (distlS x y z) (distlS x₁ y₁ z₁) ,
    distlHelp x₂ y z x₃ y₁ z₁ (distlS x₂ y z) (distlS x₃ y₁ z₁)
  distlS {(B a a₁)} {(B b b₁)} {(B c c₁)} (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distlHelp x y z x₁ y₂ z₂ (distlS x y z) (distlS x₁ y₂ z₂) ,
    distlHelp x y₁ z₁ x₁ y₃ z₃ (distlS x y₁ z₁) (distlS x₁ y₃ z₃) ,
    distlHelp x₂ y z x₃ y₂ z₂ (distlS x₂ y z) (distlS x₃ y₂ z₂)  ,
    distlHelp x₂ y₁ z₁ x₃ y₃ z₃ (distlS x₂ y₁ z₁) (distlS x₃ y₃ z₃)

  distrHelp : ∀ {r m m₁ c : Shape}
              (x : M s m c)
              (y z : M s r m)
              (x₁ : M s m₁ c)
              (y₁ z₁ : M s r m₁) →
            ((y +S z) ∙S x) ≃S (y ∙S x +S z ∙S x) →
            ((y₁ +S z₁) ∙S x₁) ≃S (y₁ ∙S x₁ +S z₁ ∙S x₁) →
            ((y +S z) ∙S x +S (y₁ +S z₁) ∙S x₁)
            ≃S ((y ∙S x +S y₁ ∙S x₁) +S z ∙S x +S z₁ ∙S x₁)
  distrHelp x y z x₁ y₁ z₁ p q =
    let open EqReasoning setoidS
    in begin
      (y +S z) ∙S x +S (y₁ +S z₁) ∙S x₁
    ≈⟨ <+S> _ _ {(y +S z) ∙S x} {y ∙S x +S z ∙S x}
                {(y₁ +S z₁) ∙S x₁} {y₁ ∙S x₁ +S z₁ ∙S x₁} p q ⟩
      (y ∙S x +S z ∙S x) +S y₁ ∙S x₁ +S z₁ ∙S x₁
    ≈⟨ swapMid (y ∙S x) (z ∙S x) (y₁ ∙S x₁) (z₁ ∙S x₁) ⟩
      (y ∙S x +S y₁ ∙S x₁) +S z ∙S x +S z₁ ∙S x₁
    ∎

  distrS : {r m c : Shape} (x : M s m c) (y z : M s r m) →
    ((y +S z) ∙S x) ≃S ((y ∙S x) +S (z ∙S x))
  distrS {L} {L} {L} (One x) (One y) (One z) =
    distr x y z
  distrS {L} {L} {B c c₁} (Row x x₁) (One x₂) (One x₃) =
    (distrS x (One x₂) (One x₃)) ,
    (distrS x₁ (One x₂) (One x₃))
  distrS {L} {B m m₁} {L} (Col x x₁) (Row y y₁) (Row z z₁) =
    distrHelp x y z x₁ y₁ z₁ (distrS x y z) (distrS x₁ y₁ z₁)
  distrS {L} {B m m₁} {B c c₁} (Q x x₁ x₂ x₃) (Row y y₁) (Row z z₁) =
    (distrHelp x y z x₂ y₁ z₁ (distrS x y z) (distrS x₂ y₁ z₁)) ,
    (distrHelp x₁ y z x₃ y₁ z₁ (distrS x₁ y z) (distrS x₃ y₁ z₁))
  distrS {B r r₁} {L} {L} (One x) (Col y y₁) (Col z z₁) =
    distrS (One x) y z ,
    distrS (One x) y₁ z₁
  distrS {B r r₁} {L} {B c c₁} (Row x x₁) (Col y y₁) (Col z z₁) =
    (distrS x y z) ,
    (distrS x₁ y z) ,
    (distrS x y₁ z₁) ,
    (distrS x₁ y₁ z₁)
  distrS {B r r₁} {B m m₁} {L} (Col x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (distrHelp x y z x₁ y₁ z₁ (distrS x y z) (distrS x₁ y₁ z₁)) ,
    (distrHelp x y₂ z₂ x₁ y₃ z₃ (distrS x y₂ z₂) (distrS x₁ y₃ z₃))
  distrS {B r r₁} {B m m₁} {B c c₁} (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distrHelp x y z x₂ y₁ z₁ (distrS x y z) (distrS x₂ y₁ z₁) ,
    distrHelp x₁ y z x₃ y₁ z₁ (distrS x₁ y z) (distrS x₃ y₁ z₁) ,
    distrHelp x y₂ z₂ x₂ y₃ z₃ (distrS x y₂ z₂) (distrS x₂ y₃ z₃) ,
    distrHelp x₁ y₂ z₂ x₃ y₃ z₃ (distrS x₁ y₂ z₂) (distrS x₃ y₃ z₃)

  SNR : SemiNearRing
  SNR =
    record
      { s = S
      ; _≃ₛ_ = _≃S_ {shape} {shape}
      ; 0ₛ = 0S shape shape
      ; _+ₛ_ = _+S_
      ; _∙ₛ_ = _∙S_
      ; isCommMon = isCommMonS
      ; zeroˡ = zeroSˡ shape shape shape
      ; zeroʳ = zeroSʳ shape shape shape
      ; _<∙>_ = <∙S> shape shape shape
      ; idem = idemS shape shape
      ; distl = distlS {shape} {shape}
      ; distr = distrS {shape} {shape}
      }

-- Matrices indexed by shape
module SquareMatrix where

open import Shape
open import Matrix

-- Square matrices have the same shape in both dimensions
Sq : Set → Shape → Set
Sq a shape = M a shape shape

open import SemiNearRingRecord
open import Algebra.Structures
open import Relation.Binary
open import Data.Product hiding (swap)

open import Relation.Binary.PropositionalEquality hiding (trans; sym) renaming (refl to refl-≡)
import Relation.Binary.EqReasoning as EqReasoning

-- Lifting a SNR to a to a Square matrix of some shape
Square : SemiNearRing → Shape → SemiNearRing
Square snr shape = SNR
  where
  open SemiNearRing snr

  S = Sq s shape

  infixr 60 _∙S_
  infixr 50 _+S_

  _+S_ : ∀ {r c} → M s r c → M s r c → M s r c
  One x     +S One x₁    = One (x +ₛ x₁)
  Row m m₁  +S Row n n₁  = Row (m +S n) (m₁ +S n₁)
  Col m m₁  +S Col n n₁  = Col (m +S n) (m₁ +S n₁)
  Q m00 m01
    m10 m11 +S Q n00 n01
                n10 n11 = Q (m00 +S n00) (m01 +S n01)
                            (m10 +S n10) (m11 +S n11)

  _∙S_ : ∀ {r m c} → M s r m → M s m c → M s r c
  One x     ∙S One x₁    = One (x ∙ₛ x₁)
  One x     ∙S Row n n₁  = Row (One x ∙S n) (One x ∙S n₁)
  Row m m₁  ∙S Col n n₁  = m ∙S n +S m₁ ∙S n₁
  Row m m₁  ∙S Q n00 n01
                n10 n11 = Row (m ∙S n00 +S m₁ ∙S n10) (m ∙S n01 +S m₁ ∙S n11)
  Col m m₁  ∙S One x     = Col (m ∙S One x) (m₁ ∙S One x)
  Col m m₁  ∙S Row n n₁  = Q (m ∙S n)   (m ∙S n₁)
                            (m₁ ∙S n)  (m₁ ∙S n₁)
  Q m00 m01
    m10 m11 ∙S Col n n₁  = Col (m00 ∙S n +S m01 ∙S n₁) (m10 ∙S n +S m11 ∙S n₁)
  Q m00 m01
    m10 m11 ∙S Q n00 n01
                n10 n11 = Q (m00 ∙S n00 +S m01 ∙S n10) (m00 ∙S n01 +S m01 ∙S n11)
                            (m10 ∙S n00 +S m11 ∙S n10) (m10 ∙S n01 +S m11 ∙S n11)

  0S : (r c : Shape) → M s r c
  0S L L = One 0ₛ
  0S L (B s s₁) = Row (0S L s) (0S L s₁)
  0S (B r r₁) L = Col (0S r L) (0S r₁ L)
  0S (B r r₁) (B s s₁) =
      Q (0S r s) (0S r s₁)
        (0S r₁ s) (0S r₁ s₁)

  _≃S_ : {r c : Shape} →
        M s r c → M s r c → Set
  _≃S_ {L} {L} (One x) (One x₁) = x ≃ₛ x₁
  _≃S_ {L} {(B c₁ c₂)} (Row m m₁) (Row n n₁) =
    _≃S_ m n × _≃S_ m₁ n₁
  _≃S_ {(B r₁ r₂)} {L} (Col m m₁) (Col n n₁) =
    _≃S_ m n × _≃S_ m₁ n₁
  _≃S_ {(B r₁ r₂)} {(B c₁ c₂)} (Q m00 m01 m10 m11) (Q n00 n01 n10 n11) =
    _≃S_ m00 n00 ×
    _≃S_ m01 n01 ×
    _≃S_ m10 n10 ×
    _≃S_ m11 n11

  reflS : (r c : Shape) →
    {X : M s r c} → X ≃S X
  reflS L L {X = One x} = reflₛ {x}
  reflS L (B c₁ c₂) {X = Row X Y} = reflS L c₁ , reflS L c₂
  reflS (B r₁ r₂) L {X = Col X Y} = reflS r₁ L , reflS r₂ L
  reflS (B r₁ r₂) (B c₁ c₂) {X = Q X Y Z W} =
    reflS r₁ c₁ , reflS r₁ c₂ ,
    reflS r₂ c₁ , reflS r₂ c₂

  symS : (r c : Shape) →
    {i j : M s r c} → i ≃S j → j ≃S i
  symS L L {One x} {One x₁} p = symₛ p
  symS L (B c₁ c₂) {Row i₁ i₂} {Row j₁ j₂} (p , q) = symS L c₁ p , symS L c₂ q
  symS (B r₁ r₂) L {Col i₁ i} {Col j j₁} (p , q) = symS r₁ L p , symS r₂ L q
  symS (B r r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j j₁ j₂ j₃} (p , q , x , y) =
    symS r c₁ p , symS r c₂ q ,
    symS r₂ c₁ x , symS r₂ c₂ y

  transS : (r c : Shape) →
    {i j k : M s r c} → i ≃S j → j ≃S k → i ≃S k
  transS L L {One x} {One x₁} {One x₂} p q = trans p q
  transS L (B c₁ c₂) {Row i i₁} {Row j j₁} {Row k k₁} (p , q) (p' , q') =
    transS L c₁ p p' , transS L c₂ q q'
  transS (B r₁ r₂) L {Col i i₁} {Col j j₁} {Col k k₁} (p , q) (p' , q') =
    transS r₁ L p p' , transS r₂ L q q'
  transS (B r₁ r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j₂ j j₃ j₁} {Q k k₁ k₂ k₃}
    (p , q , x , y) (p' , q' , x' , y') =
    transS r₁ c₁ p p' , transS r₁ c₂ q q' ,
    transS r₂ c₁ x x' , transS r₂ c₂ y y'

  isEquivS =
    record
      { refl = reflS shape shape
      ; sym = symS shape shape
      ; trans = transS shape shape }

  assocS : (r c : Shape) (x y z : M s r c) → ((x +S y) +S z) ≃S (x +S (y +S z))
  assocS L L (One x) (One y) (One z) = assocₛ x y z
  assocS L (B c c₁) (Row x x₁) (Row y y₁) (Row z z₁) =
    assocS L c x y z  , assocS L c₁ x₁ y₁ z₁
  assocS (B r r₁) L (Col x x₁) (Col y y₁) (Col z z₁) =
    assocS r L x y z , assocS r₁ L x₁ y₁ z₁
  assocS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (assocS r c x y z) , (assocS r c₁ x₁ y₁ z₁) ,
    (assocS r₁ c x₂ y₂ z₂) , (assocS r₁ c₁ x₃ y₃ z₃)

  <+S> : (r c : Shape) {x y u v : M s r c} →
    x ≃S y → u ≃S v → (x +S u) ≃S (y +S v)
  <+S> L L {One x} {One x₁} {One x₂} {One x₃} p q = p <+> q
  <+S> L (B c c₁) {Row x x₁} {Row y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <+S> L c p q , <+S> L c₁ p₁ q₁
  <+S> (B r r₁) L {Col x x₁} {Col y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    <+S> r L p q , <+S> r₁ L p₁ q₁
  <+S> (B r r₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃}
    (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> r c p q , <+S> r c₁ p₁ q₁ ,
    <+S> r₁ c p₂ q₂ , <+S> r₁ c₁ p₃ q₃

  isSemgroupS =
    record
      { isEquivalence = isEquivS
      ; assoc = assocS shape shape
      ; ∙-cong = <+S> shape shape }

  identSˡ : (r c : Shape) (x : M s r c) →
     0S r c +S x ≃S x
  identSˡ L L (One x) = identityˡₛ x
  identSˡ L (B c c₁) (Row x x₁) = identSˡ L c x , identSˡ L c₁ x₁
  identSˡ (B r r₁) L (Col x x₁) = identSˡ r L x , identSˡ r₁ L x₁
  identSˡ (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    identSˡ r c x , identSˡ r c₁ x₁ ,
    identSˡ r₁ c x₂ , identSˡ r₁ c₁ x₃

  commS : (r c : Shape) → (x y : M s r c) →
    (x +S y) ≃S (y +S x)
  commS L L (One x) (One x₁) = commₛ x x₁
  commS L (B c c₁) (Row x x₁) (Row y y₁) = (commS L c x y) , (commS L c₁ x₁ y₁)
  commS (B r r₁) L (Col x x₁) (Col y y₁) = (commS r L x y) , (commS r₁ L x₁ y₁)
  commS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) =
    commS r c x y , commS r c₁ x₁ y₁ ,
    commS r₁ c x₂ y₂ , commS r₁ c₁ x₃ y₃

  isCommMonS =
    record
      { isSemigroup = isSemgroupS
      ; identityˡ = identSˡ shape shape
      ; comm = commS shape shape }

  setoidS : {r c : Shape} → Setoid _ _
  setoidS {r} {c} =
    record
      { Carrier = M s r c
      ; _≈_ = _≃S_ {r} {c}
      ; isEquivalence =
        record
          { refl = reflS r c ; sym = symS r c ; trans = transS r c } }

  zeroSˡ : (a b c : Shape) (x : M s b c) →
    (0S a b ∙S x) ≃S 0S a c
  zeroSˡ L L L (One x) = zeroˡ x
  zeroSˡ L L (B c c₁) (Row x x₁) = (zeroSˡ L L c x) , (zeroSˡ L L c₁ x₁)
  zeroSˡ L (B b b₁) L (Col x x₁) =
    let
      open EqReasoning setoidS
      ih = zeroSˡ L b L x
      ih₁ = zeroSˡ L b₁ L x₁
    in begin
      (Row (0S L b) (0S L b₁) ∙S (Col x x₁))
    ≡⟨ refl-≡ ⟩
      (0S L b) ∙S x +S (0S L b₁) ∙S x₁
    ≈⟨ <+S> L L {0S L b ∙S x} {0S L L} {0S L b₁ ∙S x₁} {0S L L} ih ih₁ ⟩
      0S L L +S 0S L L
    ≈⟨ identSˡ L L (0S L L) ⟩
      0S L L
    ∎
  zeroSˡ L (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSˡ L b c x
      ih₁ = zeroSˡ L b₁ c x₂
     in begin
       0S L b ∙S x +S 0S L b₁ ∙S x₂
     ≈⟨ <+S> L c ih ih₁ ⟩
       0S L c +S 0S L c
     ≈⟨ identSˡ L c (0S L c) ⟩
       0S L c
     ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ L b c₁ x₁
      ih₁ = zeroSˡ L b₁ c₁ x₃
    in begin
      0S L b ∙S x₁ +S 0S L b₁ ∙S x₃
    ≈⟨ <+S> L c₁ ih ih₁ ⟩
      0S L c₁ +S 0S L c₁
    ≈⟨ identSˡ L c₁ _ ⟩
      0S L c₁
    ∎)
  zeroSˡ (B a a₁) L L (One x) = zeroSˡ a L L (One x) , zeroSˡ a₁ L L (One x)
  zeroSˡ (B a a₁) L (B c c₁) (Row x x₁) =
    zeroSˡ a L c x , zeroSˡ a L c₁ x₁ ,
    zeroSˡ a₁ L c x , zeroSˡ a₁ L c₁ x₁
  zeroSˡ (B a a₁) (B b b₁) L (Col x x₁) =
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a b L x
      ih₁ = zeroSˡ a b₁ L x₁
    in begin
      0S a b ∙S x +S 0S a b₁ ∙S x₁
    ≈⟨ <+S> a L ih ih₁ ⟩
      0S a L +S 0S a L
    ≈⟨ identSˡ a L _ ⟩
      0S a L
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a₁ b L x
      ih₁ = zeroSˡ a₁ b₁ L x₁
    in begin
      0S a₁ b ∙S x +S 0S a₁ b₁ ∙S x₁
    ≈⟨ <+S> a₁ L ih ih₁ ⟩
      0S a₁ L +S 0S a₁ L
    ≈⟨ identSˡ a₁ L _ ⟩
      0S a₁ L
    ∎)
  zeroSˡ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a b c x
      ih₁ = zeroSˡ a b₁ c x₂
    in begin
      0S a b ∙S x +S 0S a b₁ ∙S x₂
    ≈⟨ <+S> a c ih ih₁ ⟩
      0S a c +S 0S a c
    ≈⟨ identSˡ a c _ ⟩
      0S a c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a b c₁ x₁
      ih₁ = zeroSˡ a b₁ c₁ x₃
    in begin
      0S a b ∙S x₁ +S 0S a b₁ ∙S x₃
    ≈⟨ <+S> a c₁ ih ih₁ ⟩
      0S a c₁ +S 0S a c₁
    ≈⟨ identSˡ a c₁ _ ⟩
      0S a c₁
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a₁ b c x
      ih₁ = zeroSˡ a₁ b₁ c x₂
    in begin
      0S a₁ b ∙S x +S 0S a₁ b₁ ∙S x₂
    ≈⟨ <+S> a₁ c ih ih₁ ⟩
      0S a₁ c +S 0S a₁ c
    ≈⟨ identSˡ a₁ c _ ⟩
      0S a₁ c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a₁ b c₁ x₁
      ih₁ = zeroSˡ a₁ b₁ c₁ x₃
    in begin
      0S a₁ b ∙S x₁ +S 0S a₁ b₁ ∙S x₃
    ≈⟨ <+S> a₁ c₁ ih ih₁ ⟩
      0S a₁ c₁ +S 0S a₁ c₁
    ≈⟨ identSˡ a₁ c₁ _ ⟩
      0S a₁ c₁
    ∎)

  zeroSʳ : (a b c : Shape) (x : M s a b) →
    (x ∙S 0S b c) ≃S 0S a c
  zeroSʳ L L L (One x) = zeroʳ x
  zeroSʳ L L (B c c₁) (One x) =
    (zeroSʳ L L c (One x)) , (zeroSʳ L L c₁ (One x))
  zeroSʳ L (B b b₁) L (Row x x₁) =
    let
      open EqReasoning setoidS
      ih = zeroSʳ L b L x
      ih₁ = zeroSʳ L b₁ L x₁
    in begin
      Row x x₁ ∙S Col (0S b L) (0S b₁ L)
    ≡⟨ refl-≡ ⟩
      (x ∙S 0S b L) +S (x₁ ∙S 0S b₁ L)
    ≈⟨ <+S> L L {x ∙S 0S b L} {0S L L} {x₁ ∙S 0S b₁ L} {0S L L} ih ih₁ ⟩
      0S L L +S 0S L L
    ≈⟨ identSˡ L L (0S L L) ⟩
      0S L L
    ∎
  zeroSʳ L (B b b₁) (B c c₁) (Row x x₁) =
    (let
      open EqReasoning setoidS
      ih = zeroSʳ L b c x
      ih₁ = zeroSʳ L b₁ c x₁
    in begin
      x ∙S 0S b c +S x₁ ∙S 0S b₁ c
    ≈⟨ <+S> L c ih ih₁ ⟩
      0S L c +S 0S L c
    ≈⟨ identSˡ L c (0S L c) ⟩
      0S L c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ L b c₁ x
      ih₁ = zeroSʳ L b₁ c₁ x₁
    in begin
      x ∙S 0S b c₁ +S x₁ ∙S 0S b₁ c₁
    ≈⟨ <+S> L c₁ ih ih₁ ⟩
      0S L c₁ +S 0S L c₁
    ≈⟨ identSˡ L c₁ (0S L c₁) ⟩
      0S L c₁
    ∎)
  zeroSʳ (B a a₁) L L (Col x x₁) = zeroSʳ a L L x , zeroSʳ a₁ L L x₁
  zeroSʳ (B a a₁) L (B c c₁) (Col x x₁) =
    zeroSʳ a L c x ,
    zeroSʳ a L c₁ x ,
    zeroSʳ a₁ L c x₁ ,
    zeroSʳ a₁ L c₁ x₁
  zeroSʳ (B a a₁) (B b b₁) L (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a b L x
      ih₁ = zeroSʳ a b₁ L x₁
    in begin
      x ∙S 0S b L +S x₁ ∙S 0S b₁ L
    ≈⟨ <+S> a L ih ih₁ ⟩
      0S a L +S 0S a L
    ≈⟨ identSˡ a L (0S _ _) ⟩
      0S a L
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a₁ b L x₂
      ih₁ = zeroSʳ a₁ b₁ L x₃
    in begin
      x₂ ∙S 0S b L +S x₃ ∙S 0S b₁ L
    ≈⟨ <+S> a₁ L ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ L (0S _ _) ⟩
      0S a₁ L
    ∎)
  zeroSʳ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a b c x
      ih₁ = zeroSʳ a b₁ c x₁
    in begin
      x ∙S 0S b c +S x₁ ∙S 0S b₁ c
    ≈⟨ <+S> a c ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a c (0S _ _) ⟩
      0S _ _
    ∎) ,
    (let
      ih = zeroSʳ a b c₁ x
      ih₁ = zeroSʳ a b₁ c₁ x₁
    in transS a c₁ (<+S> a c₁ ih ih₁) (identSˡ a c₁ (0S _ _))
    ) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a₁ b c x₂
      ih₁ = zeroSʳ a₁ b₁ c x₃
    in begin
      x₂ ∙S 0S b c +S x₃ ∙S 0S b₁ c
    ≈⟨ <+S> a₁ c ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ c (0S _ _) ⟩
      0S a₁ c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a₁ b c₁ x₂
      ih₁ = zeroSʳ a₁ b₁ c₁ x₃
    in begin
      x₂ ∙S 0S b c₁ +S x₃ ∙S 0S b₁ c₁
    ≈⟨ <+S> a₁ c₁ ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ c₁ (0S _ _) ⟩
      0S a₁ c₁
    ∎)

  <∙S> : (a b c : Shape) {x y : M s a b} {u v : M s b c} →
    x ≃S y → u ≃S v → (x ∙S u) ≃S (y ∙S v)
  <∙S> L L L {One x} {One x₁} {One x₂} {One x₃} p q = p <∙> q
  <∙S> L L (B c c₁) {One x} {One x₁} {Row u u₁} {Row v v₁} p (q , q₁) =
    (<∙S> L L c {One x} {One x₁} {u} {v} p q) ,
    <∙S> L L c₁ {One x} {One x₁} {u₁} {v₁} p q₁
  <∙S> L (B b b₁) L {Row x x₁} {Row y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    -- Row x x₁ ∙S Col u u₁ ≃S Row y y₁ ∙S Col v v₁
    let
      open EqReasoning setoidS
      ih = <∙S> _ _ _ {x} {y} {u} {v} p q
      ih₁ = <∙S> _ _ _ {x₁} {y₁} {u₁} {v₁} p₁ q₁
    in begin
      Row x x₁ ∙S Col u u₁
    ≡⟨ refl-≡ ⟩
      x ∙S u +S x₁ ∙S u₁
    ≈⟨ <+S> L L {x ∙S u} {y ∙S v} {x₁ ∙S u₁} {y₁ ∙S v₁} ih ih₁ ⟩
      y ∙S v +S y₁ ∙S v₁
    ∎
  <∙S> L (B b b₁) (B c c₁) {Row x x₁} {Row y y₁} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁) (q , q₁ , q₂ , q₃) =
    (let
      ih = <∙S> L b c p q
      ih₁ = <∙S> L b₁ c p₁ q₂
    in <+S> L c ih ih₁) ,
    <+S> L c₁ (<∙S> L b c₁ p q₁) (<∙S> L b₁ c₁ p₁ q₃)
  <∙S> (B a a₁) L L {Col x x₁} {Col y y₁} {One x₂} {One x₃} (p , p₁) q =
    <∙S> a L L p q ,
    <∙S> a₁ L L p₁ q
  <∙S> (B a a₁) L (B c c₁) {Col x x₁} {Col y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <∙S> a L c p q ,
    <∙S> a L c₁ p q₁  ,
    <∙S> a₁ L c p₁ q ,
    <∙S> a₁ L c₁ p₁ q₁
  <∙S> (B a a₁) (B b b₁) L {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Col u u₁} {Col v v₁} (p , p₁ , p₂ , p₃) (q , q₁) =
    <+S> a L (<∙S> a b L p q) (<∙S> a b₁ L p₁ q₁) ,
    <+S> a₁ L (<∙S> a₁ b L p₂ q) (<∙S> a₁ b₁ L p₃ q₁ )
  <∙S> (B a a₁) (B b b₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> a c (<∙S> a b c p q) (<∙S> a b₁ c p₁ q₂) ,
    <+S> a c₁ (<∙S> a b c₁ p q₁) (<∙S> a b₁ c₁ p₁ q₃) ,
    <+S> a₁ c (<∙S> a₁ b c p₂ q) (<∙S> a₁ b₁ c p₃ q₂) ,
    <+S> a₁ c₁ (<∙S> a₁ b c₁ p₂ q₁) (<∙S> a₁ b₁ c₁ p₃ q₃)

  idemS : (r c : Shape) (x : M s r c) → x +S x ≃S x
  idemS L L (One x) = idem x
  idemS L (B c c₁) (Row x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) L (Col x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (idemS _ _ x) , (idemS _ _ x₁ , (idemS _ _ x₂  , idemS _ _ x₃))

  swapMid : {r c : Shape} (x y z w : M s r c) →
    (x +S y) +S (z +S w) ≃S (x +S z) +S (y +S w)
  swapMid {r} {c} x y z w =
    let open EqReasoning setoidS
    in begin
      (x +S y) +S (z +S w)
    ≈⟨ assocS _ _ x y (z +S w) ⟩
      x +S y +S z +S w
    ≈⟨ <+S> r c (reflS r c) (symS r c (assocS r c y z w)) ⟩
      x +S (y +S z) +S w
    ≈⟨ <+S> r c (reflS r c) (<+S> r c (commS r c y z) (reflS r c)) ⟩
      x +S (z +S y) +S w
    ≈⟨ <+S> r c (reflS r c) (assocS r c z y w) ⟩
      x +S z +S y +S w
    ≈⟨ symS r c (assocS r c x z (y +S w)) ⟩
      (x +S z) +S (y +S w)
    ∎

  distlHelp : ∀ {a b b₁ c₁}
              (x : M s a b)
              (y z : M s b c₁)
              (x₁ : M s a b₁)
              (y₁ z₁ : M s b₁ c₁) →
            (x ∙S (y +S z)) ≃S (x ∙S y +S x ∙S z) →
            (x₁ ∙S (y₁ +S z₁)) ≃S (x₁ ∙S y₁ +S x₁ ∙S z₁) →
            (x ∙S (y +S z) +S x₁ ∙S (y₁ +S z₁))
            ≃S ((x ∙S y +S x₁ ∙S y₁) +S x ∙S z +S x₁ ∙S z₁)
  distlHelp x y z x₁ y₁ z₁ p q =
    let open EqReasoning setoidS
    in begin
      x ∙S (y +S z) +S x₁ ∙S (y₁ +S z₁)
    ≈⟨ <+S> _ _ {x ∙S (y +S z)} {x ∙S y +S x ∙S z}
                {x₁ ∙S (y₁ +S z₁)} {x₁ ∙S y₁ +S x₁ ∙S z₁} p q ⟩
      (x ∙S y +S x ∙S z) +S x₁ ∙S y₁ +S x₁ ∙S z₁
    ≈⟨ swapMid (x ∙S y) (x ∙S z) (x₁ ∙S y₁) (x₁ ∙S z₁) ⟩
      (x ∙S y +S x₁ ∙S y₁) +S x ∙S z +S x₁ ∙S z₁
    ∎

  distlS : {a b c : Shape} (x : M s a b) (y z : M s b c) →
    (x ∙S (y +S z)) ≃S ((x ∙S y) +S (x ∙S z))
  distlS {L} {L} {L} (One x) (One y) (One z) = distl x y z
  distlS {L} {L} {B c c₁} (One x) (Row y y₁) (Row z z₁) =
    distlS (One x) y z ,
    distlS (One x) y₁ z₁
  distlS {L} {(B b b₁)} {L} (Row x x₁) (Col y y₁) (Col z z₁) =
    distlHelp x y z x₁ y₁ z₁ (distlS x y z) (distlS x₁ y₁ z₁)
  distlS {L} {(B b b₁)} {(B c c₁)} (Row x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distlHelp x y z x₁ y₂ z₂ (distlS x y z) (distlS x₁ y₂ z₂) ,
    distlHelp x y₁ z₁ x₁ y₃ z₃  (distlS x y₁ z₁) (distlS x₁ y₃ z₃)
  distlS {(B a a₁)} {L} {L} (Col x x₁) (One x₂) (One x₃) =
    distlS x (One x₂) (One x₃) ,
    distlS x₁ (One x₂) (One x₃)
  distlS {(B a a₁)} {L} {(B c c₁)} (Col x x₁) (Row y y₁) (Row z z₁) =
    distlS x y z ,
    distlS x y₁ z₁ ,
    distlS x₁ y z ,
    distlS x₁ y₁ z₁
  distlS {(B a a₁)} {(B b b₁)} {L} (Q x x₁ x₂ x₃) (Col y y₁) (Col z z₁) =
    distlHelp x y z x₁ y₁ z₁ (distlS x y z) (distlS x₁ y₁ z₁) ,
    distlHelp x₂ y z x₃ y₁ z₁ (distlS x₂ y z) (distlS x₃ y₁ z₁)
  distlS {(B a a₁)} {(B b b₁)} {(B c c₁)} (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distlHelp x y z x₁ y₂ z₂ (distlS x y z) (distlS x₁ y₂ z₂) ,
    distlHelp x y₁ z₁ x₁ y₃ z₃ (distlS x y₁ z₁) (distlS x₁ y₃ z₃) ,
    distlHelp x₂ y z x₃ y₂ z₂ (distlS x₂ y z) (distlS x₃ y₂ z₂)  ,
    distlHelp x₂ y₁ z₁ x₃ y₃ z₃ (distlS x₂ y₁ z₁) (distlS x₃ y₃ z₃)

  distrHelp : ∀ {r m m₁ c : Shape}
              (x : M s m c)
              (y z : M s r m)
              (x₁ : M s m₁ c)
              (y₁ z₁ : M s r m₁) →
            ((y +S z) ∙S x) ≃S (y ∙S x +S z ∙S x) →
            ((y₁ +S z₁) ∙S x₁) ≃S (y₁ ∙S x₁ +S z₁ ∙S x₁) →
            ((y +S z) ∙S x +S (y₁ +S z₁) ∙S x₁)
            ≃S ((y ∙S x +S y₁ ∙S x₁) +S z ∙S x +S z₁ ∙S x₁)
  distrHelp x y z x₁ y₁ z₁ p q =
    let open EqReasoning setoidS
    in begin
      (y +S z) ∙S x +S (y₁ +S z₁) ∙S x₁
    ≈⟨ <+S> _ _ {(y +S z) ∙S x} {y ∙S x +S z ∙S x}
                {(y₁ +S z₁) ∙S x₁} {y₁ ∙S x₁ +S z₁ ∙S x₁} p q ⟩
      (y ∙S x +S z ∙S x) +S y₁ ∙S x₁ +S z₁ ∙S x₁
    ≈⟨ swapMid (y ∙S x) (z ∙S x) (y₁ ∙S x₁) (z₁ ∙S x₁) ⟩
      (y ∙S x +S y₁ ∙S x₁) +S z ∙S x +S z₁ ∙S x₁
    ∎

  distrS : {r m c : Shape} (x : M s m c) (y z : M s r m) →
    ((y +S z) ∙S x) ≃S ((y ∙S x) +S (z ∙S x))
  distrS {L} {L} {L} (One x) (One y) (One z) =
    distr x y z
  distrS {L} {L} {B c c₁} (Row x x₁) (One x₂) (One x₃) =
    (distrS x (One x₂) (One x₃)) ,
    (distrS x₁ (One x₂) (One x₃))
  distrS {L} {B m m₁} {L} (Col x x₁) (Row y y₁) (Row z z₁) =
    distrHelp x y z x₁ y₁ z₁ (distrS x y z) (distrS x₁ y₁ z₁)
  distrS {L} {B m m₁} {B c c₁} (Q x x₁ x₂ x₃) (Row y y₁) (Row z z₁) =
    (distrHelp x y z x₂ y₁ z₁ (distrS x y z) (distrS x₂ y₁ z₁)) ,
    (distrHelp x₁ y z x₃ y₁ z₁ (distrS x₁ y z) (distrS x₃ y₁ z₁))
  distrS {B r r₁} {L} {L} (One x) (Col y y₁) (Col z z₁) =
    distrS (One x) y z ,
    distrS (One x) y₁ z₁
  distrS {B r r₁} {L} {B c c₁} (Row x x₁) (Col y y₁) (Col z z₁) =
    (distrS x y z) ,
    (distrS x₁ y z) ,
    (distrS x y₁ z₁) ,
    (distrS x₁ y₁ z₁)
  distrS {B r r₁} {B m m₁} {L} (Col x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (distrHelp x y z x₁ y₁ z₁ (distrS x y z) (distrS x₁ y₁ z₁)) ,
    (distrHelp x y₂ z₂ x₁ y₃ z₃ (distrS x y₂ z₂) (distrS x₁ y₃ z₃))
  distrS {B r r₁} {B m m₁} {B c c₁} (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distrHelp x y z x₂ y₁ z₁ (distrS x y z) (distrS x₂ y₁ z₁) ,
    distrHelp x₁ y z x₃ y₁ z₁ (distrS x₁ y z) (distrS x₃ y₁ z₁) ,
    distrHelp x y₂ z₂ x₂ y₃ z₃ (distrS x y₂ z₂) (distrS x₂ y₃ z₃) ,
    distrHelp x₁ y₂ z₂ x₃ y₃ z₃ (distrS x₁ y₂ z₂) (distrS x₃ y₃ z₃)

  SNR : SemiNearRing
  SNR =
    record
      { s = S
      ; _≃ₛ_ = _≃S_ {shape} {shape}
      ; 0ₛ = 0S shape shape
      ; _+ₛ_ = _+S_
      ; _∙ₛ_ = _∙S_
      ; isCommMon = isCommMonS
      ; zeroˡ = zeroSˡ shape shape shape
      ; zeroʳ = zeroSʳ shape shape shape
      ; _<∙>_ = <∙S> shape shape shape
      ; idem = idemS shape shape
      ; distl = distlS {shape} {shape}
      ; distr = distrS {shape} {shape}
      }


fix elgamal

fix elgamal

{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.Product
open import Data.Unit
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc; Fin▹ℕ) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_; _==_)
open import Data.Bit
open import Data.Bits hiding (_==_)
open import Relation.Binary.PropositionalEquality.NP as ≡
import Game.DDH
import Game.IND-CPA
import Cipher.ElGamal.Generic
open import Search.Type
open import Search.Searchable renaming (Searchable to Explorable)
open import Search.Searchable.Product
open import Search.Searchable.Fin
open import Relation.Binary.NP

module elgamal where

data `★ : ★ where
  `⊤   : `★
  `X   : `★
  _`×_ : `★ → `★ → `★
infixr 2 _`×_

module Univ (X : ★) where
    El : `★ → ★
    El `⊤         = ⊤
    El `X         = X
    El (u₀ `× u₁) = El u₀ × El u₁

    record ↺ (R : `★) (A : ★) : ★ where
      constructor mk
      field
        run↺ : El R → A
    open ↺ public

    EXP : (R : `★) → ★
    EXP R = ↺ R Bit

    Det : ★ → ★
    Det = ↺ `⊤

    μU : Explorable X → ∀ u → Explorable (El u)
    μU μX `⊤         = μ⊤
    μU μX `X         = μX
    μU μX (u₀ `× u₁) = μU μX u₀ ×-μ μU μX u₁

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : Explorable ℤq)
  (⊞-stable : ∀ x → SumStableUnder (sum μℤq) (_⊞_ x))
  where

  -- open Sum
  open Univ ℤq public
  open `★ public renaming (`X to `ℤq)

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = count (μU μℤq u) (run↺ f)

  #q_ : Count ℤq
  #q_ = count μℤq

  ⁇ : ∀ R → ↺ R (El R)
  run↺ (⁇ _) = id

  pure↺ : ∀ {R A} → A → ↺ R A
  run↺ (pure↺ x) r = x -- turning r to _ produce an error

  ⟪_⟫ : ∀ {R A} → A → ↺ R A
  ⟪_⟫ = pure↺

  {-
  ⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
  ⟪_⟫ᴰ = pureᴰ
  -}

  map↺ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  run↺ (map↺ f x) r = f (run↺ x r)

  infixl 4 _⊛_
  _⊛_ : ∀ {R S A B} → ↺ R (A → B) → ↺ S A → ↺ (R `× S) B
  run↺ (af ⊛ ax) rs = run↺ af (proj₁ rs) (run↺ ax (proj₂ rs))

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

  ⟪_·_·_⟫ : ∀ {A B C} {R S} →
              (A → B → C) → ↺ R A → ↺ S B → ↺ (R `× S) C
  ⟪ f · x · y ⟫ = map↺ f x ⊛ y

  _⟨⊞⟩_ : ∀ {R S} → ↺ R ℤq → ↺ S ℤq → ↺ (R `× S) ℤq
  x ⟨⊞⟩ y = ⟪ _⊞_ · x · y ⟫

  ⟨_⊞⟩_ : ∀ {R} → ℤq → ↺ R ℤq → ↺ R ℤq
  ⟨ x ⊞⟩ y = ⟪ _⊞_ x · y ⟫

  infix 4 _≈↺_ _≈ᴬ_
  _≈↺_ : ∀ {R : `★} (f g : EXP R) → ★
  _≈↺_ = _≡_ on #_

  _≈ᴬ_ : ∀ {A R} (f g : ↺ R A) → Set _
  _≈ᴬ_ {A} f g = ∀ (Adv : A → Bit) → ⟪ Adv · f ⟫ ≈↺ ⟪ Adv · g ⟫

  lem : ∀ x → ⟨ x ⊞⟩ (⁇ `ℤq) ≈ᴬ ⁇ _
  lem x Adv = sym (⊞-stable x (Bit▹ℕ ∘ Adv))

  -- ∀ (A : ℤq → Bit) → # (A ⁇)

open Fin.Modulo renaming (sucmod to [suc]; sucmod-inj to [suc]-inj)

{-
module ℤq-implem (q-2 : ℕ) where
  q : ℕ
  q = 2 + q-2

  ℤq : ★
  ℤq = Fin q

  [0] : ℤq
  [0] = zero

  [1] : ℤq
  [1] = suc zero
-}
module ℤq-implem (q-1 : ℕ) ([0]' [1]' : Fin (suc q-1)) where
  -- open Sum
  q : ℕ
  q = suc q-1

  ℤq : ★
  ℤq = Fin q

  μℤq : Explorable ℤq
  μℤq = μFinSuc q-1

  sumℤq : Sum ℤq
  sumℤq = sum μℤq

  [0] : ℤq
  [0] = [0]'

  [1] : ℤq
  [1] = [1]'

  [suc]-stable : SumStableUnder (sum μℤq) [suc]
  [suc]-stable = μFinSUI [suc] [suc]-inj

  _ℕ⊞_ : ℕ → ℤq → ℤq
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = m ℕ⊞ ([suc] n)

  ℕ⊞-inj : ∀ n {x y} → n ℕ⊞ x ≡ n ℕ⊞ y → x ≡ y
  ℕ⊞-inj zero    eq = eq
  ℕ⊞-inj (suc n) eq = [suc]-inj (ℕ⊞-inj n eq)

  ℕ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_ℕ⊞_ m)
  ℕ⊞-stable m = μFinSUI (_ℕ⊞_ m) (ℕ⊞-inj m)

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin▹ℕ m ℕ⊞ n

  ⊞-inj : ∀ m {x y} → m ⊞ x ≡ m ⊞ y → x ≡ y
  ⊞-inj m = ℕ⊞-inj (Fin▹ℕ m)

  ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_⊞_ m)
  ⊞-stable m = μFinSUI (_⊞_ m) (⊞-inj m)

  _ℕ⊠_ : ℕ → ℤq → ℤq
  zero  ℕ⊠ n = [0]
  suc m ℕ⊠ n = n ⊞ (m ℕ⊠ n)

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin▹ℕ m ℕ⊠ n

  _[^]ℕ_ : ℤq → ℕ → ℤq
  m [^]ℕ zero  = [1]
  m [^]ℕ suc n = m ⊠ (m [^]ℕ n)

  _[^]_ : ℤq → ℤq → ℤq
  m [^] n = m [^]ℕ (Fin▹ℕ n)

module G-implem (p-1 q-1 : ℕ) (g' 0[p] 1[p] : Fin (suc p-1)) (0[q] 1[q] : Fin (suc q-1)) where
  open ℤq-implem q-1 0[q] 1[q] public
  open ℤq-implem p-1 0[p] 1[p] public using () renaming (ℤq to G; _⊠_ to _∙_; _[^]ℕ_ to _^[p]_)

  g : G
  g = g'

  _^_ : G → ℤq → G
  x ^ n = x ^[p] Fin▹ℕ n

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

  {-
  g^-inj : ∀ m n → g^ m ≡ g^ n → m ≡ n
  g^-inj = {!!}
  -}

module G-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : Explorable ℤq)
  (⊞-stable : ∀ x → SumStableUnder (sum μℤq) (_⊞_ x))
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (_∙_ : G → G → G)
  where

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

  open ℤq-count ℤq _⊞_ μℤq ⊞-stable

  ⁇G : ↺ `ℤq G
  run↺ ⁇G x = g^ x

  #G : Count G
  #G f = #q (f ∘ g^_)

  {-
  #G-∙ : ∀ f m → #G (f ∘ _∙_ m) ≡ #G f
  #G-∙ f m = {!!}
  -}

module El-Gamal-Generic
  (ℤq       : ★)
  (_⊠_      : ℤq → ℤq → ℤq)
  (G        : ★)
  (g        : G)
  (_^_      : G → ℤq → G)
  (Message  : ★)
  (_∙_      : G → Message → Message)

  -- Required for decryption
  (_/_      : Message → G → Message)

  -- Required for the correctness proof
  (/-∙      : ∀ x y → (x ∙ y) / x ≡ y)
  (comm-^   : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x)

  -- Required for the security proof
  (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
  (μℤq      : Explorable ℤq)
  (Rₐ       : ★)
  (μRₐ      : Explorable Rₐ)
  where

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

    -- gˣ is the pk
    -- x is the sk

    Rₓ : ★
    Rₓ = ℤq

    open Cipher.ElGamal.Generic Message ℤq G g _^_ _∙_ _/_

    functional-correctness : ∀ x y m → Dec x (Enc (g^ x) m y) ≡ m
    functional-correctness x y m rewrite comm-^ g x y | /-∙ (g^ y ^ x) m = refl

    module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText Rₑ Rₖ Rₐ Rₓ KeyGen Enc
    open IND-CPA using (R)

    UnusedGame : (i : Bit) → IND-CPA.Adv → (Bit × Rₐ × ℤq × ℤq × ℤq) → Bit
    UnusedGame i (m , d) (b , rₐ , x , y , z) = b == d rₐ gˣ (gʸ , ζ)
      where gˣ = g^ x
            gʸ = g^ y
            δ  = gˣ ^ case i 0→ y 1→ z
            ζ  = δ ∙ m rₐ gˣ b

    module DDH = Game.DDH ℤq G g _^_ Rₐ

    OTP⅁ : (Rₐ → G → Message) → (Rₐ → G → G → Message → Bit) → R → Bit
    OTP⅁ M d (r , x , y , z) = d r gˣ gʸ (gᶻ ∙ M r gˣ)
      where gˣ = g^ x
            gʸ = g^ y
            gᶻ = g^ z

    TrA : Bit → IND-CPA.Adv → DDH.Adv
    TrA b (m , d) rₐ gˣ gʸ gˣʸ = d rₐ gˣ (gʸ , gˣʸ ∙ m rₐ gˣ b)

    projM : IND-CPA.Adv → Bit → Rₐ → G → Message
    projM (m , _) b rₐ gˣ = m rₐ gˣ b

    projD : IND-CPA.Adv → Rₐ → G → G → Message → Bit
    projD (_ , d) rₐ gˣ gʸ gᶻ∙M = d rₐ gˣ (gʸ , gᶻ∙M)

    module Unused where
        like-⅁ : Bit → IND-CPA.Game
        like-⅁ b (m , d) (rₐ , x , y , _z) =
          d rₐ gˣ (gʸ , (gˣ ^ y) ∙ m rₐ gˣ b)
          where gˣ = g^ x
                gʸ = g^ y

        IND-CPA-⅁≡like-⅁ : IND-CPA.⅁ ≡ like-⅁
        IND-CPA-⅁≡like-⅁ = refl

    -- R = Rₐ × ℤq × ℤq × ℤq
    μR : Explorable R
    μR = μRₐ ×-μ μℤq ×-μ μℤq ×-μ μℤq

    #ᴿ_ : Count R
    #ᴿ_ = count μR

    #q_ : Count ℤq
    #q_ = count μℤq

    _≈q_ : (f g : ℤq → Bit) → ★
    f ≈q g = #q f ≡ #q g

    Re = (f g : R → Bit) → ★
    record Tra (_≈₀_ _≈₁_ : Re) (f g : R → Bit) : ★ where
      field
        h : R → Bit
        f≈₀h : f ≈₀ h
        h≈₁g : h ≈₁ g

    record _≈ᴿ_ (f g : R → Bit) : ★ where
      constructor mk
      field
        un-≈ᴿ : #ᴿ f ≡ #ᴿ g
    open _≈ᴿ_ public

    ≈ᴿ-trans : Transitive _≈ᴿ_
    ≈ᴿ-trans (mk p) (mk q) = mk (≡.trans p q)

    module ≈ᴿ-Reasoning where
      open Trans-Reasoning _≈ᴿ_ ≈ᴿ-trans public using () renaming (_≈⟨_⟩_ to _≈ᴿ⟨_⟩_)
      infix  2 _∎

      _∎ : ∀ x → x ≈ᴿ x
      _ ∎ = mk refl

    module Proof
        (ddh-hyp : ∀ A → DDH.⅁₀ A ≈ᴿ DDH.⅁₁ A)
        (otp-lem : ∀ A m₀ m₁ → (λ x → A (g^ x ∙ m₀)) ≈q (λ x → A (g^ x ∙ m₁)))
        (A : IND-CPA.Adv) (b : Bit)
      where
        OTP⅁-lem : ∀ d M₀ M₁ → OTP⅁ M₀ d ≈ᴿ OTP⅁ M₁ d
        OTP⅁-lem d M₀ M₁ = mk (
                           sum-ext μRₐ (λ r →
                             sum-ext μℤq (λ x →
                               sum-ext μℤq (λ y →
                                 pf r x y))))
          where
          pf : ∀ r x y → count μℤq (λ z → OTP⅁ M₀ d (r , x , y , z))
                       ≡ count μℤq (λ z → OTP⅁ M₁ d (r , x , y , z))
          pf r x y rewrite otp-lem (d r (g^ x) (g^ y)) (M₀ r (g^ x)) (M₁ r (g^ x)) = refl

        -- moving this definition above OTP⅁-lem breaks type-checking: ???
        ¬b : Bit
        ¬b = not b

        Aᵇ = TrA b A
        A¬ᵇ = TrA ¬b A

        pf0,5 : IND-CPA.⅁ b A ≗ DDH.⅁₀ Aᵇ
        pf0,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

        pf2,5 : DDH.⅁₁ Aᵇ ≡ OTP⅁ (projM A b) (projD A)
        pf2,5 = refl

        pf4,5 : IND-CPA.⅁ ¬b A ≗ DDH.⅁₀ A¬ᵇ
        pf4,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

        open ≈ᴿ-Reasoning

        final : IND-CPA.⅁ b A ≈ᴿ IND-CPA.⅁ ¬b A
        final = IND-CPA.⅁ b A
              ≈ᴿ⟨ mk (sum-ext μR (cong Bit▹ℕ ∘ pf0,5)) ⟩
                DDH.⅁₀ Aᵇ
              ≈ᴿ⟨ ddh-hyp Aᵇ ⟩
                DDH.⅁₁ Aᵇ
              ≈ᴿ⟨ OTP⅁-lem (projD A) (projM A b) (projM A ¬b) ⟩
                DDH.⅁₁ A¬ᵇ
              ≈ᴿ⟨ mk (≡.sym (un-≈ᴿ (ddh-hyp A¬ᵇ))) ⟩
                DDH.⅁₀ A¬ᵇ
              ≈ᴿ⟨ mk (≡.sym (sum-ext μR (cong Bit▹ℕ ∘ pf4,5))) ⟩
                IND-CPA.⅁ ¬b A
              ∎

module El-Gamal-Base
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    (_∙_ : G → G → G)

    -- Required for decryption
    (_/_ : G → G → G)

    -- Required for the correctness proof
    (/-∙ : ∀ x y → (x ∙ y) / x ≡ y)
    (comm-^   : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x)

    {-
    (_⁻¹ : G → G)
    (⁻¹-inverse : ∀ x → x ⁻¹ ∙ x ≡ 1G)
    -}

    -- Required for the proof
    (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
    (μℤq : Explorable ℤq)
    (Rₐ : ★)
    (μRₐ : Explorable Rₐ)
    where

    open El-Gamal-Generic ℤq _⊠_ G g _^_ G _∙_
           _/_ /-∙ comm-^
           dist-^-⊠ μℤq Rₐ μRₐ public

    module OTP⅁-LEM
            (otp-lem1 : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x)))
      where

        otp-lem : ∀ (A : G → Bit) m₀ m₁ → (λ x → A (g^ x ∙ m₀)) ≈q (λ x → A (g^ x ∙ m₁))
        otp-lem A m₀ m₁ rewrite otp-lem1 A m₀ | otp-lem1 A m₁ = refl

module El-Gamal-Hashed
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    -- (HKey : ★)
    (|M| : ℕ)
    (ℋ : {-HKey →-} G → Bits |M|)

    -- (/-∙ : ∀ x y → (x ∙ y) / x ≡ y)
    (comm-^   : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x)

    -- Required for the proof
    (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
    (μℤq : Explorable ℤq)
    (Rₐ : ★)
    (μRₐ : Explorable Rₐ)
    where

    Message = Bits |M|

    ℋ⟨_⟩⊕_ : G → Message → Message
    ℋ⟨ δ ⟩⊕ m = ℋ δ ⊕ m

    _/_ : Message → G → Message
    _/_ m δ = ℋ δ ⊕ m
{-

    /-∙ : ∀ x y → ℋ⟨ x ⟩⊕ y / x ≡ y
    /-∙ x y = {!!}

    open El-Gamal-Generic ℤq _⊠_ G g _^_ Message ℋ⟨_⟩⊕_ _/_ {!!} {!!}
           dist-^-⊠ sumℤq sumℤq-ext Rₐ sumRₐ sumRₐ-ext public
           -}

           {-
    OTP⅁-lem : ∀ d M₀ M₁ → OTP⅁ M₀ d ≈ᴿ OTP⅁ M₁ d
    OTP⅁-lem = ?
    -}

module ⟨ℤp⟩★ p-3 {- p is prime -} (`Rₐ : `★) where
  p : ℕ
  p = 3 + p-3

  q : ℕ
  q = p ∸ 1

  module G = G-implem p q (## 2) (## 0) (## 1) (## 0) (## 1)
  open G

  postulate
    _⁻¹ : G → G

  _/_ : G → G → G
  x / y = x ∙ (y ⁻¹)

  postulate
    /-• : ∀ x y → (x ∙ y) / x ≡ y
    dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y
    ⊠-comm : ∀ x y → x ⊠ y ≡ y ⊠ x

  comm-^ : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x
  comm-^ α x y = (α ^ x)^ y
               ≡⟨ sym (dist-^-⊠ α x y) ⟩
                  α ^ (x ⊠ y)
               ≡⟨ cong (_^_ α) (⊠-comm x y) ⟩
                  α ^ (y ⊠ x)
               ≡⟨ dist-^-⊠ α y x ⟩
                  (α ^ y)^ x
               ∎
    where open ≡-Reasoning

  open ℤq-count ℤq _⊞_ μℤq ⊞-stable

  μRₐ : Explorable (El `Rₐ)
  μRₐ = μU μℤq `Rₐ

  Rₐ = El `Rₐ
  sumRₐ = sum μRₐ
  sumRₐ-ext = sum-ext μRₐ

  module EB = El-Gamal-Base _ _⊠_ G g _^_ _∙_ _/_ /-• comm-^ dist-^-⊠ μℤq Rₐ μRₐ
  open EB hiding (g^_)

  otp-base-lem : ∀ (A : G → Bit) m → (A ∘ g^_) ≈q (A ∘ g^_ ∘ _⊞_ m)
  otp-base-lem A m = ⊞-stable m (Bit▹ℕ ∘ A ∘ g^_)

  postulate
    ddh-hyp : (A : DDH.Adv) → DDH.⅁₀ A ≈ᴿ DDH.⅁₁ A
    otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x))

  open OTP⅁-LEM otp-lem

  {-
  final : ∀ A → IND-CPA.⅁ A 0b ≈ᴿ IND-CPA.⅁ A 1b
  final A = Proof.final ddh-hyp OTP⅁-lem A 0b
  -}

module ⟨ℤ11⟩★ = ⟨ℤp⟩★ (11 ∸ 3)
                   `X -- the amount of adversary randomness

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

{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.Product
open import Data.Unit
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc) renaming (#_ to ##_; toℕ to Fin▹ℕ)
open import Data.Nat.NP hiding (_^_; _==_)
open import Data.Bit
open import Data.Bits hiding (_==_)
open import Relation.Binary.PropositionalEquality.NP as ≡
import Game.DDH
import Game.IND-CPA
import Cipher.ElGamal.Generic
open import Search.Type
open import Search.Searchable renaming (Searchable to Explorable)
open import Search.Searchable.Product
open import Search.Searchable.Fin
open import Relation.Binary.NP

module elgamal where

data `★ : ★ where
  `⊤   : `★
  `X   : `★
  _`×_ : `★ → `★ → `★
infixr 2 _`×_

module Univ (X : ★) where
    El : `★ → ★
    El `⊤         = ⊤
    El `X         = X
    El (u₀ `× u₁) = El u₀ × El u₁

    record ↺ (R : `★) (A : ★) : ★ where
      constructor mk
      field
        run↺ : El R → A
    open ↺ public

    EXP : (R : `★) → ★
    EXP R = ↺ R Bit

    Det : ★ → ★
    Det = ↺ `⊤

    μU : Explorable X → ∀ u → Explorable (El u)
    μU μX `⊤         = μ⊤
    μU μX `X         = μX
    μU μX (u₀ `× u₁) = μU μX u₀ ×-μ μU μX u₁

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : Explorable ℤq)
  (⊞-stable : ∀ x → SumStableUnder (sum μℤq) (_⊞_ x))
  where

  -- open Sum
  open Univ ℤq public
  open `★ public renaming (`X to `ℤq)

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = count (μU μℤq u) (run↺ f)

  #q_ : Count ℤq
  #q_ = count μℤq

  ⁇ : ∀ R → ↺ R (El R)
  run↺ (⁇ _) = id

  pure↺ : ∀ {R A} → A → ↺ R A
  run↺ (pure↺ x) r = x -- turning r to _ produce an error

  ⟪_⟫ : ∀ {R A} → A → ↺ R A
  ⟪_⟫ = pure↺

  {-
  ⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
  ⟪_⟫ᴰ = pureᴰ
  -}

  map↺ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  run↺ (map↺ f x) r = f (run↺ x r)

  infixl 4 _⊛_
  _⊛_ : ∀ {R S A B} → ↺ R (A → B) → ↺ S A → ↺ (R `× S) B
  run↺ (af ⊛ ax) rs = run↺ af (proj₁ rs) (run↺ ax (proj₂ rs))

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

  ⟪_·_·_⟫ : ∀ {A B C} {R S} →
              (A → B → C) → ↺ R A → ↺ S B → ↺ (R `× S) C
  ⟪ f · x · y ⟫ = map↺ f x ⊛ y

  _⟨⊞⟩_ : ∀ {R S} → ↺ R ℤq → ↺ S ℤq → ↺ (R `× S) ℤq
  x ⟨⊞⟩ y = ⟪ _⊞_ · x · y ⟫

  ⟨_⊞⟩_ : ∀ {R} → ℤq → ↺ R ℤq → ↺ R ℤq
  ⟨ x ⊞⟩ y = ⟪ _⊞_ x · y ⟫

  infix 4 _≈↺_ _≈ᴬ_
  _≈↺_ : ∀ {R : `★} (f g : EXP R) → ★
  _≈↺_ = _≡_ on #_

  _≈ᴬ_ : ∀ {A R} (f g : ↺ R A) → Set _
  _≈ᴬ_ {A} f g = ∀ (Adv : A → Bit) → ⟪ Adv · f ⟫ ≈↺ ⟪ Adv · g ⟫

  lem : ∀ x → ⟨ x ⊞⟩ (⁇ `ℤq) ≈ᴬ ⁇ _
  lem x Adv = sym (⊞-stable x (Bit▹ℕ ∘ Adv))

  -- ∀ (A : ℤq → Bit) → # (A ⁇)

open Fin.Modulo renaming (sucmod to [suc]; sucmod-inj to [suc]-inj)

{-
module ℤq-implem (q-2 : ℕ) where
  q : ℕ
  q = 2 + q-2

  ℤq : ★
  ℤq = Fin q

  [0] : ℤq
  [0] = zero

  [1] : ℤq
  [1] = suc zero
-}
module ℤq-implem (q-1 : ℕ) ([0]' [1]' : Fin (suc q-1)) where
  -- open Sum
  q : ℕ
  q = suc q-1

  ℤq : ★
  ℤq = Fin q

  μℤq : Explorable ℤq
  μℤq = μFinSuc q-1

  sumℤq : Sum ℤq
  sumℤq = sum μℤq

  [0] : ℤq
  [0] = [0]'

  [1] : ℤq
  [1] = [1]'

  [suc]-stable : SumStableUnder (sum μℤq) [suc]
  [suc]-stable = μFinSUI [suc] [suc]-inj

  _ℕ⊞_ : ℕ → ℤq → ℤq
  zero  ℕ⊞ n = n
  suc m ℕ⊞ n = m ℕ⊞ ([suc] n)

  ℕ⊞-inj : ∀ n {x y} → n ℕ⊞ x ≡ n ℕ⊞ y → x ≡ y
  ℕ⊞-inj zero    eq = eq
  ℕ⊞-inj (suc n) eq = [suc]-inj (ℕ⊞-inj n eq)

  ℕ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_ℕ⊞_ m)
  ℕ⊞-stable m = μFinSUI (_ℕ⊞_ m) (ℕ⊞-inj m)

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin▹ℕ m ℕ⊞ n

  ⊞-inj : ∀ m {x y} → m ⊞ x ≡ m ⊞ y → x ≡ y
  ⊞-inj m = ℕ⊞-inj (Fin▹ℕ m)

  ⊞-stable : ∀ m → SumStableUnder (sum μℤq) (_⊞_ m)
  ⊞-stable m = μFinSUI (_⊞_ m) (⊞-inj m)

  _ℕ⊠_ : ℕ → ℤq → ℤq
  zero  ℕ⊠ n = [0]
  suc m ℕ⊠ n = n ⊞ (m ℕ⊠ n)

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin▹ℕ m ℕ⊠ n

  _[^]ℕ_ : ℤq → ℕ → ℤq
  m [^]ℕ zero  = [1]
  m [^]ℕ suc n = m ⊠ (m [^]ℕ n)

  _[^]_ : ℤq → ℤq → ℤq
  m [^] n = m [^]ℕ (Fin▹ℕ n)

module G-implem (p-1 q-1 : ℕ) (g' 0[p] 1[p] : Fin (suc p-1)) (0[q] 1[q] : Fin (suc q-1)) where
  open ℤq-implem q-1 0[q] 1[q] public
  open ℤq-implem p-1 0[p] 1[p] public using () renaming (ℤq to G; _⊠_ to _∙_; _[^]ℕ_ to _^[p]_)

  g : G
  g = g'

  _^_ : G → ℤq → G
  x ^ n = x ^[p] Fin▹ℕ n

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

  {-
  g^-inj : ∀ m n → g^ m ≡ g^ n → m ≡ n
  g^-inj = {!!}
  -}

module G-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : Explorable ℤq)
  (⊞-stable : ∀ x → SumStableUnder (sum μℤq) (_⊞_ x))
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (_∙_ : G → G → G)
  where

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

  open ℤq-count ℤq _⊞_ μℤq ⊞-stable

  ⁇G : ↺ `ℤq G
  run↺ ⁇G x = g^ x

  #G : Count G
  #G f = #q (f ∘ g^_)

  {-
  #G-∙ : ∀ f m → #G (f ∘ _∙_ m) ≡ #G f
  #G-∙ f m = {!!}
  -}

module El-Gamal-Generic
  (ℤq       : ★)
  (_⊠_      : ℤq → ℤq → ℤq)
  (G        : ★)
  (g        : G)
  (_^_      : G → ℤq → G)
  (Message  : ★)
  (_∙_      : G → Message → Message)

  -- Required for decryption
  (_/_      : Message → G → Message)

  -- Required for the correctness proof
  (/-∙      : ∀ x y → (x ∙ y) / x ≡ y)
  (comm-^   : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x)

  -- Required for the security proof
  (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
  (μℤq      : Explorable ℤq)
  (Rₐ       : ★)
  (μRₐ      : Explorable Rₐ)
  where

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

    -- gˣ is the pk
    -- x is the sk

    Rₓ : ★
    Rₓ = ℤq

    open Cipher.ElGamal.Generic Message ℤq G g _^_ _∙_ _/_

    functional-correctness : ∀ x y m → Dec x (Enc (g^ x) m y) ≡ m
    functional-correctness x y m rewrite comm-^ g x y | /-∙ (g^ y ^ x) m = refl

    module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText Rₑ Rₖ Rₐ Rₓ KeyGen Enc
    open IND-CPA using (R)

    UnusedGame : (i : Bit) → IND-CPA.Adv → (Bit × Rₐ × ℤq × ℤq × ℤq) → Bit
    UnusedGame i (m , d) (b , rₐ , x , y , z) = b == d rₐ gˣ (gʸ , ζ)
      where gˣ = g^ x
            gʸ = g^ y
            δ  = gˣ ^ case i 0→ y 1→ z
            ζ  = δ ∙ m rₐ gˣ b

    module DDH = Game.DDH ℤq G g _^_ Rₐ

    OTP⅁ : (Rₐ → G → Message) → (Rₐ → G → G → Message → Bit) → R → Bit
    OTP⅁ M d (r , x , y , z) = d r gˣ gʸ (gᶻ ∙ M r gˣ)
      where gˣ = g^ x
            gʸ = g^ y
            gᶻ = g^ z

    TrA : Bit → IND-CPA.Adv → DDH.Adv
    TrA b (m , d) rₐ gˣ gʸ gˣʸ = d rₐ gˣ (gʸ , gˣʸ ∙ m rₐ gˣ b)

    projM : IND-CPA.Adv → Bit → Rₐ → G → Message
    projM (m , _) b rₐ gˣ = m rₐ gˣ b

    projD : IND-CPA.Adv → Rₐ → G → G → Message → Bit
    projD (_ , d) rₐ gˣ gʸ gᶻ∙M = d rₐ gˣ (gʸ , gᶻ∙M)

    module Unused where
        like-⅁ : Bit → IND-CPA.Game
        like-⅁ b (m , d) (rₐ , x , y , _z) =
          d rₐ gˣ (gʸ , (gˣ ^ y) ∙ m rₐ gˣ b)
          where gˣ = g^ x
                gʸ = g^ y

        IND-CPA-⅁≡like-⅁ : IND-CPA.⅁ ≡ like-⅁
        IND-CPA-⅁≡like-⅁ = refl

    -- R = Rₐ × ℤq × ℤq × ℤq
    μR : Explorable R
    μR = μRₐ ×-μ μℤq ×-μ μℤq ×-μ μℤq

    #ᴿ_ : Count R
    #ᴿ_ = count μR

    #q_ : Count ℤq
    #q_ = count μℤq

    _≈q_ : (f g : ℤq → Bit) → ★
    f ≈q g = #q f ≡ #q g

    Re = (f g : R → Bit) → ★
    record Tra (_≈₀_ _≈₁_ : Re) (f g : R → Bit) : ★ where
      field
        h : R → Bit
        f≈₀h : f ≈₀ h
        h≈₁g : h ≈₁ g

    record _≈ᴿ_ (f g : R → Bit) : ★ where
      constructor mk
      field
        un-≈ᴿ : #ᴿ f ≡ #ᴿ g
    open _≈ᴿ_ public

    ≈ᴿ-trans : Transitive _≈ᴿ_
    ≈ᴿ-trans (mk p) (mk q) = mk (≡.trans p q)

    module ≈ᴿ-Reasoning where
      open Trans-Reasoning _≈ᴿ_ ≈ᴿ-trans public using () renaming (_≈⟨_⟩_ to _≈ᴿ⟨_⟩_)
      infix  2 _∎

      _∎ : ∀ x → x ≈ᴿ x
      _ ∎ = mk refl

    module Proof
        (ddh-hyp : ∀ A → DDH.⅁₀ A ≈ᴿ DDH.⅁₁ A)
        (otp-lem : ∀ A m₀ m₁ → (λ x → A (g^ x ∙ m₀)) ≈q (λ x → A (g^ x ∙ m₁)))
        (A : IND-CPA.Adv) (b : Bit)
      where
        OTP⅁-lem : ∀ d M₀ M₁ → OTP⅁ M₀ d ≈ᴿ OTP⅁ M₁ d
        OTP⅁-lem d M₀ M₁ = mk (
                           sum-ext μRₐ (λ r →
                             sum-ext μℤq (λ x →
                               sum-ext μℤq (λ y →
                                 pf r x y))))
          where
          pf : ∀ r x y → count μℤq (λ z → OTP⅁ M₀ d (r , x , y , z))
                       ≡ count μℤq (λ z → OTP⅁ M₁ d (r , x , y , z))
          pf r x y rewrite otp-lem (d r (g^ x) (g^ y)) (M₀ r (g^ x)) (M₁ r (g^ x)) = refl

        -- moving this definition above OTP⅁-lem breaks type-checking: ???
        ¬b : Bit
        ¬b = not b

        Aᵇ = TrA b A
        A¬ᵇ = TrA ¬b A

        pf0,5 : IND-CPA.⅁ b A ≗ DDH.⅁₀ Aᵇ
        pf0,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

        pf2,5 : DDH.⅁₁ Aᵇ ≡ OTP⅁ (projM A b) (projD A)
        pf2,5 = refl

        pf4,5 : IND-CPA.⅁ ¬b A ≗ DDH.⅁₀ A¬ᵇ
        pf4,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

        open ≈ᴿ-Reasoning

        final : IND-CPA.⅁ b A ≈ᴿ IND-CPA.⅁ ¬b A
        final = IND-CPA.⅁ b A
              ≈ᴿ⟨ mk (sum-ext μR (cong Bit▹ℕ ∘ pf0,5)) ⟩
                DDH.⅁₀ Aᵇ
              ≈ᴿ⟨ ddh-hyp Aᵇ ⟩
                DDH.⅁₁ Aᵇ
              ≈ᴿ⟨ OTP⅁-lem (projD A) (projM A b) (projM A ¬b) ⟩
                DDH.⅁₁ A¬ᵇ
              ≈ᴿ⟨ mk (≡.sym (un-≈ᴿ (ddh-hyp A¬ᵇ))) ⟩
                DDH.⅁₀ A¬ᵇ
              ≈ᴿ⟨ mk (≡.sym (sum-ext μR (cong Bit▹ℕ ∘ pf4,5))) ⟩
                IND-CPA.⅁ ¬b A
              ∎

module El-Gamal-Base
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    (_∙_ : G → G → G)

    -- Required for decryption
    (_/_ : G → G → G)

    -- Required for the correctness proof
    (/-∙ : ∀ x y → (x ∙ y) / x ≡ y)
    (comm-^   : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x)

    {-
    (_⁻¹ : G → G)
    (⁻¹-inverse : ∀ x → x ⁻¹ ∙ x ≡ 1G)
    -}

    -- Required for the proof
    (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
    (μℤq : Explorable ℤq)
    (Rₐ : ★)
    (μRₐ : Explorable Rₐ)
    where

    open El-Gamal-Generic ℤq _⊠_ G g _^_ G _∙_
           _/_ /-∙ comm-^
           dist-^-⊠ μℤq Rₐ μRₐ public

    module OTP⅁-LEM
            (otp-lem1 : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x)))
      where

        otp-lem : ∀ (A : G → Bit) m₀ m₁ → (λ x → A (g^ x ∙ m₀)) ≈q (λ x → A (g^ x ∙ m₁))
        otp-lem A m₀ m₁ rewrite otp-lem1 A m₀ | otp-lem1 A m₁ = refl

module El-Gamal-Hashed
    (ℤq : ★)
    (_⊠_ : ℤq → ℤq → ℤq)
    (G : ★)
    (g : G)
    (_^_ : G → ℤq → G)
    -- (HKey : ★)
    (|M| : ℕ)
    (ℋ : {-HKey →-} G → Bits |M|)

    -- (/-∙ : ∀ x y → (x ∙ y) / x ≡ y)
    (comm-^   : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x)

    -- Required for the proof
    (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
    (μℤq : Explorable ℤq)
    (Rₐ : ★)
    (μRₐ : Explorable Rₐ)
    where

    Message = Bits |M|

    ℋ⟨_⟩⊕_ : G → Message → Message
    ℋ⟨ δ ⟩⊕ m = ℋ δ ⊕ m

    _/_ : Message → G → Message
    _/_ m δ = ℋ δ ⊕ m
{-

    /-∙ : ∀ x y → ℋ⟨ x ⟩⊕ y / x ≡ y
    /-∙ x y = {!!}

    open El-Gamal-Generic ℤq _⊠_ G g _^_ Message ℋ⟨_⟩⊕_ _/_ {!!} {!!}
           dist-^-⊠ sumℤq sumℤq-ext Rₐ sumRₐ sumRₐ-ext public
           -}

           {-
    OTP⅁-lem : ∀ d M₀ M₁ → OTP⅁ M₀ d ≈ᴿ OTP⅁ M₁ d
    OTP⅁-lem = ?
    -}

module ⟨ℤp⟩★ p-3 {- p is prime -} (`Rₐ : `★) where
  p : ℕ
  p = 3 + p-3

  q : ℕ
  q = p ∸ 1

  module G = G-implem p q (## 2) (## 0) (## 1) (## 0) (## 1)
  open G

  postulate
    _⁻¹ : G → G

  _/_ : G → G → G
  x / y = x ∙ (y ⁻¹)

  postulate
    /-• : ∀ x y → (x ∙ y) / x ≡ y
    dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y
    ⊠-comm : ∀ x y → x ⊠ y ≡ y ⊠ x

  comm-^ : ∀ α x y → (α ^ x)^ y ≡ (α ^ y)^ x
  comm-^ α x y = (α ^ x)^ y
               ≡⟨ sym (dist-^-⊠ α x y) ⟩
                  α ^ (x ⊠ y)
               ≡⟨ cong (_^_ α) (⊠-comm x y) ⟩
                  α ^ (y ⊠ x)
               ≡⟨ dist-^-⊠ α y x ⟩
                  (α ^ y)^ x
               ∎
    where open ≡-Reasoning

  open ℤq-count ℤq _⊞_ μℤq ⊞-stable

  μRₐ : Explorable (El `Rₐ)
  μRₐ = μU μℤq `Rₐ

  Rₐ = El `Rₐ
  sumRₐ = sum μRₐ
  sumRₐ-ext = sum-ext μRₐ

  module EB = El-Gamal-Base _ _⊠_ G g _^_ _∙_ _/_ /-• comm-^ dist-^-⊠ μℤq Rₐ μRₐ
  open EB hiding (g^_)

  otp-base-lem : ∀ (A : G → Bit) m → (A ∘ g^_) ≈q (A ∘ g^_ ∘ _⊞_ m)
  otp-base-lem A m = ⊞-stable m (Bit▹ℕ ∘ A ∘ g^_)

  postulate
    ddh-hyp : (A : DDH.Adv) → DDH.⅁₀ A ≈ᴿ DDH.⅁₁ A
    otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x))

  open OTP⅁-LEM otp-lem

  {-
  final : ∀ A → IND-CPA.⅁ A 0b ≈ᴿ IND-CPA.⅁ A 1b
  final A = Proof.final ddh-hyp OTP⅁-lem A 0b
  -}

module ⟨ℤ11⟩★ = ⟨ℤp⟩★ (11 ∸ 3)
                   `X -- the amount of adversary randomness

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


Removed unnecessary import.

Removed unnecessary import.

Ignore-this: e6495fab2648ecac4ecc85685b6b158a

darcs-hash:20100604032100-3bd4e-e89550df44e4c9bb127867dfcd4e3a8f4e6a9bc8.gz

------------------------------------------------------------------------------
-- The division satisfies the specification
------------------------------------------------------------------------------

-- This module formalize the division algorithm following [1].
-- [1] Peter Dybjer. Program verification in a logical theory of
-- constructions. In Jean-Pierre Jouannaud, editor. Functional
-- Programming Languages and Computer Architecture, volume 201 of
-- LNCS, 1985, pages 334-349. Appears in revised form as Programming
-- Methodology Group Report 26, June 1986.

module Examples.Division.IsDIV-ER where

open import LTC.Minimal

open import Examples.Division
open import Examples.Division.EquationsER
open import Examples.Division.IsCorrectER
open import Examples.Division.IsN-ER
open import Examples.Division.Specification

open import LTC.Data.N
open import LTC.Data.N.Induction.WellFoundedPCF
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF-ER
open import LTC.Relation.InequalitiesPCF
open import LTC.Relation.Inequalities.PropertiesPCF-ER

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

-- The division result satifies the specification DIV
-- when the dividend is less than the divisor
div-x<y-DIV : {i j : D} → N i → N j -> LT i j → DIV i j (div i j)
div-x<y-DIV Ni Nj i<j = div-x<y-N i<j , div-x<y-correct Ni Nj i<j

-- The division result satisfies the specification DIV when the
-- dividend is greater or equal than the divisor.
div-x≥y-DIV : {i j : D} → N i -> N j →
              ({i' : D} → N i' → LT i' i → DIV i' j (div i' j)) →
              GT j zero →
              GE i j →
              DIV i j (div i j)
div-x≥y-DIV {i} {j} Ni Nj accH j>0 i≥j =
  (div-x≥y-N ih i≥j) , div-x≥y-correct Ni Nj ih i≥j

    where
    -- The inductive hypothesis on 'i - j'.
    ih : DIV (i - j) j (div (i - j) j)
    ih = accH {i - j}
              (minus-N Ni Nj )
              (x≥y→y>0→x-y<x Ni Nj i≥j j>0)

------------------------------------------------------------------------------
-- The division satisfies the specification

-- We do the well-founded induction on 'i' and we keep 'j' fixed.
div-DIV : {i j : D} → N i → N j → GT j zero → DIV i j (div i j)
div-DIV {j = j} Ni Nj j>0 = wfIndN-LT P iStep Ni

   where
     P : D → Set
     P d = DIV d j (div d j)

     -- The inductive step doesn't use the variable 'i'
     -- (nor 'Ni'). To make this
     -- clear we write down the inductive step using the variables
     -- 'm' and 'n'.
     iStep : {n : D} → N n →
             (accH : {m : D} → N m → LT m n → P m) →
             P n
     iStep {n} Nn accH =
       [ div-x<y-DIV Nn Nj , div-x≥y-DIV Nn Nj accH j>0 ] (x<y∨x≥y Nn Nj)

------------------------------------------------------------------------------
-- The division satisfies the specification
------------------------------------------------------------------------------

-- This module formalize the division algorithm following [1].
-- [1] Peter Dybjer. Program verification in a logical theory of
-- constructions. In Jean-Pierre Jouannaud, editor. Functional
-- Programming Languages and Computer Architecture, volume 201 of
-- LNCS, 1985, pages 334-349. Appears in revised form as Programming
-- Methodology Group Report 26, June 1986.

module Examples.Division.IsDIV-ER where

open import LTC.Minimal
open import LTC.MinimalER

open import Examples.Division
open import Examples.Division.EquationsER
open import Examples.Division.IsCorrectER
open import Examples.Division.IsN-ER
open import Examples.Division.Specification

open import LTC.Data.N
open import LTC.Data.N.Induction.WellFoundedPCF
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF-ER
open import LTC.Relation.InequalitiesPCF
open import LTC.Relation.Inequalities.PropertiesPCF-ER

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

-- The division result satifies the specification DIV
-- when the dividend is less than the divisor
div-x<y-DIV : {i j : D} → N i → N j -> LT i j → DIV i j (div i j)
div-x<y-DIV Ni Nj i<j = div-x<y-N i<j , div-x<y-correct Ni Nj i<j

-- The division result satisfies the specification DIV when the
-- dividend is greater or equal than the divisor.
div-x≥y-DIV : {i j : D} → N i -> N j →
              ({i' : D} → N i' → LT i' i → DIV i' j (div i' j)) →
              GT j zero →
              GE i j →
              DIV i j (div i j)
div-x≥y-DIV {i} {j} Ni Nj accH j>0 i≥j =
  (div-x≥y-N ih i≥j) , div-x≥y-correct Ni Nj ih i≥j

    where
    -- The inductive hypothesis on 'i - j'.
    ih : DIV (i - j) j (div (i - j) j)
    ih = accH {i - j}
              (minus-N Ni Nj )
              (x≥y→y>0→x-y<x Ni Nj i≥j j>0)

------------------------------------------------------------------------------
-- The division satisfies the specification

-- We do the well-founded induction on 'i' and we keep 'j' fixed.
div-DIV : {i j : D} → N i → N j → GT j zero → DIV i j (div i j)
div-DIV {j = j} Ni Nj j>0 = wfIndN-LT P iStep Ni

   where
     P : D → Set
     P d = DIV d j (div d j)

     -- The inductive step doesn't use the variable 'i'
     -- (nor 'Ni'). To make this
     -- clear we write down the inductive step using the variables
     -- 'm' and 'n'.
     iStep : {n : D} → N n →
             (accH : {m : D} → N m → LT m n → P m) →
             P n
     iStep {n} Nn accH =
       [ div-x<y-DIV Nn Nj , div-x≥y-DIV Nn Nj accH j>0 ] (x<y∨x≥y Nn Nj)


Only indentation.

Only indentation.

Ignore-this: c2263467480f89c699d375fd42dad3e5

darcs-hash:20100429202055-3bd4e-d360ccd24a43231bdc90120f8657214fc1c8535d.gz

------------------------------------------------------------------------------
-- Arithmetic properties using equational reasoning
------------------------------------------------------------------------------

module LTC.Function.Arithmetic.PropertiesER where

open import LTC.Minimal
open import LTC.MinimalER

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
  using ( +-leftIdentity ; *-leftZero ; *-comm ; minus-0x )

open import MyStdLib.Function
import MyStdLib.Relation.Binary.EqReasoning
open module APER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

------------------------------------------------------------------------------
-- Closure properties

pred-N : {n : D} → N n → N (pred n)
pred-N zN          = subst (λ t → N t) (sym cP₁) zN
pred-N (sN {n} Nn) = subst (λ t → N t) (sym (cP₂ n)) Nn

minus-N : {m n : D} → N m → N n → N (m - n)
minus-N {m} Nm zN                   = subst (λ t → N t) (sym (minus-x0 m)) Nm
minus-N     zN (sN {n} Nn)          = subst (λ t → N t) (sym (minus-0S n)) zN
minus-N     (sN {m} Nm) (sN {n} Nn) = subst (λ t → N t)
                                            (sym (minus-SS m n))
                                            (minus-N Nm Nn)

+-N : {m n : D} → N m → N n → N (m + n)
+-N zN Nn = subst (λ t → N t) (sym (+-leftIdentity Nn)) Nn
+-N {n = n} (sN {m} Nm ) Nn =
  subst ((λ t → N t)) (sym (+-Sx m n)) (sN (+-N Nm Nn))

*-N : {m n : D} → N m → N n → N (m * n)
*-N zN Nn = subst (λ t → N t) (sym (*-leftZero Nn)) zN
*-N {n = n} (sN {m} Nm) Nn =
  subst (λ t → N t) (sym (*-Sx m n)) (+-N Nn (*-N Nm Nn))

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

[x+y]-[x+z]≡y-z : {m n o : D} → N m → N n → N o →
                  (m + n) - (m + o) ≡ n - o
[x+y]-[x+z]≡y-z {n = n} {o = o} zN Nn No =
  begin
    (zero + n) - (zero + o) ≡⟨ subst (λ t → (zero + n) - (zero + o) ≡
                                            t - (zero + o))
                                      (+-0x n) refl
                            ⟩
     n - (zero + o)         ≡⟨ subst (λ t → n - (zero + o) ≡ n - t)
                                     (+-0x o)
                                     refl ⟩
    n - o
  ∎

[x+y]-[x+z]≡y-z {n = n} {o = o} (sN {m} Nm) Nn No =
  begin
    (succ m + n) - (succ m + o) ≡⟨ subst (λ t → succ m + n - (succ m + o) ≡
                                                t - (succ m + o))
                                         (+-Sx m n)
                                         refl
                                ⟩
    succ (m + n) - (succ m + o) ≡⟨ subst (λ t → succ (m + n) - (succ m + o) ≡
                                                succ (m + n) - t)
                                         (+-Sx m o)
                                         refl ⟩
    succ (m + n) - succ (m + o) ≡⟨ minus-SS (m + n) (m + o) ⟩
    (m + n) - (m + o) ≡⟨ [x+y]-[x+z]≡y-z Nm Nn No ⟩
    n - o
  ∎

[x-y]z≡xz*yz : {m n o : D} → N m → N n → N o → (m - n) * o ≡ m * o - n * o
[x-y]z≡xz*yz {m} .{zero} {o} Nm zN No =
  begin
    (m - zero) * o   ≡⟨ subst (λ t → (m - zero) * o ≡ t * o)
                              (minus-x0 m)
                              refl
                      ⟩
    m * o            ≡⟨ sym (minus-x0 (m * o)) ⟩
    m * o - zero     ≡⟨ subst (λ t → m * o - zero ≡ m * o - t)
                              (sym (*-0x o))
                              refl
                     ⟩
    m * o - zero * o
  ∎

[x-y]z≡xz*yz {o = o} zN (sN {n} Nn) No =
  begin
    (zero - succ n) * o  ≡⟨ subst (λ t → (zero - succ n) * o ≡ t * o)
                                  (minus-0S n)
                                  refl
                         ⟩
    zero * o             ≡⟨ *-0x o ⟩
    zero                 ≡⟨ sym (minus-0x (*-N (sN Nn) No)) ⟩
    zero - succ n * o    ≡⟨ subst (λ t → zero - succ n * o ≡ t - succ n * o)
                                   (sym (*-0x o))
                                   refl
                         ⟩
    zero * o - succ n * o
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) zN =
  begin
    (succ m - succ n) * zero      ≡⟨ *-comm (minus-N (sN Nm) (sN Nn)) zN ⟩
    zero * (succ m - succ n)      ≡⟨ *-0x (succ m - succ n) ⟩
    zero                          ≡⟨ sym (minus-0x (*-N (sN Nn) zN)) ⟩
    zero - succ n * zero          ≡⟨ subst (λ t → zero - succ n * zero ≡
                                                  t - succ n * zero)
                                           (sym (*-0x (succ m)))
                                           refl
                                  ⟩
    zero * succ m - succ n * zero ≡⟨ subst
                                       (λ t → zero * succ m - succ n * zero ≡
                                              t - succ n * zero)
                                       (*-comm zN (sN Nm))
                                       refl
                                  ⟩
    succ m * zero - succ n * zero
  ∎

[x-y]z≡xz*yz (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  begin
    (succ m - succ n) * succ o  ≡⟨ subst (λ t → (succ m - succ n) * succ o ≡
                                                t * succ o)
                                         (minus-SS m n)
                                         refl
                                ⟩
    (m - n) * succ o            ≡⟨ [x-y]z≡xz*yz Nm Nn (sN No) ⟩
    m * succ o - n * succ o     ≡⟨ sym ([x+y]-[x+z]≡y-z (sN No)
                                                        (*-N Nm (sN No))
                                                        (*-N Nn (sN No)))
                                ⟩
    (succ o + m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ o + m * succ o) - (succ o + n * succ o) ≡
                      t - (succ o + n * succ o))
               (sym (*-Sx m (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ o + n * succ o)
      ≡⟨ subst (λ t → (succ m * succ o) - (succ o + n * succ o) ≡
                      (succ m * succ o) - t)
               (sym (*-Sx n (succ o)))
               refl
      ⟩
    (succ m * succ o) - (succ n * succ o)
  ∎


ℤq: Use warn-check since check is monadic now...

{-# OPTIONS --without-K #-}
open import Type.Eq using (_==_; Eq?; ≡⇒==; ==⇒≡)
open import Data.Two.Base using (𝟚; ✓)
open import Relation.Binary.PropositionalEquality.Base using (_≡_; refl; ap)
open import FFI.JS using (JS[_]; _++_; return; _>>_)
open import FFI.JS.Check
  using    (check!)
--renaming (check      to check?)
  renaming (warn-check to check?)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Homomorphism
open import Algebra.Field

-- TODO carry on a primality proof of q
module Crypto.JS.BigI.FiniteField (q : BigI) where

-- The constructor mk is not exported.
private
  module Internals where
    data ℤ[_] : Set where
      mk : BigI → ℤ[_]

    mk-inj : ∀ {x y : BigI} → ℤ[_].mk x ≡ mk y → x ≡ y
    mk-inj refl = refl

open Internals public using (ℤ[_])
open Internals

ℤq : Set
ℤq = ℤ[_]

private
  mod-q : BigI → ℤq
  mod-q x = mk (mod x q)

-- There are two ways to go from BigI to ℤq: BigI▹ℤ[ q ] and mod-q
-- Use BigI▹ℤ[ q ] for untrusted input data and mod-q for internal
-- computation.
BigI▹ℤ[_] : BigI → JS[ ℤq ]
BigI▹ℤ[_] x =
-- Console.log "BigI▹ℤ[_]"
  check! "below the modulus" (x <I q)
         (λ _ → "Not below the modulus: q:" ++ toString q ++
                " is less than x:" ++ toString x) >>
  check! "positivity" (x ≥I 0I)
         (λ _ → "Should be positive: " ++ toString x ++ " < 0") >>
  return (mk x)

check-non-zero : ℤq → BigI
check-non-zero (mk x) = -- trace-call "check-non-zero "
  check? (x >I 0I) (λ _ → "Should be non zero") x

ℤ[_]▹BigI : ℤq → BigI
ℤ[_]▹BigI (mk x) = x

0# 1# : ℤq
0# = mk 0I
1# = mk 1I

-- One could choose here to return a dummy value when 0 is given.
-- Instead we throw an exception which in some circumstances could
-- be bad if the runtime semantics is too eager.
1/_ : ℤq → ℤq
1/ x = mk (modInv (check-non-zero x) q)

_^I_ : ℤq → BigI → ℤq
mk x ^I y = mk (modPow x y q)

ℤq▹BigI = ℤ[_]▹BigI
BigI▹ℤq = BigI▹ℤ[_]

_⊗I_ : ℤq → BigI → ℤq
x ⊗I y = mod-q (multiply (ℤq▹BigI x) y)

_+_ _−_ _*_ _/_ : ℤq → ℤq → ℤq

x + y = mod-q (add      (ℤq▹BigI x) (ℤq▹BigI y))
x − y = mod-q (subtract (ℤq▹BigI x) (ℤq▹BigI y))
x * y = x ⊗I ℤq▹BigI y
x / y = x * 1/ y

*-def : _*_ ≡ (λ x y → x ⊗I ℤq▹BigI y)
*-def = refl

0−_ : ℤq → ℤq
0− x = mod-q (negate (ℤq▹BigI x))

sum prod : List ℤq → ℤq
sum  = foldr _+_ 0#
prod = foldr _*_ 1#

instance
  ℤ[_]-Eq? : Eq? ℤq
  ℤ[_]-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤq → ℤq → 𝟚
      mk x ==' mk y = x == y
      ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
      ≡⇒==' {mk x} {mk y} p = ≡⇒== (mk-inj p)
      ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y
      ==⇒≡' {mk x} {mk y} p = ap mk (==⇒≡ p)

ℤq-Eq?  = ℤ[_]-Eq?

+-mon-ops : Monoid-Ops ℤq
+-mon-ops = _+_ , 0#

+-grp-ops : Group-Ops ℤq
+-grp-ops = +-mon-ops , 0−_

*-mon-ops : Monoid-Ops ℤq
*-mon-ops = _*_ , 1#

*-grp-ops : Group-Ops ℤq
*-grp-ops = *-mon-ops , 1/_

fld-ops : Field-Ops ℤq
fld-ops = +-grp-ops , *-grp-ops

postulate fld-struct : Field-Struct fld-ops

fld : Field ℤq
fld = fld-ops , fld-struct

module fld = Field fld

-- open fld using (+-grp) public

ℤ[_]+-grp : Group ℤq
ℤ[_]+-grp = fld.+-grp

ℤq+-grp : Group ℤq
ℤq+-grp = fld.+-grp

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

{-# OPTIONS --without-K #-}
open import Type.Eq using (_==_; Eq?; ≡⇒==; ==⇒≡)
open import Data.Two.Base using (𝟚; ✓)
open import Relation.Binary.PropositionalEquality.Base using (_≡_; refl; ap)
open import FFI.JS using (JS[_]; _++_; return; _>>_)
open import FFI.JS.Check
  using    (check!)
  renaming (check      to check?)
--renaming (warn-check to check?)

open import FFI.JS.BigI
open import Data.List.Base using (List; foldr)
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Homomorphism
open import Algebra.Field

-- TODO carry on a primality proof of q
module Crypto.JS.BigI.FiniteField (q : BigI) where

-- The constructor mk is not exported.
private
  module Internals where
    data ℤ[_] : Set where
      mk : BigI → ℤ[_]

    mk-inj : ∀ {x y : BigI} → ℤ[_].mk x ≡ mk y → x ≡ y
    mk-inj refl = refl

open Internals public using (ℤ[_])
open Internals

ℤq : Set
ℤq = ℤ[_]

private
  mod-q : BigI → ℤq
  mod-q x = mk (mod x q)

-- There are two ways to go from BigI to ℤq: BigI▹ℤ[ q ] and mod-q
-- Use BigI▹ℤ[ q ] for untrusted input data and mod-q for internal
-- computation.
BigI▹ℤ[_] : BigI → JS[ ℤq ]
BigI▹ℤ[_] x =
-- Console.log "BigI▹ℤ[_]"
  check! "below the modulus" (x <I q)
         (λ _ → "Not below the modulus: q:" ++ toString q ++
                " is less than x:" ++ toString x) >>
  check! "positivity" (x ≥I 0I)
         (λ _ → "Should be positive: " ++ toString x ++ " < 0") >>
  return (mk x)

check-non-zero : ℤq → BigI
check-non-zero (mk x) = -- trace-call "check-non-zero "
  check? (x >I 0I) (λ _ → "Should be non zero") x

ℤ[_]▹BigI : ℤq → BigI
ℤ[_]▹BigI (mk x) = x

0# 1# : ℤq
0# = mk 0I
1# = mk 1I

-- One could choose here to return a dummy value when 0 is given.
-- Instead we throw an exception which in some circumstances could
-- be bad if the runtime semantics is too eager.
1/_ : ℤq → ℤq
1/ x = mk (modInv (check-non-zero x) q)

_^I_ : ℤq → BigI → ℤq
mk x ^I y = mk (modPow x y q)

ℤq▹BigI = ℤ[_]▹BigI
BigI▹ℤq = BigI▹ℤ[_]

_⊗I_ : ℤq → BigI → ℤq
x ⊗I y = mod-q (multiply (ℤq▹BigI x) y)

_+_ _−_ _*_ _/_ : ℤq → ℤq → ℤq

x + y = mod-q (add      (ℤq▹BigI x) (ℤq▹BigI y))
x − y = mod-q (subtract (ℤq▹BigI x) (ℤq▹BigI y))
x * y = x ⊗I ℤq▹BigI y
x / y = x * 1/ y

*-def : _*_ ≡ (λ x y → x ⊗I ℤq▹BigI y)
*-def = refl

0−_ : ℤq → ℤq
0− x = mod-q (negate (ℤq▹BigI x))

sum prod : List ℤq → ℤq
sum  = foldr _+_ 0#
prod = foldr _*_ 1#

instance
  ℤ[_]-Eq? : Eq? ℤq
  ℤ[_]-Eq? = record
    { _==_ = _=='_
    ; ≡⇒== = ≡⇒=='
    ; ==⇒≡ = ==⇒≡' }
    where
      _=='_ : ℤq → ℤq → 𝟚
      mk x ==' mk y = x == y
      ≡⇒==' : ∀ {x y} → x ≡ y → ✓ (x ==' y)
      ≡⇒==' {mk x} {mk y} p = ≡⇒== (mk-inj p)
      ==⇒≡' : ∀ {x y} → ✓ (x ==' y) → x ≡ y
      ==⇒≡' {mk x} {mk y} p = ap mk (==⇒≡ p)

ℤq-Eq?  = ℤ[_]-Eq?

+-mon-ops : Monoid-Ops ℤq
+-mon-ops = _+_ , 0#

+-grp-ops : Group-Ops ℤq
+-grp-ops = +-mon-ops , 0−_

*-mon-ops : Monoid-Ops ℤq
*-mon-ops = _*_ , 1#

*-grp-ops : Group-Ops ℤq
*-grp-ops = *-mon-ops , 1/_

fld-ops : Field-Ops ℤq
fld-ops = +-grp-ops , *-grp-ops

postulate fld-struct : Field-Struct fld-ops

fld : Field ℤq
fld = fld-ops , fld-struct

module fld = Field fld

-- open fld using (+-grp) public

ℤ[_]+-grp : Group ℤq
ℤ[_]+-grp = fld.+-grp

ℤq+-grp : Group ℤq
ℤq+-grp = fld.+-grp

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


elgamal

elgamal

{-# OPTIONS --without-K #-}
{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Function.Extensionality
open import Data.Product.NP
open import Data.Unit
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc; Fin▹ℕ) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_; _==_)
open import Data.Nat.Distance
open import Data.Bit
open import Data.Zero
open import Data.Two
open import Relation.Binary.NP
open import Data.Bits hiding (_==_)
open import Relation.Binary.PropositionalEquality.NP as ≡ hiding (_∙_)
open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Explorable
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base
open import Explore.Sum
open import Explore.Product
import Explore.GroupHomomorphism as GH

import Game.DDH
import Game.IND-CPA
import Cipher.ElGamal.Generic

module elgamal where

{-
data `★ : ★ where
  `⊤   : `★
  `X   : `★
  _`×_ : `★ → `★ → `★
infixr 2 _`×_

module Univ (X : ★) where
    El : `★ → ★
    El `⊤         = ⊤
    El `X         = X
    El (u₀ `× u₁) = El u₀ × El u₁

    record ↺ (R : `★) (A : ★) : ★ where
      constructor mk
      field
        run↺ : El R → A
    open ↺ public

    EXP : (R : `★) → ★
    EXP R = ↺ R Bit

    Det : ★ → ★
    Det = ↺ `⊤

    μU : Explorable X → ∀ u → Explorable (El u)
    μU μX `⊤         = μ⊤
    μU μX `X         = μX
    μU μX (u₀ `× u₁) = μU μX u₀ ×-μ μU μX u₁

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : Explorable ℤq)
  (⊞-stable : ∀ x → SumStableUnder (sum μℤq) (_⊞_ x))
  where

  -- open Sum
  open Univ ℤq public
  open `★ public renaming (`X to `ℤq)

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = count (μU μℤq u) (run↺ f)

  #q_ : Count ℤq
  #q_ = count μℤq

  ⁇ : ∀ R → ↺ R (El R)
  run↺ (⁇ _) = id

  pure↺ : ∀ {R A} → A → ↺ R A
  run↺ (pure↺ x) r = x -- turning r to _ produce an error

  ⟪_⟫ : ∀ {R A} → A → ↺ R A
  ⟪_⟫ = pure↺

  {-
  ⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
  ⟪_⟫ᴰ = pureᴰ
  -}

  map↺ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  run↺ (map↺ f x) r = f (run↺ x r)

  infixl 4 _⊛_
  _⊛_ : ∀ {R S A B} → ↺ R (A → B) → ↺ S A → ↺ (R `× S) B
  run↺ (af ⊛ ax) rs = run↺ af (fst rs) (run↺ ax (snd rs))

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

  ⟪_·_·_⟫ : ∀ {A B C} {R S} →
              (A → B → C) → ↺ R A → ↺ S B → ↺ (R `× S) C
  ⟪ f · x · y ⟫ = map↺ f x ⊛ y

  _⟨⊞⟩_ : ∀ {R S} → ↺ R ℤq → ↺ S ℤq → ↺ (R `× S) ℤq
  x ⟨⊞⟩ y = ⟪ _⊞_ · x · y ⟫

  ⟨_⊞⟩_ : ∀ {R} → ℤq → ↺ R ℤq → ↺ R ℤq
  ⟨ x ⊞⟩ y = ⟪ _⊞_ x · y ⟫

  infix 4 _≈↺_ _≈ᴬ_
  _≈↺_ : ∀ {R : `★} (f g : EXP R) → ★
  _≈↺_ = _≡_ on #_

  _≈ᴬ_ : ∀ {A R} (f g : ↺ R A) → Set _
  _≈ᴬ_ {A} f g = ∀ (Adv : A → Bit) → ⟪ Adv · f ⟫ ≈↺ ⟪ Adv · g ⟫

  lem : ∀ x → ⟨ x ⊞⟩ (⁇ `ℤq) ≈ᴬ ⁇ _
  lem x Adv = sym (⊞-stable x (Bit▹ℕ ∘ Adv))

  -- ∀ (A : ℤq → Bit) → # (A ⁇)
-}

module El-Gamal-Generic
  (ℤqᵁ : U)
  (G        : ★)
  (g        : G)
  (_^_      : G → El ℤqᵁ → G)
  (Message  : ★)
  (_∙_      : G → Message → Message)
  (_/_      : Message → G → Message)
  (Rₐᵁ       : U)
  where
    ℤq = El ℤqᵁ
    Rₐ  = El Rₐᵁ

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

    -- gˣ is the pk
    -- x is the sk

    Rₓ : ★
    Rₓ = ℤq

    open Cipher.ElGamal.Generic Message Message ℤq G g _^_ _∙_ _/_

    module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText Rₑ Rₖ Rₐ Rₓ KeyGen Enc
    open IND-CPA renaming (R to R')

    -- R' = (Rₐ × Rₖ × Rₑ × Rₓ)
    R'ᵁ = Rₐᵁ ×ᵁ ℤqᵁ ×ᵁ ℤqᵁ ×ᵁ ℤqᵁ
    -- R' = El R'ᵁ
    sumR' = sum R'ᵁ
    R = 𝟚 × R'
    Rᵁ = 𝟚ᵁ ×ᵁ R'ᵁ
    sumR = sum Rᵁ

    sumExtRₐ = sum-ext Rₐᵁ
    sumExtℤq = sum-ext ℤqᵁ
    sumHomR' = sum-hom R'ᵁ
    sumExtR' = sum-ext R'ᵁ

    IND-CPA-⅁ : IND-CPA.Adversary → R → 𝟚
    IND-CPA-⅁ = IND-CPA.game

    module DDH = Game.DDH ℤq G g _^_ (𝟚 × Rₐ)

    DDH-⅁₀ DDH-⅁₁ : DDH.Adv → R → 𝟚
    DDH-⅁₀ A (b , rₐ , gˣ , gʸ , gᶻ) = DDH.⅁₀ A ((b , rₐ) , gˣ , gʸ , gᶻ)
    DDH-⅁₁ A (b , rₐ , gˣ , gʸ , gᶻ) = DDH.⅁₁ A ((b , rₐ) , gˣ , gʸ , gᶻ)

    transformAdv : IND-CPA.Adversary → DDH.Adv
    transformAdv (m , d) (b , rₐ) gˣ gʸ gᶻ = b == b′
                 where mb  = m rₐ gˣ b
                       c   = (gʸ , gᶻ ∙ mb)
                       b′  = d rₐ gˣ c

    #q_ : Count ℤq
    #q_ = count ℤqᵁ

    _≈q_ : (f g : ℤq → ℕ) → ★
    f ≈q g = sum ℤqᵁ f ≡ sum ℤqᵁ g

    OTP-LEM = ∀ (O : Message → ℕ) m₀ m₁ →
                              (λ x → O((g ^ x) ∙ m₀)) ≈q (λ x → O((g ^ x) ∙ m₁))

    1/2 : R → 𝟚
    1/2 (b , _) = b

    module _ {S} where
      _≈ᴿ_ : (f g : R → S) → ★
      f ≈ᴿ g = ∀ (X : S → ℕ) → sumR (X ∘ f) ≡ sumR (X ∘ g)

    Dist : (f g : R → 𝟚) → ℕ
    Dist f g = dist (count Rᵁ f) (count Rᵁ g)

    dist-cong : ∀  {f g h i} → f ≈ᴿ g → h ≈ᴿ i → Dist f h ≡ Dist g i
    dist-cong {f}{g}{h}{i} f≈g h≈i = ap₂ dist (f≈g 𝟚▹ℕ) (h≈i 𝟚▹ℕ)

    OTP-⅁ : IND-CPA.Adversary → R → 𝟚
    OTP-⅁ (m , d) (b , rₐ , x , y , z) = b == d rₐ gˣ (gʸ , gᶻ ∙ m rₐ gˣ b)
      where gˣ = g ^ x
            gʸ = g ^ y
            gᶻ = g ^ z

    module Proof (otp-lem : OTP-LEM)

                 (A : IND-CPA.Adversary) where

        module A = IND-CPA.Adversary A
        A′ = transformAdv A

        goal4 : 1/2 ≈ᴿ OTP-⅁ A
        goal4 X = sumR' (λ _ → X 0b) + sumR' (λ _ → X 1b)
                ≡⟨ sym (sumHomR' _  _) ⟩
                  sumR' (λ _ → X 0b + X 1b)
                ≡⟨ sumExtR' (lemma ∘ B 0b) ⟩
                  sumR' (Y 0b 0b +° Y 1b 0b)
                ≡⟨ sumHomR' _ _ ⟩
                  sumR' (Y 0b 0b) + sumR' (Y 1b 0b)
                ≡⟨ cong (_+_ (sumR' (Y 0b 0b))) lemma2 ⟩
                  sumR' (Y 0b 0b) + sumR' (Y 1b 1b)
                ∎
          where
            open ≡-Reasoning

            B : 𝟚 → R' → 𝟚
            B b (rₐ , x , y , z) = A.b′ rₐ (g ^ x) (g ^ y , (g ^ z) ∙ A.m rₐ (g ^ x) b)

            Y = λ bb bbb r → X (bb == B bbb r)

            lemma : ∀ b → X 0b + X 1b ≡  X (0b == b) + X (1b == b)
            lemma 1b = refl
            lemma 0b = ℕ°.+-comm (X 0b) _

            lemma2 : sumR' (Y 1b 0b) ≡ sumR' (Y 1b 1b)
            lemma2 = sumExtRₐ λ rₐ →
                     sumExtℤq λ x →
                     sumExtℤq λ y →
                       otp-lem (λ m → X (A.b′ rₐ (g ^ x) (g ^ y , m))) (A.m rₐ (g ^ x) 0₂) (A.m rₐ (g ^ x) 1₂)

                     {-
                      otp-lem (λ m → snd A rₐ (g ^ x) (g ^ y , m))
                              (fst A rₐ (g ^ x) 1b)
                              (fst A rₐ (g ^ x) 0b)
                              (λ c → X (1b == c))
    -}

        module absDist {DIST : ★}(Dist : (f g : R → 𝟚) → DIST)
          (dist-cong : ∀ {f h i} → h ≈ᴿ i → Dist f h ≡ Dist f i) where
          goal : Dist (IND-CPA-⅁ A) 1/2 ≡ Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
          goal = Dist (IND-CPA-⅁ A) 1/2
               ≡⟨ refl ⟩
                 Dist (DDH-⅁₀ A′) 1/2
               ≡⟨ dist-cong goal4 ⟩
                 Dist (DDH-⅁₀ A′) (OTP-⅁ A)
               ≡⟨ refl ⟩
                 Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
               ∎
            where open ≡-Reasoning

        open absDist Dist (λ {f}{h}{i} → dist-cong {f}{f}{h}{i} (λ _ → refl)) public

module El-Gamal-Base
    (ℤqᵁ : U)
    (ℤq-grp : GH.Group (El ℤqᵁ))
    (G : ★)
    (G-grp : GH.Group G)
    (g : G)
    (_^_ : G → El ℤqᵁ → G)
    (^-gh : GH.GroupHomomorphism ℤq-grp G-grp (_^_ g))
    (dlog : (b y : G) → El ℤqᵁ)
    (dlog-ok : (b y : G) → b ^ dlog b y ≡ y)
    (Rₐᵁ : U)
    (Rₐ : El Rₐᵁ)
    {{_ : FunExt}}
    {{_ : UA}}
    (open GH.Group ℤq-grp renaming (_∙_ to _⊞_))
    (⊞-is-equiv : ∀ k → Is-equiv (flip _⊞_ k))
    where

    open GH.Group G-grp using (_∙_) renaming (-_ to _⁻¹)

    _/_ : G → G → G
    x / y = x ∙ (y ⁻¹)

    open El-Gamal-Generic ℤqᵁ G g _^_ G _∙_ _/_ Rₐᵁ public

    otp-lem : ∀ (O : G → ℕ) m₀ m₁ →
        (λ x → O((g ^ x) ∙ m₀)) ≈q (λ x → O((g ^ x) ∙ m₁))
    otp-lem = GH.thm ℤq-grp G-grp (_^_ g) (explore ℤqᵁ)
                     ^-gh (dlog g) (dlog-ok g)
                     (explore-ext ℤqᵁ) 0 _+_
                     (λ k f → ! sumStableUnder ℤqᵁ (_ , ⊞-is-equiv k) f)
    open Proof otp-lem

    thm : ∀ A →
          let A′ = transformAdv A in
          Dist (IND-CPA-⅁ A) 1/2 ≡ Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
    thm = goal

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

{-# OPTIONS --without-K #-}
{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Function.Extensionality
open import Data.Product.NP
open import Data.Unit
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc; Fin▹ℕ) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_; _==_)
open import Data.Nat.Distance
open import Data.Bit
open import Data.Two
open import Relation.Binary.NP
open import Data.Bits hiding (_==_)
open import Relation.Binary.PropositionalEquality.NP as ≡ hiding (_∙_)
open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Explorable
open import Explore.Universe.Base
open import Explore.Sum -- renaming (μBit to μ𝟚)
open import Explore.Product
import Explore.GroupHomomorphism as GH
--open import Explore.Fin

import Game.DDH
import Game.IND-CPA
import Cipher.ElGamal.Generic

module elgamal where

{-
data `★ : ★ where
  `⊤   : `★
  `X   : `★
  _`×_ : `★ → `★ → `★
infixr 2 _`×_

module Univ (X : ★) where
    El : `★ → ★
    El `⊤         = ⊤
    El `X         = X
    El (u₀ `× u₁) = El u₀ × El u₁

    record ↺ (R : `★) (A : ★) : ★ where
      constructor mk
      field
        run↺ : El R → A
    open ↺ public

    EXP : (R : `★) → ★
    EXP R = ↺ R Bit

    Det : ★ → ★
    Det = ↺ `⊤

    μU : Explorable X → ∀ u → Explorable (El u)
    μU μX `⊤         = μ⊤
    μU μX `X         = μX
    μU μX (u₀ `× u₁) = μU μX u₀ ×-μ μU μX u₁

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : Explorable ℤq)
  (⊞-stable : ∀ x → SumStableUnder (sum μℤq) (_⊞_ x))
  where

  -- open Sum
  open Univ ℤq public
  open `★ public renaming (`X to `ℤq)

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = count (μU μℤq u) (run↺ f)

  #q_ : Count ℤq
  #q_ = count μℤq

  ⁇ : ∀ R → ↺ R (El R)
  run↺ (⁇ _) = id

  pure↺ : ∀ {R A} → A → ↺ R A
  run↺ (pure↺ x) r = x -- turning r to _ produce an error

  ⟪_⟫ : ∀ {R A} → A → ↺ R A
  ⟪_⟫ = pure↺

  {-
  ⟪_⟫ᴰ : ∀ {a} {A : Set a} → A → Det A
  ⟪_⟫ᴰ = pureᴰ
  -}

  map↺ : ∀ {A B R} → (A → B) → ↺ R A → ↺ R B
  run↺ (map↺ f x) r = f (run↺ x r)

  infixl 4 _⊛_
  _⊛_ : ∀ {R S A B} → ↺ R (A → B) → ↺ S A → ↺ (R `× S) B
  run↺ (af ⊛ ax) rs = run↺ af (fst rs) (run↺ ax (snd rs))

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

  ⟪_·_·_⟫ : ∀ {A B C} {R S} →
              (A → B → C) → ↺ R A → ↺ S B → ↺ (R `× S) C
  ⟪ f · x · y ⟫ = map↺ f x ⊛ y

  _⟨⊞⟩_ : ∀ {R S} → ↺ R ℤq → ↺ S ℤq → ↺ (R `× S) ℤq
  x ⟨⊞⟩ y = ⟪ _⊞_ · x · y ⟫

  ⟨_⊞⟩_ : ∀ {R} → ℤq → ↺ R ℤq → ↺ R ℤq
  ⟨ x ⊞⟩ y = ⟪ _⊞_ x · y ⟫

  infix 4 _≈↺_ _≈ᴬ_
  _≈↺_ : ∀ {R : `★} (f g : EXP R) → ★
  _≈↺_ = _≡_ on #_

  _≈ᴬ_ : ∀ {A R} (f g : ↺ R A) → Set _
  _≈ᴬ_ {A} f g = ∀ (Adv : A → Bit) → ⟪ Adv · f ⟫ ≈↺ ⟪ Adv · g ⟫

  lem : ∀ x → ⟨ x ⊞⟩ (⁇ `ℤq) ≈ᴬ ⁇ _
  lem x Adv = sym (⊞-stable x (Bit▹ℕ ∘ Adv))

  -- ∀ (A : ℤq → Bit) → # (A ⁇)
-}

module El-Gamal-Generic
  (ℤqᵁ : U)
  (G        : ★)
  (g        : G)
  (_^_      : G → El ℤqᵁ → G)
  (Message  : ★)
  (_∙_      : G → Message → Message)
  (_/_      : Message → G → Message)
  (Rₐᵁ       : U)
  where
    ℤq = El ℤqᵁ
    Rₐ  = El Rₐᵁ

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

    -- gˣ is the pk
    -- x is the sk

    Rₓ : ★
    Rₓ = ℤq

    open Cipher.ElGamal.Generic Message Message ℤq G g _^_ _∙_ _/_

    module IND-CPA = Game.IND-CPA PubKey SecKey Message CipherText Rₑ Rₖ Rₐ Rₓ KeyGen Enc
    open IND-CPA renaming (R to R')

    -- R' = (Rₐ × Rₖ × Rₑ × Rₓ)
    R'ᵁ = Rₐᵁ ×ᵁ ℤqᵁ ×ᵁ ℤqᵁ ×ᵁ ℤqᵁ
    -- R' = El R'ᵁ
    sumR' = sum R'ᵁ
    R = 𝟚 × R'
    Rᵁ = 𝟚ᵁ ×ᵁ R'ᵁ
    sumR = sum Rᵁ

    sumExtRₐ = sum-ext Rₐᵁ
    sumExtℤq = sum-ext ℤqᵁ
    sumHomR' = sum-hom R'ᵁ
    sumExtR' = sum-ext R'ᵁ

    IND-CPA-⅁ : IND-CPA.Adversary → R → 𝟚
    IND-CPA-⅁ = IND-CPA.game

    module DDH = Game.DDH ℤq G g _^_ (𝟚 × Rₐ)

    DDH-⅁₀ DDH-⅁₁ : DDH.Adv → R → 𝟚
    DDH-⅁₀ A (b , rₐ , gˣ , gʸ , gᶻ) = DDH.⅁₀ A ((b , rₐ) , gˣ , gʸ , gᶻ)
    DDH-⅁₁ A (b , rₐ , gˣ , gʸ , gᶻ) = DDH.⅁₁ A ((b , rₐ) , gˣ , gʸ , gᶻ)

    transformAdv : IND-CPA.Adversary → DDH.Adv
    transformAdv (m , d) (b , rₐ) gˣ gʸ gᶻ = b == b′
                 where mb  = m rₐ gˣ b
                       c   = (gʸ , gᶻ ∙ mb)
                       b′  = d rₐ gˣ c

    #q_ : Count ℤq
    #q_ = count ℤqᵁ

    _≈q_ : (f g : ℤq → ℕ) → ★
    f ≈q g = sum ℤqᵁ f ≡ sum ℤqᵁ g

    OTP-LEM = ∀ (O : Message → ℕ) m₀ m₁ →
                              (λ x → O((g ^ x) ∙ m₀)) ≈q (λ x → O((g ^ x) ∙ m₁))

    1/2 : R → 𝟚
    1/2 (b , _) = b

    module _ {S} where
      _≈ᴿ_ : (f g : R → S) → ★
      f ≈ᴿ g = ∀ (X : S → ℕ) → sumR (X ∘ f) ≡ sumR (X ∘ g)

    Dist : (f g : R → 𝟚) → ℕ
    Dist f g = dist (count Rᵁ f) (count Rᵁ g)

    dist-cong : ∀  {f g h i} → f ≈ᴿ g → h ≈ᴿ i → Dist f h ≡ Dist g i
    dist-cong {f}{g}{h}{i} f≈g h≈i = ap₂ dist (f≈g 𝟚▹ℕ) (h≈i 𝟚▹ℕ)

    OTP-⅁ : IND-CPA.Adversary → R → 𝟚
    OTP-⅁ (m , d) (b , rₐ , x , y , z) = b == d rₐ gˣ (gʸ , gᶻ ∙ m rₐ gˣ b)
      where gˣ = g ^ x
            gʸ = g ^ y
            gᶻ = g ^ z

    module Proof (otp-lem : OTP-LEM)

                 (A : IND-CPA.Adversary) where

        module A = IND-CPA.Adversary A
        A′ = transformAdv A

        goal4 : 1/2 ≈ᴿ OTP-⅁ A
        goal4 X = sumR' (λ _ → X 0b) + sumR' (λ _ → X 1b)
                ≡⟨ sym (sumHomR' _  _) ⟩
                  sumR' (λ _ → X 0b + X 1b)
                ≡⟨ sumExtR' (lemma ∘ B 0b) ⟩
                  sumR' (Y 0b 0b +° Y 1b 0b)
                ≡⟨ sumHomR' _ _ ⟩
                  sumR' (Y 0b 0b) + sumR' (Y 1b 0b)
                ≡⟨ cong (_+_ (sumR' (Y 0b 0b))) lemma2 ⟩
                  sumR' (Y 0b 0b) + sumR' (Y 1b 1b)
                ∎
          where
            open ≡-Reasoning

            B : 𝟚 → R' → 𝟚
            B b (rₐ , x , y , z) = A.b′ rₐ (g ^ x) (g ^ y , (g ^ z) ∙ A.m rₐ (g ^ x) b)

            Y = λ bb bbb r → X (bb == B bbb r)

            lemma : ∀ b → X 0b + X 1b ≡  X (0b == b) + X (1b == b)
            lemma 1b = refl
            lemma 0b = ℕ°.+-comm (X 0b) _

            lemma2 : sumR' (Y 1b 0b) ≡ sumR' (Y 1b 1b)
            lemma2 = sumExtRₐ λ rₐ →
                     sumExtℤq λ x →
                     sumExtℤq λ y →
                       otp-lem (λ m → X (A.b′ rₐ (g ^ x) (g ^ y , m))) (A.m rₐ (g ^ x) 0₂) (A.m rₐ (g ^ x) 1₂)

                     {-
                      otp-lem (λ m → snd A rₐ (g ^ x) (g ^ y , m))
                              (fst A rₐ (g ^ x) 1b)
                              (fst A rₐ (g ^ x) 0b)
                              (λ c → X (1b == c))
    -}

        module absDist {DIST : ★}(Dist : (f g : R → 𝟚) → DIST)
          (dist-cong : ∀ {f h i} → h ≈ᴿ i → Dist f h ≡ Dist f i) where
          goal : Dist (IND-CPA-⅁ A) 1/2 ≡ Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
          goal = Dist (IND-CPA-⅁ A) 1/2
               ≡⟨ refl ⟩
                 Dist (DDH-⅁₀ A′) 1/2
               ≡⟨ dist-cong goal4 ⟩
                 Dist (DDH-⅁₀ A′) (OTP-⅁ A)
               ≡⟨ refl ⟩
                 Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
               ∎
            where open ≡-Reasoning

        open absDist Dist (λ {f}{h}{i} → dist-cong {f}{f}{h}{i} (λ _ → refl)) public

module El-Gamal-Base
    (ℤqᵁ : U)
    (ℤq-grp : GH.Group (El ℤqᵁ))
    (G : ★)
    (G-grp : GH.Group G)
    (g : G)
    (_^_ : G → El ℤqᵁ → G)
    (^-gh : GH.GroupHomomorphism ℤq-grp G-grp (_^_ g))
    (dlog : (b y : G) → El ℤqᵁ)
    (dlog-ok : (b y : G) → b ^ dlog b y ≡ y)
    (Rₐᵁ : U)
    (Rₐ : El Rₐᵁ)
    {{_ : FunExt}}
    {{_ : UA}}
    (open GH.Group ℤq-grp renaming (_∙_ to _⊞_))
    (⊞-is-equiv : ∀ k → Is-equiv (flip _⊞_ k))
    where

    open GH.Group G-grp using (_∙_) renaming (-_ to _⁻¹)

    _/_ : G → G → G
    x / y = x ∙ (y ⁻¹)

    open El-Gamal-Generic ℤqᵁ G g _^_ G _∙_ _/_ Rₐᵁ public

    otp-lem : ∀ (O : G → ℕ) m₀ m₁ →
        (λ x → O((g ^ x) ∙ m₀)) ≈q (λ x → O((g ^ x) ∙ m₁))
    otp-lem = GH.thm ℤq-grp G-grp (_^_ g) (explore ℤqᵁ)
                     ^-gh (dlog g) (dlog-ok g)
                     (explore-ext ℤqᵁ) 0 _+_
                     (λ k f → ! sumStableUnder ℤqᵁ (_ , ⊞-is-equiv k) f)
    open Proof otp-lem

    thm : ∀ A →
          let A′ = transformAdv A in
          Dist (IND-CPA-⅁ A) 1/2 ≡ Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
    thm = goal

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