Nat: FromAssocComm _*_, with implicit arguments

{-# OPTIONS --without-K #-}
module Data.Nat.NP where

open import Type hiding (★)
import Algebra
open import Algebra.FunctionProperties.Eq
open import Data.Two.Base hiding (_==_; _²)
open import Data.Product using (∃; _,_) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum renaming (map to ⊎-map)
open import Data.Zero using (𝟘-elim; 𝟘)
open import Data.One using (𝟙)
open import Function.NP
open import Function.Extensionality
open import Relation.Nullary
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; _≗_; module ≡-Reasoning; !_; _∙_; ap; ap₂; coe)
       renaming (refl to idp)
open import HoTT
open Equivalences

open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties

pattern 1+_ x = suc x
pattern 2+_ x = 1+ suc x
pattern 3+_ x = 2+ suc x
pattern 4+_ x = 3+ suc x

⟨0↔1⟩ : ℕ → ℕ
⟨0↔1⟩ 0 = 1
⟨0↔1⟩ 1 = 0
⟨0↔1⟩ n = n

private
  _² : ∀ {A : ★₀} → Endo (Endo A)
  f ² = f ∘ f

⟨0↔1⟩-involutive : ⟨0↔1⟩ ∘ ⟨0↔1⟩ ≗ id
⟨0↔1⟩-involutive 0             = idp
⟨0↔1⟩-involutive 1             = idp
⟨0↔1⟩-involutive (suc (suc _)) = idp

⇑⟨_⟩ : (ℕ → ℕ) → (ℕ → ℕ)
⇑⟨ f ⟩ zero    = zero
⇑⟨ f ⟩ (suc n) = suc (f n)

⟨0↔1+_⟩ : ℕ → ℕ → ℕ
⟨0↔1+ 0     ⟩ = ⟨0↔1⟩
⟨0↔1+ suc n ⟩ = ⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩ ∘ ⟨0↔1⟩

⟨_↔+1⟩ : ℕ → ℕ → ℕ
⟨ 0     ↔+1⟩ = ⟨0↔1⟩
⟨ suc n ↔+1⟩ 0       = 0
⟨ suc n ↔+1⟩ (suc m) = suc (⟨ n ↔+1⟩ m)

⟨_↔+1⟩-involutive : ∀ n → ⟨ n ↔+1⟩ ∘ ⟨ n ↔+1⟩ ≗ id
⟨_↔+1⟩-involutive 0 = ⟨0↔1⟩-involutive
⟨_↔+1⟩-involutive (suc _) 0       = idp
⟨_↔+1⟩-involutive (suc n) (suc m) = ap suc (⟨ n ↔+1⟩-involutive m)

⟨_↔+1⟩-equiv : ℕ → ℕ ≃ ℕ
⟨ n ↔+1⟩-equiv = self-inv-equiv ⟨ n ↔+1⟩ ⟨ n ↔+1⟩-involutive

⇑⟨_⟩-involutive : ∀ {f} → f ² ≗ id → ⇑⟨ f ⟩ ² ≗ id
⇑⟨ f²id ⟩-involutive zero    = idp
⇑⟨ f²id ⟩-involutive (suc x) = ap suc (f²id x)

⟨0↔1+_⟩-involutive : ∀ n → ⟨0↔1+ n ⟩ ² ≗ id
⟨0↔1+_⟩-involutive zero = ⟨0↔1⟩-involutive
⟨0↔1+_⟩-involutive (suc n) x = ap (⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩) (⟨0↔1⟩-involutive (⇑⟨ ⟨0↔1+ n ⟩ ⟩ (⟨0↔1⟩ x)))
  ∙ ap ⟨0↔1⟩ (⇑⟨ ⟨0↔1+ n ⟩-involutive ⟩-involutive (⟨0↔1⟩ x)) ∙ ⟨0↔1⟩-involutive x

module _ {{_ : UA}} where
    ⟨_↔+1⟩-eq : ℕ → ℕ ≡ ℕ
    ⟨_↔+1⟩-eq = ua ∘ ⟨_↔+1⟩-equiv

    ⟨_↔+1⟩-eq-β : ∀ n m → coe ⟨ n ↔+1⟩-eq m ≡ ⟨ n ↔+1⟩ m
    ⟨_↔+1⟩-eq-β = coe-β ∘ ⟨_↔+1⟩-equiv

ℕˢ = ≡.setoid ℕ

module ℕcmp = StrictTotalOrder strictTotalOrder
module ℕ≤   = DecTotalOrder decTotalOrder
module ℕ°   = Algebra.CommutativeSemiring commutativeSemiring
module ℕ+   = Algebra.CommutativeMonoid ℕ°.+-commutativeMonoid
module ℕ+′  = Algebra.Monoid ℕ°.+-monoid
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne
module ℕˢ   = Setoid ℕˢ

infixr 8 _∙≤_
_∙≤_ = ℕ≤.trans
_∙cmp_ = ℕcmp.trans
_∙<_ = <-trans

[P:_zero:_suc:_] : ∀ {p} (P : ℕ → ★ p) → P zero → (∀ {n} → P n → P (suc n)) → ∀ n → P n
[P: _ zero: z suc: _ ] zero    = z
[P: P zero: z suc: s ] (suc n) = s ([P: P zero: z suc: s ] n)

[zero:_suc:_] : ∀ {a} {A : ★ a} → A → (ℕ → A → A) → ℕ → A
[zero: z suc: s ] = [P: _ zero: z suc: (λ {n} → s n) ]

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ idp ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → ℕ.suc n ≡ suc m → n ≡ m
suc-injective = ap pred

+-≤-inj : ∀ x {y z} → x + y ≤ x + z → y ≤ z
+-≤-inj zero    = id
+-≤-inj (suc x) = +-≤-inj x ∘ ≤-pred

infixl 6 _+°_
infixl 7 _*°_ _⊓°_
infixl 6 _∸°_ _⊔°_

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

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

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

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

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

-- this one is not completly in line with the
-- others
_≤°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → ★ a
f ≤° g = ∀ x → f x ≤ g x

sucx≰x : ∀ x → suc x ≰ x
sucx≰x zero    = λ()
sucx≰x (suc x) = sucx≰x x ∘ ≤-pred

total-≤ : ∀ a b → a ≤ b ⊎ b ≤ a
total-≤ zero b = inj₁ z≤n
total-≤ (suc a) zero = inj₂ z≤n
total-≤ (suc a) (suc b) with total-≤ a b
... | inj₁ p = inj₁ (s≤s p)
... | inj₂ p = inj₂ (s≤s p)

a≡a⊓b+a∸b : ∀ a b → a ≡ a ⊓ b + (a ∸ b)
a≡a⊓b+a∸b zero zero = idp
a≡a⊓b+a∸b zero (suc b) = idp
a≡a⊓b+a∸b (suc a) zero = idp
a≡a⊓b+a∸b (suc a) (suc b) rewrite ! a≡a⊓b+a∸b a b = idp

¬n≤x<n : ∀ n {x} → n ≤ x → x < n → 𝟘
¬n≤x<n n p q = sucx≰x _ (q ∙≤ p)

¬n+≤y<n : ∀ n {x y} → n + x ≤ y → y < n → 𝟘
¬n+≤y<n n p q = sucx≰x _ (q ∙≤ ℕ≤.reflexive (ℕ°.+-comm 0 n) ∙≤ ℕ≤.refl {n} +-mono z≤n ∙≤ p)

