updated the elgamal example

updated the elgamal example

{-# 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.Two
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 Explore.Type
open import Explore.Explorable
open import Explore.Explorable.Sum renaming (μBit to μ𝟚)
open import Explore.Explorable.Product
open import Explore.Explorable.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 renaming (R to R')

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

    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.Adv → R → 𝟚
    IND-CPA-⅁ A (b , rₐ , rₖ , rₑ , rₓ) = IND-CPA.⅁ b A (rₐ , rₖ , rₑ , rₓ)

    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.Adv → 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

    postulate
      A : IND-CPA.Adv

    A′ = transformAdv A

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

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

    OTP-⅁ : IND-CPA.Adv → 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

    postulate
      otp-lem : ∀ (A : Message → ℕ) m₀ m₁ →
        (λ x → A((g ^ x) ∙ m₀)) ≈q (λ x → A((g ^ x) ∙ m₁))

    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) = proj₂ A rₐ (g ^ x) (g ^ y , (g ^ z) ∙ proj₁ A 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 (proj₂ A rₐ (g ^ x) (g ^ y , m))) (proj₁ A rₐ (g ^ x) 0') (proj₁ A rₐ (g ^ x) 1')

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

    module absDist {DIST : ★}(Dist : (f g : R → 𝟚) → DIST)
      (dist-cong : ∀ {f g h i} → f ≈ᴿ g → h ≈ᴿ i → Dist f h ≡ Dist g 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 (λ _ → refl) goal4 ⟩
             Dist (DDH-⅁₀ A′) (OTP-⅁ A)
           ≡⟨ refl ⟩
             Dist (DDH-⅁₀ A′) (DDH-⅁₁ A′)
           ∎
        where open ≡-Reasoning

    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 = cong₂ dist (f≈g 𝟚▹ℕ) (h≈i 𝟚▹ℕ)

    open absDist Dist (λ {f}{g}{h}{i} → dist-cong {f}{g}{h}{i})

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

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


Unlock more in sum-setoid

Unlock more in sum-setoid

import Level as L
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP hiding (_^_)
open import Data.Nat.Properties
open import Data.Unit hiding (_≤_)
open import Data.Sum
open import Data.Maybe.NP
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Function.Equality using (_⟨$⟩_ ; ≡-setoid)
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
import Function.Related as FR
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
open import Relation.Binary.Sum
open import Relation.Binary.Product.Pointwise
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_; _≗_)

module sum-setoid where

_≤°_ : ∀ {A : ★}(f g : A → ℕ) → ★
f ≤° g = ∀ x → f x ≤ g x

Semigroup₀ = Semigroup L.zero L.zero
Monoid₀ = Monoid L.zero L.zero
CommutativeMonoid₀ = CommutativeMonoid L.zero L.zero

module SgrpExtra (sg : Semigroup₀) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★
  C = Carrier
  _≈°_ : ∀ {A : ★} (f g : A → C) → ★
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {A : ★} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong

module Sgrp (sg : Semigroup₀) where
  open Semigroup sg public
  open SgrpExtra sg public

module Mon (m : Monoid₀) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public

module CMon (cm : CommutativeMonoid₀) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public

  ∙-interchange : Interchange _≈_ _∙_ _∙_
  ∙-interchange = InterchangeFromAssocCommCong.∙-interchange
                    _≈_ isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

Search : ★ → ★₁
Search A = ∀ {B} → (_∙_ : B → B → B) → (A → B) → B
-- Search A = ∀ {I : ★} {F : I → ★} → (_∙_ : ∀ {i} → F i → F i → F i) → ∀ {i} → (A → F i) → F i

SearchMon : ★ → ★₁
SearchMon A = (m : Monoid₀) → let open Mon m in
                              (A → C) → C

searchMonFromSearch : ∀ {A} → Search A → SearchMon A
searchMonFromSearch s m = s _∙_ where open Mon m

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SearchInd : ∀ {A} → Search A → ★₁
SearchInd {A} srch = ∀ (P  : Search A → ★)
                       (P∙ : ∀ {s₀ s₁ : Search A} → P s₀ → P s₁ → P (λ _∙_ f → s₀ _∙_ f ∙ s₁ _∙_ f))
                       (Pf : ∀ x → P (λ _ f → f x))
                     →  P srch

SumInd : ∀ {A} → Sum A → ★₁
SumInd {A} sum = ∀ (P  : Sum A → ★)
                   (P+ : ∀ {s₀ s₁ : Sum A} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f))
                   (Pf : ∀ x → P (λ f → f x))
                →  P sum

SearchMono : ∀ {A} → Search A → ★₁
SearchMono sᴬ = ∀ {C} (_⊆_ : C → C → ★) →
                ∀ {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                  {f g} →
                  (∀ x → f x ⊆ g x) → sᴬ _∙_ f ⊆ sᴬ _∙_ g

SearchSgExt : ∀ {A} → Search A → ★₁
SearchSgExt sᴬ = ∀ sg {f g} → let open Sgrp sg in
                              f ≈° g → sᴬ _∙_ f ≈ sᴬ _∙_ g

SearchExt : ∀ {A} → Search A → ★₁
SearchExt {A} sᴬ = ∀ {B} op {f g : A → B} → f ≗ g → sᴬ op f ≡ sᴬ op g

SearchExtFun : ∀ {A B} → Search (A → B) → ★₁
SearchExtFun {A}{B} sᴬᴮ = ∀ {M} op {f g : (A → B) → M} → (∀ {φ ψ} → φ ≗ ψ → f φ ≡ g ψ) → sᴬᴮ op f ≡ sᴬᴮ op g

SearchExtFun-úber : ∀ {A B} → (SF : Search (A → B)) → SearchInd SF → SearchExtFun SF
SearchExtFun-úber sf sf-ind op {f = f}{g} f≈g = sf-ind (λ s → s op f ≡ s op g) (≡.cong₂ op) (λ x → f≈g (λ _ → ≡.refl))

SearchExtoid : ∀ {A : Setoid L.zero L.zero} → Search (Setoid.Carrier A) → ★₁
SearchExtoid {A} sᴬ = ∀ {M} op {f g : Setoid.Carrier A → M} → (∀ {x y} → Setoid._≈_ A x y → f x ≡ g y) → sᴬ op f ≡ sᴬ op g

SumExt : ∀ {A} → Sum A → ★
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

Searchε : ∀ {A} → SearchMon A → ★₁
Searchε sᴬ = ∀ m → let open Mon m in
                   sᴬ m (const ε) ≈ ε

SumZero : ∀ {A} → Sum A → ★
SumZero sumᴬ = sumᴬ (λ _ → 0) ≡ 0

SumLin : ∀ {A} → Sum A → ★
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

SearchHom : ∀ {A} → Search A → ★₁
SearchHom sᴬ = ∀ sg f g → let open Sgrp sg in
                          sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

SearchMonHom : ∀ {A} → SearchMon A → ★₁
SearchMonHom sᴬ = ∀ (cm : CommutativeMonoid₀) f g →
                         let open CMon cm in
                         sᴬ m (f ∙° g) ≈ sᴬ m f ∙ sᴬ m g

SumHom : ∀ {A} → Sum A → ★
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMono : ∀ {A} → Sum A → ★
SumMono sumᴬ = ∀ {f g} → f ≤° g → sumᴬ f ≤ sumᴬ g

SearchSwap : ∀ {A} → Search A → ★₁
SearchSwap {A} sᴬ = ∀ {B} sg f →
                    let open Sgrp sg in ∀ {sᴮ : (B → C) → C}
                  → (hom : ∀ f g → sᴮ (f ∙° g) ≈ sᴮ f ∙ sᴮ g)
                  → sᴬ _∙_ (sᴮ ∘ f) ≈ sᴮ (sᴬ _∙_ ∘ flip f)

sum-lin⇒sum-zero : ∀ {A} → {sum : Sum A} → SumLin sum → SumZero sum
sum-lin⇒sum-zero sum-lin = sum-lin (λ _ → 0) 0

sum-mono⇒sum-ext : ∀ {A} → {sum : Sum A} → SumMono sum → SumExt sum
sum-mono⇒sum-ext sum-mono f≗g = ℕ≤.antisym (sum-mono (ℕ≤.reflexive ∘ f≗g)) (sum-mono (ℕ≤.reflexive ∘ ≡.sym ∘ f≗g))

sum-ext+sum-hom⇒sum-mono : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
sum-ext+sum-hom⇒sum-mono {sum = sum} sum-ext sum-hom {f} {g} f≤°g =
    sum f                         ≤⟨ m≤m+n _ _ ⟩
    sum f + sum (λ x → g x ∸ f x) ≡⟨ ≡.sym (sum-hom _ _) ⟩
    sum (λ x → f x + (g x ∸ f x)) ≡⟨ sum-ext (m+n∸m≡n ∘ f≤°g) ⟩
    sum g ∎ where open ≤-Reasoning

record SumPropoid (As : Setoid L.zero L.zero) : ★₁ where
  constructor _,_
  private
    A = Setoid.Carrier As
  field
    search     : Search A
    search-ind : SearchInd search

  search-sg-ext : SearchSgExt search
  search-sg-ext sg {f} {g} f≈°g = search-ind (λ s → s _ f ≈ s _ g) ∙-cong f≈°g
    where open Sgrp sg

  search-ext : SearchExt search
  search-ext op = search-ind (λ s → s _ _ ≡ s _ _) (≡.cong₂ op)

  search-mono : SearchMono search
  search-mono _⊆_ _∙-mono_ {f} {g} f⊆°g = search-ind (λ s → s _ f ⊆ s _ g) _∙-mono_ f⊆°g

  search-swap : SearchSwap search
  search-swap sg f {sᴮ} pf = search-ind (λ s → s _ (sᴮ ∘ f) ≈ sᴮ (s _ ∘ flip f)) (λ p q → trans (∙-cong p q) (sym (pf _ _))) (λ _ → refl)
    where open Sgrp sg

  searchMon : SearchMon A
  searchMon m = search _∙_
    where open Mon m

  search-ε : Searchε searchMon
  search-ε m = search-ind (λ s → s _ (const ε) ≈ ε) (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε)) (λ _ → refl)
    where open Mon m

  search-hom : SearchMonHom searchMon
  search-hom cm f g = search-ind (λ s → s _ (f ∙° g) ≈ s _ f ∙ s _ g)
                                 (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _)) (λ _ → refl)
    where open CMon cm

  search-hom′ :
      ∀ {S T}
        (_+_ : Op₂ S)
        (_*_ : Op₂ T)
        (f   : S → T)
        (g   : A → S)
        (hom : ∀ x y → f (x + y) ≡ f x * f y)
        → f (search _+_ g) ≡ search _*_ (f ∘ g)
  search-hom′ _+_ _*_ f g hom = search-ind (λ s → f (s _+_ g) ≡ s _*_ (f ∘ g))
                                           (λ p q → ≡.trans (hom _ _) (≡.cong₂ _*_ p q))
                                           (λ _ → ≡.refl)

  StableUnder : (A → A) → ★₁
  StableUnder p = ∀ {B} (op : Op₂ B) f → search op f ≡ search op (f ∘ p)

  sum : Sum A
  sum = search _+_

  sum-ind : SumInd sum
  sum-ind P P+ Pf = search-ind (λ s → P (s _+_)) P+ Pf

  sum-ext : SumExt sum
  sum-ext = search-ext _+_

  sum-zero : SumZero sum
  sum-zero = search-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = search-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = search-mono _≤_ _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.cong₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  SumStableUnder : (A → A) → ★
  SumStableUnder p = ∀ f → (∀ {x y} → Setoid._≈_ As x y → f x ≡.≡ f y) → sum f ≡ sum (f ∘ p)

  sumStableUnder : ∀ {p} → StableUnder p → SumStableUnder p
  sumStableUnder SU-p f _ = SU-p _+_ f

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong Bool.toℕ ∘ f≗g)

  CountStableUnder : (A → A) → ★
  CountStableUnder p = ∀ f → (∀ {x y} → Setoid._≈_ As x y → f x ≡.≡ f y) → count f ≡ count (f ∘ p)

  countStableUnder : ∀ {p} → SumStableUnder p → CountStableUnder p
  countStableUnder sumSU-p f f-pres = sumSU-p (Bool.toℕ ∘ f) (≡.cong Bool.toℕ ∘ f-pres)

  search-extoid : SearchExtoid {As} search
  search-extoid op {f = f}{g} f≈g = search-ind (λ s₁ → s₁ op f ≡ s₁ op g) (≡.cong₂ op) (λ x → f≈g (Setoid.refl As))

