elgamal updates

elgamal updates

{-# OPTIONS --copatterns #-}
open import Function
open import Data.Product
open import Data.Bool.NP as Bool
open import Data.Unit
open import Data.Maybe.NP
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_)
open import Data.Bits
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup) renaming (map to vmap)
open import Algebra.FunctionProperties
open import Relation.Binary.PropositionalEquality as ≡
import cont as cont
open cont using (Cont; ContA)
open import sum

module elgamal where

private
    ★₁ : Set₂
    ★₁ = Set₁

    ★ : ★₁
    ★ = Set

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 : SumProp X → ∀ u → SumProp (El u)
    μU μX `⊤         = μ⊤
    μU μX `X         = μX
    μU μX (u₀ `× u₁) = μU μX u₀ ×μ μU μX u₁

module EntropySmoothing
  (M    : ★)        -- Message
  (Hash : ★)
  (ℋ   : M → Hash) -- Hashing function
  (Rₐ   : ★)        -- Adversary randomness
  where

  -- Entropy smoothing adversary
  ESAdv : ★
  ESAdv = Rₐ → Hash → Bit

  -- The randomness universe needed for the following games
  R : ★
  R = M × Hash × Rₐ

  -- In this game we always use ℋ on a random message
  ES⅁₀ : ESAdv → R → Bit
  ES⅁₀ A (m , _ , rₐ) = A rₐ (ℋ m)

  -- In this game we just retrun a random Hash value
  ES⅁₁ : ESAdv → R → Bit
  ES⅁₁ A (_ , h , rₐ) = A rₐ h

  ES⅁ : ESAdv → Bit → R → Bit
  ES⅁ A b r = (case b 0→ ES⅁₀ 1→ ES⅁₁) A r

module EntropySmoothingWithKey
  (M    : ★)
  (Key  : ★)
  (Hash : ★)
  (ℋ   : Key → M → Hash) -- Hashing function
  (Rₐ   : ★)              -- Adversary randomness
  where

  -- Entropy smoothing adversary
  ESAdv : ★
  ESAdv = Rₐ → Key → Hash → Bit

  -- The randomness universe needed for the following games
  R : ★
  R = Key × M × Hash × Rₐ

  -- In this game we always use ℋ on a random message
  ES⅁₀ : ESAdv → R → Bit
  ES⅁₀ A (k , m , _ , rₐ) = A rₐ k (ℋ k m)

  -- In this game we just retrun a random Hash value
  ES⅁₁ : ESAdv → R → Bit
  ES⅁₁ A (k , _ , h , rₐ) = A rₐ k h

  ES⅁ : ESAdv → Bit → R → Bit
  ES⅁ A b r = (case b 0→ ES⅁₀ 1→ ES⅁₁) A r

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (μℤq : SumProp ℤq)
  (sumℤq-⊞-lem : ∀ x f → sum μℤq (f ∘ _⊞_ x) ≡ sum μℤq f)
  where

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

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = sum (μU μℤq u) (Bool.toℕ ∘ 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 = sumℤq-⊞-lem x (Bool.toℕ ∘ Adv)

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

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

{-
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 : ℕ) ([0]' [1]' : Fin q) where
  -- open Sum
  ℤq : ★
  ℤq = Fin q

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

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

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

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin.toℕ m ℕ⊞ n

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

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin.toℕ m ℕ⊠ n

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

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

  μℤq : SumProp ℤq
  μℤq = μFin q

  allℤq : Vec ℤq q
  allℤq = allFin q

  {-
  sumℤq : Sum ℤq
  sumℤq f = Vec.sum (vmap f allℤq)
  -}

  sumℤq-[suc]-lem : ∀ f → sum μℤq (f ∘ [suc]) ≡ sum μℤq f
  sumℤq-[suc]-lem f rewrite ≡.sym (Vec.sum-map-rot₁ f allℤq)
                          | Vec.map-∘ f [suc] allℤq
                          | rot₁-map-sucmod q
                          = refl

  --  comm-[suc]-ℕ⊞ : ∀ m n → [suc] (m ℕ⊞ n) ≡ m ℕ⊞ ([suc] n)

  sumℤq-ℕ⊞-lem : ∀ m f → sum μℤq (f ∘ _ℕ⊞_ m) ≡ sum μℤq f
  sumℤq-ℕ⊞-lem zero f = refl
  sumℤq-ℕ⊞-lem (suc m) f rewrite sumℤq-[suc]-lem (f ∘ _ℕ⊞_ m)
                               | sumℤq-ℕ⊞-lem m f = refl

  sumℤq-⊞-lem : ∀ m f → sum μℤq (f ∘ _⊞_ m) ≡ sum μℤq f
  sumℤq-⊞-lem = sumℤq-ℕ⊞-lem ∘ Fin.toℕ

  {-
module G-implem (p q : ℕ) (g' : Fin p) (0[p] 1[p] : Fin p) (0[q] 1[q] : Fin q) where
  open ℤq-implem q 0[q] 1[q] public
  open ℤq-implem p 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.toℕ 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 : SumProp ℤq)
  (sumℤq-⊞-lem : ∀ x f → sum μℤq (f ∘ _⊞_ x) ≡ sum μℤq f)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (_∙_ : G → G → G)
  where

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

  open ℤq-count ℤq _⊞_ μℤq sumℤq-⊞-lem

  ⁇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 DDH
  (ℤq  : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G   : ★)
  (g^_ : ℤq → G)
  where
    DDHAdv : ★ → ★
    DDHAdv R = R → G → G → G → Bit

    DDH⅁₀ : ∀ {R} {_I : ★} → DDHAdv R → (R × ℤq × ℤq × _I) → Bit
    DDH⅁₀ D (r , x , y , _) = D r (g^ x) (g^ y) (g^ (x ⊠ y))

    DDH⅁₁ : ∀ {R} → DDHAdv R → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁₁ D (r , x , y , z) = D r (g^ x) (g^ y) (g^ z)

    DDH⅁ : ∀ {R} → DDHAdv R → Bit → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁ D b = (case b 0→ DDH⅁₀ 1→ DDH⅁₁) D

    -- DDH⅁′ : ∀ {R} → DDHAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    -- DDH⅁′ D (b , x , y , z , r) = DDH⅁ D b (x , y , z , r)

    module With↺ where
        open Univ ℤq
        open `★ public renaming (`X to `ℤq)
        DDHAdv↺ : `★ → ★
        DDHAdv↺ R = G → G → G → ↺ R Bit
        DDH⅁₀↺ : ∀ {R _I} → DDHAdv↺ R → ↺ (R `× `ℤq `× `ℤq `× _I) Bit
        run↺ (DDH⅁₀↺ D) = DDH⅁₀ (λ a b c d → run↺ (D b c d) a)

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 : SumProp ℤq)
  (Rₐ : ★)
  (μRₐ : SumProp Rₐ)
  where

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

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

    PubKey = G
    SecKey = ℤq
    KeyPair = PubKey × SecKey
    CipherText = G × Message

    M = Message
    C = CipherText

    KeyGen : ℤq → KeyPair
    KeyGen x = (g^ x , x)

    -- KeyGen↺ : ↺ ℤq KeyPair
    -- KeyGen↺ = mk KeyGen

    Enc : PubKey → Message → ℤq → CipherText
    Enc gˣ m y = gʸ , ζ where
      gʸ = g^ y
      δ = gˣ ^ y
      ζ = δ ∙ m

    -- Enc↺ : PubKey → Message → ↺ ℤq CipherText
    -- Enc↺ gˣ m = mk (Enc gˣ m)

    Dec : SecKey → CipherText → Message
    Dec x (gʸ , ζ) = ζ / (gʸ ^ x)

    EncAdv : ★ → ★
    EncAdv Rₐ = (Rₐ → PubKey → Bit → M)
              × (Rₐ → PubKey → C → Bit)

    SS⅁ : ∀ {Rₐ _I : ★} → EncAdv Rₐ → Bit → (Rₐ × ℤq × ℤq × _I) → Bit
    SS⅁ (m , D) b (rₐ , x , y , z) =
      let pk = proj₁ (KeyGen x) in
      D rₐ pk (Enc pk (m rₐ pk b) y)

      -- Unused
    Game : (i : Bit) → ∀ {Rₐ} → EncAdv Rₐ → (Bit × Rₐ × ℤq × ℤq × ℤq) → Bit
    Game 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

    {-
    Game-0b≡Game0 : ∀ {Rₐ} → Game 0b ≡ Game0 {Rₐ}
    Game-0b≡Game0 = refl
      -}

    open DDH ℤq _⊠_ G g^_ public

    OTP⅁ : ∀ {R : ★} → (R → G → Message) → (R → G → G → Message → Bit)
                     → (R × ℤq × ℤq × ℤq) → 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 : ∀ {Rₐ} → Bit → EncAdv Rₐ → DDHAdv Rₐ
    TrA b (m , D) rₐ gˣ gʸ gˣʸ = D rₐ gˣ (gʸ , gˣʸ ∙ m rₐ gˣ b)

    projM : ∀ {Rₐ} → EncAdv Rₐ → Bit → Rₐ → G → Message
    projM (m , _) b rₐ gˣ = m rₐ gˣ b

    projD : ∀ {Rₐ} → EncAdv Rₐ → Rₐ → G → G → Message → Bit
    projD (_ , D) rₐ gˣ gʸ gᶻ∙M = D rₐ gˣ (gʸ , gᶻ∙M)

    like-SS⅁ : ∀ {Rₐ _I : ★} → EncAdv Rₐ → Bit → (Rₐ × ℤq × ℤq × _I) → Bit
    like-SS⅁ (m , D) b (rₐ , x , y , _z) =
      D rₐ gˣ (gʸ , (gˣ ^ y) ∙ m rₐ gˣ b)
      where gˣ = g^ x
            gʸ = g^ y

    SS⅁≡like-SS⅁ : ∀ {R _I} → SS⅁ {R} {_I} ≡ like-SS⅁
    SS⅁≡like-SS⅁ = refl

    -- open Sum

    R = Rₐ × ℤq × ℤq × ℤq
    μR : SumProp R
    μR = μRₐ ×μ μℤq ×μ μℤq ×μ μℤq

    #R_ : Count R
    #R_ = count μR

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

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

    _≈R_ : (f g : R → Bit) → ★
    f ≈R g = #R f ≡ #R 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 Proof
        (ddh-hyp : (A : DDHAdv Rₐ) → DDH⅁ A 0b ≈R DDH⅁ A 1b)
        (otp-lem : ∀ (A : Message → Bit) m₀ m₁ → (λ x → A (g^ x ∙ m₀)) ≈q (λ x → A (g^ x ∙ m₁)))
        (A : EncAdv Rₐ) (b : Bit)
      where

        OTP⅁-lem : ∀ D M₀ M₁ → OTP⅁ M₀ D ≈R OTP⅁ M₁ D
        OTP⅁-lem D M₀ M₁ = sum-ext μRₐ (λ r →
                             sum-ext μℤq (λ x →
                               sum-ext μℤq (λ y →
                                 pf r x y)))
          where
          f0 = λ M r x y z → OTP⅁ M D (r , x , y , z)
          f1 = λ M r x y → sum μℤq (Bool.toℕ ∘ f0 M r x y)
          f2 = λ M r x → sum μℤq (f1 M r x)
          f3 = λ M r → sum μℤq (f2 M r)
          pf : ∀ r x y → f1 M₀ r x y ≡ f1 M₁ r x y
          pf r x y = pf'
            where gˣ = g^ x
                  gʸ = g^ y
                  m₀ = M₀ r gˣ
                  m₁ = M₁ r gˣ
                  f5 = λ M z → D r gˣ gʸ (g^ z ∙ M)
                  pf' : f5 m₀ ≈q f5 m₁
                  pf' rewrite otp-lem (D r gˣ gʸ) m₀ m₁ = refl

        Aᵇ = TrA b A
        A¬ᵇ = TrA (not b) A

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

        pf1 : SS⅁ A b ≈R DDH⅁ Aᵇ 0b
        pf1 = sum-ext μR (cong Bool.toℕ ∘ pf0,5)

        pf2 : DDH⅁ Aᵇ 0b ≈R DDH⅁ Aᵇ 1b
        pf2 = ddh-hyp Aᵇ

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

        pf3 : DDH⅁ Aᵇ 1b ≈R DDH⅁ A¬ᵇ 1b
        pf3 = OTP⅁-lem (projD A) (projM A b) (projM A (not b))

        pf4 : DDH⅁ A¬ᵇ 1b ≈R DDH⅁ A¬ᵇ 0b
        pf4 = ≡.sym (ddh-hyp A¬ᵇ)

        pf4,5 : SS⅁ A (not b) ≗ DDH⅁ A¬ᵇ 0b
        pf4,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

        pf5 : SS⅁ A (not b) ≈R DDH⅁ A¬ᵇ 0b
        pf5 = sum-ext μR (cong Bool.toℕ ∘ pf4,5)

        final : SS⅁ A b ≈R SS⅁ A (not b)
        final rewrite pf1 | pf2 | pf3 | pf4 | pf5 = refl

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 : SumProp ℤq)
    (Rₐ : ★)
    (μRₐ : SumProp 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 : SumProp ℤq)
    (Rₐ : ★)
    (μRₐ : SumProp Rₐ)
    where

    Message = Bits |M|

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

    _/_ : Message → G → Message
    _/_ = {!!}

    {-
    /-∙ : ∀ 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 ≈R 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
    dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y

  open ℤq-count ℤq _⊞_ μℤq sumℤq-⊞-lem

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

  module EB = El-Gamal-Base _ _⊠_ G g _^_ _∙_ _⁻¹ dist-^-⊠ sumℤq sumℤq-ext Rₐ sumRₐ sumRₐ-ext
  open EB hiding (g^_)

  postulate
    ddh-hyp : (A : DDHAdv Rₐ) → DDH⅁ A 0b ≈R DDH⅁ A 1b
    otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x))

  open OTP⅁-LEM otp-lem

  {-
  final : ∀ A → SS⅁ A 0b ≈R SS⅁ 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 Function
open import Data.Product
open import Data.Bool.NP as Bool
open import Data.Unit
open import Data.Maybe.NP
import Data.Fin.NP as Fin
open Fin using (Fin; zero; suc) renaming (#_ to ##_)
open import Data.Nat.NP hiding (_^_)
open import Data.Bits
import Data.Vec.NP as Vec
open Vec using (Vec; []; _∷_; _∷ʳ_; allFin; lookup) renaming (map to vmap)
open import Algebra.FunctionProperties
open import Relation.Binary.PropositionalEquality as ≡
import cont as cont
open cont using (Cont; ContA)

module elgamal where

private
    ★₁ : Set₂
    ★₁ = Set₁

    ★ : ★₁
    ★ = Set

[0→_,1→_] : ∀ {a} {A : Set a} → A → A → Bit → A
[0→ e₀ ,1→ e₁ ] b = if b then e₁ else e₀

case_0→_1→_ : ∀ {a} {A : Set a} → Bit → A → A → A
case b 0→ e₀ 1→ e₁ = if b then e₁ else e₀

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 = ↺ `⊤

module EntropySmoothing
  (M    : ★)        -- Message
  (Hash : ★)
  (ℋ   : M → Hash) -- Hashing function
  (Rₐ   : ★)        -- Adversary randomness
  where

  -- Entropy smoothing adversary
  ESAdv : ★
  ESAdv = Rₐ → Hash → Bit

  -- The randomness universe needed for the following games
  R : ★
  R = M × Hash × Rₐ

  -- In this game we always use ℋ on a random message
  ES⅁₀ : ESAdv → R → Bit
  ES⅁₀ A (m , _ , rₐ) = A rₐ (ℋ m)

  -- In this game we just retrun a random Hash value
  ES⅁₁ : ESAdv → R → Bit
  ES⅁₁ A (_ , h , rₐ) = A rₐ h

  ES⅁ : ESAdv → Bit → R → Bit
  ES⅁ A b r = (case b 0→ ES⅁₀ 1→ ES⅁₁) A r

module EntropySmoothingWithKey
  (M    : ★)
  (Key  : ★)
  (Hash : ★)
  (ℋ   : Key → M → Hash) -- Hashing function
  (Rₐ   : ★)              -- Adversary randomness
  where

  -- Entropy smoothing adversary
  ESAdv : ★
  ESAdv = Rₐ → Key → Hash → Bit

  -- The randomness universe needed for the following games
  R : ★
  R = Key × M × Hash × Rₐ

  -- In this game we always use ℋ on a random message
  ES⅁₀ : ESAdv → R → Bit
  ES⅁₀ A (k , m , _ , rₐ) = A rₐ k (ℋ k m)

  -- In this game we just retrun a random Hash value
  ES⅁₁ : ESAdv → R → Bit
  ES⅁₁ A (k , _ , h , rₐ) = A rₐ k h

  ES⅁ : ESAdv → Bit → R → Bit
  ES⅁ A b r = (case b 0→ ES⅁₀ 1→ ES⅁₁) A r

module ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum.Sum ℤq)
  (sumℤq-ext : Sum.SumExt sumℤq)
  (sumℤq-⊞-lem : ∀ x f → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  where

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

  sum : ∀ u → Sum (El u)
  sum `⊤         = sum⊤
  sum `X         = sumℤq
  sum (u₀ `× u₁) = sumProd (sum u₀) (sum u₁)

  sum-ext : ∀ u → SumExt (sum u)
  sum-ext `⊤         = sum⊤-ext
  sum-ext `X         = sumℤq-ext
  sum-ext (u₀ `× u₁) = sumProd-ext (sum-ext u₀) (sum-ext u₁)

  #_ : ∀ {u} → ↺ u Bit → ℕ
  #_ {u} f = sum u (Bool.toℕ ∘ run↺ f)

  #q_ : Count ℤq
  #q_ = sumToCount sumℤ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 = sumℤq-⊞-lem x (Bool.toℕ ∘ Adv)

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

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

{-
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 : ℕ) ([0]' [1]' : Fin q) where
  open Sum
  ℤq : ★
  ℤq = Fin q

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

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

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

  _⊞_ : ℤq → ℤq → ℤq
  m ⊞ n = Fin.toℕ m ℕ⊞ n

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

  _⊠_ : ℤq → ℤq → ℤq
  m ⊠ n = Fin.toℕ m ℕ⊠ n

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

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

  allℤq : Vec ℤq q
  allℤq = allFin q

  sumℤq : Sum ℤq
  sumℤq f = Vec.sum (vmap f allℤq)

  sumℤq-[suc]-lem : ∀ f → sumℤq (f ∘ [suc]) ≡ sumℤq f
  sumℤq-[suc]-lem f rewrite ≡.sym (Vec.sum-map-rot₁ f allℤq)
                          | Vec.map-∘ f [suc] allℤq
                          | rot₁-map-sucmod q
                          = refl

  --  comm-[suc]-ℕ⊞ : ∀ m n → [suc] (m ℕ⊞ n) ≡ m ℕ⊞ ([suc] n)

  sumℤq-ℕ⊞-lem : ∀ m f → sumℤq (f ∘ _ℕ⊞_ m) ≡ sumℤq f
  sumℤq-ℕ⊞-lem zero f = refl
  sumℤq-ℕ⊞-lem (suc m) f rewrite sumℤq-[suc]-lem (f ∘ _ℕ⊞_ m)
                               | sumℤq-ℕ⊞-lem m f = refl

  sumℤq-⊞-lem : ∀ m f → sumℤq (f ∘ _⊞_ m) ≡ sumℤq f
  sumℤq-⊞-lem = sumℤq-ℕ⊞-lem ∘ Fin.toℕ

  vmap-ext : ∀ {A B : ★} {f g : A → B} {n} → f ≗ g → vmap f ≗ vmap {n = n} g
  vmap-ext f≗g [] = refl
  vmap-ext f≗g (x ∷ xs) rewrite f≗g x | vmap-ext f≗g xs = refl

  sumℤq-ext : SumExt sumℤq
  sumℤq-ext f≗g rewrite vmap-ext f≗g allℤq = refl

module G-implem (p q : ℕ) (g' : Fin p) (0[p] 1[p] : Fin p) (0[q] 1[q] : Fin q) where
  open ℤq-implem q 0[q] 1[q] public
  open ℤq-implem p 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.toℕ 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)
  (sumℤq : Sum.Sum ℤq)
  (sumℤq-ext : Sum.SumExt sumℤq)
  (sumℤq-⊞-lem : ∀ x f → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  (_∙_ : G → G → G)
  where

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

  open Sum
  open ℤq-count ℤq _⊞_ sumℤq sumℤq-ext sumℤq-⊞-lem

  ⁇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 DDH
  (ℤq  : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G   : ★)
  (g^_ : ℤq → G)
  where
    DDHAdv : ★ → ★
    DDHAdv R = R → G → G → G → Bit

    DDH⅁₀ : ∀ {R} {_I : ★} → DDHAdv R → (R × ℤq × ℤq × _I) → Bit
    DDH⅁₀ D (r , x , y , _) = D r (g^ x) (g^ y) (g^ (x ⊠ y))

    DDH⅁₁ : ∀ {R} → DDHAdv R → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁₁ D (r , x , y , z) = D r (g^ x) (g^ y) (g^ z)

    DDH⅁ : ∀ {R} → DDHAdv R → Bit → (R × ℤq × ℤq × ℤq) → Bit
    DDH⅁ D b = (case b 0→ DDH⅁₀ 1→ DDH⅁₁) D

    -- DDH⅁′ : ∀ {R} → DDHAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    -- DDH⅁′ D (b , x , y , z , r) = DDH⅁ D b (x , y , z , r)

    module With↺ where
        open Univ ℤq
        open `★ public renaming (`X to `ℤq)
        DDHAdv↺ : `★ → ★
        DDHAdv↺ R = G → G → G → ↺ R Bit
        DDH⅁₀↺ : ∀ {R _I} → DDHAdv↺ R → ↺ (R `× `ℤq `× `ℤq `× _I) Bit
        run↺ (DDH⅁₀↺ D) = DDH⅁₀ (λ a b c d → run↺ (D b c d) a)

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

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

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

    PubKey = G
    SecKey = ℤq
    KeyPair = PubKey × SecKey
    CipherText = G × Message

    M = Message
    C = CipherText

    KeyGen : ℤq → KeyPair
    KeyGen x = (g^ x , x)

    -- KeyGen↺ : ↺ ℤq KeyPair
    -- KeyGen↺ = mk KeyGen

    Enc : PubKey → Message → ℤq → CipherText
    Enc gˣ m y = gʸ , ζ where
      gʸ = g^ y
      δ = gˣ ^ y
      ζ = δ ∙ m

    -- Enc↺ : PubKey → Message → ↺ ℤq CipherText
    -- Enc↺ gˣ m = mk (Enc gˣ m)

    Dec : SecKey → CipherText → Message
    Dec x (gʸ , ζ) = (gʸ ^ x) ∙⁻¹ ζ

    EncAdv : ★ → ★
    EncAdv R = (R → PubKey → Bit → M) × (R → PubKey → C → Bit)

    SS⅁ : ∀ {R _I : ★} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    SS⅁ (m , D) b (r , x , y , z) =
      let pk = proj₁ (KeyGen x) in
      D r pk (Enc pk (m r pk b) y)

    Game : (i : Bit) → ∀ {R} → EncAdv R → (Bit × R × ℤq × ℤq × ℤq) → Bit
    Game i (m , D) (b , r , x , y , z) =
      let gˣ = g^ x
          gʸ = g^ y
          δ  = gˣ ^ case i 0→ y 1→ z
          ζ  = δ ∙ m r gˣ b
      in b ==ᵇ D r gˣ (gʸ , ζ)

    {-
    Game-0b≡Game0 : ∀ {R} → Game 0b ≡ Game0 {R}
    Game-0b≡Game0 = refl
      -}

    open DDH ℤq _⊠_ G g^_ public

    -- Game0 ≈ Game 0b
    -- Game1 = Game 1b

    -- Game0 ≤ ε
    -- Game1 ≡ 0

    OTP⅁ : ∀ {R : ★} → (R → G → Message) → (R → G → G → Message → Bit)
                     → (R × ℤq × ℤq × ℤq) → 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 : ∀ {R} → Bit → EncAdv R → DDHAdv R
    TrA b (m , D) r gˣ gʸ gˣʸ = D r gˣ (gʸ , gˣʸ ∙ m r gˣ b)

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

    _/_ : G → G → G
    x / y = x ∙ (y ⁻¹)
    open El-Gamal-Generic ℤq _⊠_ G g _^_ G _∙_ (flip _/_) public

    like-SS⅁ : ∀ {R _I : ★} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    like-SS⅁ (m , D) b (r , x , y , _z) =
      D r gˣ (gʸ , (gˣ ^ y) ∙ m r gˣ b)
      where gˣ = g^ x
            gʸ = g^ y

    SS⅁≡like-SS⅁ : ∀ {R _I} → SS⅁ {R} {_I} ≡ like-SS⅁
    SS⅁≡like-SS⅁ = refl

    open Sum
    module WithSumRAndℤqProps
        (Rₐ : ★)
        (sumRₐ : Sum Rₐ)
        (sumRₐ-ext : SumExt sumRₐ)
        (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
        (sumℤq : Sum ℤq)
        (sumℤq-ext : SumExt sumℤq)
        where

        module SumR where
          R = Rₐ × ℤq × ℤq × ℤq
          sumR : Sum R
          sumR = sumProd sumRₐ (sumProd sumℤq (sumProd sumℤq sumℤq))
          #R_ : Count R
          #R_ = sumToCount sumR
          sumR-ext : SumExt sumR
          sumR-ext = sumProd-ext sumRₐ-ext (sumProd-ext sumℤq-ext (sumProd-ext sumℤq-ext sumℤq-ext))
        private
            #q_ : Count ℤq
            #q_ = sumToCount sumℤq

        open SumR

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

        _≈R_ : (f g : R → Bit) → ★
        f ≈R g = #R f ≡ #R g

        module EvenMoreProof
            (ddh-hyp : (A : DDHAdv Rₐ) → DDH⅁ A 0b ≈R DDH⅁ A 1b)
            (otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x)))
            where

                otp-lem' : ∀ D M₀ M₁ → OTP⅁ M₀ D ≈R OTP⅁ M₁ D
                otp-lem' D M₀ M₁ = sumRₐ-ext (λ r →
                                     sumℤq-ext (λ x →
                                       sumℤq-ext (λ y →
                                         pf r x y)))
                  where
                  f0 = λ M r x y z → OTP⅁ M D (r , x , y , z)
                  f1 = λ M r x y → sumℤq (Bool.toℕ ∘ f0 M r x y)
                  f2 = λ M r x → sumℤq (f1 M r x)
                  f3 = λ M r → sumℤq (f2 M r)
                  pf : ∀ r x y → f1 M₀ r x y ≡ f1 M₁ r x y
                  pf r x y = pf'
                    where gˣ = g^ x
                          gʸ = g^ y
                          m₀ = M₀ r gˣ
                          m₁ = M₁ r gˣ
                          f5 = λ M z → D r gˣ gʸ (g^ z ∙ M)
                          pf' : f5 m₀ ≈q f5 m₁
                          pf' rewrite otp-lem (D r gˣ gʸ) m₀
                                    | otp-lem (D r gˣ gʸ) m₁ = refl

                projM : EncAdv Rₐ → Bit → Rₐ → G → G
                projM (m , _) b r gˣ = m r gˣ b

                projD : EncAdv Rₐ → Rₐ → G → G → G → Bit
                projD (_ , D) r gˣ gʸ gᶻ∙M = D r gˣ (gʸ , gᶻ∙M)

                module WithAdversary (A : EncAdv Rₐ) b where
                    Aᵇ = TrA b A
                    A¬ᵇ = TrA (not b) A

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

                    pf1 : SS⅁ A b ≈R DDH⅁ Aᵇ 0b
                    pf1 = sumR-ext (cong Bool.toℕ ∘ pf0,5)

                    pf2 : DDH⅁ Aᵇ 0b ≈R DDH⅁ Aᵇ 1b
                    pf2 = ddh-hyp Aᵇ

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

                    pf3 : DDH⅁ Aᵇ 1b ≈R DDH⅁ A¬ᵇ 1b
                    pf3 = otp-lem' (projD A) (projM A b) (projM A (not b))

                    pf4 : DDH⅁ A¬ᵇ 1b ≈R DDH⅁ A¬ᵇ 0b
                    pf4 = ≡.sym (ddh-hyp A¬ᵇ)

                    pf4,5 : SS⅁ A (not b) ≗ DDH⅁ A¬ᵇ 0b
                    pf4,5 (r , x , y , z) rewrite dist-^-⊠ g x y = refl

                    pf5 : SS⅁ A (not b) ≈R DDH⅁ A¬ᵇ 0b
                    pf5 = sumR-ext (cong Bool.toℕ ∘ pf4,5)

                    final : SS⅁ A b ≈R SS⅁ A (not b)
                    final rewrite pf1 | pf2 | pf3 | pf4 | pf5 = refl

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

    Message = Bits |M|

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

    open El-Gamal-Generic ℤq _⊠_ G g _^_ Message ℋ⟨_⟩⊕_

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
    dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y

  module EB = El-Gamal-Base _ _⊠_ G g _^_ _⁻¹ _∙_
  open EB hiding (g^_)

  open ℤq-count ℤq _⊞_ sumℤq sumℤq-ext sumℤq-⊞-lem

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

  open WithSumRAndℤqProps Rₐ sumRₐ sumRₐ-ext dist-^-⊠ sumℤq sumℤq-ext

  open SumR
  postulate
    ddh-hyp : (A : DDHAdv Rₐ) → DDH⅁ A 0b ≈R DDH⅁ A 1b
    otp-lem : ∀ (A : G → Bit) m → (λ x → A (g^ x ∙ m)) ≈q (λ x → A (g^ x))

  open EvenMoreProof ddh-hyp otp-lem

  final : ∀ A → SS⅁ A 0b ≈R SS⅁ A 1b
  final A = WithAdversary.final A 0b

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

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