fold : ∀ {a} {A : ★ a} → A → Endo A → ℕ → A
fold x f n = nest n f x

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = idp
  nest₁ : nest 1 f ≡ f
  nest₁ = idp
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = idp
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = idp

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = idp
  nest-+ (suc m) n = ap (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ap (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = idp
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ idp ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ap (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ idp ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ idp ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

+-inj-over-∸ : ∀ x y z → (x + y) ∸ (x + z) ≡ y ∸ z
+-inj-over-∸ = [i+j]∸[i+k]≡j∸k

2*_ : ℕ → ℕ
2* x = x + x

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite ℕ°.+-comm n 0 = idp

_==_ : (x y : ℕ) → 𝟚
zero   == zero   = 1₂
zero   == suc _  = 0₂
suc _  == zero   = 0₂
suc m  == suc n  = m == n

open FromAssocComm _+_ (λ {x}{y}{z} → ℕ°.+-assoc x y z) (λ {x}{y} → ℕ°.+-comm x y)
  renaming ( assoc-comm to +-assoc-comm
           ; interchange to +-interchange
           )

open FromAssocComm _*_ (λ {x}{y}{z} → ℕ°.*-assoc x y z) (λ {x}{y} → ℕ°.*-comm x y)
  renaming ( assoc-comm to *-assoc-comm
           ; interchange to *-interchange
           )

a+b≡a⊔b+a⊓b : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
a+b≡a⊔b+a⊓b zero    b       rewrite ℕ°.+-comm b 0 = idp
a+b≡a⊔b+a⊓b (suc a) zero    = idp
a+b≡a⊔b+a⊓b (suc a) (suc b) rewrite +-assoc-comm {a} {1} {b}
                                  | +-assoc-comm {a ⊔ b} {1} {a ⊓ b}
                                  | a+b≡a⊔b+a⊓b a b
                                  = idp

a⊓b≡a : ∀ {a b} → a ≤ b → a ⊓ b ≡ a
a⊓b≡a z≤n = idp
a⊓b≡a (s≤s a≤b) rewrite a⊓b≡a a≤b = idp

⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
⊔≤+ zero b          = ℕ≤.refl
⊔≤+ (suc a) zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 a))
⊔≤+ (suc a) (suc b) = s≤s (⊔≤+ a b ∙≤ ≤-step ℕ≤.refl ∙≤ ℕ≤.reflexive (+-assoc-comm {1} {a} {b}))

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘′ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = idp
2*′-spec (suc n) rewrite 2*′-spec n | +-assoc-comm {1} {n} {n} = idp

2^⟨_⟩* : ℕ → ℕ → ℕ
2^⟨ n ⟩* x = fold x 2*_ n

⟨2^_*_⟩ : ℕ → ℕ → ℕ
⟨2^ n * x ⟩ = 2^⟨ n ⟩* x

2*′-inj : ∀ {m n} → 2*′ m ≡ 2*′ n → m ≡ n
2*′-inj {zero}  {zero}  _ = idp
2*′-inj {zero}  {suc _} ()
2*′-inj {suc _} {zero}  ()
2*′-inj {suc m} {suc n} p = ap suc (2*′-inj (suc-injective (suc-injective p)))

2*-inj : ∀ {m n} → 2* m ≡ 2* n → m ≡ n
2*-inj {m} {n} p rewrite ! 2*′-spec m
                       | ! 2*′-spec n
                       = 2*′-inj p

2^-inj : ∀ k {m n} → ⟨2^ k * m ⟩ ≡ ⟨2^ k * n ⟩ → m ≡ n
2^-inj zero    = id
2^-inj (suc k) = 2^-inj k ∘ 2*-inj

2*-distrib : ∀ x y → 2* x + 2* y ≡ 2* (x + y)
2*-distrib x y = +-interchange {x} {x} {y} {y}

2^*-distrib : ∀ k x y → ⟨2^ k * (x + y)⟩ ≡ ⟨2^ k * x ⟩ + ⟨2^ k * y ⟩
2^*-distrib zero x y = idp
2^*-distrib (suc k) x y rewrite 2^*-distrib k x y = ! 2*-distrib ⟨2^ k * x ⟩ ⟨2^ k * y ⟩

2^*-2*-comm : ∀ k x → ⟨2^ k * 2* x ⟩ ≡ 2* ⟨2^ k * x ⟩
2^*-2*-comm k x = 2^*-distrib k x x

2*-mono : ∀ {a b} → a ≤ b → 2* a ≤ 2* b
2*-mono pf = pf +-mono pf

2^*-mono : ∀ k {a b} → a ≤ b → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩
2^*-mono zero    pf = pf
2^*-mono (suc k) pf = 2*-mono (2^*-mono k pf)

2*-mono′ : ∀ {a b} → 2* a ≤ 2* b → a ≤ b
2*-mono′ {zero} pf = z≤n
2*-mono′ {suc a} {zero} ()
2*-mono′ {suc a} {suc b} pf rewrite +-assoc-comm {a} {1} {a}
                                  | +-assoc-comm {b} {1} {b} = s≤s (2*-mono′ (≤-pred (≤-pred pf)))

2^*-mono′ : ∀ k {a b} → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩ → a ≤ b
2^*-mono′ zero    = id
2^*-mono′ (suc k) = 2^*-mono′ k ∘ 2*-mono′

2^-comm : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ y * ⟨2^ x * z ⟩ ⟩
2^-comm zero y z = idp
2^-comm (suc x) y z rewrite 2^-comm x y z = ! 2^*-2*-comm y ⟨2^ x * z ⟩

2^-+ : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ (x + y) * z ⟩
2^-+ zero    y z = idp
2^-+ (suc x) y z = ap 2*_ (2^-+ x y z)

cancel-*-left : ∀ i j {k} → suc k * i ≡ suc k * j → i ≡ j
cancel-*-left i j {k}
  rewrite ℕ°.*-comm (suc k) i
        | ℕ°.*-comm (suc k) j = cancel-*-right i j {k}

2ⁿ*0≡0 : ∀ n → ⟨2^ n * 0 ⟩ ≡ 0
2ⁿ*0≡0 zero    = idp
2ⁿ*0≡0 (suc n) = ap₂ _+_ (2ⁿ*0≡0 n) (2ⁿ*0≡0 n)

0∸_≡0 : ∀ x → 0 ∸ x ≡ 0
0∸ zero  ≡0 = idp
0∸ suc x ≡0 = idp

2*-∸ : ∀ x y → 2* x ∸ 2* y ≡ 2* (x ∸ y)
2*-∸ _       zero    = idp
2*-∸ zero    (suc _) = idp
2*-∸ (suc x) (suc y) rewrite ! 2*-∸ x y | ℕ°.+-comm x (1 + x) | ℕ°.+-comm y (1 + y) = idp

n+k∸m : ∀ {m n} k → m ≤ n → n + k ∸ m ≡ (n ∸ m) + k
n+k∸m k z≤n = idp
n+k∸m k (s≤s m≤n) = n+k∸m k m≤n

factor-+-∸ : ∀ {b x y} → x ≤ b → y ≤ b → (b ∸ x) + (b ∸ y) ≡ 2* b ∸ (x + y)
factor-+-∸ {b} {zero} {y} z≤n y≤b rewrite ℕ°.+-comm b (b ∸ y) = ! n+k∸m b y≤b
factor-+-∸ (s≤s {x} {b} x≤b) z≤n             rewrite ℕ°.+-comm x 0 = ! n+k∸m (suc b) x≤b
factor-+-∸ (s≤s {x} {b} x≤b) (s≤s {y} y≤b)   rewrite factor-+-∸ x≤b y≤b
                                              | ℕ°.+-comm b (suc b)
                                              | ℕ°.+-comm x (suc y)
                                              | n+k∸m (suc y) x≤b
                                              | ℕ°.+-comm x y = idp

_*′_ : ℕ → ℕ → ℕ
0 *′ n = 0
1 *′ n = n
m *′ 0 = 0
m *′ 1 = m
m *′ n = m * n

*′-spec : ∀ m n → m *′ n ≡ m * n
*′-spec 0             n = idp
*′-spec 1             n = ℕ°.+-comm 0 n
*′-spec (suc (suc m)) 0 = ℕ°.*-comm 0 m
*′-spec (suc (suc m)) 1 = ap (suc ∘′ suc) (! snd ℕ°.*-identity m)
*′-spec (suc (suc m)) (suc (suc n)) = idp

≤→≢1+ : ∀ {x y} → x ≤ y → x ≢ suc y
≤→≢1+ z≤n     ()
≤→≢1+ (s≤s p) q = ≤→≢1+ p (suc-injective q)

<→≢ : ∀ {x y} → x < y → x ≢ y
<→≢ (s≤s p) = ≤→≢1+ p

∸-assoc-+ : ∀ x y z → x ∸ y ∸ z ≡ x ∸ (y + z)
∸-assoc-+ x       zero    z       = idp
∸-assoc-+ zero    (suc y) zero    = idp
∸-assoc-+ zero    (suc y) (suc z) = idp
∸-assoc-+ (suc x) (suc y) z       = ∸-assoc-+ x y z

_∸-tone_ : ∀ {x y t u} → x ≤ y → t ≤ u → t ∸ y ≤ u ∸ x
_∸-tone_ {y = y} z≤n t≤u = n∸m≤n y _ ∙≤ t≤u
s≤s x≤y ∸-tone z≤n = z≤n
s≤s x≤y ∸-tone s≤s t≤u = x≤y ∸-tone t≤u

∸-mono' : ∀ k {x y} → x ≤ y → x ∸ k ≤ y ∸ k
∸-mono' k = _∸-tone_ (ℕ≤.refl {k})

∸-anti : ∀ k {x y} → x ≤ y → k ∸ y ≤ k ∸ x
∸-anti k x≤y = _∸-tone_ x≤y (ℕ≤.refl {k})

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

module ^-Props where
  open ≡-Reasoning

  ^1-id : ∀ n → n ^ 1 ≡ n
  ^1-id = snd ℕ°.*-identity

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b 0 n = ! snd ℕ°.+-identity (b ^ n)
  ^-+ b (1+ m) n rewrite ^-+ b m n = ! ℕ°.*-assoc b (b ^ m) (b ^ n)

  ^-* : ∀ b m n → b ^(m * n) ≡ (b ^ n) ^ m
  ^-* b 0   n = idp
  ^-* b (1+ m) n
    = b ^ (n + m * n)      ≡⟨ ^-+ b n (m * n) ⟩
      b ^ n * b ^(m * n)   ≡⟨ ap (_*_ (b ^ n)) (^-* b m n) ⟩
      b ^ n * (b ^ n) ^ m  ∎

_^2 : ℕ → ℕ
n ^2 = n * n

^2-spec : ∀ n → n ^2 ≡ n ^ 2
^2-spec n rewrite snd ℕ°.*-identity n = idp

2^_ : ℕ → ℕ
2^ n = ⟨2^ n * 1 ⟩

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = idp
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = idp

2^*-spec : ∀ m n → 2^⟨ m ⟩* n ≡ 2 ^ m * n
2^*-spec zero    n rewrite ℕ°.+-comm n 0 = idp
2^*-spec (suc m) n rewrite 2^*-spec m n
                         | ℕ°.*-assoc 2 (2 ^ m) n
                         | ℕ°.+-comm (2 ^ m * n) 0 = idp

1≤2^ : ∀ n → 2^ n ≥ 1
1+≤2^ : ∀ n → 2^ n ≥ 1 + n
1+≤2^ zero    = s≤s z≤n
1+≤2^ (suc n) = (1≤2^ n) +-mono (1+≤2^ n)

1≤2^ n  = s≤s z≤n ∙≤ 1+≤2^ n

≤-steps′ : ∀ {x} y → x ≤ x + y
≤-steps′ {x} y rewrite ℕ°.+-comm x y = ≤-steps y ℕ≤.refl

≤⇒∃ : ∀ {m n} → m ≤ n → ∃ λ k → m + k ≡ n
≤⇒∃ z≤n      = _ , idp
≤⇒∃ (s≤s pf) = _ , ap suc (snd (≤⇒∃ pf))

is0? : ℕ → 𝟚
is0? zero    = 1₂
is0? (suc n) = 0₂

module _ {{_ : UA}} where
    open Equivalences
    ∃-is0?-uniq : ∃ (✓ ∘ is0?) ≡ 𝟙
    ∃-is0?-uniq = ua (equiv _ (const (0 , _)) (const idp)
                            λ { (0 , _) → idp ; (suc _ , ()) })

{-
module GeneralisedArithmetic {a} {A : ★ a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → ★₀
  m ≈ n = ✓ (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → ✓ (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p idp

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → ★₀ where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → 𝟚
zero   <= _      = 1₂
suc _  <= zero   = 0₂
suc m  <= suc n  = m <= n

module <= where
  ℛ : ℕ → ℕ → ★₀
  ℛ x y = ✓ (x <= y)

  sound : ∀ m n → ℛ m n → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → ℛ m n
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

  isTotalOrder : IsTotalOrder _≡_ ℛ
  isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total x y) }
   where
    reflexive : ∀ {i j} → i ≡ j → ℛ i j
    reflexive {i} idp = complete (ℕ≤.refl {i})
    trans : Transitive ℛ
    trans {x} {y} {z} p q = complete (ℕ≤.trans (sound x y p) (sound y z q))
    isPreorder : IsPreorder _≡_ ℛ
    isPreorder = record { isEquivalence = ≡.isEquivalence
                        ; reflexive = reflexive
                        ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
    antisym : Antisymmetric _≡_ ℛ
    antisym {x} {y} p q = ℕ≤.antisym (sound x y p) (sound y x q)
    isPartialOrder : IsPartialOrder _≡_ ℛ
    isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }

  open IsTotalOrder isTotalOrder public

<=-steps′ : ∀ {x} y → ✓ (x <= (x + y))
<=-steps′ {x} y = <=.complete (≤-steps′ {x} y)

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

x≤2y′→x∸y≤y : ∀ x y → x ≤ 2*′ y → x ∸ y ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = sucx∸y≤suc⟨x∸y⟩ x y ∙≤ s≤s (x≤2y′→x∸y≤y x y p)

x<2y′→x∸y<y : ∀ x y → x < 2*′ y → x ∸ y < y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = s≤s (sucx∸y≤suc⟨x∸y⟩ x y) ∙≤ s≤s (x<2y′→x∸y<y x y p)

x<2y→x∸y<y : ∀ x y → x < 2* y → x ∸ y < y
x<2y→x∸y<y x y p rewrite ! 2*′-spec y = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y < x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = s≤s (≤-step ℕ≤.refl) ∙≤ a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = 𝟘-elim (p (≤-pred c))

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = 𝟘-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (! eq)
... | tri> _ _ 1+n≤m = ≤-pred (≤-steps 1 1+n≤m)

not<=→< : ∀ x y → ✓ (not (x <= y)) → ✓ (suc y <= x)
not<=→< x y p = <=.complete (≰→< x y (✓-not-¬ p ∘ <=.complete))

even? odd? : ℕ → 𝟚
even? zero    = 1₂
even? (suc n) = odd? n
odd? n = not (even? n)
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Data.Nat.NP where

open import Type hiding (★)
import Algebra
open import Algebra.FunctionProperties.Eq
open import Data.Two.Base hiding (_==_; _²)
open import Data.Product using (∃; _,_) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum renaming (map to ⊎-map)
open import Data.Zero using (𝟘-elim; 𝟘)
open import Data.One using (𝟙)
open import Function.NP
open import Function.Extensionality
open import Relation.Nullary
open import Relation.Binary.NP
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; _≗_; module ≡-Reasoning; !_; _∙_; ap; ap₂; coe)
       renaming (refl to idp)
open import HoTT
open Equivalences

open import Data.Nat public hiding (module GeneralisedArithmetic; module ≤-Reasoning; fold)
open import Data.Nat.Properties

pattern 1+_ x = suc x
pattern 2+_ x = 1+ suc x
pattern 3+_ x = 2+ suc x
pattern 4+_ x = 3+ suc x

⟨0↔1⟩ : ℕ → ℕ
⟨0↔1⟩ 0 = 1
⟨0↔1⟩ 1 = 0
⟨0↔1⟩ n = n

private
  _² : ∀ {A : ★₀} → Endo (Endo A)
  f ² = f ∘ f

⟨0↔1⟩-involutive : ⟨0↔1⟩ ∘ ⟨0↔1⟩ ≗ id
⟨0↔1⟩-involutive 0             = idp
⟨0↔1⟩-involutive 1             = idp
⟨0↔1⟩-involutive (suc (suc _)) = idp

⇑⟨_⟩ : (ℕ → ℕ) → (ℕ → ℕ)
⇑⟨ f ⟩ zero    = zero
⇑⟨ f ⟩ (suc n) = suc (f n)

⟨0↔1+_⟩ : ℕ → ℕ → ℕ
⟨0↔1+ 0     ⟩ = ⟨0↔1⟩
⟨0↔1+ suc n ⟩ = ⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩ ∘ ⟨0↔1⟩

⟨_↔+1⟩ : ℕ → ℕ → ℕ
⟨ 0     ↔+1⟩ = ⟨0↔1⟩
⟨ suc n ↔+1⟩ 0       = 0
⟨ suc n ↔+1⟩ (suc m) = suc (⟨ n ↔+1⟩ m)

⟨_↔+1⟩-involutive : ∀ n → ⟨ n ↔+1⟩ ∘ ⟨ n ↔+1⟩ ≗ id
⟨_↔+1⟩-involutive 0 = ⟨0↔1⟩-involutive
⟨_↔+1⟩-involutive (suc _) 0       = idp
⟨_↔+1⟩-involutive (suc n) (suc m) = ap suc (⟨ n ↔+1⟩-involutive m)

⟨_↔+1⟩-equiv : ℕ → ℕ ≃ ℕ
⟨ n ↔+1⟩-equiv = self-inv-equiv ⟨ n ↔+1⟩ ⟨ n ↔+1⟩-involutive

⇑⟨_⟩-involutive : ∀ {f} → f ² ≗ id → ⇑⟨ f ⟩ ² ≗ id
⇑⟨ f²id ⟩-involutive zero    = idp
⇑⟨ f²id ⟩-involutive (suc x) = ap suc (f²id x)

⟨0↔1+_⟩-involutive : ∀ n → ⟨0↔1+ n ⟩ ² ≗ id
⟨0↔1+_⟩-involutive zero = ⟨0↔1⟩-involutive
⟨0↔1+_⟩-involutive (suc n) x = ap (⟨0↔1⟩ ∘ ⇑⟨ ⟨0↔1+ n ⟩ ⟩) (⟨0↔1⟩-involutive (⇑⟨ ⟨0↔1+ n ⟩ ⟩ (⟨0↔1⟩ x)))
  ∙ ap ⟨0↔1⟩ (⇑⟨ ⟨0↔1+ n ⟩-involutive ⟩-involutive (⟨0↔1⟩ x)) ∙ ⟨0↔1⟩-involutive x

module _ {{_ : UA}} where
    ⟨_↔+1⟩-eq : ℕ → ℕ ≡ ℕ
    ⟨_↔+1⟩-eq = ua ∘ ⟨_↔+1⟩-equiv

    ⟨_↔+1⟩-eq-β : ∀ n m → coe ⟨ n ↔+1⟩-eq m ≡ ⟨ n ↔+1⟩ m
    ⟨_↔+1⟩-eq-β = coe-β ∘ ⟨_↔+1⟩-equiv

ℕˢ = ≡.setoid ℕ

module ℕcmp = StrictTotalOrder strictTotalOrder
module ℕ≤   = DecTotalOrder decTotalOrder
module ℕ°   = Algebra.CommutativeSemiring commutativeSemiring
module ℕ+   = Algebra.CommutativeMonoid ℕ°.+-commutativeMonoid
module ℕ+′  = Algebra.Monoid ℕ°.+-monoid
module ⊔°   = Algebra.CommutativeSemiringWithoutOne ⊔-⊓-0-commutativeSemiringWithoutOne
module ℕˢ   = Setoid ℕˢ

infixr 8 _∙≤_
_∙≤_ = ℕ≤.trans
_∙cmp_ = ℕcmp.trans
_∙<_ = <-trans

[P:_zero:_suc:_] : ∀ {p} (P : ℕ → ★ p) → P zero → (∀ {n} → P n → P (suc n)) → ∀ n → P n
[P: _ zero: z suc: _ ] zero    = z
[P: P zero: z suc: s ] (suc n) = s ([P: P zero: z suc: s ] n)

[zero:_suc:_] : ∀ {a} {A : ★ a} → A → (ℕ → A → A) → ℕ → A
[zero: z suc: s ] = [P: _ zero: z suc: (λ {n} → s n) ]

module ≤-Reasoning where
  open Preorder-Reasoning ℕ≤.preorder public renaming (_∼⟨_⟩_ to _≤⟨_⟩_)
  infixr 2 _≡⟨_⟩_
  _≡⟨_⟩_ : ∀ x {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  _ ≡⟨ idp ⟩ p = p
  infixr 2 _<⟨_⟩_
  _<⟨_⟩_ : ∀ x {y z : ℕ} → x < y → y ≤ z → x < z
  x <⟨ p ⟩ q = suc x ≤⟨ p ⟩ q

suc-injective : ∀ {n m : ℕ} → ℕ.suc n ≡ suc m → n ≡ m
suc-injective = ap pred

+-≤-inj : ∀ x {y z} → x + y ≤ x + z → y ≤ z
+-≤-inj zero    = id
+-≤-inj (suc x) = +-≤-inj x ∘ ≤-pred

infixl 6 _+°_
infixl 7 _*°_ _⊓°_
infixl 6 _∸°_ _⊔°_

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

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

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

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

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

-- this one is not completly in line with the
-- others
_≤°_ : ∀ {a} {A : ★ a} (f g : A → ℕ) → ★ a
f ≤° g = ∀ x → f x ≤ g x

sucx≰x : ∀ x → suc x ≰ x
sucx≰x zero    = λ()
sucx≰x (suc x) = sucx≰x x ∘ ≤-pred

total-≤ : ∀ a b → a ≤ b ⊎ b ≤ a
total-≤ zero b = inj₁ z≤n
total-≤ (suc a) zero = inj₂ z≤n
total-≤ (suc a) (suc b) with total-≤ a b
... | inj₁ p = inj₁ (s≤s p)
... | inj₂ p = inj₂ (s≤s p)

a≡a⊓b+a∸b : ∀ a b → a ≡ a ⊓ b + (a ∸ b)
a≡a⊓b+a∸b zero zero = idp
a≡a⊓b+a∸b zero (suc b) = idp
a≡a⊓b+a∸b (suc a) zero = idp
a≡a⊓b+a∸b (suc a) (suc b) rewrite ! a≡a⊓b+a∸b a b = idp

¬n≤x<n : ∀ n {x} → n ≤ x → x < n → 𝟘
¬n≤x<n n p q = sucx≰x _ (q ∙≤ p)

¬n+≤y<n : ∀ n {x y} → n + x ≤ y → y < n → 𝟘
¬n+≤y<n n p q = sucx≰x _ (q ∙≤ ℕ≤.reflexive (ℕ°.+-comm 0 n) ∙≤ ℕ≤.refl {n} +-mono z≤n ∙≤ p)

fold : ∀ {a} {A : ★ a} → A → Endo A → ℕ → A
fold x f n = nest n f x

module nest-Properties {a} {A : ★ a} (f : Endo A) where
  nest₀ : nest 0 f ≡ id
  nest₀ = idp
  nest₁ : nest 1 f ≡ f
  nest₁ = idp
  nest₂ : nest 2 f ≡ f ∘ f
  nest₂ = idp
  nest₃ : nest 3 f ≡ f ∘ f ∘ f
  nest₃ = idp

  nest-+ : ∀ m n → nest (m + n) f ≡ nest m f ∘ nest n f
  nest-+ zero    n = idp
  nest-+ (suc m) n = ap (_∘_ f) (nest-+ m n)

  nest-+' : ∀ m n → nest (m + n) f ≗ nest m f ∘ nest n f
  nest-+' m n x = ap (flip _$_ x) (nest-+ m n)

  nest-* : ∀ m n → nest (m * n) f ≗ nest m (nest n f)
  nest-* zero n x = idp
  nest-* (suc m) n x =
    nest (suc m * n) f x             ≡⟨ idp ⟩
    nest (n + m * n) f x             ≡⟨ nest-+' n (m * n) x ⟩
    (nest n f ∘ nest (m * n) f) x    ≡⟨ ap (nest n f) (nest-* m n x) ⟩
    (nest n f ∘ nest m (nest n f)) x ≡⟨ idp ⟩
    nest n f (nest m (nest n f) x)   ≡⟨ idp ⟩
    nest (suc m) (nest n f) x ∎
   where open ≡-Reasoning

{- WRONG
module more-nest-Properties {a} {A : ★ a} where
  nest-+'' : ∀ (f : Endo (Endo A)) g m n → nest m f g ∘ nest n f g ≗ nest (m + n) f g
  nest-+'' f g zero n = {!!}
  nest-+'' f g (suc m) n = {!!}
-}

+-inj-over-∸ : ∀ x y z → (x + y) ∸ (x + z) ≡ y ∸ z
+-inj-over-∸ = [i+j]∸[i+k]≡j∸k

2*_ : ℕ → ℕ
2* x = x + x

2*-spec : ∀ n → 2* n ≡ 2 * n
2*-spec n rewrite ℕ°.+-comm n 0 = idp

_==_ : (x y : ℕ) → 𝟚
zero   == zero   = 1₂
zero   == suc _  = 0₂
suc _  == zero   = 0₂
suc m  == suc n  = m == n

open FromAssocComm _+_ (λ {x}{y}{z} → ℕ°.+-assoc x y z) (λ {x}{y} → ℕ°.+-comm x y)
  renaming ( assoc-comm to +-assoc-comm
           ; interchange to +-interchange
           )

*-assoc-comm : ∀ x y z → x * (y * z) ≡ y * (x * z)
*-assoc-comm x y z = ! ℕ°.*-assoc x y z ∙ ap (flip _*_ z) (ℕ°.*-comm x y) ∙ ℕ°.*-assoc y x z

*-interchange : Interchange _≡_ _*_ _*_
*-interchange = InterchangeFromAssocCommCong.∙-interchange _≡_ ≡.isEquivalence
                                                           _*_ ℕ°.*-assoc ℕ°.*-comm (λ z → ap (flip _*_ z))

a+b≡a⊔b+a⊓b : ∀ a b → a + b ≡ a ⊔ b + a ⊓ b
a+b≡a⊔b+a⊓b zero    b       rewrite ℕ°.+-comm b 0 = idp
a+b≡a⊔b+a⊓b (suc a) zero    = idp
a+b≡a⊔b+a⊓b (suc a) (suc b) rewrite +-assoc-comm {a} {1} {b}
                                  | +-assoc-comm {a ⊔ b} {1} {a ⊓ b}
                                  | a+b≡a⊔b+a⊓b a b
                                  = idp

a⊓b≡a : ∀ {a b} → a ≤ b → a ⊓ b ≡ a
a⊓b≡a z≤n = idp
a⊓b≡a (s≤s a≤b) rewrite a⊓b≡a a≤b = idp

⊔≤+ : ∀ a b → a ⊔ b ≤ a + b
⊔≤+ zero b          = ℕ≤.refl
⊔≤+ (suc a) zero    = s≤s (ℕ≤.reflexive (ℕ°.+-comm 0 a))
⊔≤+ (suc a) (suc b) = s≤s (⊔≤+ a b ∙≤ ≤-step ℕ≤.refl ∙≤ ℕ≤.reflexive (+-assoc-comm {1} {a} {b}))

2*′_ : ℕ → ℕ
2*′_ = fold 0 (suc ∘′ suc)

2*′-spec : ∀ n → 2*′ n ≡ 2* n
2*′-spec zero = idp
2*′-spec (suc n) rewrite 2*′-spec n | +-assoc-comm {1} {n} {n} = idp

2^⟨_⟩* : ℕ → ℕ → ℕ
2^⟨ n ⟩* x = fold x 2*_ n

⟨2^_*_⟩ : ℕ → ℕ → ℕ
⟨2^ n * x ⟩ = 2^⟨ n ⟩* x

2*′-inj : ∀ {m n} → 2*′ m ≡ 2*′ n → m ≡ n
2*′-inj {zero}  {zero}  _ = idp
2*′-inj {zero}  {suc _} ()
2*′-inj {suc _} {zero}  ()
2*′-inj {suc m} {suc n} p = ap suc (2*′-inj (suc-injective (suc-injective p)))

2*-inj : ∀ {m n} → 2* m ≡ 2* n → m ≡ n
2*-inj {m} {n} p rewrite ! 2*′-spec m
                       | ! 2*′-spec n
                       = 2*′-inj p

2^-inj : ∀ k {m n} → ⟨2^ k * m ⟩ ≡ ⟨2^ k * n ⟩ → m ≡ n
2^-inj zero    = id
2^-inj (suc k) = 2^-inj k ∘ 2*-inj

2*-distrib : ∀ x y → 2* x + 2* y ≡ 2* (x + y)
2*-distrib x y = +-interchange {x} {x} {y} {y}

2^*-distrib : ∀ k x y → ⟨2^ k * (x + y)⟩ ≡ ⟨2^ k * x ⟩ + ⟨2^ k * y ⟩
2^*-distrib zero x y = idp
2^*-distrib (suc k) x y rewrite 2^*-distrib k x y = ! 2*-distrib ⟨2^ k * x ⟩ ⟨2^ k * y ⟩

2^*-2*-comm : ∀ k x → ⟨2^ k * 2* x ⟩ ≡ 2* ⟨2^ k * x ⟩
2^*-2*-comm k x = 2^*-distrib k x x

2*-mono : ∀ {a b} → a ≤ b → 2* a ≤ 2* b
2*-mono pf = pf +-mono pf

2^*-mono : ∀ k {a b} → a ≤ b → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩
2^*-mono zero    pf = pf
2^*-mono (suc k) pf = 2*-mono (2^*-mono k pf)

2*-mono′ : ∀ {a b} → 2* a ≤ 2* b → a ≤ b
2*-mono′ {zero} pf = z≤n
2*-mono′ {suc a} {zero} ()
2*-mono′ {suc a} {suc b} pf rewrite +-assoc-comm {a} {1} {a}
                                  | +-assoc-comm {b} {1} {b} = s≤s (2*-mono′ (≤-pred (≤-pred pf)))

2^*-mono′ : ∀ k {a b} → ⟨2^ k * a ⟩ ≤ ⟨2^ k * b ⟩ → a ≤ b
2^*-mono′ zero    = id
2^*-mono′ (suc k) = 2^*-mono′ k ∘ 2*-mono′

2^-comm : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ y * ⟨2^ x * z ⟩ ⟩
2^-comm zero y z = idp
2^-comm (suc x) y z rewrite 2^-comm x y z = ! 2^*-2*-comm y ⟨2^ x * z ⟩

2^-+ : ∀ x y z → ⟨2^ x * ⟨2^ y * z ⟩ ⟩ ≡ ⟨2^ (x + y) * z ⟩
2^-+ zero    y z = idp
2^-+ (suc x) y z = ap 2*_ (2^-+ x y z)

cancel-*-left : ∀ i j {k} → suc k * i ≡ suc k * j → i ≡ j
cancel-*-left i j {k}
  rewrite ℕ°.*-comm (suc k) i
        | ℕ°.*-comm (suc k) j = cancel-*-right i j {k}

2ⁿ*0≡0 : ∀ n → ⟨2^ n * 0 ⟩ ≡ 0
2ⁿ*0≡0 zero    = idp
2ⁿ*0≡0 (suc n) = ap₂ _+_ (2ⁿ*0≡0 n) (2ⁿ*0≡0 n)

0∸_≡0 : ∀ x → 0 ∸ x ≡ 0
0∸ zero  ≡0 = idp
0∸ suc x ≡0 = idp

2*-∸ : ∀ x y → 2* x ∸ 2* y ≡ 2* (x ∸ y)
2*-∸ _       zero    = idp
2*-∸ zero    (suc _) = idp
2*-∸ (suc x) (suc y) rewrite ! 2*-∸ x y | ℕ°.+-comm x (1 + x) | ℕ°.+-comm y (1 + y) = idp

n+k∸m : ∀ {m n} k → m ≤ n → n + k ∸ m ≡ (n ∸ m) + k
n+k∸m k z≤n = idp
n+k∸m k (s≤s m≤n) = n+k∸m k m≤n

factor-+-∸ : ∀ {b x y} → x ≤ b → y ≤ b → (b ∸ x) + (b ∸ y) ≡ 2* b ∸ (x + y)
factor-+-∸ {b} {zero} {y} z≤n y≤b rewrite ℕ°.+-comm b (b ∸ y) = ! n+k∸m b y≤b
factor-+-∸ (s≤s {x} {b} x≤b) z≤n             rewrite ℕ°.+-comm x 0 = ! n+k∸m (suc b) x≤b
factor-+-∸ (s≤s {x} {b} x≤b) (s≤s {y} y≤b)   rewrite factor-+-∸ x≤b y≤b
                                              | ℕ°.+-comm b (suc b)
                                              | ℕ°.+-comm x (suc y)
                                              | n+k∸m (suc y) x≤b
                                              | ℕ°.+-comm x y = idp

_*′_ : ℕ → ℕ → ℕ
0 *′ n = 0
1 *′ n = n
m *′ 0 = 0
m *′ 1 = m
m *′ n = m * n

*′-spec : ∀ m n → m *′ n ≡ m * n
*′-spec 0             n = idp
*′-spec 1             n = ℕ°.+-comm 0 n
*′-spec (suc (suc m)) 0 = ℕ°.*-comm 0 m
*′-spec (suc (suc m)) 1 = ap (suc ∘′ suc) (! snd ℕ°.*-identity m)
*′-spec (suc (suc m)) (suc (suc n)) = idp

≤→≢1+ : ∀ {x y} → x ≤ y → x ≢ suc y
≤→≢1+ z≤n     ()
≤→≢1+ (s≤s p) q = ≤→≢1+ p (suc-injective q)

<→≢ : ∀ {x y} → x < y → x ≢ y
<→≢ (s≤s p) = ≤→≢1+ p

∸-assoc-+ : ∀ x y z → x ∸ y ∸ z ≡ x ∸ (y + z)
∸-assoc-+ x       zero    z       = idp
∸-assoc-+ zero    (suc y) zero    = idp
∸-assoc-+ zero    (suc y) (suc z) = idp
∸-assoc-+ (suc x) (suc y) z       = ∸-assoc-+ x y z

_∸-tone_ : ∀ {x y t u} → x ≤ y → t ≤ u → t ∸ y ≤ u ∸ x
_∸-tone_ {y = y} z≤n t≤u = n∸m≤n y _ ∙≤ t≤u
s≤s x≤y ∸-tone z≤n = z≤n
s≤s x≤y ∸-tone s≤s t≤u = x≤y ∸-tone t≤u

∸-mono' : ∀ k {x y} → x ≤ y → x ∸ k ≤ y ∸ k
∸-mono' k = _∸-tone_ (ℕ≤.refl {k})

∸-anti : ∀ k {x y} → x ≤ y → k ∸ y ≤ k ∸ x
∸-anti k x≤y = _∸-tone_ x≤y (ℕ≤.refl {k})

infix 8 _^_
_^_ : ℕ → ℕ → ℕ
b ^ zero  = 1
b ^ suc n = b * b ^ n

module ^-Props where
  open ≡-Reasoning

  ^1-id : ∀ n → n ^ 1 ≡ n
  ^1-id = snd ℕ°.*-identity

  ^-+ : ∀ b m n → b ^ (m + n) ≡ b ^ m * b ^ n
  ^-+ b 0 n = ! snd ℕ°.+-identity (b ^ n)
  ^-+ b (1+ m) n rewrite ^-+ b m n = ! ℕ°.*-assoc b (b ^ m) (b ^ n)

  ^-* : ∀ b m n → b ^(m * n) ≡ (b ^ n) ^ m
  ^-* b 0   n = idp
  ^-* b (1+ m) n
    = b ^ (n + m * n)      ≡⟨ ^-+ b n (m * n) ⟩
      b ^ n * b ^(m * n)   ≡⟨ ap (_*_ (b ^ n)) (^-* b m n) ⟩
      b ^ n * (b ^ n) ^ m  ∎

_^2 : ℕ → ℕ
n ^2 = n * n

^2-spec : ∀ n → n ^2 ≡ n ^ 2
^2-spec n rewrite snd ℕ°.*-identity n = idp

2^_ : ℕ → ℕ
2^ n = ⟨2^ n * 1 ⟩

2^-spec : ∀ n → 2^ n ≡ 2 ^ n
2^-spec zero = idp
2^-spec (suc n) rewrite 2^-spec n | 2*-spec (2 ^ n) = idp

2^*-spec : ∀ m n → 2^⟨ m ⟩* n ≡ 2 ^ m * n
2^*-spec zero    n rewrite ℕ°.+-comm n 0 = idp
2^*-spec (suc m) n rewrite 2^*-spec m n
                         | ℕ°.*-assoc 2 (2 ^ m) n
                         | ℕ°.+-comm (2 ^ m * n) 0 = idp

1≤2^ : ∀ n → 2^ n ≥ 1
1+≤2^ : ∀ n → 2^ n ≥ 1 + n
1+≤2^ zero    = s≤s z≤n
1+≤2^ (suc n) = (1≤2^ n) +-mono (1+≤2^ n)

1≤2^ n  = s≤s z≤n ∙≤ 1+≤2^ n

≤-steps′ : ∀ {x} y → x ≤ x + y
≤-steps′ {x} y rewrite ℕ°.+-comm x y = ≤-steps y ℕ≤.refl

≤⇒∃ : ∀ {m n} → m ≤ n → ∃ λ k → m + k ≡ n
≤⇒∃ z≤n      = _ , idp
≤⇒∃ (s≤s pf) = _ , ap suc (snd (≤⇒∃ pf))

is0? : ℕ → 𝟚
is0? zero    = 1₂
is0? (suc n) = 0₂

module _ {{_ : UA}} where
    open Equivalences
    ∃-is0?-uniq : ∃ (✓ ∘ is0?) ≡ 𝟙
    ∃-is0?-uniq = ua (equiv _ (const (0 , _)) (const idp)
                            λ { (0 , _) → idp ; (suc _ , ()) })

{-
module GeneralisedArithmetic {a} {A : ★ a} (0# : A) (1+ : A → A) where

  1# : A
  1# = 1+ 0#

  open Data.Nat.GeneralisedArithmetic 0# 1+ public

  exp : (* : A → A → A) → (ℕ → A → A)
  exp _*_ n b = fold 1# (λ s → b * s) n
-}
  -- hyperop a n b = fold exp

module == where
  _≈_ : (m n : ℕ) → ★₀
  m ≈ n = ✓ (m == n)

  subst : ∀ {ℓ} → Substitutive _≈_ ℓ
  subst _ {zero}  {zero}  _  = id
  subst P {suc _} {suc _} p  = subst (P ∘ suc) p
  subst _ {zero}  {suc _} ()
  subst _ {suc _} {zero}  ()

  sound : ∀ m n → ✓ (m == n) → m ≡ n
  sound m n p = subst (_≡_ m) p idp

  refl : Reflexive _≈_
  refl {zero}  = _
  refl {suc n} = refl {n}

  sym : Symmetric _≈_
  sym {m} {n} eq rewrite sound m n eq = refl {n}

  trans : Transitive _≈_
  trans {m} {n} {o} m≈n n≈o rewrite sound m n m≈n | sound n o n≈o = refl {o}

  setoid : Setoid _ _
  setoid = record { Carrier = ℕ; _≈_ = _≈_
                  ; isEquivalence =
                      record { refl = λ {x} → refl {x}
                             ; sym = λ {x} {y} → sym {x} {y}
                             ; trans = λ {x} {y} {z} → trans {x} {y} {z} } }

  open Setoid setoid public hiding (refl; sym; trans; _≈_)

{-
data _`≤?`_↝_ : (m n : ℕ) → Dec (m ≤ n) → ★₀ where
  z≤?n     : ∀ {n} → zero `≤?` n ↝ yes z≤n
  s≤?z     : ∀ {m} → suc m `≤?` zero ↝ no λ()
  s≤?s-yes : ∀ {m n m≤n} → m `≤?` n ↝ yes m≤n → suc m `≤?` suc n ↝ yes (s≤s m≤n)
  s≤?s-no  : ∀ {m n m≰n} → m `≤?` n ↝ no m≰n → suc m `≤?` suc n ↝ no (m≰n ∘ ≤-pred)

`≤?`-complete : ∀ m n → m `≤?` n ↝ (m ≤? n)
`≤?`-complete zero n = z≤?n
`≤?`-complete (suc n) zero = {!s≤?z!}
`≤?`-complete (suc m) (suc n) with m ≤? n | `≤?`-complete m n
... | yes q | r = s≤?s-yes r
... | no q  | r = s≤?s-no {!!}
-}

_<=_ : (x y : ℕ) → 𝟚
zero   <= _      = 1₂
suc _  <= zero   = 0₂
suc m  <= suc n  = m <= n

module <= where
  ℛ : ℕ → ℕ → ★₀
  ℛ x y = ✓ (x <= y)

  sound : ∀ m n → ℛ m n → m ≤ n
  sound zero    _       _  = z≤n
  sound (suc m) (suc n) p  = s≤s (sound m n p)
  sound (suc m) zero    ()

  complete : ∀ {m n} → m ≤ n → ℛ m n
  complete z≤n       = _
  complete (s≤s m≤n) = complete m≤n

  isTotalOrder : IsTotalOrder _≡_ ℛ
  isTotalOrder = record { isPartialOrder = isPartialOrder; total = λ x y → ⊎-map complete complete (ℕ≤.total x y) }
   where
    reflexive : ∀ {i j} → i ≡ j → ℛ i j
    reflexive {i} idp = complete (ℕ≤.refl {i})
    trans : Transitive ℛ
    trans {x} {y} {z} p q = complete (ℕ≤.trans (sound x y p) (sound y z q))
    isPreorder : IsPreorder _≡_ ℛ
    isPreorder = record { isEquivalence = ≡.isEquivalence
                        ; reflexive = reflexive
                        ; trans = λ {x} {y} {z} → trans {x} {y} {z} }
    antisym : Antisymmetric _≡_ ℛ
    antisym {x} {y} p q = ℕ≤.antisym (sound x y p) (sound y x q)
    isPartialOrder : IsPartialOrder _≡_ ℛ
    isPartialOrder = record { isPreorder = isPreorder; antisym = antisym }

  open IsTotalOrder isTotalOrder public

<=-steps′ : ∀ {x} y → ✓ (x <= (x + y))
<=-steps′ {x} y = <=.complete (≤-steps′ {x} y)

sucx∸y≤suc⟨x∸y⟩ : ∀ x y → suc x ∸ y ≤ suc (x ∸ y)
sucx∸y≤suc⟨x∸y⟩ x zero = ℕ≤.refl
sucx∸y≤suc⟨x∸y⟩ zero (suc y) rewrite 0∸n≡0 y = z≤n
sucx∸y≤suc⟨x∸y⟩ (suc x) (suc y) = sucx∸y≤suc⟨x∸y⟩ x y

x≤2y′→x∸y≤y : ∀ x y → x ≤ 2*′ y → x ∸ y ≤ y
x≤2y′→x∸y≤y x zero p = p
x≤2y′→x∸y≤y zero (suc y) p = z≤n
x≤2y′→x∸y≤y (suc zero) (suc y) (s≤s p) rewrite 0∸n≡0 y = z≤n
x≤2y′→x∸y≤y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = sucx∸y≤suc⟨x∸y⟩ x y ∙≤ s≤s (x≤2y′→x∸y≤y x y p)

x<2y′→x∸y<y : ∀ x y → x < 2*′ y → x ∸ y < y
x<2y′→x∸y<y x zero p = p
x<2y′→x∸y<y zero (suc y) p = s≤s z≤n
x<2y′→x∸y<y (suc zero) (suc y) (s≤s (s≤s p)) rewrite 0∸n≡0 y = s≤s z≤n
x<2y′→x∸y<y (suc (suc x)) (suc y) (s≤s (s≤s p))
  = s≤s (sucx∸y≤suc⟨x∸y⟩ x y) ∙≤ s≤s (x<2y′→x∸y<y x y p)

x<2y→x∸y<y : ∀ x y → x < 2* y → x ∸ y < y
x<2y→x∸y<y x y p rewrite ! 2*′-spec y = x<2y′→x∸y<y x y p

≰→< : ∀ x y → x ≰ y → y < x
≰→< x y p with ℕcmp.compare (suc y) x
≰→< x y p | tri< a ¬b ¬c = s≤s (≤-step ℕ≤.refl) ∙≤ a
≰→< x y p | tri≈ ¬a b ¬c = ℕ≤.reflexive b
≰→< x y p | tri> ¬a ¬b c = 𝟘-elim (p (≤-pred c))

¬≤ : ∀ {m n} → ¬(m < n) → n ≤ m
¬≤ {m} {n} p with ℕcmp.compare m n
... | tri< m<n _ _   = 𝟘-elim (p m<n)
... | tri≈ _ eq _    = ℕ≤.reflexive (! eq)
... | tri> _ _ 1+n≤m = ≤-pred (≤-steps 1 1+n≤m)

not<=→< : ∀ x y → ✓ (not (x <= y)) → ✓ (suc y <= x)
not<=→< x y p = <=.complete (≰→< x y (✓-not-¬ p ∘ <=.complete))

even? odd? : ℕ → 𝟚
even? zero    = 1₂
even? (suc n) = odd? n
odd? n = not (even? n)
-- -}
-- -}
-- -}
-- -}