SumProp : ★ → ★₁
SumProp A = SumPropoid (≡.setoid A)

open SumPropoid public

search-swap' : ∀ {A B} cm (μA : SumPropoid A) (μB : SumPropoid B) f →
               let open CMon cm
                   sᴬ = search μA _∙_
                   sᴮ = search μB _∙_ in
               sᴬ (sᴮ ∘ f) ≈ sᴮ (sᴬ ∘ flip f)
search-swap' cm μA μB f = search-swap μA sg f (search-hom μB cm)
  where open CMon cm

sum-swap : ∀ {A B} (μA : SumPropoid A) (μB : SumPropoid B) f →
           sum μA (sum μB ∘ f) ≡ sum μB (sum μA ∘ flip f)
sum-swap = search-swap' ℕ°.+-commutativeMonoid

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

_≈Search_ : ∀ {A} → (s₀ s₁ : Search A) → ★₁
s₀ ≈Search s₁ = ∀ {B} (op : Op₂ B) f → s₀ op f ≡ s₁ op f

μ⊤ : SumProp ⊤
μ⊤ = srch , ind
  where
    srch : Search ⊤
    srch _ f = f _

    ind : SearchInd srch
    ind _ _ Pf = Pf _

μBit : SumProp Bit
μBit = searchBit , ind
  where
    searchBit : Search Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    ind : SearchInd searchBit
    ind _ _P∙_ Pf = Pf 0b P∙ Pf 1b

infixr 4 _+Search_

_+Search_ : ∀ {A B} → Search A → Search B → Search (A ⊎ B)
(searchᴬ +Search searchᴮ) _∙_ f = searchᴬ _∙_ (f ∘ inj₁) ∙ searchᴮ _∙_ (f ∘ inj₂)

_+SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
                 SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ +Search sᴮ)
(Psᴬ +SearchInd Psᴮ) P P∙ Pf
  = P∙ (Psᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

_+Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A ⊎ B)
(sumᴬ +Sum sumᴮ) f = sumᴬ (f ∘ inj₁) + sumᴮ (f ∘ inj₂)

_+μ_ : ∀ {A B} → SumPropoid A → SumPropoid B → SumPropoid (A ⊎-setoid B)
μA +μ μB = _ , search-ind μA +SearchInd search-ind μB

infixr 4 _×Search_

-- liftM2 _,_ in the continuation monad
_×Search_ : ∀ {A B} → Search A → Search B → Search (A × B)
(searchᴬ ×Search searchᴮ) op f = searchᴬ op (λ x → searchᴮ op (curry f x))

_×SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
               → SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ ×Search sᴮ)
(Psᴬ ×SearchInd Psᴮ) P P∙ Pf =
  Psᴬ (λ s → P (λ _ _ → s _ _)) P∙ (Psᴮ (λ s → P (λ _ _ → s _ _)) P∙ ∘ curry Pf)

_×SearchExt_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
              SearchExt sᴬ → SearchExt sᴮ → SearchExt (sᴬ ×Search sᴮ)
(sᴬ-ext ×SearchExt sᴮ-ext) sg f≗g = sᴬ-ext sg (sᴮ-ext sg ∘ curry f≗g)

infixr 4 _×Sum_

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

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumPropoid A → SumPropoid B → SumPropoid (A ×-setoid B)
μA ×μ μB = _ , search-ind μA ×SearchInd search-ind μB

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | ≡.sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = ≡.refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = ≡.refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

μ-view : ∀ {A B} → (A → B) → SumProp A → SumProp B
μ-view {A}{B} A→B μA = searchᴮ , ind
  where
    searchᴮ : Search B
    searchᴮ m f = search μA m (f ∘ A→B)

    ind : SearchInd searchᴮ
    ind P P∙ Pf = search-ind μA (λ s → P (λ _ f → s _ (f ∘ A→B))) P∙ (Pf ∘ A→B)

μ-iso : ∀ {A B} → (A ↔ B) → SumProp A → SumProp B
μ-iso A↔B = μ-view (_⟨$⟩_ (Inverse.to A↔B))

μ-view-preserve : ∀ {A B} (A→B : A → B)(B→A : B → A)(A≈B : id ≗ B→A ∘ A→B) f (μA : SumProp A) → sum μA f ≡ sum (μ-view A→B μA) (f ∘ B→A)
μ-view-preserve A→B B→A A≈B f μA = sum-ext μA (≡.cong f ∘ A≈B)

μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : SumProp A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ _⟨$⟩_ (Inverse.from A↔B))
μ-iso-preserve A↔B f μA = μ-view-preserve (_⟨$⟩_ (Inverse.to A↔B)) (_⟨$⟩_ (Inverse.from A↔B))
                            (≡.sym ∘ Inverse.left-inverse-of A↔B) f μA

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec.NP as Vec using (Vec; tabulate; _++_) renaming (map to vmap; sum to vsum; foldr to vfoldr; foldr₁ to vfoldr₁)

vmsum : ∀ m {n} → let open Mon m in
                  Vec C n → C
vmsum m = vfoldr _ _∙_ ε
  where open Monoid m

vsgsum : ∀ sg {n} → let open Sgrp sg in
                    Vec C (suc n) → C
vsgsum sg = vfoldr₁ _∙_
  where open Sgrp sg

-- let's recall that: tabulate f ≗ vmap f (allFin n)

-- searchMonFin : ∀ n → SearchMon (Fin n)
-- searchMonFin n m f = vmsum m (tabulate f)