Mark the Translation module as unfinished

-- UNFINISHED

open import Function
open import Data.Product hiding (zip)
                         renaming (_,_ to ⟨_,_⟩; proj₁ to fst; proj₂ to snd;
                                   map to ×map)
open import Data.Zero
open import Data.One
open import Data.Two

open import PTT.Dom
import PTT.Session as Session
import PTT.Map as Map
import PTT.Env as Env
import PTT.Proto as Proto
open Session hiding (Ended)
open Env     hiding (_/₀_; _/₁_; Ended)
open Proto   hiding ()
open import PTT.Term
open import PTT.Split
open import Relation.Binary.PropositionalEquality.NP hiding (J)

S-⅋-inp : ∀ {c c₀ c₁ δI S₀ S₁}{I : Proto δI}(l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
  → S⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩ → S⟨ I ⟩
S-⅋-inp l P = {!!}

translate : ∀ {δI}{I : Proto δI} → ⟨ I ⟩ → S⟨ I ⟩
translate (end x) = S-T (TC-end x)
translate (⅋-inp l P) = S-⅋-inp l (translate (P c₀ c₁))
  where postulate c₀ c₁ : URI
translate (⊗-out l P) = {!!}
translate (split σs A1 P P₁) = {!!}
translate (nu D P) = {!!}

{-
module PTT.Translation where
module Translation
 {t}
 (T⟨_⟩ : ∀ {δI} → Proto δI → Set t)
 (T-⊗-out :
    ∀ {δI I c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ « S₀ » ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ « S₁ » ] ⟩)
    → T⟨ I ⟩)

 (T-⅋-inp :
    ∀ {δI}{I : Proto δI}{c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → T⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩)

 (T-end :
    ∀ {δI}{I : Proto δI}
      (E : Ended I)
    → T⟨ I ⟩)

 (T-split :
    ∀ {δI}{I : Proto δI}
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : T⟨ I /₀ σs ⟩)
      (P₁ : T⟨ I /₁ σs ⟩)
    → T⟨ I ⟩)

 (T-cut :
    ∀ {δI}{I : Proto δI}{S₀ S₁}
      (D : Dual S₀ S₁)
      (σs : Selections δI)
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I /₀ σs ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I /₁ σs ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩)

 (T-⊗-reorg :
    ∀ {δI δE c c₀ c₁ S₀ S₁}{J : Proto δI}{E : Env δE}
      (l  : [ E ]∈ J)
      (l₀ : c₀ ↦ « S₀ » ∈ E)
      (l₁ : c₁ ↦ « S₁ » ∈ E)
      (P : T⟨ J ⟩)
    → T⟨ J Proto./ l ,[ (E Env./' l₀ /D (↦∈.lA l₁) , c ↦ « S₀ ⊗ S₁ ») ] ⟩)

 (T-conv : ∀ {δI δJ}{I : Proto δI}{J : Proto δJ} → I ≈ J → T⟨ I ⟩ → T⟨ J ⟩)

  where

  T-fwd : ∀ {S₀ S₁} (S : Dual S₀ S₁) c₀ c₁ → T⟨ · ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩
  T-fwd 𝟙⊥ c₀ c₁ = {!!}
  T-fwd ⊥𝟙 c₀ c₁ = {!!}
  T-fwd (act (?! S S₁)) c₀ c₁ = {!!}
  T-fwd (act (!? S S₁)) c₀ c₁ = {!!}
  T-fwd (⊗⅋ S₀ S₁ S₂ S₃) c₀ c₁ =
    T-⅋-inp here[]' λ c₂ c₃ →
      T-⊗-out (there…' (there…' (there…' here…')))
              ((((· ,[ (ε , c₀ ↦ 0₂) ]) ,[ (ε , c₁ ↦ 0₂) ]) ,[ (ε , c₂ ↦ 0₂) ]) ,[ (ε , c₃ ↦ 1₂) ])
              (ε , c₀ ↦ 0₂)
              ((((· ,[ {!!} ]) ,[ {!!} ]) ,[ {!!} ]) ,[ {!!} ])
              (λ c₄ → T-conv (≈,[] (≈-! (≈,[swap] ≈-∙ {!≈,[] ≈-refl ?!})) (∼,↦ (∼-! ∼,↦end))) (T-fwd S₁ c₃ c₄))
              (λ c₄ → T-conv (≈,[] (≈,[] (≈-! (≈,[end] _ ≈-∙ (≈,[end] _ ≈-∙ ≈,[end] _))) ∼-refl) (∼,↦ (∼-! ∼,↦end))) (T-fwd S₃ c₃ c₄))
  T-fwd (⅋⊗ S S₁ S₂ S₃) c₀ c₁ = {!!}

  go : ∀ {δI}{I : Proto δI} → ⟨ I ⟩ → T⟨ I ⟩
  go (end x) = T-end x
  go (⅋-inp l P) = T-⅋-inp l (λ c₀ c₁ → go (P c₀ c₁))
  go {I = I}(⊗-out {c} {S₀} {S₁} l P) = T-conv e rPP
    where postulate c0 c1 : URI
          open [↦…]∈ l
          F = E Env./' lE , c0 ↦ « S₀ » , c1 ↦ « S₁ »
          J = I Proto./ lI ,[ F ]
          G = F /D there here /D here , c ↦ « S₀ ⊗ S₁ »
          K = J Proto./ heRe[] ,[ G ]
          rPP : T⟨ K ⟩
          rPP = T-⊗-reorg heRe[] (theRe here) heRe (go (P c0 c1))
          e : K ≈ I
          e = ≈,[] (≈,[end] (Ended-/* F)) (∼,↦ (∼,↦end ∼-∙ ∼,↦end)) ≈-∙ (≈-! (≈-/…,[…] l))
  go {I = I}(nu {S₀} {S₁} D P) = T-conv {!!} (T-cut {I = I'} D (sel₀ _ ,[ (ε , c ↦ 0₂) ] ,[ (ε , c' ↦ 1₂) ]) {!!} (λ c₀' → {!cPP!}) (λ c₁' → {!T-fwd!}))
    where postulate c c' c0 c1 : URI
          E   = ε , c0 ↦ « S₀ » , c1 ↦ « S₁ »
          E/* = ε , c0 ↦ end    , c1 ↦ end
          J = I ,[ E ]
          -- K = J / here ,[ E/* , c ↦ S₀ ⊗ S₁ ]
          K = I ,[ E/* ] ,[ E/* , c ↦ « S₀ ⊗ S₁ » ]
          gP : T⟨ J ⟩
          gP = go (P c0 c1)
          rPP : T⟨ K ⟩
          rPP = T-⊗-reorg {c = c} heRe[] (theRe here) heRe gP
          e : K ≈ I ,[ c ↦ S₀ ⊗ S₁ ]
          e = ≈,[] (≈,[end] _) (∼,↦ (∼,↦end ∼-∙ ∼,↦end))
          cPP : T⟨ I ,[ c ↦ S₀ ⊗ S₁ ] ⟩
          cPP = T-conv e rPP
          I' = I ,[ c ↦ S₀ ⊗ S₁ ] ,[ c' ↦ {!!} ]
  go (split σs A P₀ P₁) = T-split σs A (go P₀) (go P₁)
-}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

open import Function
open import Data.Product hiding (zip)
                         renaming (_,_ to ⟨_,_⟩; proj₁ to fst; proj₂ to snd;
                                   map to ×map)
open import Data.Zero
open import Data.One
open import Data.Two

open import PTT.Dom
import PTT.Session as Session
import PTT.Map as Map
import PTT.Env as Env
import PTT.Proto as Proto
open Session hiding (Ended)
open Env     hiding (_/₀_; _/₁_; Ended)
open Proto   hiding ()
open import PTT.Term
open import PTT.Split
open import Relation.Binary.PropositionalEquality.NP hiding (J)

S-⅋-inp : ∀ {c c₀ c₁ δI S₀ S₁}{I : Proto δI}(l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
  → S⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩ → S⟨ I ⟩
S-⅋-inp l P = {!!}

translate : ∀ {δI}{I : Proto δI} → ⟨ I ⟩ → S⟨ I ⟩
translate (end x) = S-T (TC-end x)
translate (⅋-inp l P) = S-⅋-inp l (translate (P c₀ c₁))
  where postulate c₀ c₁ : URI
translate (⊗-out l P) = {!!}
translate (split σs A1 P P₁) = {!!}
translate (nu D P) = {!!}

{-
module PTT.Translation where
module Translation
 {t}
 (T⟨_⟩ : ∀ {δI} → Proto δI → Set t)
 (T-⊗-out :
    ∀ {δI I c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ « S₀ » ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ « S₁ » ] ⟩)
    → T⟨ I ⟩)

 (T-⅋-inp :
    ∀ {δI}{I : Proto δI}{c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → T⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩)

 (T-end :
    ∀ {δI}{I : Proto δI}
      (E : Ended I)
    → T⟨ I ⟩)

 (T-split :
    ∀ {δI}{I : Proto δI}
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : T⟨ I /₀ σs ⟩)
      (P₁ : T⟨ I /₁ σs ⟩)
    → T⟨ I ⟩)

 (T-cut :
    ∀ {δI}{I : Proto δI}{S₀ S₁}
      (D : Dual S₀ S₁)
      (σs : Selections δI)
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I /₀ σs ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I /₁ σs ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩)

 (T-⊗-reorg :
    ∀ {δI δE c c₀ c₁ S₀ S₁}{J : Proto δI}{E : Env δE}
      (l  : [ E ]∈ J)
      (l₀ : c₀ ↦ « S₀ » ∈ E)
      (l₁ : c₁ ↦ « S₁ » ∈ E)
      (P : T⟨ J ⟩)
    → T⟨ J Proto./ l ,[ (E Env./' l₀ /D (↦∈.lA l₁) , c ↦ « S₀ ⊗ S₁ ») ] ⟩)

 (T-conv : ∀ {δI δJ}{I : Proto δI}{J : Proto δJ} → I ≈ J → T⟨ I ⟩ → T⟨ J ⟩)

  where

  T-fwd : ∀ {S₀ S₁} (S : Dual S₀ S₁) c₀ c₁ → T⟨ · ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩
  T-fwd 𝟙⊥ c₀ c₁ = {!!}
  T-fwd ⊥𝟙 c₀ c₁ = {!!}
  T-fwd (act (?! S S₁)) c₀ c₁ = {!!}
  T-fwd (act (!? S S₁)) c₀ c₁ = {!!}
  T-fwd (⊗⅋ S₀ S₁ S₂ S₃) c₀ c₁ =
    T-⅋-inp here[]' λ c₂ c₃ →
      T-⊗-out (there…' (there…' (there…' here…')))
              ((((· ,[ (ε , c₀ ↦ 0₂) ]) ,[ (ε , c₁ ↦ 0₂) ]) ,[ (ε , c₂ ↦ 0₂) ]) ,[ (ε , c₃ ↦ 1₂) ])
              (ε , c₀ ↦ 0₂)
              ((((· ,[ {!!} ]) ,[ {!!} ]) ,[ {!!} ]) ,[ {!!} ])
              (λ c₄ → T-conv (≈,[] (≈-! (≈,[swap] ≈-∙ {!≈,[] ≈-refl ?!})) (∼,↦ (∼-! ∼,↦end))) (T-fwd S₁ c₃ c₄))
              (λ c₄ → T-conv (≈,[] (≈,[] (≈-! (≈,[end] _ ≈-∙ (≈,[end] _ ≈-∙ ≈,[end] _))) ∼-refl) (∼,↦ (∼-! ∼,↦end))) (T-fwd S₃ c₃ c₄))
  T-fwd (⅋⊗ S S₁ S₂ S₃) c₀ c₁ = {!!}
{-
  -}

  go : ∀ {δI}{I : Proto δI} → ⟨ I ⟩ → T⟨ I ⟩
  go (end x) = T-end x
  go (⅋-inp l P) = T-⅋-inp l (λ c₀ c₁ → go (P c₀ c₁))
  go {I = I}(⊗-out {c} {S₀} {S₁} l P) = T-conv e rPP
    where postulate c0 c1 : URI
          open [↦…]∈ l
          F = E Env./' lE , c0 ↦ « S₀ » , c1 ↦ « S₁ »
          J = I Proto./ lI ,[ F ]
          G = F /D there here /D here , c ↦ « S₀ ⊗ S₁ »
          K = J Proto./ heRe[] ,[ G ]
          rPP : T⟨ K ⟩
          rPP = T-⊗-reorg heRe[] (theRe here) heRe (go (P c0 c1))
          e : K ≈ I
          e = ≈,[] (≈,[end] (Ended-/* F)) (∼,↦ (∼,↦end ∼-∙ ∼,↦end)) ≈-∙ (≈-! (≈-/…,[…] l))
  go {I = I}(nu {S₀} {S₁} D P) = T-conv {!!} (T-cut {I = I'} D (sel₀ _ ,[ (ε , c ↦ 0₂) ] ,[ (ε , c' ↦ 1₂) ]) {!!} (λ c₀' → {!cPP!}) (λ c₁' → {!T-fwd!}))
    where postulate c c' c0 c1 : URI
          E   = ε , c0 ↦ « S₀ » , c1 ↦ « S₁ »
          E/* = ε , c0 ↦ end    , c1 ↦ end
          J = I ,[ E ]
          -- K = J / here ,[ E/* , c ↦ S₀ ⊗ S₁ ]
          K = I ,[ E/* ] ,[ E/* , c ↦ « S₀ ⊗ S₁ » ]
          gP : T⟨ J ⟩
          gP = go (P c0 c1)
          rPP : T⟨ K ⟩
          rPP = T-⊗-reorg {c = c} heRe[] (theRe here) heRe gP
          e : K ≈ I ,[ c ↦ S₀ ⊗ S₁ ]
          e = ≈,[] (≈,[end] _) (∼,↦ (∼,↦end ∼-∙ ∼,↦end))
          cPP : T⟨ I ,[ c ↦ S₀ ⊗ S₁ ] ⟩
          cPP = T-conv e rPP
          I' = I ,[ c ↦ S₀ ⊗ S₁ ] ,[ c' ↦ {!!} ]
  go (split σs A P₀ P₁) = T-split σs A (go P₀) (go P₁)
-}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


Fixed typo.

Fixed typo.

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

-- From: On the Bright Side of Type Classes: Instances Arguments in
-- Agda (ICFP'11).

module InstanceArguments where

open import Data.Bool
open import Data.Nat hiding ( equal )

-- Note: Agda doesn't have a primitive function primBoolEquality.
primBoolEquality : Bool → Bool → Bool
primBoolEquality true  true  = true
primBoolEquality false false = true
primBoolEquality _     _     = false

primitive
  primNatEquality : ℕ → ℕ → Bool

record Eq (t : Set) : Set where
  field equal : t → t → Bool

eqBool : Eq Bool
eqBool = record { equal = primBoolEquality }

eqℕ : Eq ℕ
eqℕ = record { equal = primNatEquality }

equal : {t : Set} → {{eqT : Eq t}} → t → t → Bool
equal {{eqT}} = Eq.equal eqT

test : Bool
test = equal 5 3 ∨ equal true false

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

-- From: On the Bright Side of Type Classes: Instances Arguments in
-- Agda (ICFP'11).

module InstanceArguments where

open import Data.Bool
open import Data.Nat hiding ( equal )

-- Note: Agda doesn't have a primitive function primBoolEquality
primBoolEquality : Bool → Bool → Bool
primBoolEquality true  true  = true
primBoolEquality false false = true
primBoolEquality _     _     = false

primitive
  primNatEquality : ℕ → ℕ → Bool

record Eq (t : Set) : Set where
  field equal : t → t → Bool

eqBool : Eq Bool
eqBool = record { equal = primBoolEquality }

eqℕ : Eq ℕ
eqℕ = record { equal = primNatEquality }

equal : {t : Set} → {{eqT : Eq t}} → t → t → Bool
equal {{eqT}} = Eq.equal eqT

test : Bool
test = equal 5 3 ∨ equal true false


Revert "Import bool" - The agda stdlib is too slow to be worthwhile

This reverts commit e449e00f2c1e586ddf5a78a508185eb30347d0fc.

data Bool : Set where
  true  : Bool
  false : Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

infixr 5 _∷_

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ ∘

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (5 ∷ 3 ∷ 7 ∷ 7 ∷ ∘)) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (5 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (6 ∷ 3 ∷ ∘)) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (6 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ ∘) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ ∘) (3 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ ∘)) ∷
  (model (10 ∷ 9 ∷ ∘) (1 ∷ ∘)) ∷
  (model (3 ∷ 4 ∷ 11 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 7 ∷ 1 ∷ ∘) (4 ∷ 11 ∷ 8 ∷ ∘)) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ ∘) (11 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ ∘) (11 ∷ 3 ∷ ∘)) ∷
  (model (3 ∷ 6 ∷ 5 ∷ ∘) (∘)) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ ∘) (12 ∷ ∘)) ∷ ∘

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

open import Agda.Builtin.Bool

_or_ : Bool → Bool → Bool
true or _      = true
_ or true      = true
false or false = false

_and_ : Bool → Bool → Bool
false and _   = false
_ and false   = false
true and true = true

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

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

_≡_ : ℕ → ℕ → Bool
zero ≡ zero   = true
suc n ≡ suc m = n ≡ m
_ ≡ _         = false

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

infixr 5 _∷_

data List (A : Set) : Set where
  ∘   : List A
  _∷_ : A → List A → List A
{-# BUILTIN LIST List #-}
{-# BUILTIN NIL  ∘    #-}
{-# BUILTIN CONS _∷_  #-}

any : {A : Set} → (A → Bool) → List A → Bool
any _ ∘        = false
any f (x ∷ xs) = (f x) or (any f xs)

_∈_ : ℕ → List ℕ → Bool
x ∈ ∘        = false
x ∈ (y ∷ ys) with x ≡ y
...             | true  = true
...             | false = x ∈ ys

_∋_ : List ℕ → ℕ → Bool
xs ∋ y = y ∈ xs

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

data Arrow : Set where
  ⇒_  : ℕ → Arrow
  _⇒_ : ℕ → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q ≡ s
(p ⇒ q) ≡≡ (r ⇒ s) = (p ≡ r) and (q ≡≡ s)
_ ≡≡ _             = false

_∈∈_ : Arrow → List Arrow → Bool
x ∈∈ ∘        = false
x ∈∈ (y ∷ ys) with x ≡≡ y
...              | true  = true
...              | false = x ∈∈ ys

closure : List Arrow → List ℕ → List ℕ
closure ∘ found                = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈ found) or (n ∈ (closure rest found))
...                               | true  = closure (q ∷ rest) found
...                               | false = closure rest found

_,_⊢_ : List Arrow → List ℕ → ℕ → Bool
cs , ps ⊢ q = q ∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈ (closure cs ∘)
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

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

data Separation : Set where
  model : List ℕ → List ℕ → Separation

modelsupports : Separation → List Arrow → ℕ → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → ℕ → Bool
modeldenies (model _ fails) cs n = any (_∋_ (closure cs (n ∷ ∘))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) and (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ ∘ ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) or (cs ⟪ ms ⟫ arr)

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

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈ cs)
...                   | true  = Proved
...                   | false with (cs ⊢ arr)
...                              | true  = Derivable
...                              | false with (cs ⟪ ms ⟫ arr)
...                                         | true  = Separated
...                                         | false = Unknown

proofs : List Arrow
proofs =
   (3 ⇒ (⇒ 4)) ∷
--   (5 ⇒ (⇒ 4)) ∷
   (6 ⇒ (⇒ 4)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (3 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (9 ⇒ (⇒ 3)) ∷
   (5 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (6 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 8)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (5 ⇒ (⇒ 10)) ∷
   (10 ⇒ (⇒ 4)) ∷
   (5 ⇒ (⇒ 11)) ∷
   (6 ⇒ (⇒ 11)) ∷
   (11 ⇒ (⇒ 4)) ∷
   (10 ⇒ (⇒ 7)) ∷
   (8 ⇒ (⇒ 4)) ∷
   (9 ⇒ (⇒ 7)) ∷
   (9 ⇒ (⇒ 8)) ∷
   (3 ⇒ (⇒ 8)) ∷
   (5 ⇒ (3 ⇒ (⇒ 9))) ∷
   (6 ⇒ (7 ⇒ (⇒ 10))) ∷
   (6 ⇒ (3 ⇒ (⇒ 3))) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (⇒ 7)) ∷
   (7 ⇒ (8 ⇒ (⇒ 10))) ∷
   (3 ⇒ (10 ⇒ (⇒ 9))) ∷
   (5 ⇒ (⇒ 1)) ∷
   (3 ⇒ (1 ⇒ (⇒ 9))) ∷
   (1 ⇒ (⇒ 2)) ∷
   (10 ⇒ (⇒ 2)) ∷ ∘

cms : List Separation
cms =
  (model (12 ∷ 6 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (5 ∷ 3 ∷ 7 ∷ 7 ∷ ∘)) ∷
  (model (6 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (5 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 11 ∷ 4 ∷ 1 ∷ ∘) (6 ∷ 3 ∷ ∘)) ∷
  (model (5 ∷ 3 ∷ 11 ∷ 4 ∷ 7 ∷ 8 ∷ 3 ∷ 9 ∷ 10 ∷ 1 ∷ ∘) (6 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ ∘) (5 ∷ 6 ∷ 3 ∷ 8 ∷ 9 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 5 ∷ 6 ∷ 4 ∷ 11 ∷ 1 ∷ ∘) (3 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 11 ∷ 7 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 8 ∷ 1 ∷ ∘)) ∷
  (model (10 ∷ 9 ∷ ∘) (1 ∷ ∘)) ∷
  (model (3 ∷ 4 ∷ 11 ∷ ∘) (9 ∷ 5 ∷ 6 ∷ 10 ∷ 7 ∷ 1 ∷ ∘)) ∷
  (model (12 ∷ 7 ∷ 1 ∷ ∘) (4 ∷ 11 ∷ 8 ∷ ∘)) ∷
  (model (9 ∷ 3 ∷ 10 ∷ 8 ∷ 1 ∷ ∘) (11 ∷ ∘)) ∷
  (model (12 ∷ 4 ∷ 10 ∷ 1 ∷ ∘) (11 ∷ 3 ∷ ∘)) ∷
  (model (3 ∷ 6 ∷ 5 ∷ ∘) (∘)) ∷
  (model (1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ 7 ∷ 8 ∷ 9 ∷ 10 ∷ 11 ∷ ∘) (12 ∷ ∘)) ∷ ∘

testp : Arrow
testp = (5 ⇒ (⇒ 10))

testd : Arrow
testd = (5 ⇒ (⇒ 4))

tests : Arrow
tests = (5 ⇒ (⇒ 3))

testu : Arrow
testu = (6 ⇒ (⇒ 1))

main = (closure proofs (5 ∷ ∘))


Cosmetic changes.

Cosmetic changes.

Ignore-this: bac32ab4f5fe0e1bf251fec79f4cbf09

darcs-hash:20110424201526-3bd4e-93f4fc80361388a84c929edec36dcaa21fe1e201.gz

------------------------------------------------------------------------------
-- Predicate logic theorems
------------------------------------------------------------------------------

-- This module contains some examples showing the use of the ATPs to
-- prove theorems from predicate logic.

module PredicateLogic.TheoremsATP where

open import PredicateLogic.Constants

------------------------------------------------------------------------------
-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
{-
        φ(x)          ∀x.φ(x)          φ(t)           ∃x.φ(x)   φ(x) → ψ
  ∀I ---------    ∀E ---------    ∃I ---------    ∃E --------------------
      ∀x.φ(x)          φ(t)           ∃x.φ(x)               ψ
-}

postulate
  ∀I : ((x : D) → P¹ x) → ⋀ P¹
  ∀E : ⋀ P¹ → (t : D) → P¹ t
  -- It is necessary postulate a non-empty domain. See
  -- PredicateLogic.NonEmptyDomain.TheoremsATP.∃I.
  ∃I : ((t : D) → P¹ t) → ∃ P¹
  ∃E : ∃ P¹ → ((x : D) → P¹ x → P⁰) → P⁰
{-# ATP prove ∀I #-}
{-# ATP prove ∀E #-}
{-# ATP prove ∃E #-}

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

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

-- Quantification over a variable that does not occur can be delete.
postulate
  ∀-erase : ⋀ (λ _ → P⁰) ↔ P⁰
  ∃-erase : ∃ (λ x → P⁰ ∧ P¹ x) ↔ P⁰ ∧ ∃ (λ x → P¹ x)
{-# ATP prove ∀-erase #-}
{-# ATP prove ∃-erase #-}

-- Distributes laws for the quantifiers.
postulate
  ∀-dist : ⋀ (λ x → P¹ x ∧ Q¹ x) ↔ (⋀ P¹ ∧ ⋀ Q¹)
  ∃-dist : ∃ (λ x → P¹ x ∨ Q¹ x) ↔ (∃ P¹ ∨ ∃ Q¹)
{-# ATP prove ∀-dist #-}
{-# ATP prove ∃-dist #-}

------------------------------------------------------------------------------
-- Predicate logic theorems
------------------------------------------------------------------------------

-- This module contains some examples showing the use of the ATPs to
-- prove theorems from predicate logic.

module PredicateLogic.TheoremsATP where

open import PredicateLogic.Constants

------------------------------------------------------------------------------
-- We postulate some predicate symbols.
postulate
  P⁰    : Set
  P¹ Q¹ : D → Set
  P²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.
{-
        φ(x)          ∀x.φ(x)          φ(t)           ∃x.φ(x)   φ(x) → ψ
  ∀I ---------    ∀E ---------    ∃I ---------    ∃E --------------------
      ∀x.φ(x)          φ(t)           ∃x.φ(x)               ψ
-}

postulate
  ∀I : ((x : D) → P¹ x) → ⋀ P¹
  ∀E : ⋀ P¹ → (t : D) → P¹ t
  -- It is necessary postulate a non-empty domain.
  -- See PredicateLogic.NonEmptyDomain.TheoremsATP.
  -- ∃I : ((t : D) → P¹ t) → ∃ P¹
  ∃I : ((t : D) → P¹ t) → ∃ P¹
  ∃E : ∃ P¹ → ((x : D) → P¹ x → P⁰) → P⁰
{-# ATP prove ∀I #-}
{-# ATP prove ∀E #-}
{-# ATP prove ∃E #-}

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

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

-- Quantification over a variable that does not occur can be delete.
postulate
  ∀-erase  : ⋀ (λ _ → P⁰) ↔ P⁰
  ∃-erase : ∃ (λ x → P⁰ ∧ P¹ x) ↔ P⁰ ∧ ∃ (λ x → P¹ x)
{-# ATP prove ∀-erase #-}
{-# ATP prove ∃-erase #-}

-- Distributes laws for the quantifiers.
postulate
  ∀-dist : ⋀ (λ x → P¹ x ∧ Q¹ x) ↔ (⋀ P¹ ∧ ⋀ Q¹)
  ∃-dist : ∃ (λ x → P¹ x ∨ Q¹ x) ↔ (∃ P¹ ∨ ∃ Q¹)
{-# ATP prove ∀-dist #-}
{-# ATP prove ∃-dist #-}


redate list programming

redate list programming


agda: try and give up proving lift-term-doWeakenOne-ignore

See comments in the proof. Tillmann plans to rewrite the whole
handling of contexts.

Old-commit-hash: c120bb673f9dc0bbb6bdf96a9f0756063f874702

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

open import Relation.Binary.PropositionalEquality

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

-- This version of lift-term′ uses just weakenOne to accomplish its
-- job.

lift-term′-doWeakenMore : ∀ Γprefix Γrest {τ} →
  Term (Γprefix ⋎ Γrest) τ →
  Term (Γprefix ⋎ Δ-Context Γrest) τ

lift-term′-doWeakenMore Γprefix ∅ t₁ = t₁
lift-term′-doWeakenMore Γprefix (τ₂ • Γrest) t₁ =
  weakenOne Γprefix (Δ-Type τ₂)
    (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
      (lift-term′-doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
        (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

lift-term′-weakenOne : ∀ {Γ τ} Γ′ →
  Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′-weakenOne {Γ} Γ′ t =
  substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
    (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
      (substTerm (sym (take-drop Γ Γ′))
        t))

weakenOne-ignore :
 ∀ Γ₁ τ₂ {Γ₃ τ} → (t : Term (Γ₁ ⋎ Γ₃) τ) →
   {ρ : ⟦ Γ₁ ⋎ (τ₂ • Γ₃) ⟧} →
   ⟦ weakenOne Γ₁ τ₂ t ⟧ ρ ≡ ⟦ t ⟧ (weakenEnv Γ₁ τ₂ ρ)
weakenOne-ignore Γ₁ τ₂ t {ρ} = ≡-refl

_∪_ : ∀ {Γ Γ′} → (ρ : ⟦ Γ ⟧) → (ρ′ : ⟦ Γ′ ⟧) → ⟦ Γ ⋎ Γ′ ⟧
_∪_ {∅} {Γ′} ∅ ρ′ = ρ′
_∪_ {τ • Γ} {Γ′} (v • ρ) ρ′ = v • ρ ∪ ρ′

lift-term-doWeakenOne-ignore′ : ∀ Γprefix Γrest {τ}
  (ρ₁ : ⟦ Γprefix ⟧) (ρ₂ : ⟦ Δ-Context Γrest ⟧)
  (t : Term (Γprefix ⋎ Γrest) τ) →
  ⟦ lift-term′-doWeakenMore Γprefix Γrest t ⟧ (ρ₁ ∪ ρ₂) ≡ ⟦ t ⟧ (ρ₁ ∪ ignore ρ₂)

lift-term-doWeakenOne-ignore′ Γprefix ∅ ρ₁ ∅ t = refl
--This step gives the proof idea.
lift-term-doWeakenOne-ignore′ ∅ (τ • Γrest) ∅ (dv • v • ρ₂) t = lift-term-doWeakenOne-ignore′ (τ • ∅) Γrest (v • ∅) ρ₂ t

lift-term-doWeakenOne-ignore′ (τ₀ • Γprefix) (τ₂ • Γrest) {τ} (v₀ • ρ₁) (dv • v • ρ₂) t = {!!}
--Look at C-c C-, for the normalized goal.
-- The solution here should be something like:
  --lift-term-doWeakenOne-ignore′ (τ₀ • Γprefix ⋎ (τ₂ • ∅)) Γrest {τ} ((v₀ • ρ₁) ∪ (v • ∅)) ρ₂  ?

-- accompanied by enough subst to make it typecheck, and maybe by
-- weakenOne-ignore to account for weakenOne - or maybe not since
-- weakenOne is a definitional equality. PG
-- Not planning to finish this, it looks quite horrible.

lift-term-weakenOne-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′-weakenOne Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-weakenOne-ignore′ {Γ} {τ} Γ′ {ρ} t =
  begin
    ⟦
      substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
        (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
          (substTerm (sym (take-drop Γ Γ′))
            t))
      ⟧ ρ
  --≡⟨ {!≡-cong!} ⟩
    --{!!}
  ≡⟨ {!!} ⟩
    ⟦ t ⟧ (ignore′ Γ′ ρ)
  ∎
  where
    open ≡-Reasoning

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = lift-term′-weakenOne Γ′ (Δ t)
lift-term′ {τ = τ} Γ′ (weakenOne Γ₁ τ₂ {Γ₃} t) = lift-weakened-term Γ₁ τ₂ Γ′ t
  where
    double-weakenOne :
      ∀ Γ₁ {Γ₃ τ} τ₂ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₃))) τ
    double-weakenOne Γ₁ {Γ₃} τ₂ t =
      substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
        (weakenOne (Δ-Context Γ₁) _
          (weakenOne (Δ-Context Γ₁) _
            (substTerm (Δ-Context-⋎ Γ₁ Γ₃) (lift-term′ ∅ t))))

    lift-weakened-term :
      ∀ Γ₁ {Γ₃ τ} τ₂ Γ′ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context′ (Γ₁ ⋎ (τ₂ • Γ₃)) Γ′) τ
    lift-weakened-term ∅ τ₂ ∅ t = double-weakenOne ∅ τ₂ t
    lift-weakened-term Γ₁ τ₂ ∅ t = double-weakenOne Γ₁ τ₂ t
    lift-weakened-term ∅ τ₃ (.τ₃ • Γ′₁) t₁ = weakenOne ∅ τ₃ (lift-term′ Γ′₁ t₁)
    lift-weakened-term (τ₁ • Γ₁) {Γ₃} τ₂ (.τ₁ • Γ′₁) t₁ =
      lift-term′-weakenOne (τ₁ • Γ′₁) (weakenOne (τ₁ • Γ₁) τ₂ t₁)
    -- In the last case, I was not able to finish without using the expensive
    -- lift-term′-weakenOne

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | refl = lift-term-ignore′ Γ′ t₂
... | false | false | refl = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext-t (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext-t (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext-t (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}

module total where

-- INCREMENTAL λ-CALCULUS
--   with total derivatives
--
-- Features:
--   * changes and derivatives are unified (following Cai)
--   * Δ e describes how e changes when its free variables or its arguments change
--   * denotational semantics including semantics of changes
--
-- Work in Progress:
--   * lemmas about behavior of changes
--   * lemmas about behavior of Δ
--   * correctness proof for symbolic derivation

import Relation.Binary as B

open import Relation.Binary using
  (IsEquivalence; Setoid; Reflexive; Symmetric; Transitive)
import Relation.Binary.EqReasoning as EqR

open import Relation.Nullary using (¬_)

open import meaning
open import Model
open import Changes
open import ChangeContexts
open import binding Type ⟦_⟧Type
open import TotalTerms

open import Relation.Binary.PropositionalEquality

-- LIFTING terms into Δ-Contexts

lift-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) τ
lift-var this = that this
lift-var (that x) = that (that (lift-var x))

lift-var′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Var Γ τ → Var (Δ-Context′ Γ Γ′) τ
lift-var′ ∅ x = lift-var x
lift-var′ (τ • Γ′) this = this
lift-var′ (τ • Γ′) (that x) = that (lift-var′ Γ′ x)

-- This version of lift-term′ uses just weakenOne to accomplish its
-- job.

lift-term′-doWeakenMore : ∀ Γprefix Γrest {τ} →
  Term (Γprefix ⋎ Γrest) τ →
  Term (Γprefix ⋎ Δ-Context Γrest) τ

lift-term′-doWeakenMore Γprefix ∅ t₁ = t₁
lift-term′-doWeakenMore Γprefix (τ₂ • Γrest) t₁ =
  weakenOne Γprefix (Δ-Type τ₂)
    (substTerm (sym (move-prefix Γprefix τ₂ (Δ-Context Γrest)))
      (lift-term′-doWeakenMore (Γprefix ⋎ (τ₂ • ∅)) Γrest
        (substTerm (move-prefix Γprefix τ₂ Γrest) t₁)))

lift-term′-weakenOne : ∀ {Γ τ} Γ′ →
  Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′-weakenOne {Γ} Γ′ t =
  substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
    (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
      (substTerm (sym (take-drop Γ Γ′))
        t))

weakenOne-ignore :
 ∀ Γ₁ τ₂ {Γ₃ τ} → (t : Term (Γ₁ ⋎ Γ₃) τ) →
   {ρ : ⟦ Γ₁ ⋎ (τ₂ • Γ₃) ⟧} →
   ⟦ weakenOne Γ₁ τ₂ t ⟧ ρ ≡ ⟦ t ⟧ (weakenEnv Γ₁ τ₂ ρ)
weakenOne-ignore Γ₁ τ₂ t {ρ} = ≡-refl

_∪_ : ∀ {Γ Γ′} → (ρ : ⟦ Γ ⟧) → (ρ′ : ⟦ Γ′ ⟧) → ⟦ Γ ⋎ Γ′ ⟧
_∪_ {∅} {Γ′} ∅ ρ′ = ρ′
_∪_ {τ • Γ} {Γ′} (v • ρ) ρ′ = v • ρ ∪ ρ′

lift-term-doWeakenOne-ignore′ : ∀ Γprefix Γrest {τ} →
  {ρ₁ : ⟦ Γprefix ⟧} {ρ₂ : ⟦ Δ-Context Γrest ⟧}
  (t : Term (Γprefix ⋎ Γrest) τ) →
  ⟦ lift-term′-doWeakenMore Γprefix Γrest t ⟧ (ρ₁ ∪ ρ₂) ≡ ⟦ t ⟧ (ρ₁ ∪ ignore ρ₂)
lift-term-doWeakenOne-ignore′ = {!!}

lift-term-weakenOne-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′-weakenOne Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-weakenOne-ignore′ {Γ} {τ} Γ′ {ρ} t =
  begin
    ⟦
      substTerm (sym (take-⋎-Δ-Context-drop-Δ-Context′ Γ Γ′))
        (lift-term′-doWeakenMore (take Γ Γ′) (drop Γ Γ′)
          (substTerm (sym (take-drop Γ Γ′))
            t))
      ⟧ ρ
  --≡⟨ {!≡-cong!} ⟩
    --{!!}
  ≡⟨ {!!} ⟩
    ⟦ t ⟧ (ignore′ Γ′ ρ)
  ∎
  where
    open ≡-Reasoning

lift-term′ : ∀ {Γ τ} → (Γ′ : Prefix Γ) → Term Γ τ → Term (Δ-Context′ Γ Γ′) τ
lift-term′ Γ′ (abs t) = abs (lift-term′ (_ • Γ′) t)
lift-term′ Γ′ (app t₁ t₂) = app (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂)
lift-term′ Γ′ (var x) = var (lift-var′ Γ′ x)
lift-term′ Γ′ true = true
lift-term′ Γ′ false = false
lift-term′ Γ′ (if t₁ t₂ t₃) = if (lift-term′ Γ′ t₁) (lift-term′ Γ′ t₂) (lift-term′ Γ′ t₃)
lift-term′ Γ′ (Δ t) = lift-term′-weakenOne Γ′ (Δ t)
lift-term′ {τ = τ} Γ′ (weakenOne Γ₁ τ₂ {Γ₃} t) = lift-weakened-term Γ₁ τ₂ Γ′ t
  where
    double-weakenOne :
      ∀ Γ₁ {Γ₃ τ} τ₂ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context (Γ₁ ⋎ (τ₂ • Γ₃))) τ
    double-weakenOne Γ₁ {Γ₃} τ₂ t =
      substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
        (weakenOne (Δ-Context Γ₁) _
          (weakenOne (Δ-Context Γ₁) _
            (substTerm (Δ-Context-⋎ Γ₁ Γ₃) (lift-term′ ∅ t))))

    lift-weakened-term :
      ∀ Γ₁ {Γ₃ τ} τ₂ Γ′ → Term (Γ₁ ⋎ Γ₃) τ →
      Term (Δ-Context′ (Γ₁ ⋎ (τ₂ • Γ₃)) Γ′) τ
    lift-weakened-term ∅ τ₂ ∅ t = double-weakenOne ∅ τ₂ t
    lift-weakened-term Γ₁ τ₂ ∅ t = double-weakenOne Γ₁ τ₂ t
    lift-weakened-term ∅ τ₃ (.τ₃ • Γ′₁) t₁ = weakenOne ∅ τ₃ (lift-term′ Γ′₁ t₁)
    lift-weakened-term (τ₁ • Γ₁) {Γ₃} τ₂ (.τ₁ • Γ′₁) t₁ =
      lift-term′-weakenOne (τ₁ • Γ′₁) (weakenOne (τ₁ • Γ₁) τ₂ t₁)
    -- In the last case, I was not able to finish without using the expensive
    -- lift-term′-weakenOne

lift-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) τ
lift-term = lift-term′ ∅

-- PROPERTIES of lift-term

lift-var-ignore : ∀ {Γ τ} (ρ : ⟦ Δ-Context Γ ⟧) (x : Var Γ τ) →
  ⟦ lift-var x ⟧ ρ ≡ ⟦ x ⟧ (ignore ρ)
lift-var-ignore (v • dv • ρ) this = ≡-refl
lift-var-ignore (v • dv • ρ) (that x) = lift-var-ignore ρ x

lift-var-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) (ρ : ⟦ Δ-Context′ Γ Γ′ ⟧) (x : Var Γ τ) →
  ⟦ lift-var′ Γ′ x ⟧ ρ ≡ ⟦ x ⟧ (ignore′ Γ′ ρ)
lift-var-ignore′ ∅ ρ x = lift-var-ignore ρ x
lift-var-ignore′ (τ • Γ′) (v • ρ) this = ≡-refl
lift-var-ignore′ (τ • Γ′) (v • ρ) (that x) = lift-var-ignore′ Γ′ ρ x

lift-term-ignore′ : ∀ {Γ τ} →
  (Γ′ : Prefix Γ) {ρ : ⟦ Δ-Context′  Γ Γ′ ⟧} (t : Term Γ τ) →
  ⟦ lift-term′ Γ′ t ⟧ ρ ≡ ⟦ t ⟧ (ignore′ Γ′ ρ)
lift-term-ignore′ Γ′ (abs t) =
  ext (λ v → lift-term-ignore′ (_ • Γ′) t)
lift-term-ignore′ Γ′ (app t₁ t₂) =
  ≡-app (lift-term-ignore′ Γ′ t₁) (lift-term-ignore′ Γ′ t₂)
lift-term-ignore′ Γ′ (var x) = lift-var-ignore′ Γ′ _ x
lift-term-ignore′ Γ′ true = ≡-refl
lift-term-ignore′ Γ′ false = ≡-refl
lift-term-ignore′ Γ′ {ρ} (if t₁ t₂ t₃)
  with ⟦ lift-term′ Γ′ t₁ ⟧ ρ
     | ⟦ t₁ ⟧ (ignore′ Γ′ ρ)
     | lift-term-ignore′ Γ′ {ρ} t₁
... | true | true | refl = lift-term-ignore′ Γ′ t₂
... | false | false | refl = lift-term-ignore′ Γ′ t₃
lift-term-ignore′ Γ′ (Δ t) = {!!}
lift-term-ignore′ _ (weakenOne _ _ {_} {._} _) = {!!}

lift-term-ignore : ∀ {Γ τ} {ρ : ⟦ Δ-Context Γ ⟧} (t : Term Γ τ) →
  ⟦ lift-term t ⟧ ρ ≡ ⟦ t ⟧ (ignore ρ)
lift-term-ignore = lift-term-ignore′ ∅

-- PROPERTIES of Δ

Δ-abs : ∀ {Γ τ₁ τ₂} (t : Term (τ₁ • Γ) τ₂) →
  Δ (abs t) ≈ abs (abs (Δ t))
Δ-abs t = ext-t (λ ρ → ≡-refl)

Δ-app : ∀ {Γ τ₁ τ₂} (t₁ : Term Γ (τ₁ ⇒ τ₂)) (t₂ : Term Γ τ₁) →
  Δ (app t₁ t₂) ≈ app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
Δ-app t₁ t₂ = ≈-sym (ext-t (λ ρ →
  begin
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ lift-term t₂ ⟧ ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ lift-term t₂ ⟧ ρ))
  ≡⟨ ≡-cong
       (λ x →
          diff
          (⟦ t₁ ⟧ (update ρ)
           (apply (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ))) x))
          (⟦ t₁ ⟧ (ignore ρ) x))
       (lift-term-ignore {ρ = ρ} t₂) ⟩
    diff
      (⟦ t₁ ⟧ (update ρ)
       (apply
         (diff (⟦ t₂ ⟧ (update ρ)) (⟦ t₂ ⟧ (ignore ρ)))
         (⟦ t₂ ⟧ (ignore ρ))))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ≡⟨  ≡-cong
       (λ x →
          diff (⟦ t₁ ⟧ (update ρ) x) (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ))))
       (apply-diff (⟦ t₂ ⟧ (ignore ρ)) (⟦ t₂ ⟧ (update ρ)))  ⟩
    diff
      (⟦ t₁ ⟧ (update ρ) (⟦ t₂ ⟧ (update ρ)))
      (⟦ t₁ ⟧ (ignore ρ) (⟦ t₂ ⟧ (ignore ρ)))
  ∎)) where open ≡-Reasoning

-- SYMBOLIC DERIVATION

derive-var : ∀ {Γ τ} → Var Γ τ → Var (Δ-Context Γ) (Δ-Type τ)
derive-var this = this
derive-var (that x) = that (that (derive-var x))

_and_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a and b = if a b false

!_ : ∀ {Γ} → Term Γ bool → Term Γ bool
! x = if x false true

-- XXX: to finish this, we just need to call lift-term, like in
-- derive-term. Should be easy, just a bit boring.
apply-pure-term : ∀ {τ Γ} → Term Γ (Δ-Type τ ⇒ τ ⇒ τ)
apply-pure-term {bool} = abs {!!}
apply-pure-term {τ₁ ⇒ τ₂} {Γ} = abs (abs (abs (app (app apply-pure-term (app (app (var (that (that this))) (var this)) ({!Δ {Γ} (var this)!}))) (app (var (that this)) (var this)))))
--abs (abs (abs (app (app apply-compose-term (app (var (that (that this))) (var this))) (app (var (that this)) (var this)))))
 -- λdf. λf.  λx.           apply (     df                       x       (Δx))  (     f                 x        )

-- Term xor
_xor-term_ : ∀ {Γ} → Term Γ bool → Term Γ bool → Term Γ bool
a xor-term b = if a (! b) b

diff-term : ∀ {τ Γ} → Term Γ τ → Term Γ τ → Term Γ (Δ-Type τ)
diff-term {τ ⇒ τ₁} = λ f₁ f₂ → {!diff-term (f₁ x) (f₂ x)!}
diff-term {bool} = _xor-term_

apply-term : ∀ {τ Γ} → Term Γ (Δ-Type τ) → Term Γ τ → Term Γ τ
apply-term {τ ⇒ τ₁} = {!!}
apply-term {bool} = _xor-term_

derive-term : ∀ {Γ τ} → Term Γ τ → Term (Δ-Context Γ) (Δ-Type τ)
derive-term (abs t) = abs (abs (derive-term t))
derive-term (app t₁ t₂) = app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
derive-term (var x) = var (derive-var x)
derive-term true = false
derive-term false = false
derive-term (if c t e) =
  if ((derive-term c) and (lift-term c))
    (diff-term (apply-term (derive-term e) (lift-term e)) (lift-term t))
    (if ((derive-term c) and (lift-term (! c)))
      (diff-term (apply-term (derive-term t) (lift-term t)) (lift-term e))
      (if (lift-term c)
        (derive-term t)
        (derive-term e)))

derive-term (Δ t) = Δ (derive-term t)
derive-term (weakenOne Γ₁ τ₂ {Γ₃} t) =
  substTerm (Δ-Context-⋎-expanded Γ₁ τ₂ Γ₃)
    (weakenOne (Δ-Context Γ₁) (Δ-Type τ₂)
      (weakenOne (Δ-Context Γ₁) τ₂
        (substTerm (Δ-Context-⋎ Γ₁ Γ₃)
          (derive-term t))))

-- CORRECTNESS of derivation

derive-var-correct : ∀ {Γ τ} → (ρ : ⟦ Δ-Context Γ ⟧) → (x : Var Γ τ) →
  diff (⟦ x ⟧ (update ρ)) (⟦ x ⟧ (ignore ρ)) ≡
  ⟦ derive-var x ⟧ ρ
derive-var-correct (dv • v • ρ) this = diff-apply dv v
derive-var-correct (dv • v • ρ) (that x) = derive-var-correct ρ x

derive-term-correct : ∀ {Γ τ} → (t : Term Γ τ) →
   Δ t ≈ derive-term t
derive-term-correct {Γ} (abs t) =
  begin
    Δ (abs t)
  ≈⟨ Δ-abs t ⟩
    abs (abs (Δ t))
  ≈⟨ ≈-abs (≈-abs (derive-term-correct t)) ⟩
    abs (abs (derive-term t))
  ≈⟨ ≈-refl ⟩
    derive-term (abs t)
  ∎ where open ≈-Reasoning
derive-term-correct (app t₁ t₂) =
  begin
    Δ (app t₁ t₂)
  ≈⟨ Δ-app t₁ t₂ ⟩
    app (app (Δ t₁) (lift-term t₂)) (Δ t₂)
  ≈⟨ ≈-app (≈-app (derive-term-correct t₁) ≈-refl) (derive-term-correct t₂) ⟩
    app (app (derive-term t₁) (lift-term t₂)) (derive-term t₂)
  ≈⟨ ≈-refl ⟩
    derive-term (app t₁ t₂)
  ∎ where open ≈-Reasoning
derive-term-correct (var x) = ext-t (λ ρ → derive-var-correct ρ x)
derive-term-correct true = ext-t (λ ρ → ≡-refl)
derive-term-correct false = ext-t (λ ρ → ≡-refl)
derive-term-correct (if t₁ t₂ t₃) = {!!}
derive-term-correct (Δ t) = ≈-Δ (derive-term-correct t)
derive-term-correct (weakenOne _ _ t) = {!!}


Update to Neglible

Update to Neglible

{-# OPTIONS --copatterns #-}
open import Algebra

open import Function

open import Data.Nat.NP
open import Data.Nat.Distance
open import Data.Nat.Properties
open import Data.Two
open import Data.Zero
open import Data.Product

open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP

open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base

module Neglible where

module prop = CommutativeSemiring commutativeSemiring
module OR = Poset (DecTotalOrder.poset decTotalOrder)

≤-*-cancel : ∀ {x m n} → 1 ≤ x →  x * m ≤ x * n → m ≤ n
≤-*-cancel {suc x} {m} {n} (s≤s le) mn
  rewrite prop.*-comm (suc x) m | prop.*-comm (suc x) n = cancel-*-right-≤ _ _ _ mn

record ℕ→ℚ : Set where
  constructor _/_[_]
  field
    εN : (n : ℕ) → ℕ
    εD : (n : ℕ) → ℕ
    εD-pos : ∀ n → εD n > 0

record Is-Neg (ε : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ ε
  field
    cₙ : (c : ℕ) → ℕ
    prf : ∀(c n : ℕ) → n > cₙ n → n ^ c * εN n ≤ εD n
open Is-Neg

0ℕℚ : ℕ→ℚ
ℕ→ℚ.εN 0ℕℚ _ = 0
ℕ→ℚ.εD 0ℕℚ _ = 1
ℕ→ℚ.εD-pos 0ℕℚ _ = s≤s z≤n

0ℕℚ-neg : Is-Neg 0ℕℚ
cₙ 0ℕℚ-neg _ = 0
prf 0ℕℚ-neg c n x = OR.trans (OR.reflexive (proj₂ prop.zero (n ^ c))) z≤n

_+ℕℚ_ : ℕ→ℚ → ℕ→ℚ → ℕ→ℚ
ℕ→ℚ.εN ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εN n * μD n + μN n * εD n
ℕ→ℚ.εD ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εD n * μD n
ℕ→ℚ.εD-pos ((εN / εD [ εD+ ]) +ℕℚ (μN / μD [ μD+ ])) n = εD+ n *-mono μD+ n

+ℕℚ-neg : {ε μ : ℕ→ℚ} → Is-Neg ε → Is-Neg μ → Is-Neg (ε +ℕℚ μ)
cₙ (+ℕℚ-neg ε μ) n = 1 + cₙ ε n + cₙ μ n
prf (+ℕℚ-neg {εM} {μM} ε μ) c n n>nc = ≤-*-cancel {x = n} (OR.trans (s≤s z≤n) n>nc) lemma
  where

  open ≤-Reasoning
  open ℕ→ℚ εM
  open ℕ→ℚ μM renaming (εN to μN; εD to μD; εD-pos to μD-pos)

  lemma =  n * (n ^ c * (εN n * μD n + μN n * εD n))
        ≡⟨ ! prop.*-assoc n (n ^ c) _
         ∙ proj₁ prop.distrib (n ^ (1 + c)) (εN n * μD n) (μN n * εD n)
         ∙ ap₂ _+_ (! prop.*-assoc (n ^ (1 + c)) (εN n) (μD n))
                   (! (prop.*-assoc (n ^ (1 + c)) (μN n) (εD n))) ⟩
           n ^ (1 + c) * εN n * μD n + n ^ (1 + c) * μN n * εD n
        ≤⟨     (prf ε (1 + c) n (OR.trans (s≤s (≤-step (m≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (μD n ∎))
        +-mono (prf μ (1 + c) n (OR.trans (s≤s (≤-step (n≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (εD n ∎)) ⟩
           εD n * μD n + μD n * εD n
        ≡⟨ ap₂ _+_ (refl {x = εD n * μD n}) (prop.*-comm (μD n) (εD n) ∙ ! proj₂ prop.+-identity (εD n * μD n)) ⟩
           2 * (εD n * μD n)
        ≤⟨ OR.trans (s≤s (s≤s z≤n)) n>nc *-mono (εD n * μD n ∎) ⟩
           n * (εD n * μD n)
        ∎

infix 4 _≤→_
record _≤→_ (f g : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ f renaming (εN to fN; εD to fD)
  open ℕ→ℚ g renaming (εN to gN; εD to gD)
  field
    -- fN k / fD k ≤ gN k / gD k
    ≤→ : ∀ k → fN k * gD k ≤ gN k * fD k

≤→-trans : ∀ {f g h} → f ≤→ g → g ≤→ h → f ≤→ h
_≤→_.≤→ (≤→-trans {fN / fD [ fD-pos ]} {gN / gD [ gD-pos ]} {hN / hD [ hD-pos ]} (mk fg) (mk gh)) k
  = ≤-*-cancel (gD-pos k) lemma
  where
    open ≤-Reasoning
    lemma : gD k * (fN k * hD k) ≤ gD k * (hN k * fD k)
    lemma = gD k * (fN k * hD k)
          ≡⟨ ! prop.*-assoc (gD k) (fN k) (hD k)
             ∙ ap (flip _*_ (hD k)) (prop.*-comm (gD k) (fN k))
           ⟩
            (fN k * gD k) * hD k
          ≤⟨ fg k *-mono OR.refl ⟩
            (gN k * fD k) * hD k
          ≡⟨ prop.*-assoc (gN k) (fD k) (hD k)
             ∙ ap (_*_ (gN k)) (prop.*-comm (fD k) (hD k))
             ∙ ! prop.*-assoc (gN k) (hD k) (fD k)
           ⟩
            (gN k * hD k) * fD k
          ≤⟨ gh k *-mono OR.refl ⟩
            (hN k * gD k) * fD k
          ≡⟨ ap (flip _*_ (fD k)) (prop.*-comm (hN k) (gD k))
             ∙ prop.*-assoc (gD k) (hN k) (fD k)
           ⟩
            gD k * (hN k * fD k)
          ∎

+ℕℚ-mono : ∀ {f f' g g'} → f ≤→ f' → g ≤→ g' → f +ℕℚ g ≤→ f' +ℕℚ g'
_≤→_.≤→ (+ℕℚ-mono {fN / fD [ _ ]} {f'N / f'D [ _ ]} {gN / gD [ _ ]} {g'N / g'D [ _ ]} (mk ff) (mk gg)) k
  = (fN k * gD k + gN k * fD k) * (f'D k * g'D k)
  ≡⟨ proj₂ prop.distrib (f'D k * g'D k) (fN k * gD k) (gN k * fD k)  ⟩
    fN k * gD k * (f'D k * g'D k) + gN k * fD k * (f'D k * g'D k)
  ≡⟨ ap₂ _+_ (*-interchange (fN k) (gD k) (f'D k) (g'D k) ∙ ap (_*_ (fN k * f'D k)) (prop.*-comm (gD k) (g'D k)))
             (ap (_*_ (gN k * fD k)) (prop.*-comm (f'D k) (g'D k)) ∙ *-interchange (gN k) (fD k) (g'D k) (f'D k))
   ⟩
    fN k * f'D k * (g'D k * gD k) + gN k * g'D k * (fD k * f'D k)
  ≤⟨ (ff k *-mono OR.refl) +-mono (gg k *-mono OR.refl) ⟩
    f'N k * fD k * (g'D k * gD k) + g'N k * gD k * (fD k * f'D k)
  ≡⟨ ap₂ _+_ (*-interchange (f'N k) (fD k) (g'D k) (gD k))
             (ap (_*_ (g'N k * gD k)) (prop.*-comm (fD k) (f'D k))
             ∙ *-interchange (g'N k) (gD k) (f'D k) (fD k)
             ∙ ap (_*_ (g'N k * f'D k)) (prop.*-comm (gD k) (fD k)))
   ⟩
    f'N k * g'D k * (fD k * gD k) + g'N k * f'D k * (fD k * gD k)
  ≡⟨ ! proj₂ prop.distrib (fD k * gD k) (f'N k * g'D k) (g'N k * f'D k) ⟩
    (f'N k * g'D k + g'N k * f'D k) * (fD k * gD k)
  ∎
  where
    open ≤-Reasoning

record NegBounded (f : ℕ→ℚ) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
      ε-neg : Is-Neg ε
      bounded : f ≤→ ε

module _ where
  open NegBounded
  ≤-NB : {f g : ℕ→ℚ} → f ≤→ g → NegBounded g → NegBounded f
  ε (≤-NB le nb) = ε nb
  ε-neg (≤-NB le nb) = ε-neg nb
  bounded (≤-NB le nb) = ≤→-trans le (bounded nb)

  _+NB_ : {f g : ℕ→ℚ} → NegBounded f → NegBounded g → NegBounded (f +ℕℚ g)
  ε (fNB +NB gNB) = ε fNB +ℕℚ ε gNB
  ε-neg (fNB +NB gNB) = +ℕℚ-neg (ε-neg fNB) (ε-neg gNB)
  bounded (fNB +NB gNB) = +ℕℚ-mono (bounded fNB) (bounded gNB)

module ~-NegBounded (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n))(inh : ∀ x → 0 < Card (Rᵁ x)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  ~dist : (f g : (x : ℕ) → R x → 𝟚) → ℕ→ℚ
  ℕ→ℚ.εN (~dist f g) n = dist (# (f n)) (# (g n))
  ℕ→ℚ.εD (~dist f g) n = Card (Rᵁ n)
  ℕ→ℚ.εD-pos (~dist f g) n = inh n

  ~dist-sum : ∀ f g h → ~dist f h ≤→ ~dist f g +ℕℚ ~dist g h
  _≤→_.≤→ (~dist-sum f g h) k
      = #fh * (|R| * |R|)
      ≤⟨ dist-sum #f #g #h *-mono OR.refl ⟩
        (#fg + #gh) * (|R| * |R|)
      ≡⟨ ! prop.*-assoc (#fg + #gh) |R| |R| ∙ ap (flip _*_ |R|) (proj₂ prop.distrib |R| #fg #gh) ⟩
        (#fg * |R| + #gh * |R|) * |R|
      ∎
    where
      open ≤-Reasoning
      |R| = Card (Rᵁ k)
      #f = # (f k)
      #g = # (g k)
      #h = # (h k)
      #fh = dist #f #h
      #fg = dist #f #g
      #gh = dist #g #h

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ~ : NegBounded (~dist f g)

  ~-trans : Transitive _~_
  _~_.~ (~-trans {f}{g}{h} fg gh) = ≤-NB (~dist-sum f g h) (_~_.~ fg +NB _~_.~ gh)

module ~-Inlined (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
    open ℕ→ℚ ε
    field
      ε-neg : Is-Neg ε
      bounded : ∀ k → εD k * dist (# (f k)) (# (g k)) ≤ Card (Rᵁ k) * εN k

  ~-trans : Transitive _~_
  _~_.ε (~-trans x x₁) = _
  _~_.ε-neg (~-trans x x₁) = +ℕℚ-neg (_~_.ε-neg x) (_~_.ε-neg x₁)
  _~_.bounded (~-trans {f}{g}{h}(mk ε₀ ε₀-neg fg) (mk ε₁ ε₁-neg gh)) k
      = (b * d) * dist #f #h
      ≤⟨ (b * d ∎) *-mono dist-sum #f #g #h ⟩
        (b * d) * (dist #f #g + dist #g #h)
      ≡⟨ proj₁ prop.distrib (b * d) (dist #f #g) (dist #g #h)
         ∙ ap₂ _+_ (ap₂ _*_ (prop.*-comm b d) refl
         ∙ prop.*-assoc d b (dist #f #g)) (prop.*-assoc b d (dist #g #h))
       ⟩
        d * (b * dist #f #g) + b * (d * dist #g #h)
      ≤⟨ ((d ∎) *-mono fg k) +-mono ((b ∎) *-mono gh k) ⟩
        d * (|R| * a) + b * (|R| * c)
      ≡⟨ ap₂ _+_ (rot d |R| a) (rot b |R| c) ∙ ! proj₁ prop.distrib |R| (a * d) (c * b) ⟩
        |R| * ℕ→ℚ.εN (ε₀ +ℕℚ ε₁) k
      ∎
   where
     open ≤-Reasoning
     rot : ∀ x y z → x * (y * z) ≡ y * (z * x)
     rot x y z = prop.*-comm x (y * z) ∙ prop.*-assoc y z x
     |R| = Card (Rᵁ k)
     #f = # (f k)
     #g = # (g k)
     #h = # (h k)
     a = ℕ→ℚ.εN ε₀ k
     b = ℕ→ℚ.εD ε₀ k
     c = ℕ→ℚ.εN ε₁ k
     d = ℕ→ℚ.εD ε₁ k
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --copatterns #-}
open import Algebra

open import Function

open import Data.Nat.NP
open import Data.Nat.Distance
open import Data.Nat.Properties
open import Data.Two
open import Data.Zero
open import Data.Product

open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP

open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base

module Neglible where

module prop = CommutativeSemiring commutativeSemiring
module OR = Poset (DecTotalOrder.poset decTotalOrder)

≤-*-cancel : ∀ {x m n} → 1 ≤ x →  x * m ≤ x * n → m ≤ n
≤-*-cancel {suc x} {m} {n} (s≤s le) mn
  rewrite prop.*-comm (suc x) m | prop.*-comm (suc x) n = cancel-*-right-≤ _ _ _ mn

record ℕ→ℚ : Set where
  constructor _/_[_]
  field
    εN : (n : ℕ) → ℕ
    εD : (n : ℕ) → ℕ
    εD-pos : ∀ n → εD n > 0

record Is-Neg (ε : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ ε
  field
    cₙ : (c : ℕ) → ℕ
    prf : ∀(c n : ℕ) → n > cₙ n → n ^ c * εN n ≤ εD n
open Is-Neg

0ℕℚ : ℕ→ℚ
ℕ→ℚ.εN 0ℕℚ _ = 0
ℕ→ℚ.εD 0ℕℚ _ = 1
ℕ→ℚ.εD-pos 0ℕℚ _ = s≤s z≤n

0ℕℚ-neg : Is-Neg 0ℕℚ
cₙ 0ℕℚ-neg _ = 0
prf 0ℕℚ-neg c n x = OR.trans (OR.reflexive (proj₂ prop.zero (n ^ c))) z≤n

_+ℕℚ_ : ℕ→ℚ → ℕ→ℚ → ℕ→ℚ
ℕ→ℚ.εN ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εN n * μD n + μN n * εD n
ℕ→ℚ.εD ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εD n * μD n
ℕ→ℚ.εD-pos ((εN / εD [ εD+ ]) +ℕℚ (μN / μD [ μD+ ])) n = εD+ n *-mono μD+ n

+ℕℚ-neg : {ε μ : ℕ→ℚ} → Is-Neg ε → Is-Neg μ → Is-Neg (ε +ℕℚ μ)
cₙ (+ℕℚ-neg ε μ) n = 1 + cₙ ε n + cₙ μ n
prf (+ℕℚ-neg {εM} {μM} ε μ) c n n>nc = ≤-*-cancel {x = n} (OR.trans (s≤s z≤n) n>nc) lemma
  where

  open ≤-Reasoning
  open ℕ→ℚ εM
  open ℕ→ℚ μM renaming (εN to μN; εD to μD; εD-pos to μD-pos)

  lemma =  n * (n ^ c * (εN n * μD n + μN n * εD n))
        ≡⟨ ! prop.*-assoc n (n ^ c) _
         ∙ proj₁ prop.distrib (n ^ (1 + c)) (εN n * μD n) (μN n * εD n)
         ∙ ap₂ _+_ (! prop.*-assoc (n ^ (1 + c)) (εN n) (μD n))
                   (! (prop.*-assoc (n ^ (1 + c)) (μN n) (εD n))) ⟩
           n ^ (1 + c) * εN n * μD n + n ^ (1 + c) * μN n * εD n
        ≤⟨     (prf ε (1 + c) n (OR.trans (s≤s (≤-step (m≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (μD n ∎))
        +-mono (prf μ (1 + c) n (OR.trans (s≤s (≤-step (n≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (εD n ∎)) ⟩
           εD n * μD n + μD n * εD n
        ≡⟨ ap₂ _+_ (refl {x = εD n * μD n}) (prop.*-comm (μD n) (εD n) ∙ ! proj₂ prop.+-identity (εD n * μD n)) ⟩
           2 * (εD n * μD n)
        ≤⟨ OR.trans (s≤s (s≤s z≤n)) n>nc *-mono (εD n * μD n ∎) ⟩
           n * (εD n * μD n)
        ∎

module _ (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
    open ℕ→ℚ ε
    field
      ε-neg : Is-Neg ε
      bounded : ∀ k → εD k * dist (# (f k)) (# (g k)) ≤ Card (Rᵁ k) * εN k

  ~-trans : Transitive _~_
  _~_.ε (~-trans x x₁) = _
  _~_.ε-neg (~-trans x x₁) = +ℕℚ-neg (_~_.ε-neg x) (_~_.ε-neg x₁)
  _~_.bounded (~-trans {f}{g}{h}(mk ε₀ ε₀-neg fg) (mk ε₁ ε₁-neg gh)) k
      = (b * d) * dist #f #h
      ≤⟨ (b * d ∎) *-mono dist-sum #f #g #h ⟩
        (b * d) * (dist #f #g + dist #g #h)
      ≡⟨ proj₁ prop.distrib (b * d) (dist #f #g) (dist #g #h)
         ∙ ap₂ _+_ (ap₂ _*_ (prop.*-comm b d) refl
         ∙ prop.*-assoc d b (dist #f #g)) (prop.*-assoc b d (dist #g #h))
       ⟩
        d * (b * dist #f #g) + b * (d * dist #g #h)
      ≤⟨ ((d ∎) *-mono fg k) +-mono ((b ∎) *-mono gh k) ⟩
        d * (|R| * a) + b * (|R| * c)
      ≡⟨ ap₂ _+_ (rot d |R| a) (rot b |R| c) ∙ ! proj₁ prop.distrib |R| (a * d) (c * b) ⟩
        |R| * ℕ→ℚ.εN (ε₀ +ℕℚ ε₁) k
      ∎
   where
     open ≤-Reasoning
     rot : ∀ x y z → x * (y * z) ≡ y * (z * x)
     rot x y z = prop.*-comm x (y * z) ∙ prop.*-assoc y z x
     |R| = Card (Rᵁ k)
     #f = # (f k)
     #g = # (g k)
     #h = # (h k)
     a = ℕ→ℚ.εN ε₀ k
     b = ℕ→ℚ.εD ε₀ k
     c = ℕ→ℚ.εN ε₁ k
     d = ℕ→ℚ.εD ε₁ k
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


Added difference lemma

Added difference lemma

open import Function
open import Data.Nat.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≗_; _≡_)

open import Data.Bits
import flipbased

module flipbased-counting
   (↺ : ∀ {a} → ℕ → Set a → Set a)
   (toss : ↺ 1 Bit)
   (return↺ : ∀ {n a} {A : Set a} → A → ↺ n A)
   (map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B)
   (join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A)
   (count↺ : ∀ {n} → ↺ n Bit → ℕ)
 where

open flipbased ↺ toss return↺ map↺ join↺

infix 4 _≈↺_ _≋↺_ _≈⅁?_ _≈ᴬ_ _≈ᴬ′_

-- f ≈↺ g when f and g return the same number of 1 (and 0).
_≈↺_ : ∀ {n} (f g : EXP n) → Set
_≈↺_ = _≡_ on count↺

_≈⅁?_ : ∀ {c} (g₀ g₁ : ⅁? c) → Set
g₀ ≈⅁? g₁ = ∀ b → g₀ b ≈↺ g₁ b

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

_≈ᴬ′_ : ∀ {n a} {A : Set a} (f g : ↺ n A) → Set _
_≈ᴬ′_ {n} {A = A} f g = ∀ {ca} (Adv : A → ↺ ca Bit) → f >>= Adv ≈↺ g >>= Adv

{- Restore if we find more use of it
RelatedEXP : (ℕ → ℕ → Set) → ∀ {m n} → EXP m → EXP n → Set
RelatedEXP _∼_ {m} {n} f g = ⟨2^ n * count↺ f ⟩ ∼ ⟨2^ m * count↺ g ⟩

module ... z where
  x ∼ y = dist x y > ... z ...
-}

_≋↺_ : ∀ {m n} → EXP m → EXP n → Set
-- _≋↺_ = RelatedEXP _≡_
_≋↺_ {m} {n} f g = ⟨2^ n * count↺ f ⟩ ≡ ⟨2^ m * count↺ g ⟩

Safe⅁? : ∀ {c} (f : ⅁? c) → Set
Safe⅁? f = f 0b ≈↺ f 1b

Reversible⅁? : ∀ {c} (g : ⅁? c) → Set
Reversible⅁? g = g ≈⅁? g ∘ not

≈⇒≋↺ : ∀ {n} {f g : EXP n} → f ≈↺ g → f ≋↺ g
≈⇒≋↺ eq rewrite eq = ≡.refl

≋⇒≈↺ : ∀ {n} {f g : EXP n} → f ≋↺ g → f ≈↺ g
≋⇒≈↺ {n} = 2^-inj n

difference-lemma↺ : ∀ {n}(A B F : EXP n)
  → #⟨ |not| (run↺ F) |∧| run↺ A ⟩ ≡ #⟨ |not| (run↺ F) |∧| run↺ B ⟩
  → dist #⟨ run↺ A ⟩ #⟨ run↺ B ⟩ ≤ #⟨ run↺ F ⟩
difference-lemma↺ A B F = difference-lemma (run↺ A) (run↺ B) (run↺ F)

module ≈⅁? {n} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = ⅁? n

        ℛ : C → C → Set _
        ℛ = _≈⅁?_

        refl : Reflexive ℛ
        refl b = ≡.refl

        sym : Symmetric ℛ
        sym p b = ≡.sym (p b)

        trans : Transitive ℛ
        trans p q b = ≡.trans (p b) (q b)

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≋↺ {n} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = EXP n

        ℛ : C → C → Set _
        ℛ = _≋↺_

        refl : Reflexive ℛ
        refl = ≡.refl

        sym : Symmetric ℛ
        sym = ≡.sym

        trans : Transitive ℛ
        trans = ≡.trans

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≈↺ {n} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = EXP n

        ℛ : C → C → Set _
        ℛ = _≈↺_

        refl : Reflexive ℛ
        refl = ≡.refl

        sym : Symmetric ℛ
        sym = ≡.sym

        trans : Transitive ℛ
        trans = ≡.trans

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≈ᴬ {n} {a} {A : Set a} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = ↺ n A

        ℛ : C → C → Set _
        ℛ = _≈ᴬ_

        refl : Reflexive ℛ
        refl A = ≡.refl

        sym : Symmetric ℛ
        sym p A = ≡.sym (p A)

        trans : Transitive ℛ
        trans p q A = ≡.trans (p A) (q A)

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≈ᴬ′ {n} {a} {A : Set a} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = ↺ n A

        ℛ : C → C → Set _
        ℛ = _≈ᴬ′_

        refl : Reflexive ℛ
        refl A = ≡.refl

        sym : Symmetric ℛ
        sym p A = ≡.sym (p A)

        trans : Transitive ℛ
        trans p q A = ≡.trans (p A) (q A)

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ⅁? {n} where
  join : EXP n → EXP n → ⅁? n
  join f g b = if b then f else g

  safe-sym : ∀ {g : ⅁? n} → Safe⅁? g → Safe⅁? (g ∘ not)
  safe-sym {g} g-safe = ≈↺.sym {n} {g 0b} {g 1b} g-safe

  Reversible⇒Safe : ∀ {c} (g : ⅁? c) → Reversible⅁? g → Safe⅁? g
  Reversible⇒Safe g g≈g∘not = g≈g∘not 0b

data Rat : Set where _/_ : (num denom : ℕ) → Rat

Pr[_≡1] : ∀ {n} (f : EXP n) → Rat
Pr[_≡1] {n} f = count↺ f / 2^ n

open import Function
open import Data.Nat.NP
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≗_; _≡_)

open import Data.Bits
import flipbased

module flipbased-counting
   (↺ : ∀ {a} → ℕ → Set a → Set a)
   (toss : ↺ 1 Bit)
   (return↺ : ∀ {n a} {A : Set a} → A → ↺ n A)
   (map↺ : ∀ {n a b} {A : Set a} {B : Set b} → (A → B) → ↺ n A → ↺ n B)
   (join↺ : ∀ {n₁ n₂ a} {A : Set a} → ↺ n₁ (↺ n₂ A) → ↺ (n₁ + n₂) A)
   (count↺ : ∀ {n} → ↺ n Bit → ℕ)
 where

open flipbased ↺ toss return↺ map↺ join↺

infix 4 _≈↺_ _≋↺_ _≈⅁?_ _≈ᴬ_ _≈ᴬ′_

-- f ≈↺ g when f and g return the same number of 1 (and 0).
_≈↺_ : ∀ {n} (f g : EXP n) → Set
_≈↺_ = _≡_ on count↺

_≈⅁?_ : ∀ {c} (g₀ g₁ : ⅁? c) → Set
g₀ ≈⅁? g₁ = ∀ b → g₀ b ≈↺ g₁ b

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

_≈ᴬ′_ : ∀ {n a} {A : Set a} (f g : ↺ n A) → Set _
_≈ᴬ′_ {n} {A = A} f g = ∀ {ca} (Adv : A → ↺ ca Bit) → f >>= Adv ≈↺ g >>= Adv

{- Restore if we find more use of it
RelatedEXP : (ℕ → ℕ → Set) → ∀ {m n} → EXP m → EXP n → Set
RelatedEXP _∼_ {m} {n} f g = ⟨2^ n * count↺ f ⟩ ∼ ⟨2^ m * count↺ g ⟩

module ... z where
  x ∼ y = dist x y > ... z ...
-}

_≋↺_ : ∀ {m n} → EXP m → EXP n → Set
-- _≋↺_ = RelatedEXP _≡_
_≋↺_ {m} {n} f g = ⟨2^ n * count↺ f ⟩ ≡ ⟨2^ m * count↺ g ⟩

Safe⅁? : ∀ {c} (f : ⅁? c) → Set
Safe⅁? f = f 0b ≈↺ f 1b

Reversible⅁? : ∀ {c} (g : ⅁? c) → Set
Reversible⅁? g = g ≈⅁? g ∘ not

≈⇒≋↺ : ∀ {n} {f g : EXP n} → f ≈↺ g → f ≋↺ g
≈⇒≋↺ eq rewrite eq = ≡.refl

≋⇒≈↺ : ∀ {n} {f g : EXP n} → f ≋↺ g → f ≈↺ g
≋⇒≈↺ {n} = 2^-inj n

module ≈⅁? {n} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = ⅁? n

        ℛ : C → C → Set _
        ℛ = _≈⅁?_

        refl : Reflexive ℛ
        refl b = ≡.refl

        sym : Symmetric ℛ
        sym p b = ≡.sym (p b)

        trans : Transitive ℛ
        trans p q b = ≡.trans (p b) (q b)

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≋↺ {n} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = EXP n

        ℛ : C → C → Set _
        ℛ = _≋↺_

        refl : Reflexive ℛ
        refl = ≡.refl

        sym : Symmetric ℛ
        sym = ≡.sym

        trans : Transitive ℛ
        trans = ≡.trans

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≈↺ {n} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = EXP n

        ℛ : C → C → Set _
        ℛ = _≈↺_

        refl : Reflexive ℛ
        refl = ≡.refl

        sym : Symmetric ℛ
        sym = ≡.sym

        trans : Transitive ℛ
        trans = ≡.trans

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≈ᴬ {n} {a} {A : Set a} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = ↺ n A

        ℛ : C → C → Set _
        ℛ = _≈ᴬ_

        refl : Reflexive ℛ
        refl A = ≡.refl

        sym : Symmetric ℛ
        sym p A = ≡.sym (p A)

        trans : Transitive ℛ
        trans p q A = ≡.trans (p A) (q A)

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ≈ᴬ′ {n} {a} {A : Set a} where
  setoid : Setoid _ _
  setoid = record { Carrier = C; _≈_ = ℛ; isEquivalence = isEquivalence }
      where
        C : Set _
        C = ↺ n A

        ℛ : C → C → Set _
        ℛ = _≈ᴬ′_

        refl : Reflexive ℛ
        refl A = ≡.refl

        sym : Symmetric ℛ
        sym p A = ≡.sym (p A)

        trans : Transitive ℛ
        trans p q A = ≡.trans (p A) (q A)

        isEquivalence : IsEquivalence ℛ
        isEquivalence = record { refl = λ {x} → refl {x}
                               ; sym = λ {x y} → sym {x} {y}
                               ; trans = λ {x y z} → trans {x} {y} {z} }

  module Reasoning = Setoid-Reasoning setoid
  open Setoid setoid public

module ⅁? {n} where
  join : EXP n → EXP n → ⅁? n
  join f g b = if b then f else g

  safe-sym : ∀ {g : ⅁? n} → Safe⅁? g → Safe⅁? (g ∘ not)
  safe-sym {g} g-safe = ≈↺.sym {n} {g 0b} {g 1b} g-safe

  Reversible⇒Safe : ∀ {c} (g : ⅁? c) → Reversible⅁? g → Safe⅁? g
  Reversible⇒Safe g g≈g∘not = g≈g∘not 0b

data Rat : Set where _/_ : (num denom : ℕ) → Rat

Pr[_≡1] : ∀ {n} (f : EXP n) → Rat
Pr[_≡1] {n} f = count↺ f / 2^ n