Added Agsy examples.

Added Agsy examples.

Ignore-this: 6a5ebd515088c189d2d71d42872cd0e8

darcs-hash:20101203172202-3bd4e-06ca65a535ff142673537ff8af3ac4820edad9fb.gz

------------------------------------------------------------------------------
-- Testing Agsy using the Agda standard library
------------------------------------------------------------------------------

module AgsyTest where

open import Data.Nat

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

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

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)  -- via Agsy {-c}
+-assoc zero    n o = refl
+-assoc (suc m) n o = cong suc (+-assoc m n o)

x+1+y≡1+x+y : ∀ m n → m + suc n ≡ suc (m + n)  -- via Agsy {-c}
x+1+y≡1+x+y zero    n = refl
x+1+y≡1+x+y (suc m) n = cong suc (x+1+y≡1+x+y m n)

0+n≡n+0 : ∀ n → 0 + n ≡ n + 0  -- via Agsy {-c}
0+n≡n+0 zero    = refl
0+n≡n+0 (suc n) = cong suc (0+n≡n+0 n)

+-comm : ∀ m n → m + n ≡ n + m  -- via Agsy {-c -m}
+-comm zero    n = 0+n≡n+0 n
+-comm (suc m) n =
  begin
    suc (m + n) ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m) ≡⟨ sym (x+1+y≡1+x+y n m) ⟩
    n + suc m
  ∎