searchFinSuc : ∀ n → Search (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr₁ _∙_ (tabulate f)
{-

μMaybe : ∀ {A} → SumProp A → SumProp (Maybe A)
μMaybe μA = μ-iso (FI.sym Maybe↔⊤⊎) (μ⊤ +μ μA)

μMaybe^ : ∀ {A} n → SumPropoid A → SumPropoid (Maybe^ n A)
μMaybe^ zero    μA = μA
μMaybe^ (suc n) μA = μMaybe (μMaybe^ n μA)
-}
μFinSuc : ∀ n → SumProp (Fin (suc n))
μFinSuc n = searchFinSuc n , ind n
  where ind : ∀ n → SearchInd (searchFinSuc n)
        ind zero    P P∙ Pf = Pf zero
        ind (suc n) P P∙ Pf = P∙ (Pf zero) (ind n (λ s → P (λ op f → s op (f ∘ suc))) P∙ (Pf ∘ suc))

{-

μFinSucIso : ∀ n → SumProp (Fin (suc n))
μFinSucIso n = μ-iso (Maybe^⊤↔Fin1+ n) (μMaybe^ n μ⊤)

μ^ : ∀ {A} (μA : SumProp A) n → SumProp (A ^ n)
μ^ μA zero    = μ⊤
μ^ μA (suc n) = μA ×μ μ^ μA n

μVec : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec μA n = μ-iso (^↔Vec n) (μ^ μA n)

searchVec : ∀ {A} n → Search A → Search (Vec A n)
searchVec zero    searchᴬ op f = f []
searchVec (suc n) searchᴬ op f = searchᴬ op (λ x → searchVec n searchᴬ op (f ∘ _∷_ x))

searchVec-spec : ∀ {A} (μA : SumProp A) n → searchVec n (search μA) ≈Search search (μVec μA n)
searchVec-spec μA zero    op f = ≡.refl
searchVec-spec μA (suc n) op f = search-ext μA op (λ x → searchVec-spec μA n op (f ∘ _∷_ x))

searchVec-++ : ∀ {A} n {m} (μA : SumProp A) sg
               → let open Sgrp sg in
                 (f : Vec A (n + m) → C)
               → search (μVec μA (n + m)) _∙_ f
               ≈ search (μVec μA n) _∙_ (λ xs →
                   search (μVec μA m) _∙_ (λ ys →
                     f (xs ++ ys)))
searchVec-++ zero    μA sg f = Sgrp.refl sg
searchVec-++ (suc n) μA sg f = search-sg-ext μA sg (λ x →
                                 searchVec-++ n μA sg (f ∘ _∷_ x))

sumVec-swap : ∀ {A} n {m} (μA : SumProp A)(f : Vec A (n + m) → ℕ)
            → sum (μVec μA n) (λ xs → sum (μVec μA m) (λ ys → f (xs ++ ys)))
            ≡ sum (μVec μA m) (λ ys → sum (μVec μA n) (λ xs → f (xs ++ ys)))
sumVec-swap n {m} μA f = sum-swap (μVec μA n) (μVec μA m) (λ xs ys → f (xs ++ ys))

swapS : ∀ {A B} → SumProp (A × B) → SumProp (B × A)
swapS = μ-iso swap-iso

swapS-preserve : ∀ {A B} f (μA×B : SumProp (A × B)) → sum μA×B f ≡ sum (swapS μA×B) (f ∘ swap)
swapS-preserve = μ-iso-preserve swap-iso

module _ {A : Set}(μA : SumProp A) where

  sA = search μA

  extend : ∀ {n} → A → (Fin n → A) → Fin (suc n) → A
  extend x g zero    = x
  extend x g (suc i) = g i

  abs : Fin 0 → A
  abs ()

  -- There is one function Fin 0 → A (called abs) so this should be fine
  -- if not there is a version below that forces the domain to be non-empty
  sFun : ∀ n → Search (Fin n → A)
  sFun zero    op f = f abs
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

  Ind : ∀ n → SearchInd (sFun n)
  Ind zero    P P∙ Pf = Pf abs
  Ind (suc n) P P∙ Pf =
    search-ind μA (λ sa → P (λ op f → sa op (λ x → sFun n op (f ∘ extend x))))
      P∙
      (λ x → Ind n (λ sf → P (λ op f → sf op (f ∘ extend x)))
        P∙ (Pf ∘ extend x))

  μFun : ∀ {n} → SumProp (Fin n → A)
  μFun = sFun _ , Ind _

{-
  -- If we want to force non-empty domain

  sFun : ∀ n → Search (Fin (suc n) → A)
  sFun zero    op f = sA op (f ∘ const)
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

  Ind : ∀ n → SearchInd (sFun n)
  Ind zero    P P∙ Pf = search-ind μA (λ sa → P (λ op f → sa op (f ∘ const))) P∙ (Pf ∘ const)
  Ind (suc n) P P∙ Pf = search-ind μA (λ sa → P (λ op f → sa op (λ x → sFun n op (f ∘ extend x))))
      P∙
      (λ x → Ind n (λ sf → P (λ op f → sf op (f ∘ extend x))) P∙ (Pf ∘ extend x))

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

import Level as L
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP hiding (_^_)
open import Data.Nat.Properties
open import Data.Unit hiding (_≤_)
open import Data.Sum
open import Data.Maybe.NP
open import Data.Product
open import Data.Bits
open import Data.Bool.NP as Bool
open import Function.Equality using (_⟨$⟩_)
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
import Function.Related as FR
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_; _≗_)

module sum-setoid where

SEToid = Setoid L.zero L.zero

_≤°_ : ∀ {A : ★}(f g : A → ℕ) → ★
f ≤° g = ∀ x → f x ≤ g x

Semigroup₀ = Semigroup L.zero L.zero
Monoid₀ = Monoid L.zero L.zero
CommutativeMonoid₀ = CommutativeMonoid L.zero L.zero

module SgrpExtra (sg : Semigroup₀) where
  open Semigroup sg
  open Setoid-Reasoning (Semigroup.setoid sg) public
  C : ★
  C = Carrier
  _≈°_ : ∀ {A : ★} (f g : A → C) → ★
  f ≈° g = ∀ x → f x ≈ g x
  _∙°_   : ∀ {A : ★} (f g : A → C) → A → C
  (f ∙° g) x = f x ∙ g x
  infixl 7 _-∙-_
  _-∙-_ : _∙_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  _-∙-_ = ∙-cong

module Sgrp (sg : Semigroup₀) where
  open Semigroup sg public
  open SgrpExtra sg public

module Mon (m : Monoid₀) where
  open Monoid m public
  sg = semigroup
  open SgrpExtra semigroup public

module CMon (cm : CommutativeMonoid₀) where
  open CommutativeMonoid cm public
  sg = semigroup
  m = monoid
  open SgrpExtra sg public

  ∙-interchange : Interchange _≈_ _∙_ _∙_
  ∙-interchange = InterchangeFromAssocCommCong.∙-interchange
                    _≈_ isEquivalence
                    _∙_ assoc comm (λ _ → flip ∙-cong refl)

Search : ★ → ★₁
Search A = ∀ {B} → (_∙_ : B → B → B) → (A → B) → B
-- Search A = ∀ {I : ★} {F : I → ★} → (_∙_ : ∀ {i} → F i → F i → F i) → ∀ {i} → (A → F i) → F i

SearchMon : ★ → ★₁
SearchMon A = (m : Monoid₀) → let open Mon m in
                              (A → C) → C

searchMonFromSearch : ∀ {A} → Search A → SearchMon A
searchMonFromSearch s m = s _∙_ where open Mon m

Sum : ★ → ★
Sum A = (A → ℕ) → ℕ

Count : ★ → ★
Count A = (A → Bit) → ℕ

SearchInd : ∀ {A} → Search A → ★₁
SearchInd {A} srch = ∀ (P  : Search A → ★)
                       (P∙ : ∀ {s₀ s₁ : Search A} → P s₀ → P s₁ → P (λ _∙_ f → s₀ _∙_ f ∙ s₁ _∙_ f))
                       (Pf : ∀ x → P (λ _ f → f x))
                     →  P srch

SumInd : ∀ {A} → Sum A → ★₁
SumInd {A} sum = ∀ (P  : Sum A → ★)
                   (P+ : ∀ {s₀ s₁ : Sum A} → P s₀ → P s₁ → P (λ f → s₀ f + s₁ f))
                   (Pf : ∀ x → P (λ f → f x))
                →  P sum

SearchMono : ∀ {A} → Search A → ★₁
SearchMono sᴬ = ∀ {C} (_⊆_ : C → C → ★) →
                ∀ {_∙_} (∙-mono : _∙_ Preserves₂ _⊆_ ⟶ _⊆_ ⟶ _⊆_)
                  {f g} →
                  (∀ x → f x ⊆ g x) → sᴬ _∙_ f ⊆ sᴬ _∙_ g

SearchSgExt : ∀ {A} → Search A → ★₁
SearchSgExt sᴬ = ∀ sg {f g} → let open Sgrp sg in
                              f ≈° g → sᴬ _∙_ f ≈ sᴬ _∙_ g

SearchExt : ∀ {A} → Search A → ★₁
SearchExt {A} sᴬ = ∀ {B} op {f g : A → B} → f ≗ g → sᴬ op f ≡ sᴬ op g

SearchExtFun : ∀ {A B} → Search (A → B) → ★₁
SearchExtFun {A}{B} sᴬᴮ = ∀ {M} op {f g : (A → B) → M} → (∀ {φ ψ} → φ ≗ ψ → f φ ≡ g ψ) → sᴬᴮ op f ≡ sᴬᴮ op g

SearchExtFun-úber : ∀ {A B} → (SF : Search (A → B)) → SearchInd SF → SearchExtFun SF
SearchExtFun-úber sf sf-ind op {f = f}{g} f≈g = sf-ind (λ s → s op f ≡ s op g) (≡.cong₂ op) (λ x → f≈g (λ _ → ≡.refl))

SearchExtoid : ∀ {A : Setoid L.zero L.zero} → Search (Setoid.Carrier A) → ★₁
SearchExtoid {A} sᴬ = ∀ {M} op {f g : Setoid.Carrier A → M} → (∀ {x y} → Setoid._≈_ A x y → f x ≡ g y) → sᴬ op f ≡ sᴬ op g

SumExt : ∀ {A} → Sum A → ★
SumExt sumᴬ = ∀ {f g} → f ≗ g → sumᴬ f ≡ sumᴬ g

CountExt : ∀ {A} → Count A → ★
CountExt countᴬ = ∀ {f g} → f ≗ g → countᴬ f ≡ countᴬ g

Searchε : ∀ {A} → SearchMon A → ★₁
Searchε sᴬ = ∀ m → let open Mon m in
                   sᴬ m (const ε) ≈ ε

SumZero : ∀ {A} → Sum A → ★
SumZero sumᴬ = sumᴬ (λ _ → 0) ≡ 0

SumLin : ∀ {A} → Sum A → ★
SumLin sumᴬ = ∀ f k → sumᴬ (λ x → k * f x) ≡ k * sumᴬ f

SearchHom : ∀ {A} → Search A → ★₁
SearchHom sᴬ = ∀ sg f g → let open Sgrp sg in
                          sᴬ _∙_ (f ∙° g) ≈ sᴬ _∙_ f ∙ sᴬ _∙_ g

SearchMonHom : ∀ {A} → SearchMon A → ★₁
SearchMonHom sᴬ = ∀ (cm : CommutativeMonoid₀) f g →
                         let open CMon cm in
                         sᴬ m (f ∙° g) ≈ sᴬ m f ∙ sᴬ m g

SumHom : ∀ {A} → Sum A → ★
SumHom sumᴬ = ∀ f g → sumᴬ (λ x → f x + g x) ≡ sumᴬ f + sumᴬ g

SumMono : ∀ {A} → Sum A → ★
SumMono sumᴬ = ∀ {f g} → f ≤° g → sumᴬ f ≤ sumᴬ g

SearchSwap : ∀ {A} → Search A → ★₁
SearchSwap {A} sᴬ = ∀ {B} sg f →
                    let open Sgrp sg in ∀ {sᴮ : (B → C) → C}
                  → (hom : ∀ f g → sᴮ (f ∙° g) ≈ sᴮ f ∙ sᴮ g)
                  → sᴬ _∙_ (sᴮ ∘ f) ≈ sᴮ (sᴬ _∙_ ∘ flip f)

sum-lin⇒sum-zero : ∀ {A} → {sum : Sum A} → SumLin sum → SumZero sum
sum-lin⇒sum-zero sum-lin = sum-lin (λ _ → 0) 0

sum-mono⇒sum-ext : ∀ {A} → {sum : Sum A} → SumMono sum → SumExt sum
sum-mono⇒sum-ext sum-mono f≗g = ℕ≤.antisym (sum-mono (ℕ≤.reflexive ∘ f≗g)) (sum-mono (ℕ≤.reflexive ∘ ≡.sym ∘ f≗g))

sum-ext+sum-hom⇒sum-mono : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
sum-ext+sum-hom⇒sum-mono {sum = sum} sum-ext sum-hom {f} {g} f≤°g =
    sum f                         ≤⟨ m≤m+n _ _ ⟩
    sum f + sum (λ x → g x ∸ f x) ≡⟨ ≡.sym (sum-hom _ _) ⟩
    sum (λ x → f x + (g x ∸ f x)) ≡⟨ sum-ext (m+n∸m≡n ∘ f≤°g) ⟩
    sum g ∎ where open ≤-Reasoning

record SumPropoid (As : Setoid L.zero L.zero) : ★₁ where
  constructor _,_
  private
    A = Setoid.Carrier As
  field
    search     : Search A
    search-ind : SearchInd search

  search-sg-ext : SearchSgExt search
  search-sg-ext sg {f} {g} f≈°g = search-ind (λ s → s _ f ≈ s _ g) ∙-cong f≈°g
    where open Sgrp sg

  search-ext : SearchExt search
  search-ext op = search-ind (λ s → s _ _ ≡ s _ _) (≡.cong₂ op)

  search-mono : SearchMono search
  search-mono _⊆_ _∙-mono_ {f} {g} f⊆°g = search-ind (λ s → s _ f ⊆ s _ g) _∙-mono_ f⊆°g

  search-swap : SearchSwap search
  search-swap sg f {sᴮ} pf = search-ind (λ s → s _ (sᴮ ∘ f) ≈ sᴮ (s _ ∘ flip f)) (λ p q → trans (∙-cong p q) (sym (pf _ _))) (λ _ → refl)
    where open Sgrp sg

  searchMon : SearchMon A
  searchMon m = search _∙_
    where open Mon m

  search-ε : Searchε searchMon
  search-ε m = search-ind (λ s → s _ (const ε) ≈ ε) (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε)) (λ _ → refl)
    where open Mon m

  search-hom : SearchMonHom searchMon
  search-hom cm f g = search-ind (λ s → s _ (f ∙° g) ≈ s _ f ∙ s _ g)
                                 (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _)) (λ _ → refl)
    where open CMon cm

  search-hom′ :
      ∀ {S T}
        (_+_ : Op₂ S)
        (_*_ : Op₂ T)
        (f   : S → T)
        (g   : A → S)
        (hom : ∀ x y → f (x + y) ≡ f x * f y)
        → f (search _+_ g) ≡ search _*_ (f ∘ g)
  search-hom′ _+_ _*_ f g hom = search-ind (λ s → f (s _+_ g) ≡ s _*_ (f ∘ g))
                                           (λ p q → ≡.trans (hom _ _) (≡.cong₂ _*_ p q))
                                           (λ _ → ≡.refl)

  StableUnder : (A → A) → ★₁
  StableUnder p = ∀ {B} (op : Op₂ B) f → search op f ≡ search op (f ∘ p)

  sum : Sum A
  sum = search _+_

  sum-ind : SumInd sum
  sum-ind P P+ Pf = search-ind (λ s → P (s _+_)) P+ Pf

  sum-ext : SumExt sum
  sum-ext = search-ext _+_

  sum-zero : SumZero sum
  sum-zero = search-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = search-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = search-mono _≤_ _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.cong₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  SumStableUnder : (A → A) → ★
  SumStableUnder p = ∀ f → (∀ {x y} → Setoid._≈_ As x y → f x ≡.≡ f y) → sum f ≡ sum (f ∘ p)

  sumStableUnder : ∀ {p} → StableUnder p → SumStableUnder p
  sumStableUnder SU-p f _ = SU-p _+_ f

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong Bool.toℕ ∘ f≗g)

  CountStableUnder : (A → A) → ★
  CountStableUnder p = ∀ f → (∀ {x y} → Setoid._≈_ As x y → f x ≡.≡ f y) → count f ≡ count (f ∘ p)

  countStableUnder : ∀ {p} → SumStableUnder p → CountStableUnder p
  countStableUnder sumSU-p f f-pres = sumSU-p (Bool.toℕ ∘ f) (≡.cong Bool.toℕ ∘ f-pres)

  search-extoid : SearchExtoid {As} search
  search-extoid op {f = f}{g} f≈g = search-ind (λ s₁ → s₁ op f ≡ s₁ op g) (≡.cong₂ op) (λ x → f≈g (Setoid.refl As))

open SumPropoid public

search-swap' : ∀ {A B} cm (μA : SumPropoid A) (μB : SumPropoid B) f →
               let open CMon cm
                   sᴬ = search μA _∙_
                   sᴮ = search μB _∙_ in
               sᴬ (sᴮ ∘ f) ≈ sᴮ (sᴬ ∘ flip f)
search-swap' cm μA μB f = search-swap μA sg f (search-hom μB cm)
  where open CMon cm

sum-swap : ∀ {A B} (μA : SumPropoid A) (μB : SumPropoid B) f →
           sum μA (sum μB ∘ f) ≡ sum μB (sum μA ∘ flip f)
sum-swap = search-swap' ℕ°.+-commutativeMonoid

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

_≈Search_ : ∀ {A} → (s₀ s₁ : Search A) → ★₁
s₀ ≈Search s₁ = ∀ {B} (op : Op₂ B) f → s₀ op f ≡ s₁ op f

{-
μ⊤ : SumProp ⊤
μ⊤ = srch , ind
  where
    srch : Search ⊤
    srch _ f = f _

    ind : SearchInd srch
    ind _ _ Pf = Pf _

μBit : SumProp Bit
μBit = searchBit , ind
  where
    searchBit : Search Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    ind : SearchInd searchBit
    ind _ _P∙_ Pf = Pf 0b P∙ Pf 1b

infixr 4 _+Search_

_+Search_ : ∀ {A B} → Search A → Search B → Search (A ⊎ B)
(searchᴬ +Search searchᴮ) _∙_ f = searchᴬ _∙_ (f ∘ inj₁) ∙ searchᴮ _∙_ (f ∘ inj₂)

_+SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
                 SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ +Search sᴮ)
(Psᴬ +SearchInd Psᴮ) P P∙ Pf
  = P∙ (Psᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

_+Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A ⊎ B)
(sumᴬ +Sum sumᴮ) f = sumᴬ (f ∘ inj₁) + sumᴮ (f ∘ inj₂)

_+μ_ : ∀ {A B} → SumProp A → SumProp B → SumProp (A ⊎ B)
μA +μ μB = _ , search-ind μA +SearchInd search-ind μB

infixr 4 _×Search_

-- liftM2 _,_ in the continuation monad
_×Search_ : ∀ {A B} → Search A → Search B → Search (A × B)
(searchᴬ ×Search searchᴮ) op f = searchᴬ op (λ x → searchᴮ op (curry f x))

_×SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
               → SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ ×Search sᴮ)
(Psᴬ ×SearchInd Psᴮ) P P∙ Pf =
  Psᴬ (λ s → P (λ _ _ → s _ _)) P∙ (Psᴮ (λ s → P (λ _ _ → s _ _)) P∙ ∘ curry Pf)

_×SearchExt_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
              SearchExt sᴬ → SearchExt sᴮ → SearchExt (sᴬ ×Search sᴮ)
(sᴬ-ext ×SearchExt sᴮ-ext) sg f≗g = sᴬ-ext sg (sᴮ-ext sg ∘ curry f≗g)

infixr 4 _×Sum_

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

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumProp A → SumProp B → SumProp (A × B)
μA ×μ μB = _ , search-ind μA ×SearchInd search-ind μB

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | ≡.sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = ≡.refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = ≡.refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

μ-view : ∀ {A B} → (A → B) → SumProp A → SumProp B
μ-view {A}{B} A→B μA = searchᴮ , ind
  where
    searchᴮ : Search B
    searchᴮ m f = search μA m (f ∘ A→B)

    ind : SearchInd searchᴮ
    ind P P∙ Pf = search-ind μA (λ s → P (λ _ f → s _ (f ∘ A→B))) P∙ (Pf ∘ A→B)

μ-iso : ∀ {A B} → (A ↔ B) → SumProp A → SumProp B
μ-iso A↔B = μ-view (_⟨$⟩_ (Inverse.to A↔B))

μ-view-preserve : ∀ {A B} (A→B : A → B)(B→A : B → A)(A≈B : id ≗ B→A ∘ A→B) f (μA : SumProp A) → sum μA f ≡ sum (μ-view A→B μA) (f ∘ B→A)
μ-view-preserve A→B B→A A≈B f μA = sum-ext μA (≡.cong f ∘ A≈B)

μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : SumProp A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ _⟨$⟩_ (Inverse.from A↔B))
μ-iso-preserve A↔B f μA = μ-view-preserve (_⟨$⟩_ (Inverse.to A↔B)) (_⟨$⟩_ (Inverse.from A↔B))
                            (≡.sym ∘ Inverse.left-inverse-of A↔B) f μA

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec.NP as Vec using (Vec; tabulate; _++_) renaming (map to vmap; sum to vsum; foldr to vfoldr; foldr₁ to vfoldr₁)

vmsum : ∀ m {n} → let open Mon m in
                  Vec C n → C
vmsum m = vfoldr _ _∙_ ε
  where open Monoid m

vsgsum : ∀ sg {n} → let open Sgrp sg in
                    Vec C (suc n) → C
vsgsum sg = vfoldr₁ _∙_
  where open Sgrp sg

-- let's recall that: tabulate f ≗ vmap f (allFin n)

-- searchMonFin : ∀ n → SearchMon (Fin n)
-- searchMonFin n m f = vmsum m (tabulate f)