------------------------------------------------------------------------------
-- Testing Agsy using the Agda standard library
------------------------------------------------------------------------------

module AgsyTest where

open import Data.Nat

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

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

0+m≡m+0 : ∀ m → 0 + m ≡ m + 0  -- via Agsy {-c}
0+m≡m+0 zero    = refl
0+m≡m+0 (suc n) = cong suc (0+m≡m+0 n)

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero    zero    = refl -- via Agsy
+-comm zero    (suc n) = sym (cong suc (+-comm n zero))  -- via Agsy
+-comm (suc m) zero    = sym (cong suc (+-comm zero m))  -- via Agsy
+-comm (suc m) (suc n) = {!-t 20!} -- Agsy: No solution found at time out (20s)


JS: add is-null

JS: add is-null

module FFI.JS where

open import Data.Empty       public renaming (⊥ to 𝟘)
open import Data.Unit.Base   public renaming (⊤ to 𝟙)
open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List; []; _∷_)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)
open import Function         using (id; _∘_)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

postulate
  Number   : Set
  JSArray  : Set → Set
  JSObject : Set
  JSValue  : Set

postulate readNumber : String → Number
{-# COMPILED_JS readNumber Number #-}

postulate 0N : Number
{-# COMPILED_JS 0N 0 #-}

postulate 1N : Number
{-# COMPILED_JS 1N 1 #-}

postulate 2N : Number
{-# COMPILED_JS 2N 2 #-}

postulate 4N : Number
{-# COMPILED_JS 4N 4 #-}

postulate 8N : Number
{-# COMPILED_JS 8N 8 #-}

postulate 16N : Number
{-# COMPILED_JS 16N 16 #-}

postulate 32N : Number
{-# COMPILED_JS 32N 32 #-}

postulate 64N : Number
{-# COMPILED_JS 64N 64 #-}

postulate 128N : Number
{-# COMPILED_JS 128N 128 #-}

postulate 256N : Number
{-# COMPILED_JS 256N 256 #-}

postulate 512N : Number
{-# COMPILED_JS 512N 512 #-}

postulate 1024N : Number
{-# COMPILED_JS 1024N 1024 #-}

postulate 2048N : Number
{-# COMPILED_JS 2048N 2048 #-}

postulate 4096N : Number
{-# COMPILED_JS 4096N 4096 #-}

postulate _+_ : Number → Number → Number
{-# COMPILED_JS _+_ function(x) { return function(y) { return x + y; }; } #-}

postulate _−_ : Number → Number → Number
{-# COMPILED_JS _−_ function(x) { return function(y) { return x - y; }; } #-}

postulate _*_ : Number → Number → Number
{-# COMPILED_JS _*_ function(x) { return function(y) { return x * y; }; } #-}

postulate _/_ : Number → Number → Number
{-# COMPILED_JS _/_ function(x) { return function(y) { return x / y; }; } #-}

infixr 5  _++_
postulate _++_ : String → String → String
{-# COMPILED_JS _++_ function(x) { return function(y) { return x + y; }; } #-}

postulate _+JS_ : JSValue → JSValue → JSValue
{-# COMPILED_JS _+JS_ function(x) { return function(y) { return x + y; }; } #-}

postulate _≤JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≤JS_ function(x) { return function(y) { return x <= y; }; } #-}

postulate _<JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _<JS_ function(x) { return function(y) { return x < y; }; } #-}

postulate _>JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _>JS_ function(x) { return function(y) { return x > y; }; } #-}

postulate _≥JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≥JS_ function(x) { return function(y) { return x >= y; }; } #-}

postulate _===_ : JSValue → JSValue → Bool
{-# COMPILED_JS _===_ function(x) { return function(y) { return x === y; }; } #-}

postulate reverse : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS reverse function(ty) { return function(x) { return x.reverse(); }; } #-}

postulate sort : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS sort function(ty) { return function(x) { return x.sort(); }; } #-}

postulate split : (sep target : String) → JSArray String
{-# COMPILED_JS split function(sep) { return function(target) { return target.split(sep); }; } #-}

postulate join : (sep : String)(target : JSArray String) → String
{-# COMPILED_JS join function(sep) { return function(target) { return target.join(sep); }; } #-}

postulate fromList : {A B : Set}(xs : List A)(fromElt : A → B) → JSArray B
{-# COMPILED_JS fromList require("libagda").fromList #-}

postulate length : String → Number
{-# COMPILED_JS length function(s) { return s.length; } #-}

postulate JSON-stringify : JSValue → String
{-# COMPILED_JS JSON-stringify JSON.stringify #-}

postulate JSON-parse : String → JSValue
{-# COMPILED_JS JSON-parse JSON.parse #-}

postulate toString : JSValue → String
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}

postulate fromBool : Bool → JSValue
{-# COMPILED_JS fromBool function(x) { return x; } #-}

postulate fromString : String → JSValue
{-# COMPILED_JS fromString function(x) { return x; } #-}

postulate fromChar : Char → JSValue
{-# COMPILED_JS fromChar String #-}

postulate Char▹String : Char → String
{-# COMPILED_JS Char▹String String #-}

postulate fromNumber : Number → JSValue
{-# COMPILED_JS fromNumber function(x) { return x; } #-}

postulate fromJSArray : {A : Set} → JSArray A → JSValue
{-# COMPILED_JS fromJSArray function(ty) { return function(x) { return x; }; } #-}

postulate fromJSObject : JSObject → JSValue
{-# COMPILED_JS fromJSObject function(x) { return x; } #-}

postulate objectFromList : {A : Set}(xs : List A)(fromKey : A → String)(fromVal : A → JSValue) → JSObject
{-# COMPILED_JS objectFromList require("libagda").objectFromList #-}

postulate decodeJSArray : {A B : Set}(arr : JSArray A)(fromElt : Number → A → B) → List B
{-# COMPILED_JS decodeJSArray require("libagda").decodeJSArray #-}

postulate castNumber : JSValue → Number
{-# COMPILED_JS castNumber Number #-}

postulate castString : JSValue → String
{-# COMPILED_JS castString String #-}

-- TODO dyn check of length 1?
postulate castChar : JSValue → Char
{-# COMPILED_JS castChar String #-}

-- TODO dyn check of length 1?
postulate String▹Char : String → Char
{-# COMPILED_JS String▹Char String #-}

-- TODO dyn check?
postulate castJSArray : JSValue → JSArray JSValue
{-# COMPILED_JS castJSArray function(x) { return x; } #-}

-- TODO dyn check?
postulate castJSObject : JSValue → JSObject
{-# COMPILED_JS castJSObject function(x) { return x; } #-}

postulate nullJS : JSValue
{-# COMPILED_JS nullJS null #-}

postulate _·[_] : JSValue → JSValue → JSValue
{-# COMPILED_JS _·[_] require("libagda").readProp #-}

postulate _Array[_] : {A : Set} → JSArray A → Number → A
{-# COMPILED_JS _Array[_] function(ty) { return require("libagda").readProp; } #-}

postulate onJSArray : {A : Set} (f : JSArray JSValue → A) → JSValue → A
{-# COMPILED_JS onJSArray require("libagda").onJSArray #-}

postulate onString : {A : Set} (f : String → A) → JSValue → A
{-# COMPILED_JS onString require("libagda").onString #-}

-- Writes 'msg' and 'inp' to the console and then returns `f inp`
postulate trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
{-# COMPILED_JS trace require("libagda").trace #-}

postulate throw : {A : Set} → String → A → A
{-# COMPILED_JS throw require("libagda").throw #-}

postulate is-null : JSValue → Bool
{-# COMPILED_JS is-null function(x) { return (x == null); } #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number → Value
  bool   : Bool   → Value
  null   : Value

Object = List (String × JSValue)

postulate fromValue : Value → JSValue
{-# COMPILED_JS fromValue require("libagda").fromValue #-}

-- TODO we could make it a COMPILED type and remove the encoding by using JSValue as the internal repr.
data ValueView : Set₀ where
  array  : JSArray JSValue → ValueView
  object : JSObject        → ValueView
  string : String          → ValueView
  number : Number          → ValueView
  bool   : Bool            → ValueView
  null   : ValueView

-- TODO not yet tested
postulate viewJSValue : JSValue → ValueView
{-# COMPILED_JS viewJSValue require("libagda").viewJSValue #-}

Bool▹String : Bool → String
Bool▹String true  = "true"
Bool▹String false = "false"

List▹String : List Char → String
List▹String xs = join "" (fromList xs Char▹String)

String▹List : String → List Char
String▹List s = decodeJSArray (split "" s) (λ _ → String▹Char)

Number▹String : Number → String
Number▹String = castString ∘ fromNumber

JSArray▹ListString : {A : Set} → JSArray A → List A
JSArray▹ListString a = decodeJSArray a (λ _ → id)

fromObject : Object → JSObject
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_<Char_ : Char → Char → Bool
x <Char y = fromChar x <JS fromChar y

_>Char_ : Char → Char → Bool
x >Char y = fromChar x >JS fromChar y

_≥Char_ : Char → Char → Bool
x ≥Char y = fromChar x ≥JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_<String_ : String → String → Bool
x <String y = fromString x <JS fromString y

_>String_ : String → String → Bool
x >String y = fromString x >JS fromString y

_≥String_ : String → String → Bool
x ≥String y = fromString x ≥JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_<Number_ : Number → Number → Bool
x <Number y = fromNumber x <JS fromNumber y

_>Number_ : Number → Number → Bool
x >Number y = fromNumber x >JS fromNumber y

_≥Number_ : Number → Number → Bool
x ≥Number y = fromNumber x ≥JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

_·«_»A : JSValue → String → JSArray JSValue
v ·« s »A = castJSArray (v ·« s »)

trace-call : {A B : Set} → String → (A → B) → A → B
trace-call s f x = trace s (f x) id

postulate JSCmd : Set → Set

Callback1 : Set → Set
Callback1 A = JSCmd ((A → 𝟘) → 𝟘)

Callback0 : Set
Callback0 = Callback1 𝟙

Callback2 : Set → Set → Set
Callback2 A B = JSCmd ((A → B → 𝟘) → 𝟘)

postulate assert : Bool → Callback0
{-# COMPILED_JS assert require("libagda").assert #-}

check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
check true  errmsg x = x
check false errmsg x = throw (errmsg _) x

warn-check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
warn-check true  errmsg x = x
warn-check false errmsg x = trace ("Warning: " ++ errmsg _) x id

infixr 0  _>>_ _!₁_ _!₂_
data JS! : Set₁ where
  end  : JS!
  _!₁_ : {A : Set}(cmd : Callback1 A)(cb : A → JS!) → JS!
  _!₂_ : {A B : Set}(cmd : JSCmd ((A → B → 𝟘) → 𝟘))(cb : A → B → JS!) → JS!

_>>_ : Callback0 → JS! → JS!
cmd >> cont = cmd !₁ λ _ → cont
-- -}
-- -}
-- -}
-- -}
-- -}

module FFI.JS where

open import Data.Empty       public renaming (⊥ to 𝟘)
open import Data.Unit.Base   public renaming (⊤ to 𝟙)
open import Data.Char.Base   public using (Char)
open import Data.String.Base public using (String)
open import Data.Bool.Base   public using (Bool; true; false)
open import Data.List.Base   using (List; []; _∷_)
open import Data.Product     using (_×_) renaming (proj₁ to fst; proj₂ to snd)
open import Function         using (id; _∘_)

open import Control.Process.Type

{-# COMPILED_JS Bool function (x,v) { return ((x)? v["true"]() : v["false"]()); } #-}
{-# COMPILED_JS true  true #-}
{-# COMPILED_JS false false #-}

postulate
  Number   : Set
  JSArray  : Set → Set
  JSObject : Set
  JSValue  : Set

postulate readNumber : String → Number
{-# COMPILED_JS readNumber Number #-}

postulate 0N : Number
{-# COMPILED_JS 0N 0 #-}

postulate 1N : Number
{-# COMPILED_JS 1N 1 #-}

postulate 2N : Number
{-# COMPILED_JS 2N 2 #-}

postulate 4N : Number
{-# COMPILED_JS 4N 4 #-}

postulate 8N : Number
{-# COMPILED_JS 8N 8 #-}

postulate 16N : Number
{-# COMPILED_JS 16N 16 #-}

postulate 32N : Number
{-# COMPILED_JS 32N 32 #-}

postulate 64N : Number
{-# COMPILED_JS 64N 64 #-}

postulate 128N : Number
{-# COMPILED_JS 128N 128 #-}

postulate 256N : Number
{-# COMPILED_JS 256N 256 #-}

postulate 512N : Number
{-# COMPILED_JS 512N 512 #-}

postulate 1024N : Number
{-# COMPILED_JS 1024N 1024 #-}

postulate 2048N : Number
{-# COMPILED_JS 2048N 2048 #-}

postulate 4096N : Number
{-# COMPILED_JS 4096N 4096 #-}

postulate _+_ : Number → Number → Number
{-# COMPILED_JS _+_ function(x) { return function(y) { return x + y; }; } #-}

postulate _−_ : Number → Number → Number
{-# COMPILED_JS _−_ function(x) { return function(y) { return x - y; }; } #-}

postulate _*_ : Number → Number → Number
{-# COMPILED_JS _*_ function(x) { return function(y) { return x * y; }; } #-}

postulate _/_ : Number → Number → Number
{-# COMPILED_JS _/_ function(x) { return function(y) { return x / y; }; } #-}

infixr 5  _++_
postulate _++_ : String → String → String
{-# COMPILED_JS _++_ function(x) { return function(y) { return x + y; }; } #-}

postulate _+JS_ : JSValue → JSValue → JSValue
{-# COMPILED_JS _+JS_ function(x) { return function(y) { return x + y; }; } #-}

postulate _≤JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≤JS_ function(x) { return function(y) { return x <= y; }; } #-}

postulate _<JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _<JS_ function(x) { return function(y) { return x < y; }; } #-}

postulate _>JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _>JS_ function(x) { return function(y) { return x > y; }; } #-}

postulate _≥JS_ : JSValue → JSValue → Bool
{-# COMPILED_JS _≥JS_ function(x) { return function(y) { return x >= y; }; } #-}

postulate _===_ : JSValue → JSValue → Bool
{-# COMPILED_JS _===_ function(x) { return function(y) { return x === y; }; } #-}

postulate reverse : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS reverse function(ty) { return function(x) { return x.reverse(); }; } #-}

postulate sort : {A : Set} → JSArray A → JSArray A
{-# COMPILED_JS sort function(ty) { return function(x) { return x.sort(); }; } #-}

postulate split : (sep target : String) → JSArray String
{-# COMPILED_JS split function(sep) { return function(target) { return target.split(sep); }; } #-}

postulate join : (sep : String)(target : JSArray String) → String
{-# COMPILED_JS join function(sep) { return function(target) { return target.join(sep); }; } #-}

postulate fromList : {A B : Set}(xs : List A)(fromElt : A → B) → JSArray B
{-# COMPILED_JS fromList require("libagda").fromList #-}

postulate length : String → Number
{-# COMPILED_JS length function(s) { return s.length; } #-}

postulate JSON-stringify : JSValue → String
{-# COMPILED_JS JSON-stringify JSON.stringify #-}

postulate JSON-parse : String → JSValue
{-# COMPILED_JS JSON-parse JSON.parse #-}

postulate toString : JSValue → String
{-# COMPILED_JS toString function(x) { return x.toString(); } #-}

postulate fromBool : Bool → JSValue
{-# COMPILED_JS fromBool function(x) { return x; } #-}

postulate fromString : String → JSValue
{-# COMPILED_JS fromString function(x) { return x; } #-}

postulate fromChar : Char → JSValue
{-# COMPILED_JS fromChar String #-}

postulate Char▹String : Char → String
{-# COMPILED_JS Char▹String String #-}

postulate fromNumber : Number → JSValue
{-# COMPILED_JS fromNumber function(x) { return x; } #-}

postulate fromJSArray : {A : Set} → JSArray A → JSValue
{-# COMPILED_JS fromJSArray function(ty) { return function(x) { return x; }; } #-}

postulate fromJSObject : JSObject → JSValue
{-# COMPILED_JS fromJSObject function(x) { return x; } #-}

postulate objectFromList : {A : Set}(xs : List A)(fromKey : A → String)(fromVal : A → JSValue) → JSObject
{-# COMPILED_JS objectFromList require("libagda").objectFromList #-}

postulate decodeJSArray : {A B : Set}(arr : JSArray A)(fromElt : Number → A → B) → List B
{-# COMPILED_JS decodeJSArray require("libagda").decodeJSArray #-}

postulate castNumber : JSValue → Number
{-# COMPILED_JS castNumber Number #-}

postulate castString : JSValue → String
{-# COMPILED_JS castString String #-}

-- TODO dyn check of length 1?
postulate castChar : JSValue → Char
{-# COMPILED_JS castChar String #-}

-- TODO dyn check of length 1?
postulate String▹Char : String → Char
{-# COMPILED_JS String▹Char String #-}

-- TODO dyn check?
postulate castJSArray : JSValue → JSArray JSValue
{-# COMPILED_JS castJSArray function(x) { return x; } #-}

-- TODO dyn check?
postulate castJSObject : JSValue → JSObject
{-# COMPILED_JS castJSObject function(x) { return x; } #-}

postulate nullJS : JSValue
{-# COMPILED_JS nullJS null #-}

postulate _·[_] : JSValue → JSValue → JSValue
{-# COMPILED_JS _·[_] require("libagda").readProp #-}

postulate _Array[_] : {A : Set} → JSArray A → Number → A
{-# COMPILED_JS _Array[_] function(ty) { return require("libagda").readProp; } #-}

postulate onJSArray : {A : Set} (f : JSArray JSValue → A) → JSValue → A
{-# COMPILED_JS onJSArray require("libagda").onJSArray #-}

postulate onString : {A : Set} (f : String → A) → JSValue → A
{-# COMPILED_JS onString require("libagda").onString #-}

-- Writes 'msg' and 'inp' to the console and then returns `f inp`
postulate trace : {A B : Set}(msg : String)(inp : A)(f : A → B) → B
{-# COMPILED_JS trace require("libagda").trace #-}

postulate throw : {A : Set} → String → A → A
{-# COMPILED_JS throw require("libagda").throw #-}

data Value : Set₀ where
  array  : List Value → Value
  object : List (String × Value) → Value
  string : String → Value
  number : Number → Value
  bool   : Bool   → Value
  null   : Value

Object = List (String × JSValue)

postulate fromValue : Value → JSValue
{-# COMPILED_JS fromValue require("libagda").fromValue #-}

-- TODO we could make it a COMPILED type and remove the encoding by using JSValue as the internal repr.
data ValueView : Set₀ where
  array  : JSArray JSValue → ValueView
  object : JSObject        → ValueView
  string : String          → ValueView
  number : Number          → ValueView
  bool   : Bool            → ValueView
  null   : ValueView

-- TODO not yet tested
postulate viewJSValue : JSValue → ValueView
{-# COMPILED_JS viewJSValue require("libagda").viewJSValue #-}

Bool▹String : Bool → String
Bool▹String true  = "true"
Bool▹String false = "false"

List▹String : List Char → String
List▹String xs = join "" (fromList xs Char▹String)

String▹List : String → List Char
String▹List s = decodeJSArray (split "" s) (λ _ → String▹Char)

Number▹String : Number → String
Number▹String = castString ∘ fromNumber

JSArray▹ListString : {A : Set} → JSArray A → List A
JSArray▹ListString a = decodeJSArray a (λ _ → id)

fromObject : Object → JSObject
fromObject o = objectFromList o fst snd

_≤Char_ : Char → Char → Bool
x ≤Char y = fromChar x ≤JS fromChar y

_<Char_ : Char → Char → Bool
x <Char y = fromChar x <JS fromChar y

_>Char_ : Char → Char → Bool
x >Char y = fromChar x >JS fromChar y

_≥Char_ : Char → Char → Bool
x ≥Char y = fromChar x ≥JS fromChar y

_≤String_ : String → String → Bool
x ≤String y = fromString x ≤JS fromString y

_<String_ : String → String → Bool
x <String y = fromString x <JS fromString y

_>String_ : String → String → Bool
x >String y = fromString x >JS fromString y

_≥String_ : String → String → Bool
x ≥String y = fromString x ≥JS fromString y

_≤Number_ : Number → Number → Bool
x ≤Number y = fromNumber x ≤JS fromNumber y

_<Number_ : Number → Number → Bool
x <Number y = fromNumber x <JS fromNumber y

_>Number_ : Number → Number → Bool
x >Number y = fromNumber x >JS fromNumber y

_≥Number_ : Number → Number → Bool
x ≥Number y = fromNumber x ≥JS fromNumber y

_·«_» : JSValue → String → JSValue
v ·« s » = v ·[ fromString s ]

_·«_»A : JSValue → String → JSArray JSValue
v ·« s »A = castJSArray (v ·« s »)

trace-call : {A B : Set} → String → (A → B) → A → B
trace-call s f x = trace s (f x) id

postulate JSCmd : Set → Set

Callback1 : Set → Set
Callback1 A = JSCmd ((A → 𝟘) → 𝟘)

Callback0 : Set
Callback0 = Callback1 𝟙

Callback2 : Set → Set → Set
Callback2 A B = JSCmd ((A → B → 𝟘) → 𝟘)

postulate assert : Bool → Callback0
{-# COMPILED_JS assert require("libagda").assert #-}

check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
check true  errmsg x = x
check false errmsg x = throw (errmsg _) x

warn-check : {A : Set}(pred : Bool)(errmsg : 𝟙 → String)(input : A) → A
warn-check true  errmsg x = x
warn-check false errmsg x = trace ("Warning: " ++ errmsg _) x id

infixr 0  _>>_ _!₁_ _!₂_
data JS! : Set₁ where
  end  : JS!
  _!₁_ : {A : Set}(cmd : Callback1 A)(cb : A → JS!) → JS!
  _!₂_ : {A B : Set}(cmd : JSCmd ((A → B → 𝟘) → 𝟘))(cb : A → B → JS!) → JS!

_>>_ : Callback0 → JS! → JS!
cmd >> cont = cmd !₁ λ _ → cont
-- -}
-- -}
-- -}
-- -}
-- -}


elgamal is proved... almost

elgamal is proved... almost

{-# 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)
--import Data.Vec.Properties as Vec
open import Algebra.FunctionProperties
open import Relation.Binary.PropositionalEquality as ≡

module elgamal where

★₁ : Set₂
★₁ = 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₀

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

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

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

sumToCount : ∀ {A} → Sum A → Count A
sumToCount sumA f = sumA (Bool.toℕ ∘ f)

sumBit : Sum Bit
sumBit f = f 0b + f 1b

-- liftM2 _,_ in the continuation monad
sumProd : ∀ {A B : Set} → Sum A → Sum B → Sum (A × B)
sumProd sumA sumB f = sumA (λ x₀ →
                       sumB (λ x₁ →
                         f (x₀ , x₁)))

sumProd-ext : ∀ {A B : Set} {sumA : Sum A} {sumB : Sum B} →
              SumExt sumA → SumExt sumB → SumExt (sumProd sumA sumB)
sumProd-ext sumA-ext sumB-ext f g f≗g = sumA-ext _ _ (λ x → sumB-ext _ _ (λ y → f≗g (x , y)))

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 ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum ℤq)
  (sumℤq-lem : ∀ f x → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  where

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

  sum : (u : `★) → Sum (El u)
  sum `⊤         f = f _
  sum `X         f = sumℤq f
  sum (u₀ `× u₁) f = sum u₀ (λ x₀ →
                       sum u₁ (λ x₁ →
                         f (x₀ , x₁)))

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

  ⁇ : ∀ 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 (Bool.toℕ ∘ Adv) x

  -- ∀ (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
  ℤ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ℕ

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

  postulate
    g^-inj : ∀ m n → g^ m ≡ g^ n → m ≡ n

module G-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : Sum ℤq)
  (sumℤq-lem : ∀ f x → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  where

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

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

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

    -- ⅁′ : ∀ {R} → DDHAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    -- ⅁′ 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

    -- α is the pk
    -- α = g ^ x
    -- 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 α m y = β , ζ where
      β = g ^ y
      δ = α ^ y
      ζ = δ ⊕ m

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

    Dec : SecKey → CipherText → Message
    Dec x (β , ζ) = (β ^ x) ⊕⁻¹ ζ

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

    {-
    Game0 : ∀ {R _I : Set} → EncAdv R → (Bit × ℤq × ℤq × _I × R) → Bit
    Game0 A (b , x , y , z , r) =
      let (pk , sk) = KeyGen x
          (m , D) = A pk r in
      D (Enc pk (m b) y)

    Game : (i : Bit) → ∀ {R} → EncAdv R → (Bit × ℤq × ℤq × ℤq × R) → Bit
    Game i A (b , x , y , z , r) =
      let (α , sk) = KeyGen x
          (m , D) = A α r
          β = g ^ y
          δ = α ^ case i 0→ y 1→ z
          ζ = δ ⊕ m b
      in {-b ==ᵇ-} D (β , ζ)

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

    SS⅁ : ∀ {R _I : Set} → EncAdv R → Bit → (R × ℤq × ℤq × _I) → Bit
    SS⅁ A b (r , x , y , z) =
      let -- (pk , sk) = KeyGen x
          (m , D) = A pk r in
      D (Enc pk (m b) y)
         where pk = g ^ x

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

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

    -- Game0 ≤ ε
    -- Game1 ≡ 0

    -- ⁇ ⊕ x ≈ ⁇

    -- g ^ ⁇ ∙ x ≈ g ^ ⁇

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

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

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

    TrA : ∀ {R} → Bit → EncAdv R → DDHAdv R
    TrA b A r gˣ gʸ gˣʸ = d (gʸ , gˣʸ ∙ m b)
       where m,d = A gˣ r
             m = proj₁ m,d
             d = proj₂ m,d

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

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

    OTP⅁ : ∀ {R : Set} → (R → G → G) → (R → G → G → G → 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

    module WithℤqProps
        (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
      -- (⊠-comm : Commutative _≡_ _⊠_)
      -- (^-comm : ∀ α x y → (α ^ x) ^ y ≡ (α ^ y) ^ x)
        (sumℤq : Sum ℤq)
        (sumℤq-ext : SumExt sumℤq) where
        #q_ : Count ℤq
        #q_ = sumToCount sumℤq

        module SumU
          (R : Set)
          (sumR : Sum R)
          (sumR-ext : SumExt sumR)
          where
          U = R × ℤq × ℤq × ℤq
          sumU : Sum U
          sumU = sumProd sumR (sumProd sumℤq (sumProd sumℤq sumℤq))
          #U_ : Count U
          #U_ = sumToCount sumU
          sumU-ext : SumExt sumU
          sumU-ext = sumProd-ext sumR-ext (sumProd-ext sumℤq-ext (sumProd-ext sumℤq-ext sumℤq-ext))

        module WithSumR
            (R : Set)
            (sumR : Sum R)
            (sumR-ext : SumExt sumR)
           where
           open SumU R sumR sumR-ext

           module EvenMoreProof
            (ddh-hyp : (A : DDHAdv R) → #U (DDH⅁ A 0b) ≡ #U (DDH⅁ A 1b))

            (otp-lem : ∀ (A : G → Bit) m → #q(λ x → A (g^ x ∙ m)) ≡ #q(λ x → A (g^ x)))
            where

                _≈U_ : (f g : U → Bit) → Set
                f ≈U g = #U f ≡ #U g

                otp-lem' : ∀ D M₀ M₁ → OTP⅁ M₀ D ≈U OTP⅁ M₁ D
                otp-lem' D M₀ M₁ = sumR-ext (f3 M₀) (f3 M₁) (λ r →
                                     sumℤq-ext (f2 M₀ r) (f2 M₁ r) (λ x →
                                       sumℤq-ext (f1 M₀ r x) (f1 M₁ r x) (λ 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
                          m0 = M₀ r gˣ
                          m1 = M₁ r gˣ
                          f5 = λ M z → D r gˣ gʸ (g^ z ∙ M)
                          pf' : #q(f5 m0) ≡ #q(f5 m1)
                          pf' rewrite otp-lem (D r gˣ gʸ) m0
                                    | otp-lem (D r gˣ gʸ) m1 = refl

      {-
        #-proj₁ : ∀ {A B : Set} {f g : A → Bit} → # f ≡ # g
                   → #_ {A × B} (f ∘ proj₁) ≡ #_ {A × B} (g ∘ proj₁)
        #-proj₁ = {!!}

        otp-lem'' : ∀ (A : G → Bit) m
           → #(λ { (x , y) → A (g^ x ∙ m) }) ≡ #(λ { (x , y) → A (g ^ x) })
        otp-lem'' = {!!}
        -}
                projM : EncAdv R → Bit → R → G → G
                projM A b r gˣ = proj₁ (A gˣ r) b

                projD : EncAdv R → R → G → G → G → Bit
                projD A r gˣ gʸ gᶻ∙M = proj₂ (A gˣ r) (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 : #U(SS⅁ A b) ≡ #U(DDH⅁ Aᵇ 0b)
                    pf1 = sumU-ext _ _ (cong Bool.toℕ ∘ pf0,5)

                    pf2 : DDH⅁ Aᵇ 0b ≈U 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 ≈U DDH⅁ A¬ᵇ 1b
                    pf3 = otp-lem' (projD A) (projM A b) (projM A (not b))

                    pf4 : DDH⅁ A¬ᵇ 1b ≈U 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 : #U(SS⅁ A (not b)) ≡ #U(DDH⅁ A¬ᵇ 0b)
                    pf5 = sumU-ext _ _ (cong Bool.toℕ ∘ pf4,5)

                    final : #U(SS⅁ A b) ≡ #U(SS⅁ A (not b))
                    final rewrite pf1 | pf2 | pf3 | pf4 | pf5 = refl

      {-
        pf1 : ∀ {R} A r → Game 0b {R} A r ≡ ⅁′ (TrA 1b A) r
        pf1 A (true , x , y , z , r) rewrite dist-^-⊠ g x y = refl
        pf1 A (false , x , y , z , r) = {!!}

        pf2 : ∀ {R} A r → Game 1b {R} A r ≡ ⅁′ (TrA 0b A) r
        pf2 A (true , x , y , z , r)  = {!!}
        pf2 A (false , x , y , z , r) = {!!}
-}
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 Proof
      -- (⊠-comm : Commutative _≡_ _⊠_)
      -- (^-lem : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
      (^-comm : ∀ α x y → (α ^ x) ^ y ≡ (α ^ y) ^ x)
      -- (x ∙ x ⁻¹ ≡ 0)
      (ℚ : ★)
      (dist : ℚ → ℚ → ℚ)
      (1/2 : ℚ)
      (_≤_ : ℚ → ℚ → ★)
      (ε-DDH : ℚ)
      where

        Pr[S_] : Bool → ℚ
        Pr[S b ] = {!!}

        -- SS
        -- SS = dist Pr[

        Pr[S₀] = Pr[S 0b ]
        Pr[S₁] = Pr[S 1b ]

        pf1 : Pr[S₁] ≡ 1/2
        pf1 = {!!}

        pf2 : dist Pr[S₀] 1/2 ≡ dist Pr[S₀] Pr[S₁]
        pf2 = {!!}

        pf3 : dist Pr[S₀] Pr[S₁] ≤ ε-DDH
        pf3 = {!!}

        pf4 : dist Pr[S₀] 1/2 ≤ ε-DDH
        pf4 = {!!}

module G11 = G-implem 11 10 (## 2) (## 0) (## 1) (## 0) (## 1)
open G11
module E11 = El-Gamal-Base _ _⊠_ G g _^_ {!!} _∙_
open E11
open WithℤqProps ?
-- open Proof {!!}

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

{-# 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)
--import Data.Vec.Properties as Vec
open import Algebra.FunctionProperties
open import Relation.Binary.PropositionalEquality as ≡

module elgamal where

★₁ : Set₂
★₁ = Set₁

★ : Set₁
★ = Set

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

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

sumBit : (Bit → ℕ) → ℕ
sumBit f = f 0b + f 1b

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 ℤq-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : (ℤq → ℕ) → ℕ)
  (sumℤq-lem : ∀ f x → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  where

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

  sum : (u : `★) → (El u → ℕ) → ℕ
  sum `⊤         f = f _
  sum `X         f = sumℤq f
  sum (u₀ `× u₁) f = sum u₀ (λ x₀ →
                       sum u₁ (λ x₁ →
                         f (x₀ , x₁)))

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

  ⁇ : ∀ 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 (Bool.toℕ ∘ Adv) x

  -- ∀ (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
  ℤ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 : (ℤ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

  postulate
    g^-inj : ∀ m n → g^ m ≡ g^ n → m ≡ n

module G-count
  (ℤq : ★)
  (_⊞_ : ℤq → ℤq → ℤq)
  (sumℤq : (ℤq → ℕ) → ℕ)
  (sumℤq-lem : ∀ f x → sumℤq (f ∘ _⊞_ x) ≡ sumℤq f)
  (G : ★)
  (g : G)
  (_^_ : G → ℤq → G)
  where

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

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

module DDH
  (ℤq  : ★)
  (_⊠_ : ℤq → ℤq → ℤq)
  (G   : ★)
  (g^_ : ℤq → G)
  where
    DDHAdv : ★ → ★
    DDHAdv R = G → G → G → R → Bool

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

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

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

    -- ⅁′ : ∀ {R} → DDHAdv R → (Bool × ℤq × ℤq × ℤq × R) → Bool
    -- ⅁′ 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 Bool
        ⅁₀↺ : ∀ {R _I} → DDHAdv↺ R → ↺ (`ℤq `× `ℤq `× _I `× R) Bool
        run↺ (⅁₀↺ D) = ⅁₀ (λ a b c → run↺ (D a b c))

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

    -- α is the pk
    -- α = g ^ x
    -- 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 α m y = β , ζ where
      β = g ^ y
      δ = α ^ y
      ζ = δ ⊕ m

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

    Dec : SecKey → CipherText → Message
    Dec x (β , ζ) = (β ^ x) ⊕⁻¹ ζ

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

    {-
    Game0 : ∀ {R _I : Set} → EncAdv R → (Bool × ℤq × ℤq × _I × R) → Bool
    Game0 A (b , x , y , z , r) =
      let (pk , sk) = KeyGen x
          (m , D) = A pk r in
      D (Enc pk (m b) y)

    Game : (i : Bool) → ∀ {R} → EncAdv R → (Bool × ℤq × ℤq × ℤq × R) → Bool
    Game i A (b , x , y , z , r) =
      let (α , sk) = KeyGen x
          (m , D) = A α r
          β = g ^ y
          δ = α ^ case i 0→ y 1→ z
          ζ = δ ⊕ m b
      in {-b ==ᵇ-} D (β , ζ)

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

    SS⅁ : ∀ {R _I : Set} → EncAdv R → Bool → (ℤq × ℤq × _I × R) → Bool
    SS⅁ A b (x , y , z , r) =
      let -- (pk , sk) = KeyGen x
          (m , D) = A pk r in
      D (Enc pk (m b) y)
         where pk = g ^ x

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

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

    -- Game0 ≤ ε
    -- Game1 ≡ 0

    -- ⁇ ⊕ x ≈ ⁇

    -- g ^ ⁇ ∙ x ≈ g ^ ⁇

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

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

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

    TrA : ∀ {R} → Bool → EncAdv R → DDHAdv R
    TrA b A gˣ gʸ gˣʸ r = d (gʸ , gˣʸ ∙ m b)
       where m,d = A gˣ r
             m = proj₁ m,d
             d = proj₂ m,d

    like-SS⅁ : ∀ {R _I : Set} → EncAdv R → Bool → (ℤq × ℤq × _I × R) → Bool
    like-SS⅁ A b (x , y , z , r) =
      let -- gˣ = g ^ x
          -- gʸ = g ^ y
          (m , D) = A gˣ r in
      D (gʸ , (gˣ ^ y) ∙ m b)
      where gˣ = g ^ x
            gʸ = g ^ y

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

    module Proof
      -- (⊠-comm : Commutative _≡_ _⊠_)
      (dist-^-⊠ : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
      -- (^-comm : ∀ α x y → (α ^ x) ^ y ≡ (α ^ y) ^ x)

      (#_ : ∀ {R} → (R → Bit) → ℕ)
      (ddh-hyp : ∀ {R} (A : DDHAdv R) → # (DDH⅁ A 0b) ≡ # (DDH⅁ A 1b))
      (otp-lem : ∀ (A : G → Bit) m → #(λ x → A (g^ x ∙ m)) ≡ #(λ x → A (g ^ x)))
      -- (wk≈ : ∀ {R1 R2} (f : R2 → R1)(x y : R1 → Bit) (z t : R2 → Bit) → x ≈ y → z ≈ t)
      where

        _≈_ : ∀ {R} → (f g : R → Bit) → Set
        f ≈ g = # f ≡ # g

        pf1 : ∀ {R} A b r → SS⅁ {R} A b r ≡ DDH⅁ (TrA b A) 0b r
        pf1 A b (x , y , z , r) rewrite dist-^-⊠ g x y = refl

        pf2 : ∀ {R} A b → DDH⅁ {R} (TrA b A) 0b ≈ DDH⅁ (TrA b A) 1b
        pf2 A b = ddh-hyp (TrA b A)

        pf3 : ∀ {R} A b → DDH⅁ {R} (TrA b A) 1b ≈ DDH⅁ (TrA (not b) A) 1b
        pf3 {R} A b = pf3'
          where
            Aᵇ = TrA b A

            -- pf3'' : # (DDH⅁₁ {R} Aᵇ) ≈ DDH⅁₁ (TrA (not b) A)
            -- pf3'' = ?

            pf3' : DDH⅁₁ {R} Aᵇ ≈ DDH⅁₁ (TrA (not b) A)
            pf3' = {!wk≈ (λ { (x , y , z , r) → {!!} }) _ _ _ _ (otp-lem {!!} {!!})!}

      {-
        pf1 : ∀ {R} A r → Game 0b {R} A r ≡ ⅁′ (TrA 1b A) r
        pf1 A (true , x , y , z , r) rewrite dist-^-⊠ g x y = refl
        pf1 A (false , x , y , z , r) = {!!}

        pf2 : ∀ {R} A r → Game 1b {R} A r ≡ ⅁′ (TrA 0b A) r
        pf2 A (true , x , y , z , r)  = {!!}
        pf2 A (false , x , y , z , r) = {!!}
-}
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 Proof
      -- (⊠-comm : Commutative _≡_ _⊠_)
      -- (^-lem : ∀ α x y → α ^ (x ⊠ y) ≡ (α ^ x) ^ y)
      (^-comm : ∀ α x y → (α ^ x) ^ y ≡ (α ^ y) ^ x)
      -- (x ∙ x ⁻¹ ≡ 0)
      (ℚ : ★)
      (dist : ℚ → ℚ → ℚ)
      (1/2 : ℚ)
      (_≤_ : ℚ → ℚ → ★)
      (ε-DDH : ℚ)
      where

        Pr[S_] : Bool → ℚ
        Pr[S b ] = {!!}

        -- SS
        -- SS = dist Pr[

        Pr[S₀] = Pr[S 0b ]
        Pr[S₁] = Pr[S 1b ]

        pf1 : Pr[S₁] ≡ 1/2
        pf1 = {!!}

        pf2 : dist Pr[S₀] 1/2 ≡ dist Pr[S₀] Pr[S₁]
        pf2 = {!!}

        pf3 : dist Pr[S₀] Pr[S₁] ≤ ε-DDH
        pf3 = {!!}

        pf4 : dist Pr[S₀] 1/2 ≤ ε-DDH
        pf4 = {!!}

module G11 = G-implem 11 10 (## 2) (## 0) (## 1) (## 0) (## 1)
open G11
module E11 = El-Gamal-Base _ _⊠_ G g _^_ {!!} _∙_
open E11
open Proof {!!}

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


Put constructor arguments on different lines.

Old-commit-hash: 02f9c59c59ddef7050c2c035457c98ecb00464dc

import Syntax.Type.Plotkin as Type

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product
open Type B
open import Syntax.Context {Type}

data Term
  (Γ : Context) :
  (τ : Type) → Set
  where
  const : ∀ {τ} →
    (c : C τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ
weaken Γ₁≼Γ₂ (const c) = const c
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

-- Specialized weakening
weaken₁ : ∀ {Γ σ τ} →
  Term Γ τ → Term (σ • Γ) τ
weaken₁ t = weaken (drop _ • ≼-refl) t

weaken₂ : ∀ {Γ α β τ} →
  Term Γ τ → Term (α • β • Γ) τ
weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

weaken₃ : ∀ {Γ α β γ τ} →
  Term Γ τ → Term (α • β • γ • Γ) τ
weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

-- Shorthands for nested applications
app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
app₂ f x = app (app f x)

app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
app₃ f x = app₂ (app f x)

app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
app₄ f x = app₃ (app f x)

app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
app₅ f x = app₄ (app f x)

app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
app₆ f x = app₅ (app f x)

import Syntax.Type.Plotkin as Type

module Syntax.Term.Plotkin
    {B : Set {- of base types -}}
    {C : Type.Type B → Set {- of constants -}}
  where

-- Terms of languages described in Plotkin style

open import Function using (_∘_)
open import Data.Product
open Type B
open import Syntax.Context {Type}

data Term
  (Γ : Context) :
  (τ : Type) → Set
  where
  const : ∀ {τ} → (c : C τ) → Term Γ τ
  var : ∀ {τ} → (x : Var Γ τ) → Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ))
    (t : Term Γ σ) → Term Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) → Term Γ (σ ⇒ τ)

-- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
-- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

lift-diff-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} →
    term Γ (τ ⇒ τ ⇒ Δtype τ) × term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-diff-apply diff apply {base ι} = diff , apply
lift-diff-apply diff apply {σ ⇒ τ} =
  let
    -- for diff
    g  = var (that (that (that this)))
    f  = var (that (that this))
    x  = var (that this)
    Δx = var this
    -- for apply
    Δh = var (that (that this))
    h  = var (that this)
    y  = var this
    -- syntactic sugars
    diffσ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {σ} {Γ})
    diffτ  = λ {Γ} → proj₁ (lift-diff-apply diff apply {τ} {Γ})
    applyσ = λ {Γ} → proj₂ (lift-diff-apply diff apply {σ} {Γ})
    applyτ = λ {Γ} → proj₂ (lift-diff-apply diff apply {τ} {Γ})
    _⊝σ_ = λ s t  → app (app diffσ s) t
    _⊝τ_ = λ s t  → app (app diffτ s) t
    _⊕σ_ = λ t Δt → app (app applyσ Δt) t
    _⊕τ_ = λ t Δt → app (app applyτ Δt) t
  in
    abs (abs (abs (abs (app f (x ⊕σ Δx) ⊝τ app g x))))
    ,
    abs (abs (abs (app h y ⊕τ app (app Δh y) (y ⊝σ y))))

lift-diff : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (τ ⇒ τ ⇒ Δtype τ)

lift-diff diff apply = λ {τ Γ} →
  proj₁ (lift-diff-apply diff apply {τ} {Γ})

lift-apply : ∀ {Δbase : B → Type} →
  let
    Δtype = lift-Δtype Δbase
    term = Term
  in
  (∀ {ι Γ} → term Γ (base ι ⇒ base ι ⇒ Δtype (base ι))) →
  (∀ {ι Γ} → term Γ (Δtype (base ι) ⇒ base ι ⇒ base ι)) →
  ∀ {τ Γ} → term Γ (Δtype τ ⇒ τ ⇒ τ)

lift-apply diff apply = λ {τ Γ} →
  proj₂ (lift-diff-apply diff apply {τ} {Γ})

-- Weakening

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ
weaken Γ₁≼Γ₂ (const c) = const c
weaken Γ₁≼Γ₂ (var x) = var (lift Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

-- Specialized weakening
weaken₁ : ∀ {Γ σ τ} →
  Term Γ τ → Term (σ • Γ) τ
weaken₁ t = weaken (drop _ • ≼-refl) t

weaken₂ : ∀ {Γ α β τ} →
  Term Γ τ → Term (α • β • Γ) τ
weaken₂ t = weaken (drop _ • drop _ • ≼-refl) t

weaken₃ : ∀ {Γ α β γ τ} →
  Term Γ τ → Term (α • β • γ • Γ) τ
weaken₃ t = weaken (drop _ • drop _ • drop _ • ≼-refl) t

-- Shorthands for nested applications
app₂ : ∀ {Γ α β γ} →
    Term Γ (α ⇒ β ⇒ γ) →
    Term Γ α → Term Γ β → Term Γ γ
app₂ f x = app (app f x)

app₃ : ∀ {Γ α β γ δ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ
app₃ f x = app₂ (app f x)

app₄ : ∀ {Γ α β γ δ ε} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε
app₄ f x = app₃ (app f x)

app₅ : ∀ {Γ α β γ δ ε ζ} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ
app₅ f x = app₄ (app f x)

app₆ : ∀ {Γ α β γ δ ε ζ η} →
    Term Γ (α ⇒ β ⇒ γ ⇒ δ ⇒ ε ⇒ ζ ⇒ η) →
    Term Γ α → Term Γ β → Term Γ γ → Term Γ δ →
    Term Γ ε → Term Γ ζ → Term Γ η
app₆ f x = app₅ (app f x)