searchFinSuc : ∀ n → Search (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr₁ _∙_ (tabulate f)

μMaybe : ∀ {A} → SumProp A → SumProp (Maybe A)
μMaybe μA = μ-iso (FI.sym Maybe↔⊤⊎) (μ⊤ +μ μA)

μMaybe^ : ∀ {A} n → SumProp A → SumProp (Maybe^ n A)
μMaybe^ zero    μA = μA
μMaybe^ (suc n) μA = μMaybe (μMaybe^ n μA)

μFinSuc : ∀ n → SumProp (Fin (suc n))
μFinSuc n = searchFinSuc n , ind n
  where ind : ∀ n → SearchInd (searchFinSuc n)
        ind zero    P P∙ Pf = Pf zero
        ind (suc n) P P∙ Pf = P∙ (Pf zero) (ind n (λ s → P (λ op f → s op (f ∘ suc))) P∙ (Pf ∘ suc))

μFinSucIso : ∀ n → SumProp (Fin (suc n))
μFinSucIso n = μ-iso (Maybe^⊤↔Fin1+ n) (μMaybe^ n μ⊤)

μ^ : ∀ {A} (μA : SumProp A) n → SumProp (A ^ n)
μ^ μA zero    = μ⊤
μ^ μA (suc n) = μA ×μ μ^ μA n

μVec : ∀ {A} (μA : SumProp A) n  → SumProp (Vec A n)
μVec μA n = μ-iso (^↔Vec n) (μ^ μA n)

searchVec : ∀ {A} n → Search A → Search (Vec A n)
searchVec zero    searchᴬ op f = f []
searchVec (suc n) searchᴬ op f = searchᴬ op (λ x → searchVec n searchᴬ op (f ∘ _∷_ x))

searchVec-spec : ∀ {A} (μA : SumProp A) n → searchVec n (search μA) ≈Search search (μVec μA n)
searchVec-spec μA zero    op f = ≡.refl
searchVec-spec μA (suc n) op f = search-ext μA op (λ x → searchVec-spec μA n op (f ∘ _∷_ x))

searchVec-++ : ∀ {A} n {m} (μA : SumProp A) sg
               → let open Sgrp sg in
                 (f : Vec A (n + m) → C)
               → search (μVec μA (n + m)) _∙_ f
               ≈ search (μVec μA n) _∙_ (λ xs →
                   search (μVec μA m) _∙_ (λ ys →
                     f (xs ++ ys)))
searchVec-++ zero    μA sg f = Sgrp.refl sg
searchVec-++ (suc n) μA sg f = search-sg-ext μA sg (λ x →
                                 searchVec-++ n μA sg (f ∘ _∷_ x))

sumVec-swap : ∀ {A} n {m} (μA : SumProp A)(f : Vec A (n + m) → ℕ)
            → sum (μVec μA n) (λ xs → sum (μVec μA m) (λ ys → f (xs ++ ys)))
            ≡ sum (μVec μA m) (λ ys → sum (μVec μA n) (λ xs → f (xs ++ ys)))
sumVec-swap n {m} μA f = sum-swap (μVec μA n) (μVec μA m) (λ xs ys → f (xs ++ ys))

swapS : ∀ {A B} → SumProp (A × B) → SumProp (B × A)
swapS = μ-iso swap-iso

swapS-preserve : ∀ {A B} f (μA×B : SumProp (A × B)) → sum μA×B f ≡ sum (swapS μA×B) (f ∘ swap)
swapS-preserve = μ-iso-preserve swap-iso

module _ {A : Set}(μA : SumProp A) where

  sA = search μA

  extend : ∀ {n} → A → (Fin n → A) → Fin (suc n) → A
  extend x g zero    = x
  extend x g (suc i) = g i

  abs : Fin 0 → A
  abs ()

  -- There is one function Fin 0 → A (called abs) so this should be fine
  -- if not there is a version below that forces the domain to be non-empty
  sFun : ∀ n → Search (Fin n → A)
  sFun zero    op f = f abs
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

  Ind : ∀ n → SearchInd (sFun n)
  Ind zero    P P∙ Pf = Pf abs
  Ind (suc n) P P∙ Pf =
    search-ind μA (λ sa → P (λ op f → sa op (λ x → sFun n op (f ∘ extend x))))
      P∙
      (λ x → Ind n (λ sf → P (λ op f → sf op (f ∘ extend x)))
        P∙ (Pf ∘ extend x))

  μFun : ∀ {n} → SumProp (Fin n → A)
  μFun = sFun _ , Ind _

{-
  -- If we want to force non-empty domain

  sFun : ∀ n → Search (Fin (suc n) → A)
  sFun zero    op f = sA op (f ∘ const)
  sFun (suc n) op f = sA op (λ x → sFun n op (f ∘ extend x))

  Ind : ∀ n → SearchInd (sFun n)
  Ind zero    P P∙ Pf = search-ind μA (λ sa → P (λ op f → sa op (f ∘ const))) P∙ (Pf ∘ const)
  Ind (suc n) P P∙ Pf = search-ind μA (λ sa → P (λ op f → sa op (λ x → sFun n op (f ∘ extend x))))
      P∙
      (λ x → Ind n (λ sf → P (λ op f → sf op (f ∘ extend x))) P∙ (Pf ∘ extend x))

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


Fixed doc.

Fixed doc.

Ignore-this: 1176ac103b139489f79a9d236b7f707d

darcs-hash:20100719141536-3bd4e-7a766f5ad4169bb90a7d945092ee748da7180ba2.gz

------------------------------------------------------------------------------
-- Testing the use of general hints
------------------------------------------------------------------------------

module Test.Succeed.OnlyAxioms.GeneralHints where

postulate
  D    : Set
  zero : D
  succ : D → D

data N : D → Set where
  zN : N zero
  sN : (n : D) → N n → N (succ n)
-- The data constructors are general hints. They are translate as axioms.
{-# ATP hint zN #-}
{-# ATP hint sN #-}


less asinine names #14

less asinine names #14

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity
open import lemmas-progress-checks

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that boxed values, indeterminates, cast
-- errors, and expressions that step are pairwise disjoint. (note that as a
-- consequence of currying and comutativity of products, this means that
-- there are six theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  boxedval-not-indet : ∀{d} → d boxedval → d indet → ⊥
  boxedval-not-indet (BVVal VConst) ()
  boxedval-not-indet (BVVal VLam) ()
  boxedval-not-indet (BVArrCast x bv) (ICastArr x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastGroundHole x₁ ind) = boxedval-not-indet bv ind
  boxedval-not-indet (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = boxedval-not-indet bv ind

  -- boxed values and errors are disjoint
  boxedval-not-err : ∀{d} → d boxedval → d casterr → ⊥
  boxedval-not-err (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  boxedval-not-err (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  boxedval-not-err (BVArrCast x bv) (CECong FHOuter er) = boxedval-not-err bv (ce-castarr er)
  boxedval-not-err (BVArrCast x bv) (CECong (FHCast x₁) er) = boxedval-not-err bv (CECong x₁ er)
  boxedval-not-err (BVHoleCast x bv) (CECong FHOuter er) = boxedval-not-err bv (ce-castth er)
  boxedval-not-err (BVHoleCast x bv) (CECong (FHCast x₁) er) = boxedval-not-err bv (CECong x₁ er)
  boxedval-not-err (BVVal x) (CECong FHOuter er) = boxedval-not-err (BVVal x) er
  boxedval-not-err (BVVal ()) (CECong (FHAp1 x₁) er)
  boxedval-not-err (BVVal ()) (CECong (FHAp2 x₁ x₂) er)
  boxedval-not-err (BVVal ()) (CECong (FHNEHole x₁) er)
  boxedval-not-err (BVVal ()) (CECong (FHCast x₁) er)

  -- boxed values and expressions that step are disjoint
  boxedval-not-step : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  boxedval-not-step (BVVal VConst) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVVal VLam) (d' , Step FHOuter () x₃)
  boxedval-not-step (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  boxedval-not-step (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)
  boxedval-not-step (BVHoleCast () bv) (d' , Step FHOuter (ITCastID x₁) FHOuter)
  boxedval-not-step (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
  boxedval-not-step (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround x₁ x₂) FHOuter) = x₂ refl
  boxedval-not-step (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = boxedval-not-step bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- indeterminates and errors are disjoint
    indet-not-err : ∀{d} → d indet → d casterr → ⊥
    indet-not-err IEHole (CECong FHOuter err) = indet-not-err IEHole err
    indet-not-err (INEHole x) (CECong FHOuter err) = final-not-err x (ce-nehole err)
    indet-not-err (INEHole x) (CECong (FHNEHole x₁) err) = final-not-err x (CECong x₁ err)
    indet-not-err (IAp x indet x₁) (CECong FHOuter err)
      with ce-ap err
    ... | Inl d1err = indet-not-err indet d1err
    ... | Inr d2err = final-not-err x₁ d2err
    indet-not-err (IAp x indet x₁) (CECong (FHAp1 x₂) err) = indet-not-err indet (CECong x₂ err)
    indet-not-err (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = final-not-err x₁ (CECong x₃ err)
    indet-not-err (ICastArr x indet) (CECong FHOuter err) = indet-not-err indet (ce-castarr err)
    indet-not-err (ICastArr x indet) (CECong (FHCast x₁) err) = indet-not-err indet (CECong x₁ err)
    indet-not-err (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    indet-not-err (ICastGroundHole x indet) (CECong FHOuter err) = indet-not-err indet (ce-castth err)
    indet-not-err (ICastGroundHole x indet) (CECong (FHCast x₁) err) = indet-not-err indet (CECong x₁ err)
    indet-not-err (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    indet-not-err (ICastHoleGround x indet x₁) (CECong FHOuter err) = indet-not-err indet (ce-castht err x)
    indet-not-err (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = indet-not-err indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    final-not-err : ∀{d} → d final → d casterr → ⊥
    final-not-err (FBoxed x) err = boxedval-not-err x err
    final-not-err (FIndet x) err = indet-not-err x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = boxedval-not-indet x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole () ind) (ITCastID x₁)
  lem2 (ICastGroundHole x ind) (ITCastSucceed x₁ ())
  lem2 (ICastGroundHole GHole ind) (ITGround x₁ x₂) = x₂ refl
  lem2 (ICastHoleGround x ind ()) (ITCastID x₂)
  lem2 (ICastHoleGround x ind x₁) (ITCastSucceed x₂ x₃) = x _ _ refl
  lem2 (ICastHoleGround x ind GHole) (ITExpand x₂ x₃) = x₃ refl

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁ y ) = y refl

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    indet-not-step : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    indet-not-step IEHole (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (d' , Step FHOuter () FHOuter)
    indet-not-step (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    indet-not-step (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    indet-not-step (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    indet-not-step (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = indet-not-step ind (_ , Step x₂ x₃ x₄)
    indet-not-step (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = final-not-step f (_ , Step x₃ x₄ x₆)
    indet-not-step (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    indet-not-step (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    indet-not-step (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    indet-not-step (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround _ y) FHOuter) = y refl
    indet-not-step (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)
    indet-not-step (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    indet-not-step (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    indet-not-step (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    indet-not-step (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = indet-not-step ind (_ , Step x₁ x₂ x₃)

    final-not-step : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    final-not-step (FBoxed x) stp = boxedval-not-step x stp
    final-not-step (FIndet x) stp = indet-not-step x stp

  -- errors and expressions that step are disjoint
  err-not-step : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    -- cast fail caserr-not-step
  err-not-step (CECastFail x x₁ () x₃) (_ , Step FHOuter (ITCastID x₄) FHOuter)
  err-not-step (CECastFail x x₁ x₂ x₃) (_ , Step FHOuter (ITCastSucceed x₄ x₅) FHOuter) = x₃ refl
  err-not-step (CECastFail x x₁ GHole x₃) (_ , Step FHOuter (ITExpand x₄ x₅) FHOuter) = x₅ refl
  err-not-step (CECastFail x x₁ x₂ x₃) (_ , Step (FHCast x₄) x₅ (FHCast x₆)) = {!!}

    -- congruence caserr-not-step
  err-not-step (CECong FHOuter ce) (π1 , Step FHOuter x₂ FHOuter) = err-not-step ce (π1 , Step FHOuter x₂ FHOuter)
  err-not-step (CECong (FHAp1 FHOuter) (CECong FHOuter ce)) (_ , Step FHOuter (ITLam x₂) FHOuter) = boxedval-not-err (BVVal VLam) ce
  err-not-step (CECong (FHAp1 x) ce) (_ , Step FHOuter (ITApCast x₁ x₂) FHOuter) = {!!}  -- fe x₁ (CECong {!ce-out-cast ce!} ce)
  err-not-step (CECong (FHAp2 x x₁) ce) (π1 , Step FHOuter x₂ FHOuter) = {!ce-out-cast ce x₁!}
  err-not-step (CECong (FHNEHole x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!}
  err-not-step (CECong (FHCast x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!}

  err-not-step (CECong FHOuter ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃))
    with ce-ap ce
  ... | Inl d1err = err-not-step d1err (_ , Step x₁ x₂ x₃)
  ... | Inr d2err = {!Step x₁ x₂ x₃!} -- this is a counter example: d2 is a casterror but d1 isn't yet a value so the whole thing steps
  err-not-step (CECong (FHAp1 x) ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = final-not-step x (_ , Step x₂ x₃ x₄)

  err-not-step (CECong FHOuter ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅))
    with ce-ap ce
  ... | Inl d1err = final-not-err x₄ d1err
  ... | Inr d2err = err-not-step d2err (_ , Step x₂ x₃ x₅)
  err-not-step (CECong (FHAp1 x) ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  err-not-step (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = {!!}

  err-not-step (CECong FHOuter ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = err-not-step (ce-nehole ce) (_ , Step x₁ x₂ x₃)
  err-not-step (CECong (FHNEHole x) ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)

  err-not-step (CECong FHOuter ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!} -- err-not-step {!!} (_ , Step x₁ x₂ x₃) -- this might not work
  err-not-step (CECong (FHCast x) ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = err-not-step (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import type-assignment-unicity
open import lemmas-progress-checks

-- taken together, the theorems in this file argue that for any expression
-- d, at most one summand of the labeled sum that results from progress may
-- be true at any time, i.e. that boxed values, indeterminates, cast
-- errors, and expressions that step are pairwise disjoint. (note that as a
-- consequence of currying and comutativity of products, this means that
-- there are six theorems to prove)
module progress-checks where
  -- boxed values and indeterminates are disjoint
  vi : ∀{d} → d boxedval → d indet → ⊥
  vi (BVVal VConst) ()
  vi (BVVal VLam) ()
  vi (BVArrCast x bv) (ICastArr x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastGroundHole x₁ ind) = vi bv ind
  vi (BVHoleCast x bv) (ICastHoleGround x₁ ind x₂) = vi bv ind

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter er) = ve bv (ce-castarr er)
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong FHOuter er) = ve bv (ce-castth er)
  ve (BVHoleCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVVal x) (CECong FHOuter er) = ve (BVVal x) er
  ve (BVVal ()) (CECong (FHAp1 x₁) er)
  ve (BVVal ()) (CECong (FHAp2 x₁ x₂) er)
  ve (BVVal ()) (CECong (FHNEHole x₁) er)
  ve (BVVal ()) (CECong (FHCast x₁) er)

  -- boxed values and expressions that step are disjoint
  vs : ∀{d} → d boxedval → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  vs (BVVal VConst) (d' , Step FHOuter () x₃)
  vs (BVVal VLam) (d' , Step FHOuter () x₃)
  vs (BVArrCast x bv) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
  vs (BVArrCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)
  vs (BVHoleCast () bv) (d' , Step FHOuter (ITCastID x₁) FHOuter)
  vs (BVHoleCast x bv) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
  vs (BVHoleCast GHole bv) (_ , Step FHOuter (ITGround x₁ x₂) FHOuter) = x₂ refl
  vs (BVHoleCast x bv) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = vs bv (_ , Step x₁ x₂ x₃)

  -- todo: what class of P is this true for?
  -- lem-something : ∀{ d ε d'} → d == ε ⟦ d' ⟧ → P d' → P d

  mutual
    -- todo: there's something going on with these lemmas here that's
    -- repetative and i don't quite understand how to make it more compact

    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err
    ie (INEHole x) (CECong FHOuter err) = fe x (ce-nehole err)
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err)
      with ce-ap err
    ... | Inl d1err = ie indet d1err
    ... | Inr d2err = fe x₁ d2err
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = ie indet (ce-castarr err)
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = ie indet (ce-castth err)
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = ie indet (ce-castht err x)
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

    -- final expressions are not errors (not one of the 6 cases for progress, just a convenience)
    fe : ∀{d} → d final → d casterr → ⊥
    fe (FBoxed x) err = ve x err
    fe (FIndet x) err = ie x err

  -- todo: these are bad names; probably some places below where i inlined
  -- some of these lemmas before i'd come up with them
  lem2 : ∀{d d'} → d indet → d →> d' → ⊥
  lem2 IEHole ()
  lem2 (INEHole x) ()
  lem2 (IAp x₁ () x₂) (ITLam x₃)
  lem2 (IAp x (ICastArr x₁ ind) x₂) (ITApCast x₃ x₄) = x _ _ _ _ _ refl
  lem2 (ICastArr x ind) (ITCastID (FBoxed x₁)) = vi x₁ ind
  lem2 (ICastArr x ind) (ITCastID (FIndet x₁)) = x refl
  lem2 (ICastGroundHole () ind) (ITCastID x₁)
  lem2 (ICastGroundHole x ind) (ITCastSucceed x₁ ())
  lem2 (ICastGroundHole GHole ind) (ITGround x₁ x₂) = x₂ refl
  lem2 (ICastHoleGround x ind ()) (ITCastID x₂)
  lem2 (ICastHoleGround x ind x₁) (ITCastSucceed x₂ x₃) = x _ _ refl
  lem2 (ICastHoleGround x ind GHole) (ITExpand x₂ x₃) = x₃ refl

  lem3 : ∀{d d'} → d boxedval → d →> d' → ⊥
  lem3 (BVVal VConst) ()
  lem3 (BVVal VLam) ()
  lem3 (BVArrCast x bv) (ITCastID x₁) = x refl
  lem3 (BVHoleCast () bv) (ITCastID x₁)
  lem3 (BVHoleCast () bv) (ITCastSucceed x₁ x₂)
  lem3 (BVHoleCast GHole bv) (ITGround x₁ y ) = y refl

  lem1 : ∀{d d'} → d final → d →> d' → ⊥
  lem1 (FBoxed x) = lem3 x
  lem1 (FIndet x) = lem2 x

  lem4 : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  lem4 x FHOuter = x
  lem4 (FBoxed (BVVal ())) (FHAp1 eps)
  lem4 (FBoxed (BVVal ())) (FHAp2 x₂ eps)
  lem4 (FBoxed (BVVal ())) (FHNEHole eps)
  lem4 (FBoxed (BVVal ())) (FHCast eps)
  lem4 (FBoxed (BVArrCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FBoxed (BVHoleCast x₁ x₂)) (FHCast eps) = lem4 (FBoxed x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (IAp x₁ x₂ x₃)) (FHAp2 x₄ eps) = lem4 x₃ eps
  lem4 (FIndet (INEHole x₁)) (FHNEHole eps) = lem4 x₁ eps
  lem4 (FIndet (ICastArr x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = lem4 (FIndet x₂) eps
  lem4 (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = lem4 (FIndet x₂) eps

  lem5 : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  lem5 f sub step = lem1 (lem4 f sub) step

  -- indeterminates and expressions that step are disjoint
  mutual
    is : ∀{d} → d indet → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    is IEHole (d' , Step FHOuter () FHOuter)
    is (INEHole x) (d' , Step FHOuter () FHOuter)
    is (INEHole x) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = lem5 x x₁ x₂
    is (IAp x₁ () x₂) (_ , Step FHOuter (ITLam x₃) FHOuter)
    is (IAp x (ICastArr x₁ ind) x₂) (_ , Step FHOuter (ITApCast x₃ x₄) FHOuter) = x _ _ _ _ _  refl
    is (IAp x ind _) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = is ind (_ , Step x₂ x₃ x₄)
    is (IAp x ind f) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = fs f (_ , Step x₃ x₄ x₆)
    is (ICastArr x ind) (d0' , Step FHOuter (ITCastID x₁) FHOuter) = x refl
    is (ICastArr x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastGroundHole () ind) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastGroundHole x ind) (d' , Step FHOuter (ITCastSucceed x₁ ()) FHOuter)
    is (ICastGroundHole GHole ind) (_ , Step FHOuter (ITGround _ y) FHOuter) = y refl
    is (ICastGroundHole x ind) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)
    is (ICastHoleGround x ind ()) (d' , Step FHOuter (ITCastID x₁) FHOuter)
    is (ICastHoleGround x ind g) (d' , Step FHOuter (ITCastSucceed x₁ x₂) FHOuter) = x _ _ refl
    is (ICastHoleGround x ind GHole) (_ , Step FHOuter (ITExpand x₁ x₂) FHOuter) = x₂ refl
    is (ICastHoleGround x ind g) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = is ind (_ , Step x₁ x₂ x₃)

    fs : ∀{d} → d final → Σ[ d' ∈ dhexp ] (d ↦ d') → ⊥
    fs (FBoxed x) stp = vs x stp
    fs (FIndet x) stp = is x stp

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
    -- cast fail cases
  es (CECastFail x x₁ () x₃) (_ , Step FHOuter (ITCastID x₄) FHOuter)
  es (CECastFail x x₁ x₂ x₃) (_ , Step FHOuter (ITCastSucceed x₄ x₅) FHOuter) = x₃ refl
  es (CECastFail x x₁ GHole x₃) (_ , Step FHOuter (ITExpand x₄ x₅) FHOuter) = x₅ refl
  es (CECastFail x x₁ x₂ x₃) (_ , Step (FHCast x₄) x₅ (FHCast x₆)) = {!!}

    -- congruence cases
  es (CECong FHOuter ce) (π1 , Step FHOuter x₂ FHOuter) = es ce (π1 , Step FHOuter x₂ FHOuter)
  es (CECong (FHAp1 FHOuter) (CECong FHOuter ce)) (_ , Step FHOuter (ITLam x₂) FHOuter) = ve (BVVal VLam) ce
  es (CECong (FHAp1 x) ce) (_ , Step FHOuter (ITApCast x₁ x₂) FHOuter) = {!!}  -- fe x₁ (CECong {!ce-out-cast ce!} ce)
  es (CECong (FHAp2 x x₁) ce) (π1 , Step FHOuter x₂ FHOuter) = {!ce-out-cast ce x₁!}
  es (CECong (FHNEHole x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!}
  es (CECong (FHCast x) ce) (π1 , Step FHOuter x₂ FHOuter) = {!!}

  es (CECong FHOuter ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃))
    with ce-ap ce
  ... | Inl d1err = es d1err (_ , Step x₁ x₂ x₃)
  ... | Inr d2err = {!Step x₁ x₂ x₃!} -- this is a counter example: d2 is a casterror but d1 isn't yet a value so the whole thing steps
  es (CECong (FHAp1 x) ce) (_ , Step (FHAp1 x₁) x₂ (FHAp1 x₃)) = es (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)
  es (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp1 x₂) x₃ (FHAp1 x₄)) = fs x (_ , Step x₂ x₃ x₄)

  es (CECong FHOuter ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅))
    with ce-ap ce
  ... | Inl d1err = fe x₄ d1err
  ... | Inr d2err = es d2err (_ , Step x₂ x₃ x₅)
  es (CECong (FHAp1 x) ce) (_ , Step (FHAp2 x₁ x₂) x₃ (FHAp2 x₄ x₅)) = {!!}
  es (CECong (FHAp2 x x₁) ce) (_ , Step (FHAp2 x₂ x₃) x₄ (FHAp2 x₅ x₆)) = {!!}

  es (CECong FHOuter ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = es (ce-nehole ce) (_ , Step x₁ x₂ x₃)
  es (CECong (FHNEHole x) ce) (_ , Step (FHNEHole x₁) x₂ (FHNEHole x₃)) = es (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)

  es (CECong FHOuter ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = {!!} -- es {!!} (_ , Step x₁ x₂ x₃) -- this might not work
  es (CECong (FHCast x) ce) (_ , Step (FHCast x₁) x₂ (FHCast x₃)) = es (ce-out-cast ce x) (_ , Step x₁ x₂ x₃)


More one-time-pad related lemmas: ⟪ m ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⁇

module single-bit-one-time-pad where

open import Function
open import Data.Bool.NP
open import Data.Product renaming (map to <_×_>)
open import Data.Nat.NP
import Data.Vec.NP as V
open V using (Vec; take; drop; drop′; take′; _++_)
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; module ≡-Reasoning)

open import Data.Bits
open import flipbased-implem
open import program-distance

K = Bit
M = Bit
C = Bit

record Adv (S₀ S₁ S₂ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    step₁ : S₀ → (Bit → M) × S₁
    step₂ : C × S₁ → S₂
    step₃ : S₂ → Bit

record Adv₁ (S₀ S₁ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    -- step₁ s₀ = id , s₀
    step₂ : C × S₀ → S₁
    step₃ : S₁ → Bit

Adv₂ : ∀ ca → Set
Adv₂ ca = ↺ ca (C → Bit)

module Run⅁′ {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open Adv A
  E : M → ↺ 1 C
  E m = toss >>= λ k → return↺ (m xor k)
  run⅁′ : ⅁? (ca + 1)
  run⅁′ b = step₀ >>= λ s₀ →
            case step₁ s₀ of λ {(m , s₁) →
            E (m b) >>= λ c →
            return↺ (step₃ (step₂ (c , s₁)))}

module Run⅁ {S₀ S₁ S₂ ca} (E : K → M → C) (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
  open Adv A

  kont₀ : ⅁? _
  kont₀ k =
    step₀ ▹↺ λ s₀ →
    case step₁ s₀ of λ {(m , s₁) →
    let c = E k (m b) in
    step₃ (step₂ (c , s₁))}

  run⅁ : EXP (1 + ca)
  run⅁ = toss >>= kont₀

  {- looks wrong
module Run⅁-Properties {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b k : Bit) where
  open Run⅁ A
  kont₀-not : kont₀ b k ≡ kont₀ (not b) (not k)
  kont₀-not rewrite xor-not-not b k = {!refl!}
  -}

module SymAdv (homPrgDist : HomPrgDist) {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  step₁′ : S₀ → (Bit → M) × S₁
  step₁′ s₀ = case step₁ s₀ of λ { (m , s₁) → (m ∘ not , s₁) }
  symA : Adv S₀ S₁ S₂ ca
  symA = mk step₀ step₁′ step₂ (not ∘ step₃)

  symA′ : Adv S₀ S₁ S₂ ca
  symA′ = mk step₀ step₁′ step₂ step₃

  open Run⅁ _xor_ A renaming (run⅁ to runA)
  open Run⅁ _xor_ symA renaming (run⅁ to runSymA)
  open Run⅁ _xor_ symA′ renaming (run⅁ to runSymA′)
  {-
  helper : ∀ {n} (g₀ g₁ : EXP n) → g₀ ]-[ g₁ → not↺ g₀ ]-[ not↺ g₁
  helper = {!!}
  lem : runA ⇓ runSymA
  lem A-breaks-E = {!helper (uunSymA′ 0b) (runSymA′ 1)!}
     where pf : breaks runSymA
           pf = {!!}
  -}

module Run⅁₂ {ca} (A : Adv₂ ca) (b : Bit) where
  E : Bit → M → C
  E k m = m xor k

  m : Bit → Bit
  m = id

  kont₀ : ⅁? _
  kont₀ k =
      A ▹↺ λ f →
      f (E k (m b))

      {-
    kont₀′ : ⅁? _
    kont₀′ k =
      conv-Adv A ▹↺ λ f →
      f (E k (m b))
      -}

  run⅁₂ : EXP (1 + ca)
  run⅁₂ = toss >>= kont₀

module Run⅁₂-Properties {ca} (A : Adv₂ ca) where
    open Run⅁₂ A renaming (run⅁₂ to runA)
    kont₀-not : ∀ b k → kont₀ b k ≡ kont₀ (not b) (not k)
    kont₀-not b k rewrite xor-not-not b k = ≡.refl

    open ≡-Reasoning

    lem₂ : ∀ b → count↺ (runA b) ≡ count↺ (runA (not b))
    lem₂ b = count↺ (runA b)
          ≡⟨ ≡.refl ⟩
            count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
          ≡⟨ ≡.cong₂ (_+_ on count↺) (kont₀-not b 0b) (kont₀-not b 1b) ⟩
            count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
          ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
            count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
          ≡⟨ ≡.refl ⟩
            count↺ (runA (not b)) ∎

    lem₃ : Safe⅁? runA
    lem₃ = lem₂ 0b

    -- A specialized version of lem₂ (≈lem₃)
    lem₄ : Safe⅁? (Run⅁₂.run⅁₂ A)
    lem₄    = count↺ (runA 0b)
            ≡⟨ ≡.refl ⟩
              count↺ (kont₀ 0b 0b) + count↺ (kont₀ 0b 1b)
            ≡⟨ ≡.cong₂ (_+_ on count↺) (kont₀-not 0b 0b) (kont₀-not 0b 1b) ⟩
              count↺ (kont₀ 1b 1b) + count↺ (kont₀ 1b 0b)
            ≡⟨ ℕ°.+-comm (count↺ (kont₀ 1b 1b)) _ ⟩
              count↺ (kont₀ 1b 0b) + count↺ (kont₀ 1b 1b)
            ≡⟨ ≡.refl ⟩
              count↺ (runA 1b) ∎

conv-Adv : ∀ {ca S₀ S₁ S₂} → Adv S₀ S₁ S₂ ca → Adv₂ ca
conv-Adv A = step₀ ▹↺ λ s₀ →
             case step₁ s₀ of λ {(m , s₁) →
             λ c → m (step₃ (step₂ (c , s₁)))}
  where open Adv A

module Conv-Adv-Props (homPrgDist : HomPrgDist) {ca S₀ S₁ S₂} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  open Run⅁ _xor_ A renaming (run⅁ to runA)
  -- open Run⅁-Properties A

  A′ : Adv₂ ca
  A′ = conv-Adv A
  open Run⅁₂ A′ using () renaming (kont₀ to kont₀′; run⅁₂ to runA′)

  kont₀′′ : ∀ b k → EXP ca
  kont₀′′ b k =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ ((m b) xor k , s₁)))}

  kont₀′′′ : ∀ b′ → EXP ca
  kont₀′′′ b′ =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ (b′ , s₁)))}

  {-
  kont′′-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′′ b k)
  kont′′-lem true true = {!!}
  kont′′-lem false true = {!!}
  kont′′-lem true false = {!!}
  kont′′-lem false false = {!!}

  kont-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′ b k)
  kont-lem b true = {!!}
  kont-lem b false = {!!}

  conv-Adv-lem : runA ≈⅁? runA′
  conv-Adv-lem b = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ _+_ (kont-lem b 0b) (kont-lem b 1b) ⟩
          count↺ (kont₀′ b 0b) + count↺ (kont₀′ b 1b)
        ≡⟨ refl ⟩
          count↺ (runA′ b) ∎

  conv-Adv-sound : runA ⇓ runA′
  conv-Adv-sound = ]-[-cong-≈↺ (conv-Adv-lem 0b) (conv-Adv-lem 1b)
  -}
-- Cute fact: this is true by computation!
count↺-toss->>= : ∀ {c} (f : ⅁? c) → count↺ (toss >>= f) ≡ count↺ (f 0b) + count↺ (f 1b)
count↺-toss->>= f = ≡.refl

{-
module Run⅁-Properties' {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
    open Run⅁ _xor_ A renaming (run⅁ to runA)
    lem : count↺ (runA b) ≡ count↺ (runA (not b))
    lem = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ (_+_ on count↺) {x = kont₀ b 0b} {kont₀ (not b) 1b} {kont₀ b 1b} {kont₀ (not b) 0b} {!!} {!!} ⟩
          count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
        ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
          count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
        ≡⟨ refl ⟩
          count↺ (runA (not b)) ∎
-}
open import program-distance
open import Relation.Nullary

⁇ : ∀ {n} → ↺ n (Bits n)
⁇ = random

lem'' : ∀ {k} (f : Bits k → Bit) → #⟨ f ∘ tail ⟩ ≡ 2* #⟨ f ⟩
lem'' f = ≡.refl

lem' : ∀ {k} (f g : Bits k → Bit) → #⟨ f ∘ tail ⟩ ≡ #⟨ g ∘ tail ⟩ → #⟨ f ⟩ ≡ #⟨ g ⟩
lem' f g pf = 2*-inj (≡.trans (lem'' f) (≡.trans pf (≡.sym (lem'' g))))

drop-tail : ∀ k {n a} {A : Set a} → drop (suc k) {n} ≗ drop k ∘ tail {A = A}
drop-tail k (x ∷ xs) = V.drop-∷ k x xs

lemdrop′ : ∀ {k n} (f : Bits n → Bit) → #⟨ f ∘ drop′ k ⟩ ≡ ⟨2^ k * #⟨ f ⟩ ⟩
lemdrop′ {zero} f = ≡.refl
lemdrop′ {suc k} f = #⟨ f ∘ drop′ k ∘ tail ⟩
                   ≡⟨ lem'' (f ∘ drop′ k) ⟩
                     2* #⟨ f ∘ drop′ k ⟩
                   ≡⟨ ≡.cong 2*_ (lemdrop′ {k} f) ⟩
                     2* ⟨2^ k * #⟨ f ⟩ ⟩ ∎
                    where open ≡-Reasoning

vswap : ∀ m {n} {a} {A : Set a} → Vec A (m + n) → Vec A (n + m)
vswap m xs = drop′ m xs ++ take′ m xs

≈ᴬ′-toss : ∀ b → ⟪ b ⟫ᴰ ⟨xor⟩ toss ≈ᴬ′ toss
≈ᴬ′-toss true Adv = ℕ°.+-comm (count↺ (Adv true)) _
≈ᴬ′-toss false Adv = ≡.refl

≈ᴬ-toss : ∀ b → ⟪ b ⟫ᴰ ⟨xor⟩ toss ≈ᴬ toss
≈ᴬ-toss b Adv = ≈ᴬ′-toss b (returnᴰ ∘ Adv)

-- should be equivalent to #-comm if ⟪ m ⟫ᴰ ⟨⊕⟩ x were convertible to ⟪ _⊕_ m · x ⟫
≈ᴬ-⁇ : ∀ {k} (m : Bits k) → ⟪ m ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⁇
≈ᴬ-⁇ {zero}  _       _ = ≡.refl
≈ᴬ-⁇ {suc k} (h ∷ m) Adv
  rewrite ≈ᴬ-⁇ m (Adv ∘ _∷_ (h xor 0b))
        | ≈ᴬ-⁇ m (Adv ∘ _∷_ (h xor 1b))
        = ≈ᴬ′-toss h (λ x → ⟪ Adv ∘ _∷_ x · ⁇ ⟫)

≈ᴬ-⁇₂ : ∀ {k} (m₀ m₁ : Bits k) → ⟪ m₀ ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ m₁ ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₂ {k} m₀ m₁ = ≈ᴬ.trans {k} (≈ᴬ-⁇ m₀) (≈ᴬ.sym {k} (≈ᴬ-⁇ m₁))

≈ᴬ-⁇₃ : ∀ {k} (m : Bit → Bits k) (b : Bit) → ⟪ m b ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ m (not b) ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₃ m b = ≈ᴬ-⁇₂ (m b) (m (not b))

≈ᴬ-⁇₄ : ∀ {k} (m : Bits k × Bits k) (b : Bit) → ⟪ proj m b ⟫ᴰ ⟨⊕⟩ ⁇ ≈ᴬ ⟪ proj m (not b) ⟫ᴰ ⟨⊕⟩ ⁇
≈ᴬ-⁇₄ = ≈ᴬ-⁇₃ ∘ proj

module single-bit-one-time-pad where

open import Function
open import Data.Bool.NP
open import Data.Product
open import Data.Nat.NP
open import Relation.Binary.PropositionalEquality.NP

open import Data.Bits
open import flipbased-implem
open import program-distance

K = Bit
M = Bit
C = Bit

record Adv (S₀ S₁ S₂ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    step₁ : S₀ → (Bit → M) × S₁
    step₂ : C × S₁ → S₂
    step₃ : S₂ → Bit

record Adv₁ (S₀ S₁ : Set) ca : Set where
  constructor mk
  field
    step₀ : ↺ ca S₀
    -- step₁ s₀ = id , s₀
    step₂ : C × S₀ → S₁
    step₃ : S₁ → Bit

Adv₂ : ∀ ca → Set
Adv₂ ca = ↺ ca (C → Bit)

module Run⅁′ {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open Adv A
  E : M → ↺ 1 C
  E m = toss >>= λ k → return↺ (m xor k)
  run⅁′ : ⅁? (ca + 1)
  run⅁′ b = step₀ >>= λ s₀ →
            case step₁ s₀ of λ {(m , s₁) →
            E (m b) >>= λ c →
            return↺ (step₃ (step₂ (c , s₁)))}

module Run⅁ {S₀ S₁ S₂ ca} (E : K → M → C) (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
  open Adv A

  kont₀ : ⅁? _
  kont₀ k =
    step₀ ▹↺ λ s₀ →
    case step₁ s₀ of λ {(m , s₁) →
    let c = E k (m b) in
    step₃ (step₂ (c , s₁))}

  run⅁ : EXP (1 + ca)
  run⅁ = toss >>= kont₀

  {- looks wrong
module Run⅁-Properties {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b k : Bit) where
  open Run⅁ A
  kont₀-not : kont₀ b k ≡ kont₀ (not b) (not k)
  kont₀-not rewrite xor-not-not b k = {!refl!}
  -}

module SymAdv (homPrgDist : HomPrgDist) {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  step₁′ : S₀ → (Bit → M) × S₁
  step₁′ s₀ = case step₁ s₀ of λ { (m , s₁) → (m ∘ not , s₁) }
  symA : Adv S₀ S₁ S₂ ca
  symA = mk step₀ step₁′ step₂ (not ∘ step₃)

  symA′ : Adv S₀ S₁ S₂ ca
  symA′ = mk step₀ step₁′ step₂ step₃

  open Run⅁ _xor_ A renaming (run⅁ to runA)
  open Run⅁ _xor_ symA renaming (run⅁ to runSymA)
  open Run⅁ _xor_ symA′ renaming (run⅁ to runSymA′)
  not↺ : ∀ {n} → EXP n → EXP n
  not↺ = map↺ not
  {-
  helper : ∀ {n} (g₀ g₁ : EXP n) → g₀ ]-[ g₁ → not↺ g₀ ]-[ not↺ g₁
  helper = {!!}
  lem : runA ⇓ runSymA
  lem A-breaks-E = {!helper (uunSymA′ 0b) (runSymA′ 1)!}
     where pf : breaks runSymA
           pf = {!!}
  -}

module Run⅁₂ {ca} (A : Adv₂ ca) (b : Bit) where
  E : Bit → M → C
  E k m = m xor k

  m : Bit → Bit
  m = id

  kont₀ : ⅁? _
  kont₀ k =
      A ▹↺ λ f →
      f (E k (m b))

      {-
    kont₀′ : ⅁? _
    kont₀′ k =
      conv-Adv A ▹↺ λ f →
      f (E k (m b))
      -}

  run⅁₂ : EXP (1 + ca)
  run⅁₂ = toss >>= kont₀

module Run⅁₂-Properties {ca} (A : Adv₂ ca) (b k : Bit) where
  open Run⅁₂ A
  kont₀-not : kont₀ b k ≡ kont₀ (not b) (not k)
  kont₀-not rewrite xor-not-not b k = refl

conv-Adv : ∀ {ca S₀ S₁ S₂} → Adv S₀ S₁ S₂ ca → Adv₂ ca
conv-Adv A = step₀ ▹↺ λ s₀ →
             case step₁ s₀ of λ {(m , s₁) →
             λ c → m (step₃ (step₂ (c , s₁)))}
  where open Adv A

open ≡-Reasoning

module Conv-Adv-Props (homPrgDist : HomPrgDist) {ca S₀ S₁ S₂} (A : Adv S₀ S₁ S₂ ca) where
  open HomPrgDist homPrgDist
  open Adv A
  open Run⅁ _xor_ A renaming (run⅁ to runA)
  -- open Run⅁-Properties A

  A′ : Adv₂ ca
  A′ = conv-Adv A
  open Run⅁₂ A′ using () renaming (kont₀ to kont₀′; run⅁₂ to runA′)

  kont₀′′ : ∀ b k → EXP ca
  kont₀′′ b k =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ ((m b) xor k , s₁)))}

  kont₀′′′ : ∀ b′ → EXP ca
  kont₀′′′ b′ =
      step₀ ▹↺ λ s₀ →
      case step₁ s₀ of λ {(m , s₁) →
      m (step₃ (step₂ (b′ , s₁)))}

  {-
  kont′′-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′′ b k)
  kont′′-lem true true = {!!}
  kont′′-lem false true = {!!}
  kont′′-lem true false = {!!}
  kont′′-lem false false = {!!}

  kont-lem : ∀ b k → count↺ (kont₀ b k) ≡ count↺ (kont₀′ b k)
  kont-lem b true = {!!}
  kont-lem b false = {!!}

  conv-Adv-lem : runA ≈⅁? runA′
  conv-Adv-lem b = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ _+_ (kont-lem b 0b) (kont-lem b 1b) ⟩
          count↺ (kont₀′ b 0b) + count↺ (kont₀′ b 1b)
        ≡⟨ refl ⟩
          count↺ (runA′ b) ∎

  conv-Adv-sound : runA ⇓ runA′
  conv-Adv-sound = ]-[-cong-≈↺ (conv-Adv-lem 0b) (conv-Adv-lem 1b)
  -}
-- Cute fact: this is true by computation!
count↺-toss->>= : ∀ {c} (f : ⅁? c) → count↺ (toss >>= f) ≡ count↺ (f 0b) + count↺ (f 1b)
count↺-toss->>= f = refl

{-
module Run⅁-Properties' {S₀ S₁ S₂ ca} (A : Adv S₀ S₁ S₂ ca) (b : Bit) where
    open Run⅁ _xor_ A renaming (run⅁ to runA)
    lem : count↺ (runA b) ≡ count↺ (runA (not b))
    lem = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ (_+_ on count↺) {x = kont₀ b 0b} {kont₀ (not b) 1b} {kont₀ b 1b} {kont₀ (not b) 0b} {!!} {!!} ⟩
          count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
        ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
          count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
        ≡⟨ refl ⟩
          count↺ (runA (not b)) ∎
-}
open import program-distance
open import Relation.Nullary

lem₂ : ∀ {ca} (A : Adv₂ ca) b → count↺ (Run⅁₂.run⅁₂ A b) ≡ count↺ (Run⅁₂.run⅁₂ A (not b))
lem₂ A b = count↺ (runA b)
        ≡⟨ refl ⟩
          count↺ (kont₀ b 0b) + count↺ (kont₀ b 1b)
        ≡⟨ cong₂ (_+_ on count↺) (kont₀-not 0b) (kont₀-not 1b) ⟩
          count↺ (kont₀ (not b) 1b) + count↺ (kont₀ (not b) 0b)
        ≡⟨ ℕ°.+-comm (count↺ (kont₀ (not b) 1b)) _ ⟩
          count↺ (kont₀ (not b) 0b) + count↺ (kont₀ (not b) 1b)
        ≡⟨ refl ⟩
          count↺ (runA (not b)) ∎
  where open Run⅁₂ A renaming (run⅁₂ to runA)
        open Run⅁₂-Properties A b

lem₃ : ∀ {ca} (A : Adv₂ ca) → Safe⅁? (Run⅁₂.run⅁₂ A)
lem₃ A = lem₂ A 0b

-- A specialized version of lem₂
lem₄ : ∀ {ca} (A : Adv₂ ca) → Safe⅁? (Run⅁₂.run⅁₂ A)
lem₄ A  = count↺ (runA 0b)
        ≡⟨ refl ⟩
          count↺ (kont₀ 0b 0b) + count↺ (kont₀ 0b 1b)
        ≡⟨ cong₂ (_+_ on count↺) (kont₀-not 0b) (kont₀-not 1b) ⟩
          count↺ (kont₀ 1b 1b) + count↺ (kont₀ 1b 0b)
        ≡⟨ ℕ°.+-comm (count↺ (kont₀ 1b 1b)) _ ⟩
          count↺ (kont₀ 1b 0b) + count↺ (kont₀ 1b 1b)
        ≡⟨ refl ⟩
          count↺ (runA 1b) ∎
  where open Run⅁₂ A renaming (run⅁₂ to runA)
        open Run⅁₂-Properties A 0b