modular-exp [still called ecc]: better use of the Alegbra modules

open import Relation.Binary.PropositionalEquality.NP
open import Data.Two.Base
open import Data.List
open import Function
open import Algebra.FunctionProperties.Eq
open Implicits
open import Algebra.Monoid.Commutative
open import Algebra.Ring

module ecc
  {𝔽 : Set} (𝔽-ring : Ring 𝔽)
  {ℙ : Set} (ℙ-monoid : Commutative-Monoid ℙ)
  where

open module 𝔽 = Ring 𝔽-ring

open module ⊕ = Commutative-Monoid ℙ-monoid
  renaming
    ( _∙_ to _⊕_
    ; ∙= to ⊕=
    ; ε∙-identity to ε⊕-identity
    ; ∙ε-identity to ⊕ε-identity
    ; _² to 2·_
    )

2·-⊕-distr : ∀ {P Q} → 2· (P ⊕ Q) ≡ 2· P ⊕ 2· Q
2·-⊕-distr = ⊕.interchange

2·-⊕ : ∀ {P Q R} → 2· P ⊕ (Q ⊕ R) ≡ (P ⊕ Q) ⊕ (P ⊕ R)
2·-⊕ = ⊕.interchange

-- NOT used yet
multiply-bin : List 𝟚 → ℙ → ℙ
multiply-bin scalar P = go scalar
  where
    go : List 𝟚 → ℙ
    go []       = P
    go (b ∷ bs) = [0: x₀ 1: x₁ ] b
      where x₀ = 2· go bs
            x₁ = P ⊕ x₀

{-
multiply : 𝔽 → ℙ → ℙ
multiply scalar P =
  -- if scalar == 0 or scalar >= N: raise Exception("Invalid Scalar/Private Key")
    multiply-bin (bin scalar) P

_·_ = multiply
infixr 8 _·_
-}

infixl 7 1+2*_
1+2*_ = λ x → 1+ 2* x

data Parity-View : 𝔽 → Set where
  zero⟨_⟩    : ∀ {n} → n ≡ 0# → Parity-View n
  even_by⟨_⟩ : ∀ {m n} → Parity-View m → n ≡ 2* m    → Parity-View n
  odd_by⟨_⟩  : ∀ {m n} → Parity-View m → n ≡ 1+ 2* m → Parity-View n

cast_by⟨_⟩ : ∀ {x y} → Parity-View x → y ≡ x → Parity-View y
cast zero⟨ xₑ ⟩       by⟨ yₑ ⟩ = zero⟨ yₑ ∙ xₑ ⟩
cast even xₚ by⟨ xₑ ⟩ by⟨ yₑ ⟩ = even xₚ by⟨ yₑ ∙ xₑ ⟩
cast odd  xₚ by⟨ xₑ ⟩ by⟨ yₑ ⟩ = odd  xₚ by⟨ yₑ ∙ xₑ ⟩

infixr 8 _·ₚ_
_·ₚ_ : ∀ {n} (p : Parity-View n) → ℙ → ℙ
zero⟨ e ⟩      ·ₚ P = ε
even p by⟨ e ⟩ ·ₚ P = 2· (p ·ₚ P)
odd  p by⟨ e ⟩ ·ₚ P = P ⊕ (2· (p ·ₚ P))

_+2*_ : 𝟚 → 𝔽 → 𝔽
0₂ +2* m =   2* m
1₂ +2* m = 1+2* m

{-
postulate
    bin-2* : ∀ {n} → bin (2* n) ≡ 0₂ ∷ bin n
    bin-1+2* : ∀ {n} → bin (1+2* n) ≡ 1₂ ∷ bin n

bin-+2* : (b : 𝟚)(n : 𝔽) → bin (b +2* n) ≡ b ∷ bin n
bin-+2* 1₂ n = bin-1+2*
bin-+2* 0₂ n = bin-2*
-}

-- (msb) most significant bit first
binₚ : ∀ {n} → Parity-View n → List 𝟚
binₚ zero⟨ e ⟩      = []
binₚ even p by⟨ e ⟩ = 0₂ ∷ binₚ p
binₚ odd  p by⟨ e ⟩ = 1₂ ∷ binₚ p

half : ∀ {n} → Parity-View n → 𝔽
half zero⟨ _ ⟩            = 0#
half (even_by⟨_⟩ {m} _ _) = m
half (odd_by⟨_⟩  {m} _ _) = m

{-
bin-parity : ∀ {n} (p : ParityView n) → bin n ≡ parity p ∷ bin (half p)
bin-parity (even n) = bin-2*
bin-parity (odd n)  = bin-1+2*
-}

infixl 6 1+ₚ_ _+ₚ_
1+ₚ_ : ∀ {x} → Parity-View x → Parity-View (1+ x)
1+ₚ zero⟨ e ⟩      = odd zero⟨ refl ⟩ by⟨ ap 1+_ (e ∙ ! 0+-identity) ⟩
1+ₚ even p by⟨ e ⟩ = odd p      by⟨ ap 1+_ e ⟩
1+ₚ odd  p by⟨ e ⟩ = even 1+ₚ p by⟨ ap 1+_ e ∙ ! +-assoc ∙ +-interchange ⟩

_+ₚ_ : ∀ {x y} → Parity-View x → Parity-View y → Parity-View (x + y)
zero⟨ xₑ ⟩       +ₚ yₚ        = cast yₚ by⟨ ap (λ z → z + _) xₑ ∙ 0+-identity ⟩
xₚ              +ₚ zero⟨ yₑ ⟩ = cast xₚ by⟨ ap (_+_ _) yₑ ∙ +-comm ∙ 0+-identity ⟩
even xₚ by⟨ xₑ ⟩ +ₚ even yₚ by⟨ yₑ ⟩ = even     xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-interchange ⟩
even xₚ by⟨ xₑ ⟩ +ₚ odd  yₚ by⟨ yₑ ⟩ = odd      xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-comm ∙ +-assoc ∙ ap 1+_ (+-comm ∙ +-interchange) ⟩
odd  xₚ by⟨ xₑ ⟩ +ₚ even yₚ by⟨ yₑ ⟩ = odd      xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-assoc ∙ ap 1+_ +-interchange ⟩
odd  xₚ by⟨ xₑ ⟩ +ₚ odd  yₚ by⟨ yₑ ⟩ = even 1+ₚ (xₚ +ₚ yₚ) by⟨ += xₑ yₑ ∙ +-on-sides refl +-interchange ⟩

infixl 7 2*ₚ_
2*ₚ_ : ∀ {x} → Parity-View x → Parity-View (2* x)
2*ₚ xₚ = xₚ +ₚ xₚ

open ≡-Reasoning

module _ {P Q} where
    ·ₚ-⊕-distr : ∀ {x} (xₚ : Parity-View x) → xₚ ·ₚ (P ⊕ Q) ≡ xₚ ·ₚ P ⊕ xₚ ·ₚ Q
    ·ₚ-⊕-distr zero⟨ xₑ ⟩       = ! ε⊕-identity
    ·ₚ-⊕-distr even xₚ by⟨ xₑ ⟩ = ap 2·_ (·ₚ-⊕-distr xₚ) ∙ 2·-⊕-distr
    ·ₚ-⊕-distr odd  xₚ by⟨ xₑ ⟩ = ap (λ z → P ⊕ Q ⊕ 2· z) (·ₚ-⊕-distr xₚ)
                               ∙ ap (λ z → P ⊕ Q ⊕ z) (! 2·-⊕)
                               ∙ ⊕.interchange

module _ {P} where
    cast-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₑ : y ≡ x) → cast xₚ by⟨ yₑ ⟩ ·ₚ P ≡ xₚ ·ₚ P
    cast-·ₚ-distr zero⟨ x₁ ⟩ yₑ = refl
    cast-·ₚ-distr even xₚ by⟨ x₁ ⟩ yₑ = refl
    cast-·ₚ-distr odd xₚ by⟨ x₁ ⟩ yₑ = refl

    1+ₚ-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → (1+ₚ xₚ) ·ₚ P ≡ P ⊕ xₚ ·ₚ P
    1+ₚ-·ₚ-distr zero⟨ xₑ ⟩       = ap (_⊕_ P) ε⊕-identity
    1+ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ = refl
    1+ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ = ap 2·_ (1+ₚ-·ₚ-distr xₚ) ∙ ⊕.interchange ∙ ⊕.assoc

    +ₚ-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₚ : Parity-View y)
                 → (xₚ +ₚ yₚ) ·ₚ P ≡ xₚ ·ₚ P ⊕ yₚ ·ₚ P
    +ₚ-·ₚ-distr zero⟨ xₑ ⟩ yₚ = cast-·ₚ-distr yₚ _ ∙ ! ε⊕-identity

    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ⊕ε-identity
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ⊕ε-identity

    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr
    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ = ap (_⊕_ P) (ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr) ∙ ⊕.assoc-comm
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap (_⊕_ P) (ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr) ∙ ! ⊕.assoc
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩
       = (odd xₚ by⟨ xₑ ⟩ +ₚ odd yₚ by⟨ yₑ ⟩) ·ₚ P
       ≡⟨by-definition⟩
         2·((1+ₚ (xₚ +ₚ yₚ)) ·ₚ P)
       ≡⟨ ap 2·_ helper ⟩
         2·(P ⊕ (xₚ ·ₚ P ⊕ yₚ ·ₚ P))
       ≡⟨ 2·-⊕-distr ⟩
         2· P ⊕ (2·(xₚ ·ₚ P ⊕ yₚ ·ₚ P))
       ≡⟨ ap (_⊕_ (2· P)) 2·-⊕-distr ⟩
         2· P ⊕ (2·(xₚ ·ₚ P) ⊕ 2·(yₚ ·ₚ P))
       ≡⟨ 2·-⊕ ⟩
         P ⊕ 2·(xₚ ·ₚ P) ⊕ (P ⊕ 2·(yₚ ·ₚ P))
       ≡⟨by-definition⟩
         odd xₚ by⟨ xₑ ⟩ ·ₚ P ⊕ odd yₚ by⟨ yₑ ⟩ ·ₚ P
       ∎
        where helper = (1+ₚ (xₚ +ₚ yₚ)) ·ₚ P
                     ≡⟨ 1+ₚ-·ₚ-distr (xₚ +ₚ yₚ) ⟩
                       P ⊕ ((xₚ +ₚ yₚ) ·ₚ P)
                     ≡⟨ ap (_⊕_ P) (+ₚ-·ₚ-distr xₚ yₚ) ⟩
                       P ⊕ (xₚ ·ₚ P ⊕ yₚ ·ₚ P)
                     ∎

*-1+-distr : ∀ {x y} → x * (1+ y) ≡ x + x * y
*-1+-distr = *-+-distrˡ ∙ += *1-identity refl

1+-*-distr : ∀ {x y} → (1+ x) * y ≡ y + x * y
1+-*-distr = *-+-distrʳ ∙ += 1*-identity refl

infixl 7 _*ₚ_
_*ₚ_ : ∀ {x y} → Parity-View x → Parity-View y → Parity-View (x * y)
zero⟨ xₑ ⟩       *ₚ yₚ              = zero⟨ *= xₑ refl ∙ 0*-zero ⟩
xₚ              *ₚ zero⟨ yₑ ⟩       = zero⟨ *= refl yₑ ∙ *0-zero ⟩
even xₚ by⟨ xₑ ⟩ *ₚ yₚ              = even (xₚ *ₚ yₚ) by⟨ *= xₑ refl ∙ *-+-distrʳ ⟩
xₚ              *ₚ even yₚ by⟨ yₑ ⟩ = even (xₚ *ₚ yₚ) by⟨ *= refl yₑ ∙ *-+-distrˡ ⟩
odd xₚ by⟨ xₑ ⟩  *ₚ odd yₚ by⟨ yₑ ⟩  = odd  (xₚ +ₚ yₚ +ₚ 2*ₚ (xₚ *ₚ yₚ)) by⟨ *= xₑ yₑ ∙ helper ⟩
   where
     x = _
     y = _
     helper = (1+2* x)*(1+2* y)
            ≡⟨ 1+-*-distr ⟩
              1+2* y + 2* x * 1+2* y
            ≡⟨ ap (λ z → 1+2* y + z)
                 (2* x * 1+2* y
                 ≡⟨ *-1+-distr ⟩
                 (2* x + 2* x * 2* y)
                 ≡⟨ += refl *-+-distrˡ ∙ +-interchange ⟩
                 (2* (x + 2* x * y))
                 ∎) ⟩
              1+2* y + 2* (x + 2* x * y)
            ≡⟨ +-assoc ∙ ap 1+_ +-interchange ⟩
              1+2*(y + (x + 2* x * y))
            ≡⟨ ap 1+2*_ (! +-assoc ∙ += +-comm refl) ⟩
              1+2*(x + y + 2* x * y)
            ≡⟨ ap (λ z → 1+2*(x + y + z)) *-+-distrʳ ⟩
              1+2*(x + y + 2* (x * y))
            ∎

module _ {P} where
    2·-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → 2·(xₚ ·ₚ P) ≡ xₚ ·ₚ 2· P
    2·-·ₚ-distr xₚ = ! ·ₚ-⊕-distr xₚ

    2*ₚ-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → (2*ₚ xₚ) ·ₚ P ≡ 2·(xₚ ·ₚ P)
    2*ₚ-·ₚ-distr xₚ = +ₚ-·ₚ-distr xₚ xₚ

·ₚ-ε : ∀ {x} (xₚ : Parity-View x) → xₚ ·ₚ ε ≡ ε
·ₚ-ε zero⟨ xₑ ⟩       = refl
·ₚ-ε even xₚ by⟨ xₑ ⟩ = ap 2·_ (·ₚ-ε xₚ) ∙ ε⊕-identity
·ₚ-ε odd xₚ by⟨ xₑ ⟩  = ε⊕-identity ∙ ap 2·_ (·ₚ-ε xₚ) ∙ ε⊕-identity

*ₚ-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₚ : Parity-View y) {P} → (xₚ *ₚ yₚ) ·ₚ P ≡ xₚ ·ₚ yₚ ·ₚ P
*ₚ-·ₚ-distr zero⟨ xₑ ⟩ yₚ = refl
*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ·ₚ-ε even xₚ by⟨ xₑ ⟩
*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ·ₚ-ε odd  xₚ by⟨ xₑ ⟩

*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap 2·_ (*ₚ-·ₚ-distr xₚ even yₚ by⟨ yₑ ⟩)
*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ = ap 2·_ (*ₚ-·ₚ-distr xₚ odd  yₚ by⟨ yₑ ⟩)

*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ {P} =
   ap 2·_ (*ₚ-·ₚ-distr odd xₚ by⟨ xₑ ⟩ yₚ) ∙ 2·-⊕-distr ∙ ap (λ z → 2· (yₚ ·ₚ P) ⊕ 2· z) (2·-·ₚ-distr xₚ)
*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ {P} =
   ap (_⊕_ P)
     (ap 2·_
        (+ₚ-·ₚ-distr (xₚ +ₚ yₚ) (2*ₚ (xₚ *ₚ yₚ))
        ∙ ⊕= (+ₚ-·ₚ-distr xₚ yₚ) (2*ₚ-·ₚ-distr (xₚ *ₚ yₚ))
        ∙ ⊕= ⊕.comm (ap 2·_ (*ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-·ₚ-distr xₚ) ∙ ⊕.assoc
        ∙ ⊕= refl (! ·ₚ-⊕-distr xₚ) ) ∙ 2·-⊕-distr)
     ∙ ⊕.!assoc
-- -}
-- -}
-- -}
-- -}

--open import prelude renaming (Bool to 𝟚; true to 1₂; false to 0₂)
open import Relation.Binary.PropositionalEquality.NP
open import Data.Two.Base
open import Data.List
open import Function
open import Algebra.FunctionProperties.Eq
open Implicits
open import Algebra.Raw
open import Algebra.Field
open import Algebra.Monoid
open import Algebra.Monoid.Commutative
open import Algebra.Group

module ecc
  (ℙ : Set)
  (ℙ-monoid : Commutative-Monoid ℙ)
  (Number : Set)
  (+-comm-mon : Commutative-Monoid Number)
  (*-mon : Monoid Number)
  (open Additive-Commutative-Monoid +-comm-mon)
  (open Multiplicative-Monoid *-mon)
  (+-*-distr : ∀ {x y z} → (x + y) * z ≡ x * z + y * z)
  (*-+-distr : ∀ {x y z} → x * (y + z) ≡ x * y + x * z)
  (0*-zero : ∀ {x} → 0# * x ≡ 0#)
  (*0-zero : ∀ {x} → x * 0# ≡ 0#)
   --(modinv-*-distr : ∀ {x y} → modinv (x * y) ≡ modinv x * modinv y)
   --(modinv-modinv : ∀ {x} → modinv (modinv x) ≡ x)
   --(*-assoc : ∀ {x y z} → (x * y) * z ≡ x * (y * z))
   --(*-comm : ∀ {x y} → x * y ≡ y * x)
   --(modinv-cancel : ∀ {x y} → x * modinv x * y ≡ y)
   --(2*1ₙ : 2* 1# ≡ 2ₙ)
   --(2*-spec : ∀ {n} → 2* n ≡ 2ₙ * n)
  where

module ⊕ = Commutative-Monoid ℙ-monoid
open ⊕
  renaming
    ( _∙_ to _⊕_
    ; ∙= to ⊕=
    ; ε∙-identity to ε⊕-identity
    ; ∙ε-identity to ⊕ε-identity
    )

2·_ : ℙ → ℙ
2· P = P ⊕ P

2·-⊕-distr : ∀ {P Q} → 2· (P ⊕ Q) ≡ 2· P ⊕ 2· Q
2·-⊕-distr = ⊕.interchange

2·-⊕ : ∀ {P Q R} → 2· P ⊕ (Q ⊕ R) ≡ (P ⊕ Q) ⊕ (P ⊕ R)
2·-⊕ = ⊕.interchange

{-
ec-multiply-bin : List 𝟚 → ℙ → ℙ
ec-multiply-bin scalar P = go scalar
  where
    go : List 𝟚 → ℙ
    go []       = P
    go (b ∷ bs) = [0: x₀ 1: x₁ ] b
      where x₀ = 2· go bs
            x₁ = P ⊕ x₀

ec-multiply : Number → ℙ → ℙ
ec-multiply scalar P =
  -- if scalar == 0 or scalar >= N: raise Exception("Invalid Scalar/Private Key")
    ec-multiply-bin (bin scalar) P

_·_ = ec-multiply
infixr 8 _·_
-}

open From-Op₂.From-Assoc-Comm _+_ +-assoc +-comm
  renaming ( on-sides to +-on-sides)

infixl 6 1+_
infixl 7 2*_ 1+2*_
1+_ = λ x → 1# + x
2*_ = λ x → x + x
1+2*_ = λ x → 1+ 2* x

data Parity-View : Number → Set where
  zero⟨_⟩    : ∀ {n} → n ≡ 0# → Parity-View n
  even_by⟨_⟩ : ∀ {m n} → Parity-View m → n ≡ 2* m    → Parity-View n
  odd_by⟨_⟩  : ∀ {m n} → Parity-View m → n ≡ 1+ 2* m → Parity-View n

cast_by⟨_⟩ : ∀ {x y} → Parity-View x → y ≡ x → Parity-View y
cast zero⟨ xₑ ⟩       by⟨ yₑ ⟩ = zero⟨ yₑ ∙ xₑ ⟩
cast even xₚ by⟨ xₑ ⟩ by⟨ yₑ ⟩ = even xₚ by⟨ yₑ ∙ xₑ ⟩
cast odd  xₚ by⟨ xₑ ⟩ by⟨ yₑ ⟩ = odd  xₚ by⟨ yₑ ∙ xₑ ⟩

infixr 8 _·ₚ_
_·ₚ_ : ∀ {n} (p : Parity-View n) → ℙ → ℙ
zero⟨ e ⟩      ·ₚ P = ε
even p by⟨ e ⟩ ·ₚ P = 2· (p ·ₚ P)
odd  p by⟨ e ⟩ ·ₚ P = P ⊕ (2· (p ·ₚ P))

_+2*_ : 𝟚 → Number → Number
0₂ +2* m =   2* m
1₂ +2* m = 1+2* m

{-
postulate
    bin-2* : ∀ {n} → bin (2* n) ≡ 0₂ ∷ bin n
    bin-1+2* : ∀ {n} → bin (1+2* n) ≡ 1₂ ∷ bin n

bin-+2* : (b : 𝟚)(n : Number) → bin (b +2* n) ≡ b ∷ bin n
bin-+2* 1₂ n = bin-1+2*
bin-+2* 0₂ n = bin-2*
-}

-- (msb) most significant bit first
binₚ : ∀ {n} → Parity-View n → List 𝟚
binₚ zero⟨ e ⟩      = []
binₚ even p by⟨ e ⟩ = 0₂ ∷ binₚ p
binₚ odd  p by⟨ e ⟩ = 1₂ ∷ binₚ p

half : ∀ {n} → Parity-View n → Number
half zero⟨ _ ⟩            = 0#
half (even_by⟨_⟩ {m} _ _) = m
half (odd_by⟨_⟩  {m} _ _) = m

{-
bin-parity : ∀ {n} (p : ParityView n) → bin n ≡ parity p ∷ bin (half p)
bin-parity (even n) = bin-2*
bin-parity (odd n)  = bin-1+2*
-}

infixl 6 1+ₚ_ _+ₚ_
1+ₚ_ : ∀ {x} → Parity-View x → Parity-View (1+ x)
1+ₚ zero⟨ e ⟩      = odd zero⟨ refl ⟩ by⟨ ap 1+_ (e ∙ ! 0+-identity) ⟩
1+ₚ even p by⟨ e ⟩ = odd p      by⟨ ap 1+_ e ⟩
1+ₚ odd  p by⟨ e ⟩ = even 1+ₚ p by⟨ ap 1+_ e ∙ ! +-assoc ∙ +-interchange ⟩

_+ₚ_ : ∀ {x y} → Parity-View x → Parity-View y → Parity-View (x + y)
zero⟨ xₑ ⟩       +ₚ yₚ        = cast yₚ by⟨ ap (λ z → z + _) xₑ ∙ 0+-identity ⟩
xₚ              +ₚ zero⟨ yₑ ⟩ = cast xₚ by⟨ ap (_+_ _) yₑ ∙ +-comm ∙ 0+-identity ⟩
even xₚ by⟨ xₑ ⟩ +ₚ even yₚ by⟨ yₑ ⟩ = even     xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-interchange ⟩
even xₚ by⟨ xₑ ⟩ +ₚ odd  yₚ by⟨ yₑ ⟩ = odd      xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-comm ∙ +-assoc ∙ ap 1+_ (+-comm ∙ +-interchange) ⟩
odd  xₚ by⟨ xₑ ⟩ +ₚ even yₚ by⟨ yₑ ⟩ = odd      xₚ +ₚ yₚ by⟨ += xₑ yₑ ∙ +-assoc ∙ ap 1+_ +-interchange ⟩
odd  xₚ by⟨ xₑ ⟩ +ₚ odd  yₚ by⟨ yₑ ⟩ = even 1+ₚ (xₚ +ₚ yₚ) by⟨ += xₑ yₑ ∙ +-on-sides refl +-interchange ⟩

infixl 7 2*ₚ_
2*ₚ_ : ∀ {x} → Parity-View x → Parity-View (2* x)
2*ₚ xₚ = xₚ +ₚ xₚ

open ≡-Reasoning

module _ {P Q} where
    ·ₚ-⊕-distr : ∀ {x} (xₚ : Parity-View x) → xₚ ·ₚ (P ⊕ Q) ≡ xₚ ·ₚ P ⊕ xₚ ·ₚ Q
    ·ₚ-⊕-distr zero⟨ xₑ ⟩       = ! ε⊕-identity
    ·ₚ-⊕-distr even xₚ by⟨ xₑ ⟩ = ap 2·_ (·ₚ-⊕-distr xₚ) ∙ 2·-⊕-distr
    ·ₚ-⊕-distr odd  xₚ by⟨ xₑ ⟩ = ap (λ z → P ⊕ Q ⊕ 2· z) (·ₚ-⊕-distr xₚ)
                               ∙ ap (λ z → P ⊕ Q ⊕ z) (! 2·-⊕)
                               ∙ ⊕.interchange

module _ {P} where
    cast-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₑ : y ≡ x) → cast xₚ by⟨ yₑ ⟩ ·ₚ P ≡ xₚ ·ₚ P
    cast-·ₚ-distr zero⟨ x₁ ⟩ yₑ = refl
    cast-·ₚ-distr even xₚ by⟨ x₁ ⟩ yₑ = refl
    cast-·ₚ-distr odd xₚ by⟨ x₁ ⟩ yₑ = refl

    1+ₚ-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → (1+ₚ xₚ) ·ₚ P ≡ P ⊕ xₚ ·ₚ P
    1+ₚ-·ₚ-distr zero⟨ xₑ ⟩       = ap (_⊕_ P) ε⊕-identity
    1+ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ = refl
    1+ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ = ap 2·_ (1+ₚ-·ₚ-distr xₚ) ∙ ⊕.interchange ∙ ⊕.assoc

    +ₚ-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₚ : Parity-View y)
                 → (xₚ +ₚ yₚ) ·ₚ P ≡ xₚ ·ₚ P ⊕ yₚ ·ₚ P
    +ₚ-·ₚ-distr zero⟨ xₑ ⟩ yₚ = cast-·ₚ-distr yₚ _ ∙ ! ε⊕-identity

    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ⊕ε-identity
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ⊕ε-identity

    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr
    +ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ = ap (_⊕_ P) (ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr) ∙ ⊕.assoc-comm
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap (_⊕_ P) (ap 2·_ (+ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-⊕-distr) ∙ ! ⊕.assoc
    +ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩
       = (odd xₚ by⟨ xₑ ⟩ +ₚ odd yₚ by⟨ yₑ ⟩) ·ₚ P
       ≡⟨by-definition⟩
         2·((1+ₚ (xₚ +ₚ yₚ)) ·ₚ P)
       ≡⟨ ap 2·_ helper ⟩
         2·(P ⊕ (xₚ ·ₚ P ⊕ yₚ ·ₚ P))
       ≡⟨ 2·-⊕-distr ⟩
         2· P ⊕ (2·(xₚ ·ₚ P ⊕ yₚ ·ₚ P))
       ≡⟨ ap (_⊕_ (2· P)) 2·-⊕-distr ⟩
         2· P ⊕ (2·(xₚ ·ₚ P) ⊕ 2·(yₚ ·ₚ P))
       ≡⟨ 2·-⊕ ⟩
         P ⊕ 2·(xₚ ·ₚ P) ⊕ (P ⊕ 2·(yₚ ·ₚ P))
       ≡⟨by-definition⟩
         odd xₚ by⟨ xₑ ⟩ ·ₚ P ⊕ odd yₚ by⟨ yₑ ⟩ ·ₚ P
       ∎
        where helper = (1+ₚ (xₚ +ₚ yₚ)) ·ₚ P
                     ≡⟨ 1+ₚ-·ₚ-distr (xₚ +ₚ yₚ) ⟩
                       P ⊕ ((xₚ +ₚ yₚ) ·ₚ P)
                     ≡⟨ ap (_⊕_ P) (+ₚ-·ₚ-distr xₚ yₚ) ⟩
                       P ⊕ (xₚ ·ₚ P ⊕ yₚ ·ₚ P)
                     ∎

*-1+-distr : ∀ {x y} → x * (1+ y) ≡ x + x * y
*-1+-distr = *-+-distr ∙ += *1-identity refl

1+-*-distr : ∀ {x y} → (1+ x) * y ≡ y + x * y
1+-*-distr = +-*-distr ∙ += 1*-identity refl

infixl 7 _*ₚ_
_*ₚ_ : ∀ {x y} → Parity-View x → Parity-View y → Parity-View (x * y)
zero⟨ xₑ ⟩       *ₚ yₚ              = zero⟨ *= xₑ refl ∙ 0*-zero ⟩
xₚ              *ₚ zero⟨ yₑ ⟩       = zero⟨ *= refl yₑ ∙ *0-zero ⟩
even xₚ by⟨ xₑ ⟩ *ₚ yₚ              = even (xₚ *ₚ yₚ) by⟨ *= xₑ refl ∙ +-*-distr ⟩
xₚ              *ₚ even yₚ by⟨ yₑ ⟩ = even (xₚ *ₚ yₚ) by⟨ *= refl yₑ ∙ *-+-distr ⟩
odd xₚ by⟨ xₑ ⟩  *ₚ odd yₚ by⟨ yₑ ⟩  = odd  (xₚ +ₚ yₚ +ₚ 2*ₚ (xₚ *ₚ yₚ)) by⟨ *= xₑ yₑ ∙ helper ⟩
   where
     x = _
     y = _
     helper = (1+2* x)*(1+2* y)
            ≡⟨ 1+-*-distr ⟩
              1+2* y + 2* x * 1+2* y
            ≡⟨ ap (λ z → 1+2* y + z)
                 (2* x * 1+2* y
                 ≡⟨ *-1+-distr ⟩
                 (2* x + 2* x * 2* y)
                 ≡⟨ += refl *-+-distr ∙ +-interchange ⟩
                 (2* (x + 2* x * y))
                 ∎) ⟩
              1+2* y + 2* (x + 2* x * y)
            ≡⟨ +-assoc ∙ ap 1+_ +-interchange ⟩
              1+2*(y + (x + 2* x * y))
            ≡⟨ ap 1+2*_ (! +-assoc ∙ += +-comm refl) ⟩
              1+2*(x + y + 2* x * y)
            ≡⟨ ap (λ z → 1+2*(x + y + z)) +-*-distr ⟩
              1+2*(x + y + 2* (x * y))
            ∎

module _ {P} where
    2·-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → 2·(xₚ ·ₚ P) ≡ xₚ ·ₚ 2· P
    2·-·ₚ-distr xₚ = ! ·ₚ-⊕-distr xₚ

    2*ₚ-·ₚ-distr : ∀ {x} (xₚ : Parity-View x) → (2*ₚ xₚ) ·ₚ P ≡ 2·(xₚ ·ₚ P)
    2*ₚ-·ₚ-distr xₚ = +ₚ-·ₚ-distr xₚ xₚ

·ₚ-ε : ∀ {x} (xₚ : Parity-View x) → xₚ ·ₚ ε ≡ ε
·ₚ-ε zero⟨ xₑ ⟩       = refl
·ₚ-ε even xₚ by⟨ xₑ ⟩ = ap 2·_ (·ₚ-ε xₚ) ∙ ε⊕-identity
·ₚ-ε odd xₚ by⟨ xₑ ⟩  = ε⊕-identity ∙ ap 2·_ (·ₚ-ε xₚ) ∙ ε⊕-identity

*ₚ-·ₚ-distr : ∀ {x y} (xₚ : Parity-View x) (yₚ : Parity-View y) {P} → (xₚ *ₚ yₚ) ·ₚ P ≡ xₚ ·ₚ yₚ ·ₚ P
*ₚ-·ₚ-distr zero⟨ xₑ ⟩ yₚ = refl
*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ·ₚ-ε even xₚ by⟨ xₑ ⟩
*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ zero⟨ yₑ ⟩ = ! ·ₚ-ε odd  xₚ by⟨ xₑ ⟩

*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ = ap 2·_ (*ₚ-·ₚ-distr xₚ even yₚ by⟨ yₑ ⟩)
*ₚ-·ₚ-distr even xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ = ap 2·_ (*ₚ-·ₚ-distr xₚ odd  yₚ by⟨ yₑ ⟩)

*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ even yₚ by⟨ yₑ ⟩ {P} =
   ap 2·_ (*ₚ-·ₚ-distr odd xₚ by⟨ xₑ ⟩ yₚ) ∙ 2·-⊕-distr ∙ ap (λ z → 2· (yₚ ·ₚ P) ⊕ 2· z) (2·-·ₚ-distr xₚ)
*ₚ-·ₚ-distr odd  xₚ by⟨ xₑ ⟩ odd  yₚ by⟨ yₑ ⟩ {P} =
   ap (_⊕_ P)
     (ap 2·_
        (+ₚ-·ₚ-distr (xₚ +ₚ yₚ) (2*ₚ (xₚ *ₚ yₚ))
        ∙ ⊕= (+ₚ-·ₚ-distr xₚ yₚ) (2*ₚ-·ₚ-distr (xₚ *ₚ yₚ))
        ∙ ⊕= ⊕.comm (ap 2·_ (*ₚ-·ₚ-distr xₚ yₚ) ∙ 2·-·ₚ-distr xₚ) ∙ ⊕.assoc
        ∙ ⊕= refl (! ·ₚ-⊕-distr xₚ) ) ∙ 2·-⊕-distr)
     ∙ ! ⊕.assoc
-- -}
-- -}
-- -}
-- -}


From discussion; fix Extract so that it now depends on Σ-protocol

open import Type
open import Function.NP
open import Data.Maybe
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum using (_⊎_)
open import Data.List.NP renaming (map to mapᴸ)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Control.Strategy using (Strategy; module TranscriptRun; done; ask)

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}
  (any-W : W)
  {RS : ★}
  (L? : ∀ w Y → Dec (L w Y))
  (Λ? : Decidable (_≡_ {A = Λ}))
  (Eps  : ★)
  (ε[_] : Eps → ★)
  (ε0 : Eps)
  (ε[0] : ε[ ε0 ] ≡ 𝟘)
  where

module _ {R : ★} where
    _≋_ : (f g : R → 𝟚) → ★₁
    f ≋ g = (Σ R (✓ ∘ f)) ≡ (Σ R (✓ ∘ g))

    _≈_ : (f g : R → 𝟚) → ★₁
    f ≈ g = ∃₂ λ ε₀ ε₁ →
            (Σ R (✓ ∘ f) ⊎ ε[ ε₀ ]) ≡ (Σ R (✓ ∘ g) ⊎ ε[ ε₁ ])

    ≋→≈ : ∀ {f g} → f ≋ g → f ≈ g
    ≋→≈ f≋g = ε0 , ε0 , ap (flip _⊎_ ε[ ε0 ]) f≋g

{-
Random-Oracle-List : ★
Random-Oracle-List = List (Q × Resp)
-}

module Game-Types (Q Resp : ★)(Prf : Λ → ★) where
  Random-Oracle : ★
  Random-Oracle = Q → Resp

  data Adversary-Query : ★ where
    query-H : (q : Q) → Adversary-Query
    query-create-proof : (w : W)(Y : Λ) → Adversary-Query

  Challenger-Resp : Adversary-Query → ★
  Challenger-Resp (query-H s) = Resp
  Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

  Adversary : ★ → ★
  Adversary = Strategy Adversary-Query Challenger-Resp

  Transcript = List (Σ Adversary-Query Challenger-Resp)

  Prfs : ★
  Prfs = List (Σ Λ Prf)

record Proof-System (RP : ★)(Prf : Λ → ★) : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : (Y : Λ)(π : Prf Y) → 𝟚

  Complete : ★
  Complete = ∀ rp {w Y} → L w Y → Verify Y (Prove rp w Y) ≡ 1₂

  -- Not in the paper but...
  Sound : ★
  Sound = ∀ rp {w Y} → Verify Y (Prove rp w Y) ≡ 1₂ → L w Y

record Simulator (Q : ★)(Resp : ★){Prf RP}(PF : Proof-System RP Prf) : ★ where
  open Proof-System PF
  open Game-Types Q Resp Prf

  field
    -- Computing the compound patch to the random oracle
    H-patch  : RS → Transcript → Random-Oracle → Random-Oracle

    -- Simulate does not patch itself but H-patch does
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : ∀ rs t Y → Verify Y (Simulate rs t Y) ≡ 1₂

  open Proof-System PF public
  open Game-Types Q Resp Prf public

module Is-Zero-Knowledge
  {RP Prf Q Resp}
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (PF : Proof-System RP Prf)
  (open Proof-System PF)
  (sim : Simulator Q Resp PF)
  (open Simulator sim)
  (ro : Random-Oracle)
  where

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H-patch rs t ro q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    ... | yes p = just (Simulate rs t Y)
    ... | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    -- β = 0₂ is real
    -- β = 1₂ is simulated
    Experiment : ∀ {Output} → 𝟚 → Adversary Output → RS → Output × Transcript
    Experiment β adv rs = runT (challenger β rs) adv []

    EXP₀ EXP₁ : Adversary 𝟚 → RS → 𝟚
    EXP₀ Adv = fst ∘ Experiment 0₂ Adv
    EXP₁ Adv = fst ∘ Experiment 1₂ Adv

    -- Too strong
    IsZK = ∀ Adv → EXP₀ Adv ≈ EXP₁ Adv

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Simulation-Sound-Extractability
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp : ★)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
           where
    open Proof-System PF
    open Game-Types Q Resp Prf

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π _                                  = 0₂

    HistoryForExtractor = List (Prfs × Transcript)

    ExtractorServerPart =
         (past-history : HistoryForExtractor) {- previous invocations of Adv -}
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Prfs → (init-transcript : Transcript)
                     → ExtractorServerPart
                     × Strategy 𝟙 (const (Prfs × Transcript)) (List W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    valid-witnesses? : List W → List Λ → 𝟚
    valid-witnesses? [] [] = 1₂
    valid-witnesses? (w ∷ ws) (prf ∷ prfs) = valid-witness? w prf ∧ valid-witnesses? ws prfs
    valid-witnesses? _ _ = 0₂

    open TranscriptRun

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

        K-winning-prfs : Prfs → 𝟚
        K-winning-prfs []   = 1₂
        K-winning-prfs prfs = any K-winning-prf prfs

    module Game
        (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
        (sim : Simulator Q Resp PF)
        (open Is-Zero-Knowledge L-to-Prf PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Prfs)
        (w : RA)(rs : RS)(ro : Q → Resp)(K' : Extractor) where

        initial-result = Experiment ro 1₂ (Adv w) rs

        initial-prfs : Prfs
        initial-prfs = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-intial-run : 𝟚
        K-winning-intial-run = K-winning-prfs initial-transcript initial-prfs

        -- Second run

        K = K' initial-prfs initial-transcript

        Kf = fst K
        Ks = snd K

        ws = fst (runT (λ h _ → runT (λ t q → Kf (mapᴸ snd h) t q) (Adv w) []) Ks [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witnesses? ws (mapᴸ fst initial-prfs)

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RΣP : ★}
  (any-RΣP : RΣP)
  where

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  v ⇄ p = Σ-Protocol.Σ-game (v , p)

  Correct : Σ-Protocol → ★
  Correct p = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Protocol p
    in Σ-game r Y c ≡ 1₂

  record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : ★ where
    open Σ-Protocol Σ-proto
    field
      Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
      Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
      -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
      -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  -- A pair of "Σ-Transcript"s such that the commitment is shared
  -- and the challenges are different.
  record Σ-Transcript² Σ-proto Y : ★ where
    constructor mk
    open Σ-Protocol Σ-proto using (Σ-verifier)
    field
      -- The commitment is shared
      get-A         : Commitment

      -- The challenges...
      get-c₀ get-c₁ : Challenge

      -- ...are different
      c₀≢c₁         : get-c₀ ≢ get-c₁

      -- The proofs are arbitrary
      get-f₀ get-f₁ : Σ-Prf Y

      -- The Σ-transcript verify
      verify₀ : Σ-verifier Y (mk get-A get-c₀ get-f₀) ≡ 1₂
      verify₁ : Σ-verifier Y (mk get-A get-c₁ get-f₁) ≡ 1₂

  record Special-Soundness Σ-proto : ★ where
    field
      Extract    : ∀ {Y}(t : Σ-Transcript² Σ-proto Y) → W
      Extract-ok : ∀ {Y}(t : Σ-Transcript² Σ-proto Y) → L (Extract t) Y

  module Fiat-Shamir-Transformation
              (Σ-proto : Σ-Protocol)
              -- For the transformation we technically only need Simulate, no proofs...
              -- but we take the proofs as well
              (shvzk : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              where

      open Σ-Protocol Σ-proto
      open Special-Honest-Verifier-Zero-Knowledge shvzk

      FS-Prf : Λ → ★
      FS-Prf Y = Challenge × Σ-Prf Y

      sFS : (H : (Λ × Commitment) → Challenge) → Proof-System RΣP FS-Prf
      sFS H = record { Prove = sFS-Prove ; Verify = sFS-Verify }
        where
          sFS-Prove : RΣP → W → (Y : Λ) → FS-Prf Y
          sFS-Prove r w Y = let c = H (Y , get-A r Y) in c , get-f r Y c
          sFS-Verify : ∀ Y → FS-Prf Y → 𝟚
          sFS-Verify Y (c , π) = Σ-verifier Y (mk (Simulate Y c π) c π)

      -- The weak fiat-shamir is like the strong one but the H function do not get to see
      -- the statement, hence the 'snd'
      wFS : (H : Commitment → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      wFS H = sFS (H ∘ snd)

  module Theorem1
              (Σ-proto : Σ-Protocol)
              -- (Σ-correct : Correct Σ-proto)
              (shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              (ssound  : Special-Soundness Σ-proto)
              (open Σ-Protocol Σ-proto)
              (H : (Λ × Commitment) → Challenge)
              where
      module SHVZK = Special-Honest-Verifier-Zero-Knowledge shvzk

      module FST = Fiat-Shamir-Transformation Σ-proto shvzk
      open FST using (FS-Prf)

      Q = Λ × Commitment
      Resp = Challenge

      sFS : Proof-System RΣP FS-Prf
      sFS = FST.sFS H
      module SFS = Proof-System sFS

      FS-Prf? : {Y Y' : Λ} → FS-Prf Y → FS-Prf Y' → 𝟚
      FS-Prf? π π' = {!!}

      open Simulation-Sound-Extractability sFS FS-Prf? Q Resp

      L-to-FS-Prf : ∀ {w Y} → L w Y → FS-Prf Y
      L-to-FS-Prf {w} w∈Y = SFS.Prove any-RΣP w _

      FS-Random-Oracle = (Λ × Commitment) → Challenge
      FS-Patch = FS-Random-Oracle → FS-Random-Oracle

      open Special-Soundness ssound
      open Game-Types Q Resp FS-Prf

      module _ (rnd-c : Λ → Challenge)(rnd-Σ-Prf : ∀ Y → Σ-Prf Y) where

        module _ (rs : RS) where
        {-
          Σ-t² : ∀{Y} → SFS.Transcript → Maybe (Σ-Transcript² Y)
          Σ-t² t = {!!}
          -}

    {-
module H-def (ro : Random-Oracle)(t : Random-Oracle-List)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q
  -}
          H-patch-1 : (q : Adversary-Query) → Challenger-Resp q → FS-Random-Oracle → FS-Random-Oracle
          H-patch-1 (query-H q) r = id
          H-patch-1 (query-create-proof w Y) r ro (Y' , c')
            = ro (Y' , case ⌊ Λ? Y Y' ⌋ 0: c' 1: SHVZK.Simulate Y (rnd-c Y) (rnd-Σ-Prf Y))

          H-patch : Transcript → FS-Patch
          H-patch []            = id
          H-patch ((q , r) ∷ t) = H-patch-1 q r ∘ H-patch t

          module _ (t : Transcript)(Y : Λ) where
              Simulate : FS-Prf Y
              Simulate = rnd-c Y , rnd-Σ-Prf Y
              -- SFS.Prove any-RΣP (maybe′ (Extract {Y}) any-W (Σ-t² t)) Y

              c : Challenge
              c = fst Simulate

              Σ-prf : Σ-Prf Y
              Σ-prf = snd Simulate

              verify-sim-spec : SFS.Verify Y Simulate ≡ 1₂
              verify-sim-spec = SHVZK.Simulate-ok Y c Σ-prf

        S : Simulator (Λ × Commitment) Challenge sFS
        S = record { H-patch = H-patch
                   ; Simulate = Simulate
                   ; verify-sim-spec = verify-sim-spec }

        open Is-Zero-Knowledge L-to-FS-Prf sFS S {!!}

        K0 : Prfs → Transcript → ExtractorServerPart
        K0 prfs init-transcript past-history on-going-transcript q = {!!}

        K1 : Prfs → Transcript → Strategy 𝟙 (const (Prfs × Transcript)) (List W)
        K1 [] init-transcript = done {!!}
        K1 ((Y , π) ∷ prfs) init-transcript = ask _ (λ pt → {!!})

        K : Extractor
        K prfs init-transcript = K0 prfs init-transcript , K1 prfs init-transcript

        module _ Adv where
          is-zk' : EXP₀ Adv ≋ EXP₁ Adv
          is-zk' = {!!}

        is-zk : IsZK
        is-zk Adv = ≋→≈ (is-zk' Adv)

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

open import Type
open import Function.NP
open import Data.Maybe
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum using (_⊎_)
open import Data.List.NP renaming (map to mapᴸ)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP
open import Control.Strategy using (Strategy; module TranscriptRun; done; ask)

module ZK.Strong-Fiat-Shamir
  {W Λ : ★}{L : W → Λ → ★}
  (any-W : W)
  {RS : ★}
  (L? : ∀ w Y → Dec (L w Y))
  (Λ? : Decidable (_≡_ {A = Λ}))
  (Eps  : ★)
  (ε[_] : Eps → ★)
  (ε0 : Eps)
  (ε[0] : ε[ ε0 ] ≡ 𝟘)
  where

module _ {R : ★} where
    _≋_ : (f g : R → 𝟚) → ★₁
    f ≋ g = (Σ R (✓ ∘ f)) ≡ (Σ R (✓ ∘ g))

    _≈_ : (f g : R → 𝟚) → ★₁
    f ≈ g = ∃₂ λ ε₀ ε₁ →
            (Σ R (✓ ∘ f) ⊎ ε[ ε₀ ]) ≡ (Σ R (✓ ∘ g) ⊎ ε[ ε₁ ])

    ≋→≈ : ∀ {f g} → f ≋ g → f ≈ g
    ≋→≈ f≋g = ε0 , ε0 , ap (flip _⊎_ ε[ ε0 ]) f≋g

{-
Random-Oracle-List : ★
Random-Oracle-List = List (Q × Resp)
-}

module Game-Types (Q Resp : ★)(Prf : Λ → ★) where
  Random-Oracle : ★
  Random-Oracle = Q → Resp

  data Adversary-Query : ★ where
    query-H : (q : Q) → Adversary-Query
    query-create-proof : (w : W)(Y : Λ) → Adversary-Query

  Challenger-Resp : Adversary-Query → ★
  Challenger-Resp (query-H s) = Resp
  Challenger-Resp (query-create-proof w Y) = Maybe (Prf Y)

  Adversary : ★ → ★
  Adversary = Strategy Adversary-Query Challenger-Resp

  Transcript = List (Σ Adversary-Query Challenger-Resp)

  Prfs : ★
  Prfs = List (Σ Λ Prf)

record Proof-System (RP : ★)(Prf : Λ → ★) : ★ where
  field
    Prove  : RP → (w : W)(Y : Λ) → Prf Y
    Verify : (Y : Λ)(π : Prf Y) → 𝟚

  Complete : ★
  Complete = ∀ rp {w Y} → L w Y → Verify Y (Prove rp w Y) ≡ 1₂

  -- Not in the paper but...
  Sound : ★
  Sound = ∀ rp {w Y} → Verify Y (Prove rp w Y) ≡ 1₂ → L w Y

record Simulator (Q : ★)(Resp : ★){Prf RP}(PF : Proof-System RP Prf) : ★ where
  open Proof-System PF
  open Game-Types Q Resp Prf

  field
    -- Computing the compound patch to the random oracle
    H-patch  : RS → Transcript → Random-Oracle → Random-Oracle

    -- Simulate does not patch itself but H-patch does
    Simulate : RS → Transcript → (Y : Λ) → Prf Y
    verify-sim-spec : ∀ rs t Y → Verify Y (Simulate rs t Y) ≡ 1₂

  open Proof-System PF public
  open Game-Types Q Resp Prf public

module Is-Zero-Knowledge
  {RP Prf Q Resp}
  (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
  (PF : Proof-System RP Prf)
  (open Proof-System PF)
  (sim : Simulator Q Resp PF)
  (open Simulator sim)
  (ro : Random-Oracle)
  where

    simulated-Challenger : RS → Transcript → ∀ q → Challenger-Resp q
    simulated-Challenger rs t (query-H q) = H-patch rs t ro q
    simulated-Challenger rs t (query-create-proof w Y) with L? w Y
    ... | yes p = just (Simulate rs t Y)
    ... | no ¬p = nothing

    real-Challenger : ∀ q → Challenger-Resp q
    real-Challenger (query-H q) = ro q
    real-Challenger (query-create-proof w Y) with L? w Y
    ... | yes p = just (L-to-Prf p)
    ... | no  _ = nothing

    challenger : 𝟚 → RS → Transcript → ∀ q → Challenger-Resp q
    challenger 0₂ _  _ = real-Challenger
    challenger 1₂ rs t = simulated-Challenger rs t

    open TranscriptRun
    -- β = 0₂ is real
    -- β = 1₂ is simulated
    Experiment : ∀ {Output} → 𝟚 → Adversary Output → RS → Output × Transcript
    Experiment β adv rs = runT (challenger β rs) adv []

    EXP₀ EXP₁ : Adversary 𝟚 → RS → 𝟚
    EXP₀ Adv = fst ∘ Experiment 0₂ Adv
    EXP₁ Adv = fst ∘ Experiment 1₂ Adv

    -- Too strong
    IsZK = ∀ Adv → EXP₀ Adv ≈ EXP₁ Adv

{-
-- there exists a simulator, such that for all adversaries they are clueless if
-- they are in the real or simulated Experiment
Zero-Knowledge : Proof-System → ★
Zero-Knowledge PF = Σ (Simulator PF) (λ sim → {!!})
-}

module Simulation-Sound-Extractability
           {RP}{Prf : Λ → ★}
           (PF : Proof-System RP Prf)
           (Prf? : ∀ {Y Y'} → Prf Y → Prf Y' → 𝟚)
           (Q Resp : ★)
  -- (Prf? : ∀ Y → Decidable (_≡_ {A = Prf Y}))
           where
    open Proof-System PF
    open Game-Types Q Resp Prf

    Prf-in-Q : ∀ {Y} → Prf Y → Σ Adversary-Query Challenger-Resp → 𝟚
    Prf-in-Q π (query-create-proof _ _ , just π') = Prf? π π'
    Prf-in-Q π _                                  = 0₂

    HistoryForExtractor = List (Prfs × Transcript)

    ExtractorServerPart =
         (past-history : HistoryForExtractor) {- previous invocations of Adv -}
         (on-going-transcript : Transcript)   {- about the current invocation of Adv -}
       → Π Adversary-Query Challenger-Resp

    Extractor : ★
    Extractor = Prfs → (init-transcript : Transcript)
                     → ExtractorServerPart
                     × Strategy 𝟙 (const (Prfs × Transcript)) (List W)

    valid-witness? : W → Λ → 𝟚
    valid-witness? w Y = ⌊ L? w Y ⌋

    valid-witnesses? : List W → List Λ → 𝟚
    valid-witnesses? [] [] = 1₂
    valid-witnesses? (w ∷ ws) (prf ∷ prfs) = valid-witness? w prf ∧ valid-witnesses? ws prfs
    valid-witnesses? _ _ = 0₂

    open TranscriptRun

    module _ (t : Transcript) where
        Prf-in-Transcript : ∀ {Y} → Prf Y → 𝟚
        Prf-in-Transcript π = any (Prf-in-Q π) t

        K-winning-prf : Σ Λ Prf → 𝟚
        K-winning-prf (Y , π) = not (Verify Y π)
                              ∨ Prf-in-Transcript π

        K-winning-prfs : Prfs → 𝟚
        K-winning-prfs []   = 1₂
        K-winning-prfs prfs = any K-winning-prf prfs

    module Game
        (L-to-Prf : ∀ {w Y} → L w Y → Prf Y)
        (sim : Simulator Q Resp PF)
        (open Is-Zero-Knowledge L-to-Prf PF sim)
        {RA : ★}

        {- The malicious prover -}
        (Adv : RA → Adversary Prfs)
        (w : RA)(rs : RS)(ro : Q → Resp)(K' : Extractor) where

        initial-result = Experiment ro 1₂ (Adv w) rs

        initial-prfs : Prfs
        initial-prfs = fst initial-result

        initial-transcript : Transcript
        initial-transcript = snd initial-result

        K-winning-intial-run : 𝟚
        K-winning-intial-run = K-winning-prfs initial-transcript initial-prfs

        -- Second run

        K = K' initial-prfs initial-transcript

        Kf = fst K
        Ks = snd K

        ws = fst (runT (λ h _ → runT (λ t q → Kf (mapᴸ snd h) t q) (Adv w) []) Ks [])

        K-winning-second-run : 𝟚
        K-winning-second-run = valid-witnesses? ws (mapᴸ fst initial-prfs)

module Sigma-Protocol
  (Commitment Challenge : ★)
  (Σ-Prf : Λ → ★)
  {RP RΣP : ★}
  (any-RΣP : RΣP)
  where

  record Σ-Prover : ★ where
    field
      get-A : RΣP → (Y : Λ) → Commitment
      get-f : RΣP → (Y : Λ) → (c : Challenge) → Σ-Prf Y

  record Σ-Transcript (Y : Λ) : ★ where
    constructor mk
    field
      get-A : Commitment
      get-c : Challenge
      get-f : Σ-Prf Y

  Σ-Verifier : ★
  Σ-Verifier = (Y : Λ)(t : Σ-Transcript Y) → 𝟚

  record Σ-Protocol : ★ where
    constructor _,_
    field
      Σ-verifier : Σ-Verifier
      Σ-prover   : Σ-Prover
    open Σ-Prover Σ-prover public

    Σ-game : (r : RΣP)(Y : Λ)(c : Challenge) → 𝟚
    Σ-game r Y c = Σ-verifier Y (mk A c f)
      where
        A = get-A r Y
        f = get-f r Y c

  _⇄_ : Σ-Verifier → Σ-Prover → RΣP → Λ → Challenge → 𝟚
  (v ⇄ p) r Y c = Σ-Protocol.Σ-game (v , p) r Y c

  Correct : Σ-Protocol → ★
  Correct (v , p) = ∀ {Y w} → L w Y → (r : RΣP)(c : _) →
    let open Σ-Prover p
    in v Y (mk (get-A r Y) c (get-f r Y c)) ≡ 1₂

  record Special-Honest-Verifier-Zero-Knowledge (Σ-proto : Σ-Protocol) : ★ where
    open Σ-Protocol Σ-proto
    field
      Simulate : (Y : Λ)(c : Challenge)(f : Σ-Prf Y) → Commitment
      Simulate-ok : ∀ Y c f → Σ-verifier Y (mk (Simulate Y c f) c f) ≡ 1₂
      -- If (c,f) uniformly distributed then (Simulate Y c f , c , f) is
      -- distributed equaly to ((Σ-verifier ⇄ Σ-prover) r Y c)

  -- A pair of "Σ-Transcript"s such that the commitment is shared
  -- and the challenges are different.
  record Σ-Transcript² Y : ★ where
    constructor mk
    field
      -- The commitment is shared
      get-A         : Commitment

      -- The challenges...
      get-c₀ get-c₁ : Challenge

      -- ...are different
      c₀≢c₁         : get-c₀ ≢ get-c₁

      -- The proofs are arbitrary
      get-f₀ get-f₁ : Σ-Prf Y

  record Special-Soundness : ★ where
    field
      Extract    : ∀ {Y}(t : Σ-Transcript² Y) → W
      Extract-ok : ∀ {Y}(t : Σ-Transcript² Y) → L (Extract t) Y

  module Fiat-Shamir-Transformation
              (Σ-proto : Σ-Protocol)
              (shvzk : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              where

      open Σ-Protocol Σ-proto
      open Special-Honest-Verifier-Zero-Knowledge shvzk

      FS-Prf : Λ → ★
      FS-Prf Y = Challenge × Σ-Prf Y

      sFS : (H : (Λ × Commitment) → Challenge) → Proof-System RΣP FS-Prf
      sFS H = record { Prove = sFS-Prove ; Verify = sFS-Verify }
        where
          sFS-Prove : RΣP → W → (Y : Λ) → FS-Prf Y
          sFS-Prove r w Y = let c = H (Y , get-A r Y) in c , get-f r Y c
          sFS-Verify : ∀ Y → Challenge × Σ-Prf Y → 𝟚
          sFS-Verify Y (c , π) = Σ-verifier Y (mk (Simulate Y c π) c π)

      -- The weak fiat-shamir is like the strong one but the H function do not get to see
      -- the statement, hence the 'snd'
      wFS : (H : Commitment → Challenge) → Proof-System RΣP (λ Y → Challenge × Σ-Prf Y)
      wFS H = sFS (H ∘ snd)

  module Theorem1
              (Σ-proto : Σ-Protocol)
              -- (Σ-correct : Correct Σ-proto)
              (shvzk   : Special-Honest-Verifier-Zero-Knowledge Σ-proto)
              (ssound  : Special-Soundness)
              (open Σ-Protocol Σ-proto)
              (H : (Λ × Commitment) → Challenge)
              where
      module SHVZK = Special-Honest-Verifier-Zero-Knowledge shvzk

      module FST = Fiat-Shamir-Transformation Σ-proto shvzk
      open FST using (FS-Prf)

      Q = Λ × Commitment
      Resp = Challenge

      sFS : Proof-System RΣP FS-Prf
      sFS = FST.sFS H
      module SFS = Proof-System sFS

      FS-Prf? : {Y Y' : Λ} → FS-Prf Y → FS-Prf Y' → 𝟚
      FS-Prf? π π' = {!!}

      open Simulation-Sound-Extractability sFS FS-Prf? Q Resp

      L-to-FS-Prf : ∀ {w Y} → L w Y → FS-Prf Y
      L-to-FS-Prf {w} w∈Y = SFS.Prove any-RΣP w _

      FS-Random-Oracle = (Λ × Commitment) → Challenge
      FS-Patch = FS-Random-Oracle → FS-Random-Oracle

      open Special-Soundness ssound
      open Game-Types Q Resp FS-Prf

      module _ (rnd-c : Λ → Challenge)(rnd-Σ-Prf : ∀ Y → Σ-Prf Y) where

        module _ (rs : RS) where
        {-
          Σ-t² : ∀{Y} → SFS.Transcript → Maybe (Σ-Transcript² Y)
          Σ-t² t = {!!}
          -}

    {-
module H-def (ro : Random-Oracle)(t : Random-Oracle-List)(q : Q) where
  H : Resp
  H with find (λ { (query-H q' , r) → ⌊ Q? q' q ⌋
                 ; (query-create-proof _ _ , _) → 0₂ }) t
  ... | just (query-H q₁ , r) = r
  ... | _ = ro q
  -}
          H-patch-1 : (q : Adversary-Query) → Challenger-Resp q → FS-Random-Oracle → FS-Random-Oracle
          H-patch-1 (query-H q) r = id
          H-patch-1 (query-create-proof w Y) r ro (Y' , c')
            = ro (Y' , case ⌊ Λ? Y Y' ⌋ 0: c' 1: SHVZK.Simulate Y (rnd-c Y) (rnd-Σ-Prf Y))

          H-patch : Transcript → FS-Patch
          H-patch []            = id
          H-patch ((q , r) ∷ t) = H-patch-1 q r ∘ H-patch t

          module _ (t : Transcript)(Y : Λ) where
              Simulate : FS-Prf Y
              Simulate = rnd-c Y , rnd-Σ-Prf Y
              -- SFS.Prove any-RΣP (maybe′ (Extract {Y}) any-W (Σ-t² t)) Y

              c : Challenge
              c = fst Simulate

              Σ-prf : Σ-Prf Y
              Σ-prf = snd Simulate

              verify-sim-spec : SFS.Verify Y Simulate ≡ 1₂
              verify-sim-spec = SHVZK.Simulate-ok Y c Σ-prf

        S : Simulator (Λ × Commitment) Challenge sFS
        S = record { H-patch = H-patch
                   ; Simulate = Simulate
                   ; verify-sim-spec = verify-sim-spec }

        open Is-Zero-Knowledge L-to-FS-Prf sFS S {!!}

        K0 : Prfs → Transcript → ExtractorServerPart
        K0 prfs init-transcript past-history on-going-transcript q = {!!}

        K1 : Prfs → Transcript → Strategy 𝟙 (const (Prfs × Transcript)) (List W)
        K1 [] init-transcript = done {!!}
        K1 ((Y , π) ∷ prfs) init-transcript = ask _ (λ pt → {!!})

        K : Extractor
        K prfs init-transcript = K0 prfs init-transcript , K1 prfs init-transcript

        module _ Adv where
          is-zk' : EXP₀ Adv ≋ EXP₁ Adv
          is-zk' = {!!}

        is-zk : IsZK
        is-zk Adv = ≋→≈ (is-zk' Adv)

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


#31 missed one file

#31 missed one file

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) D1 D2 D3 (FHAp1 D4) = {!!}
  pres-lem (FHAp2 eps) D1 D2 D3 (FHAp2 D4) = {!!}
  pres-lem (FHNEHole eps) D1 D2 D3 (FHNEHole D4) = {!!}
  pres-lem (FHCast eps) D1 D2 D3 (FHCast D4) = {!!}

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp ta ta₁) (ITLam) = {!!}
  pres-lem3 (TAAp ta ta₁) (ITApCast) = {!!}
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) () -- todo: this is a little surprising; nehole doesn't take a transition but it defieately can still step
  pres-lem3 (TACast ta x) (ITCastID) = {!!}
  pres-lem3 (TACast ta x) (ITCastSucceed x₂) = {!!}
  pres-lem3 (TACast ta x) (ITGround y) = {!!}
  pres-lem3 (TACast ta x) (ITExpand x₂) = {!!}

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) D1 D2 D3 (FHAp1 D4) = {!!}
  pres-lem (FHAp2 x eps) D1 D2 D3 (FHAp2 x₁ D4) = {!!}
  pres-lem (FHNEHole eps) D1 D2 D3 (FHNEHole D4) = {!!}
  pres-lem (FHCast eps) D1 D2 D3 (FHCast D4) = {!!}

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 x eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp ta ta₁) (ITLam x₁) = {!!}
  pres-lem3 (TAAp ta ta₁) (ITApCast x x₁) = {!!}
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) () -- todo: this is a little surprising; nehole doesn't take a transition but it defieately can still step
  pres-lem3 (TACast ta x) (ITCastID x₁) = {!!}
  pres-lem3 (TACast ta x) (ITCastSucceed x₁ x₂) = {!!}
  pres-lem3 (TACast ta x) (ITGround x₁ y) = {!!}
  pres-lem3 (TACast ta x) (ITExpand x₁ x₂) = {!!}

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂


Simplified the development.

Simplified the development.

Easier to read.

module DCBSets where

open import prelude
open import relations

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (Σ[ n ∈ (⊤ → X) ] (Σ[ α ∈ (U → X → Set) ]( ∀(u : U)(x : X) → Dec (α u x) ))))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , _ , α , _) (V , Y , _ , β , _) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , n₁ , α , _)} {(V , Y , n₂ , β , _)} {(W , Z , n₃ , γ , _)} (f , F  , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , n , α , _)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , _ , α , _)}{(V , Y , _ , β , _)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , _ , α , _}
         {V , Y , _ , β , _}
         {W , Z , _ , γ , _}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , _ , α , _}{V , Y , _ , β , _}{W , Z , _ , γ , _}{S , T , _ , ι , _}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _ , _ , _}{V , Y , _ , _ , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _ , _ , _}{V , Y , _ , _ , _}{f , F , _} = refl , refl

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

⊗d : ∀{U V X Y}{α : U → X → Set}{β  : V → Y → Set}{d₁ : (u : U) (x : X) → Dec (α u x)}{d₂ : (u : V) (x : Y) → Dec (β u x)} → (u : Σ U (λ x → V)) (x : Σ X (λ x₁ → Y)) → Dec ((α ⊗ᵣ β) u x)
⊗d {U}{V}{X}{Y}{α}{β}{d₁}{d₂} (u , v) (x , y) with d₁ u x | d₂ v y
... | yes z | yes z' = yes (z , z')
... | yes z | no z' = no (λ z'' → z' (snd z''))
... | no z | yes z' = no (λ z'' → z (fst z''))
... | no z | no z' = no (λ z'' → z' (snd z''))

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂) = ((U × V) , (X × Y) , trans-× n₁ n₂ , α ⊗ᵣ β , ⊗d {α = α} {β}{d₁}{d₂})

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , _ , α , _)}{(V , Y , _ , β , _)}{(W , Z , _ , γ , _)}{(S , T , _ , δ , _)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

π₁ : {A B : Obj} → Hom (A ⊗ₒ B) A
π₁ {U , X , n₁ , α , d₁}{V , Y , n₂ , β , d₂} = fst , (λ r x → x , n₂ triv) , cond
 where
   cond : {u : Σ U (λ x → V)} {y : X} → (α ⊗ᵣ β) u (y , n₂ triv) → α (fst u) y
   cond {u , v}{x} (p₁ , p₂) = p₁

π₂ : {A B : Obj} → Hom (A ⊗ₒ B) B
π₂ {U , X , n₁ , α , d₁}{V , Y , n₂ , β , d₂} = snd , (λ r y → n₁ triv , y) , cond
 where
  cond : {u : Σ U (λ x → V)} {y : Y} → (α ⊗ᵣ β) u (n₁ triv , y) → β (snd u) y
  cond {u , v}{y} (p₁ , p₂) = p₂

cart-ar : {A B C : Obj}
  → (f : Hom C A)
  → (g : Hom C B)
  → Hom C (A ⊗ₒ B)
cart-ar {U , X , x , α , d₁}{V , Y , y , β , d₂}{W , Z , z , γ , d₃} (f , F , p₁) (g , G , p₂) = trans-× f g ,  cart-ar-d , cond
 where
   cart-ar-d : W → Σ X (λ x → Y) → Z
   cart-ar-d w (x , y) with d₂ (g w) y
   ... | yes t = F w x
   ... | no t = G w y

   cond : {u : W} {y : Σ X (λ x → Y)} → γ u (cart-ar-d u y) → (α ⊗ᵣ β) (f u , g u) y
   cond {w}{x , y} p₃ with d₂ (g w) y
   ... | yes t = p₁ p₃ , t
   ... | no t = ⊥-elim (t (p₂ p₃)) , p₂  p₃

cart-diag₁ : ∀{A B C : Obj}
  → {f : Hom C A}
  → {g : Hom C B}
  → (cart-ar f g) ○ π₁ ≡h f
cart-diag₁ = {!!}

cart-diag₂ : ∀{A B C : Obj}
  → {f : Hom C A}
  → {g : Hom C B}
  → (cart-ar f g) ○ π₂ ≡h g
cart-diag₂ = {!!}

module DCBSets where

open import prelude
open import relations

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (Σ[ n ∈ (⊤ → X) ] (Σ[ α ∈ (U → X → Set) ]( ∀(u : U)(x : X) → Dec (α u x) ))))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , _ , α , _) (V , Y , _ , β , _) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , n₁ , α , _)} {(V , Y , n₂ , β , _)} {(W , Z , n₃ , γ , _)} (f , F  , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , n , α , _)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , _ , α , _)}{(V , Y , _ , β , _)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , _ , α , _}{V , Y , _ , β , _}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , _ , α , _}
         {V , Y , _ , β , _}
         {W , Z , _ , γ , _}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , _ , α , _}{V , Y , _ , β , _}{W , Z , _ , γ , _}{S , T , _ , ι , _}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _ , _ , _}{V , Y , _ , _ , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _ , _ , _}{V , Y , _ , _ , _}{f , F , _} = refl , refl

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

⊗d : ∀{U V X Y}{α : U → X → Set}{β  : V → Y → Set}{d₁ : (u : U) (x : X) → Dec (α u x)}{d₂ : (u : V) (x : Y) → Dec (β u x)} → (u : Σ U (λ x → V)) (x : Σ X (λ x₁ → Y)) → Dec ((α ⊗ᵣ β) u x)
⊗d {U}{V}{X}{Y}{α}{β}{d₁}{d₂} (u , v) (x , y) with d₁ u x | d₂ v y
... | yes z | yes z' = yes (z , z')
... | yes z | no z' = no (λ z'' → z' (snd z''))
... | no z | yes z' = no (λ z'' → z (fst z''))
... | no z | no z' = no (λ z'' → z' (snd z''))

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂) = ((U × V) , (X × Y) , trans-× n₁ n₂ , α ⊗ᵣ β , ⊗d {α = α} {β}{d₁}{d₂})

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , _ , α , _)}{(V , Y , _ , β , _)}{(W , Z , _ , γ , _)}{(S , T , _ , δ , _)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {m₁ : ⊤ → U}
    → {n₁ : ⊤ → X}
    → {m₂ : ⊤ → V}
    → {n₂ : ⊤ → Y}
    → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
    → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
    → Hom ((U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂)) (U , X , n₁ , α , d₁)
π₁ {U}{X}{V}{Y}{α}{β}{m₁}{n₁}{m₂}{n₂} = fst , (λ r x → x , n₂ triv) , cond
 where
   cond : {u : Σ U (λ x → V)} {y : X} → (α ⊗ᵣ β) u (y , n₂ triv) → α (fst u) y
   cond {u , v}{x} (p₁ , p₂) = p₁

π₂ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {m₁ : ⊤ → U}
    → {n₁ : ⊤ → X}
    → {m₂ : ⊤ → V}
    → {n₂ : ⊤ → Y}
    → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
    → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
    → Hom ((U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂)) (V , Y , n₂ , β , d₂)
π₂ {U}{X}{V}{Y}{α}{β}{m₁}{n₁}{m₂}{n₂} = snd , (λ r y → n₁ triv , y) , cond
 where
  cond : {u : Σ U (λ x → V)} {y : Y} → (α ⊗ᵣ β) u (n₁ triv , y) → β (snd u) y
  cond {u , v}{y} (p₁ , p₂) = p₂

cart-ar : {U X V Y W Z : Set}
  → {α : U → X → Set}
  → {β : V → Y → Set}
  → {γ : W → Z → Set}
  → {n₁ : ⊤ → X}
  → {n₂ : ⊤ → Y}
  → {n₃ : ⊤ → Z}
  → {d₁ : ∀(u : U)(x : X) → Dec (α u x)}
  → {d₂ : ∀(v : V)(y : Y) → Dec (β v y)}
  → {d₃ : ∀(w : W)(z : Z) → Dec (γ w z)}
  → Hom (W , Z , n₃ , γ , d₃) (U , X , n₁ , α , d₁)
  → Hom (W , Z , n₃ , γ , d₃) (V , Y , n₂ , β , d₂)
  → Hom (W , Z , n₃ , γ , d₃) ((U , X , n₁ , α , d₁) ⊗ₒ (V , Y , n₂ , β , d₂))
cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ}{n₁}{n₂}{n₃}{d₁}{d₂}{d₃} (f , F , p₁) (g , G , p₂) = trans-× f g ,  cart-ar-d , cond
 where
   cart-ar-d : W → Σ X (λ x → Y) → Z
   cart-ar-d w (x , y) with d₂ (g w) y
   ... | yes t = F w x
   ... | no t = G w y

   cond : {u : W} {y : Σ X (λ x → Y)} → γ u (cart-ar-d u y) → (α ⊗ᵣ β) (f u , g u) y
   cond {w}{x , y} p₃ with d₂ (g w) y
   ... | yes t = p₁ p₃ , t
   ... | no t = ⊥-elim (t (p₂ p₃)) , p₂  p₃


Use instance arguments for vowel predicate.

module Text.Greek.Script where

open import Data.Maybe
open import Data.Vec
open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality using (_≢_)

data Case : Set where
  lower upper : Case

data Letter : Set where
  α′ β′ γ′ δ′ ε′ ζ′ η′ θ′ ι′ κ′ λ′ μ′ ν′ ξ′ ο′ π′ ρ′ σ′ τ′ υ′ φ′ χ′ ψ′ ω′ : Letter

vowels : Vec _ _
vowels = α′ ∷ ε′ ∷ η′ ∷ ι′ ∷ ο′ ∷ υ′ ∷ ω′ ∷ []

always-short-letters : Vec _ _
always-short-letters = ε′ ∷ ο′ ∷ []

diaeresis-letters : Vec _ _
diaeresis-letters = ι′ ∷ υ′ ∷ []

iota-subscript-letters : Vec _ _
iota-subscript-letters = α′ ∷ η′ ∷ ω′ ∷ []

data _vowel : Letter → Set where
  is-vowel : ∀ {v} → v ∈ vowels → v vowel

data _always-short : Letter → Set where
  is-always-short : ∀ {v} → ⦃ p : v vowel ⦄ → v ∈ always-short-letters → v always-short

data _diaeresis : Letter → Set where
  add-diaeresis : ∀ {v} → ⦃ p : v vowel ⦄ → v ∈ diaeresis-letters → v diaeresis

data _⟦_⟧-final : Letter → Case → Set where
  make-final : σ′ ⟦ lower ⟧-final

data _⟦_⟧-smooth : Letter → Case → Set where
  add-smooth-lower-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → v ⟦ lower ⟧-smooth
  add-smooth-ρ : ρ′ ⟦ lower ⟧-smooth
  add-smooth-upper-vowel-not-Υ : ∀ {v} → ⦃ p : v vowel ⦄ → v ≢ υ′ → v ⟦ upper ⟧-smooth

data _rough : Letter → Set where
  add-rough-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → v rough
  add-rough-ρ : ρ′ rough

data _iota-subscript : Letter → Set where
  add-iota-subscript : ∀ {v} → ⦃ p : v vowel ⦄ → v ∈ iota-subscript-letters → v iota-subscript

data _⟦_⟧-breathing : Letter → Case → Set where
  add-smooth : ∀ {ℓ c} → ℓ ⟦ c ⟧-smooth → ℓ ⟦ c ⟧-breathing
  add-rough : ∀ {ℓ c} → ℓ rough → ℓ ⟦ c ⟧-breathing

data _long-vowel : Letter → Set where
  make-long-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → ¬ v always-short → v long-vowel

data _accent : Letter → Set where
  add-acute : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  add-grave : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  add-circumflex : ∀ {ℓ} → ℓ long-vowel → ℓ accent

data Token : Letter → Case → Set where
  unmarked : ∀ {ℓ c} → Token ℓ c
  with-accent : ∀ {ℓ c} → ℓ accent → Token ℓ c
  with-breathing : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → Token ℓ c
  with-accent-breathing : ∀ {ℓ c} → ℓ accent → ℓ ⟦ c ⟧-breathing → Token ℓ c
  with-accent-breathing-iota : ∀ {ℓ c} → ℓ accent → ℓ ⟦ c ⟧-breathing → ℓ iota-subscript → Token ℓ c
  with-diaeresis : ∀ {ℓ c} → ℓ diaeresis → Token ℓ c
  with-accent-diaeresis : ∀ {ℓ c} → ℓ accent → ℓ diaeresis → Token ℓ c
  with-accent-iota : ∀ {ℓ c} → ℓ accent → ℓ iota-subscript → Token ℓ c
  with-breathing-iota : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → ℓ iota-subscript → Token ℓ c
  with-iota : ∀ {ℓ c} → ℓ iota-subscript → Token ℓ c
  final : ∀ {ℓ c} → ℓ ⟦ c ⟧-final → Token ℓ c

-- Constructions

-- Α α
instance α-vowel : α′ vowel
α-vowel = is-vowel here

¬α-always-short : ¬ α′ always-short
¬α-always-short (is-always-short (there (there ())))

α-long-vowel : α′ long-vowel
α-long-vowel = make-long-vowel ¬α-always-short

α-acute : α′ accent
α-acute = add-acute

α-grave : α′ accent
α-grave = add-grave

α-circumflex : α′ accent
α-circumflex = add-circumflex α-long-vowel

α-smooth : α′ ⟦ lower ⟧-breathing
α-smooth = add-smooth add-smooth-lower-vowel

Α-smooth : α′ ⟦ upper ⟧-breathing
Α-smooth = add-smooth (add-smooth-upper-vowel-not-Υ (λ ()))

α-rough : α′ ⟦ lower ⟧-breathing
α-rough = add-rough add-rough-vowel

Α-rough : α′ ⟦ upper ⟧-breathing
Α-rough = add-rough add-rough-vowel

α-iota-subscript : α′ iota-subscript
α-iota-subscript = add-iota-subscript here

-- Ε ε
instance ε-vowel : ε′ vowel
ε-vowel = is-vowel (there here)

ε-always-short : ε′ always-short
ε-always-short = is-always-short here

ε-acute : ε′ accent
ε-acute = add-acute

ε-grave : ε′ accent
ε-grave = add-grave

ε-smooth : ε′ ⟦ lower ⟧-breathing
ε-smooth = add-smooth add-smooth-lower-vowel

Ε-smooth : ε′ ⟦ upper ⟧-breathing
Ε-smooth = add-smooth (add-smooth-upper-vowel-not-Υ (λ ()))

ε-rough : ε′ ⟦ lower ⟧-breathing
ε-rough = add-rough add-rough-vowel

Ε-rough : ε′ ⟦ upper ⟧-breathing
Ε-rough = add-rough add-rough-vowel

-- Η η
instance η-vowel : η′ vowel
η-vowel = is-vowel (there (there here))

¬η-always-short : ¬ η′ always-short
¬η-always-short (is-always-short (there (there ())))

η-long-vowel : η′ long-vowel
η-long-vowel = make-long-vowel ¬η-always-short

η-acute : η′ accent
η-acute = add-acute

η-grave : η′ accent
η-grave = add-grave

η-circumflex : η′ accent
η-circumflex = add-circumflex η-long-vowel

η-smooth : η′ ⟦ lower ⟧-breathing
η-smooth = add-smooth add-smooth-lower-vowel

Η-smooth : η′ ⟦ upper ⟧-breathing
Η-smooth = add-smooth (add-smooth-upper-vowel-not-Υ (λ ()))

η-rough : η′ ⟦ lower ⟧-breathing
η-rough = add-rough add-rough-vowel

Η-rough : η′ ⟦ upper ⟧-breathing
Η-rough = add-rough add-rough-vowel

η-iota-subscript : η′ iota-subscript
η-iota-subscript = add-iota-subscript (there here)

-- Ι ι

instance ι-vowel : ι′ vowel
ι-vowel = is-vowel (there (there (there here)))

¬ι-always-short : ¬ ι′ always-short
¬ι-always-short (is-always-short (there (there ())))

ι-long-vowel : ι′ long-vowel
ι-long-vowel = make-long-vowel ¬ι-always-short

ι-not-υ : ι′ ≢ υ′
ι-not-υ ()

ι-acute : ι′ accent
ι-acute = add-acute

ι-grave : ι′ accent
ι-grave = add-grave

ι-circumflex : ι′ accent
ι-circumflex = add-circumflex ι-long-vowel

ι-smooth : ι′ ⟦ lower ⟧-breathing
ι-smooth = add-smooth add-smooth-lower-vowel

Ι-smooth : ι′ ⟦ upper ⟧-breathing
Ι-smooth = add-smooth (add-smooth-upper-vowel-not-Υ (λ ()))

ι-rough : ι′ ⟦ lower ⟧-breathing
ι-rough = add-rough add-rough-vowel

-- Ο ο

-- Unicode
-- U+0390 - U+03CE
ΐ : Token ι′ lower -- U+0390 GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
ΐ = unmarked
Α : Token α′ upper -- U+0391 GREEK CAPITAL LETTER ALPHA
Α = unmarked
Β : Token β′ upper -- U+0392 GREEK CAPITAL LETTER BETA
Β = unmarked
Γ : Token γ′ upper -- U+0393 GREEK CAPITAL LETTER GAMMA
Γ = unmarked
Δ : Token δ′ upper -- U+0394 GREEK CAPITAL LETTER DELTA
Δ = unmarked
Ε : Token ε′ upper -- U+0395 GREEK CAPITAL LETTER EPSILON
Ε = unmarked
Ζ : Token ζ′ upper -- U+0396 GREEK CAPITAL LETTER ZETA
Ζ = unmarked
Η : Token η′ upper -- U+0397 GREEK CAPITAL LETTER ETA
Η = unmarked
Θ : Token θ′ upper -- U+0398 GREEK CAPITAL LETTER THETA
Θ = unmarked
Ι : Token ι′ upper -- U+0399 GREEK CAPITAL LETTER IOTA
Ι = unmarked
Κ : Token κ′ upper -- U+039A GREEK CAPITAL LETTER KAPPA
Κ = unmarked
Λ : Token λ′ upper -- U+039B GREEK CAPITAL LETTER LAMDA
Λ = unmarked
Μ : Token μ′ upper -- U+039C GREEK CAPITAL LETTER MU
Μ = unmarked
Ν : Token ν′ upper -- U+039D GREEK CAPITAL LETTER NU
Ν = unmarked
Ξ : Token ξ′ upper -- U+039E GREEK CAPITAL LETTER XI
Ξ = unmarked
Ο : Token ο′ upper -- U+039F GREEK CAPITAL LETTER OMICRON
Ο = unmarked
Π : Token π′ upper -- U+03A0 GREEK CAPITAL LETTER PI
Π = unmarked
Ρ : Token ρ′ upper -- U+03A1 GREEK CAPITAL LETTER RHO
Ρ = unmarked
                  -- U+03A2 <reserved>
Σ : Token σ′ upper -- U+03A3 GREEK CAPITAL LETTER SIGMA
Σ = unmarked
Τ : Token τ′ upper -- U+03A4 GREEK CAPITAL LETTER TAU
Τ = unmarked
Υ : Token υ′ upper -- U+03A5 GREEK CAPITAL LETTER UPSILON
Υ = unmarked
Φ : Token φ′ upper -- U+03A6 GREEK CAPITAL LETTER PHI
Φ = unmarked
Χ : Token χ′ upper -- U+03A7 GREEK CAPITAL LETTER CHI
Χ = unmarked
Ψ : Token ψ′ upper -- U+03A8 GREEK CAPITAL LETTER PSI
Ψ = unmarked
Ω : Token ω′ upper -- U+03A9 GREEK CAPITAL LETTER OMEGA
Ω = unmarked
Ϊ : Token ι′ upper -- U+03AA GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
Ϊ = unmarked
Ϋ : Token υ′ upper -- U+03AB GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
Ϋ = unmarked
ά : Token α′ lower -- U+03AC GREEK SMALL LETTER ALPHA WITH TONOS
ά = unmarked
έ : Token ε′ lower -- U+03AD GREEK SMALL LETTER EPSILON WITH TONOS
έ = unmarked
ή : Token η′ lower -- U+03AE GREEK SMALL LETTER ETA WITH TONOS
ή = unmarked
ί : Token ι′ lower -- U+03AF GREEK SMALL LETTER IOTA WITH TONOS
ί = unmarked
ΰ : Token υ′ lower -- U+03B0 GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
ΰ = unmarked
α : Token α′ lower -- U+03B1 GREEK SMALL LETTER ALPHA
α = unmarked
β : Token β′ lower -- U+03B2 GREEK SMALL LETTER BETA
β = unmarked
γ : Token γ′ lower -- U+03B3 GREEK SMALL LETTER GAMMA
γ = unmarked
δ : Token δ′ lower -- U+03B4 GREEK SMALL LETTER DELTA
δ = unmarked
ε : Token ε′ lower -- U+03B5 GREEK SMALL LETTER EPSILON
ε = unmarked
ζ : Token ζ′ lower -- U+03B6 GREEK SMALL LETTER ZETA
ζ = unmarked
η : Token η′ lower -- U+03B7 GREEK SMALL LETTER ETA
η = unmarked
θ : Token θ′ lower -- U+03B8 GREEK SMALL LETTER THETA
θ = unmarked
ι : Token ι′ lower -- U+03B9 GREEK SMALL LETTER IOTA
ι = unmarked
κ : Token κ′ lower -- U+03BA GREEK SMALL LETTER KAPPA
κ = unmarked
∙λ : Token λ′ lower -- U+03BB GREEK SMALL LETTER LAMDA
∙λ = unmarked
μ : Token μ′ lower -- U+03BC GREEK SMALL LETTER MU
μ = unmarked
ν : Token ν′ lower -- U+03BD GREEK SMALL LETTER NU
ν = unmarked
ξ : Token ξ′ lower -- U+03BE GREEK SMALL LETTER XI
ξ = unmarked
ο : Token ο′ lower -- U+03BF GREEK SMALL LETTER OMICRON
ο = unmarked
π : Token π′ lower -- U+03C0 GREEK SMALL LETTER PI
π = unmarked
ρ : Token ρ′ lower -- U+03C1 GREEK SMALL LETTER RHO
ρ = unmarked
ς : Token σ′ lower -- U+03C2 GREEK SMALL LETTER FINAL SIGMA
ς = unmarked
σ : Token σ′ lower -- U+03C3 GREEK SMALL LETTER SIGMA
σ = unmarked
τ : Token τ′ lower -- U+03C4 GREEK SMALL LETTER TAU
τ = unmarked
υ : Token υ′ lower -- U+03C5 GREEK SMALL LETTER UPSILON
υ = unmarked
φ : Token φ′ lower -- U+03C6 GREEK SMALL LETTER PHI
φ = unmarked
χ : Token χ′ lower -- U+03C7 GREEK SMALL LETTER CHI
χ = unmarked
ψ : Token ψ′ lower -- U+03C8 GREEK SMALL LETTER PSI
ψ = unmarked
ω : Token ω′ lower -- U+03C9 GREEK SMALL LETTER OMEGA
ω = unmarked
ϊ : Token ι′ lower -- U+03CA GREEK SMALL LETTER IOTA WITH DIALYTIKA
ϊ = unmarked
ϋ : Token υ′ lower -- U+03CB GREEK SMALL LETTER UPSILON WITH DIALYTIKA
ϋ = unmarked
ό : Token ο′ lower -- U+03CC GREEK SMALL LETTER OMICRON WITH TONOS
ό = unmarked
ύ : Token υ′ lower -- U+03CD GREEK SMALL LETTER UPSILON WITH TONOS
ύ = unmarked
ώ : Token ω′ lower -- U+03CE GREEK SMALL LETTER OMEGA WITH TONOS
ώ = unmarked

ἀ : Token α′ lower
ἀ = with-breathing α-smooth
ἁ : Token α′ lower
ἁ = with-breathing α-rough
ἂ : Token α′ lower
ἂ = with-accent-breathing α-grave α-smooth
ἃ : Token α′ lower
ἃ = with-accent-breathing α-grave α-rough
ἄ : Token α′ lower
ἄ = with-accent-breathing α-acute α-smooth
ἅ : Token α′ lower
ἅ = with-accent-breathing α-acute α-rough
ἆ : Token α′ lower
ἆ = with-accent-breathing α-circumflex α-smooth
ἇ : Token α′ lower
ἇ = with-accent-breathing α-circumflex α-rough
Ἀ : Token α′ upper
Ἀ = with-breathing Α-smooth
Ἁ : Token α′ upper
Ἁ = with-breathing Α-rough
Ἂ : Token α′ upper
Ἂ = with-accent-breathing α-grave Α-smooth
Ἃ : Token α′ upper
Ἃ = with-accent-breathing α-grave Α-rough
Ἄ : Token α′ upper
Ἄ = with-accent-breathing α-acute Α-smooth
Ἅ : Token α′ upper
Ἅ = with-accent-breathing α-acute Α-rough
Ἆ : Token α′ upper
Ἆ = with-accent-breathing α-circumflex Α-smooth
Ἇ : Token α′ upper
Ἇ = with-accent-breathing α-circumflex Α-rough

-- U+1F7x
ὰ : Token α′ lower
ὰ = with-accent α-grave
ά : Token α′ lower
ά = with-accent α-acute

-- U+1F8x
ᾀ : Token α′ lower
ᾀ = with-breathing-iota α-smooth α-iota-subscript
ᾁ : Token α′ lower
ᾁ = with-breathing-iota α-rough α-iota-subscript
ᾂ : Token α′ lower
ᾂ = with-accent-breathing-iota α-grave α-smooth α-iota-subscript
ᾃ : Token α′ lower
ᾃ = with-accent-breathing-iota α-grave α-rough α-iota-subscript
ᾄ : Token α′ lower
ᾄ = with-accent-breathing-iota α-acute α-smooth α-iota-subscript
ᾅ : Token α′ lower
ᾅ = with-accent-breathing-iota α-acute α-rough α-iota-subscript
ᾆ : Token α′ lower
ᾆ = with-accent-breathing-iota α-circumflex α-smooth α-iota-subscript
ᾇ : Token α′ lower
ᾇ = with-accent-breathing-iota α-circumflex α-rough α-iota-subscript
ᾈ : Token α′ upper
ᾈ = with-breathing-iota Α-smooth α-iota-subscript
ᾉ : Token α′ upper
ᾉ = with-breathing-iota Α-rough α-iota-subscript
ᾊ : Token α′ upper
ᾊ = with-accent-breathing-iota α-grave Α-smooth α-iota-subscript
ᾋ : Token α′ upper
ᾋ = with-accent-breathing-iota α-grave Α-rough α-iota-subscript
ᾌ : Token α′ upper
ᾌ = with-accent-breathing-iota α-acute Α-smooth α-iota-subscript
ᾍ : Token α′ upper
ᾍ = with-accent-breathing-iota α-acute Α-rough α-iota-subscript
ᾎ : Token α′ upper
ᾎ = with-accent-breathing-iota α-circumflex Α-smooth α-iota-subscript
ᾏ : Token α′ upper
ᾏ = with-accent-breathing-iota α-circumflex Α-rough α-iota-subscript

-- U+1FBx
-- ᾰ
-- ᾱ
ᾲ : Token α′ lower
ᾲ = with-accent-iota α-grave α-iota-subscript
ᾳ : Token α′ lower
ᾳ = with-iota α-iota-subscript
ᾴ : Token α′ lower
ᾴ = with-accent-iota α-acute α-iota-subscript
ᾶ : Token α′ lower
ᾶ = with-accent α-circumflex
ᾷ : Token α′ lower
ᾷ = with-accent-iota α-circumflex α-iota-subscript
-- Ᾰ
-- Ᾱ
Ὰ : Token α′ upper
Ὰ = with-accent α-grave
Ά : Token α′ upper
Ά = with-accent α-acute
ᾼ : Token α′ upper
ᾼ = with-iota α-iota-subscript

-- Mapping

data Accent : Set where
  acute-mark grave-mark circumflex-mark : Accent

letter-to-accent : ∀ {v} → v accent → Accent
letter-to-accent add-acute = acute-mark
letter-to-accent add-grave = grave-mark
letter-to-accent (add-circumflex x) = circumflex-mark

get-accent : ∀ {ℓ c} → Token ℓ c → Maybe Accent
get-accent (with-accent a) = just (letter-to-accent a)
get-accent (with-accent-breathing a _) = just (letter-to-accent a)
get-accent (with-accent-breathing-iota a _ _) = just (letter-to-accent a)
get-accent (with-accent-diaeresis a _) = just (letter-to-accent a)
get-accent (with-accent-iota a _) = just (letter-to-accent a)
get-accent _ = nothing

data Breathing : Set where
  smooth-mark rough-mark : Breathing

letter-to-breathing : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → Breathing
letter-to-breathing (add-smooth x) = smooth-mark
letter-to-breathing (add-rough x) = rough-mark

get-breathing : ∀ {ℓ c} → Token ℓ c → Maybe Breathing
get-breathing (with-breathing x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing _ x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing-iota _ x _) = just (letter-to-breathing x)
get-breathing (with-breathing-iota x _) = just (letter-to-breathing x)
get-breathing _ = nothing

data IotaSubscript : Set where
  iota-subscript-mark : IotaSubscript

get-iota-subscript : ∀ {ℓ c} → Token ℓ c → Maybe IotaSubscript
get-iota-subscript (with-accent-breathing-iota _ _ _) = just iota-subscript-mark
get-iota-subscript (with-accent-iota _ _) = just iota-subscript-mark
get-iota-subscript (with-breathing-iota _ _) = just iota-subscript-mark
get-iota-subscript _ = nothing

data Diaeresis : Set where
  diaeresis-mark : Diaeresis

get-diaeresis : ∀ {ℓ c} → Token ℓ c → Maybe Diaeresis
get-diaeresis (with-diaeresis _) = just diaeresis-mark
get-diaeresis (with-accent-diaeresis _ _) = just diaeresis-mark
get-diaeresis _ = nothing

data FinalForm : Set where
  final-form : FinalForm

get-final-form : ∀ {ℓ c} → Token ℓ c → Maybe FinalForm
get-final-form (final _) = just final-form
get-final-form _ = nothing

module Text.Greek.Script where

open import Data.Maybe
open import Data.Vec
open import Relation.Nullary using (¬_)
open import Relation.Binary.PropositionalEquality using (_≢_)

data Case : Set where
  lower upper : Case

data Letter : Set where
  α′ β′ γ′ δ′ ε′ ζ′ η′ θ′ ι′ κ′ λ′ μ′ ν′ ξ′ ο′ π′ ρ′ σ′ τ′ υ′ φ′ χ′ ψ′ ω′ : Letter

vowels : Vec _ _
vowels = α′ ∷ ε′ ∷ η′ ∷ ι′ ∷ ο′ ∷ υ′ ∷ ω′ ∷ []

always-short-letters : Vec _ _
always-short-letters = ε′ ∷ ο′ ∷ []

diaeresis-letters : Vec _ _
diaeresis-letters = ι′ ∷ υ′ ∷ []

iota-subscript-letters : Vec _ _
iota-subscript-letters = α′ ∷ η′ ∷ ω′ ∷ []

data _vowel : Letter → Set where
  is-vowel : ∀ {v} → v ∈ vowels → v vowel

data _always-short : Letter → Set where
  is-always-short : ∀ {v} → v vowel → v ∈ always-short-letters → v always-short

data _diaeresis : Letter → Set where
  add-diaeresis : ∀ {v} → v vowel → v ∈ diaeresis-letters → v diaeresis

data _⟦_⟧-final : Letter → Case → Set where
  make-final : σ′ ⟦ lower ⟧-final

data _⟦_⟧-smooth : Letter → Case → Set where
  add-smooth-lower-vowel : ∀ {v} → v vowel → v ⟦ lower ⟧-smooth
  add-smooth-ρ : ρ′ ⟦ lower ⟧-smooth
  add-smooth-upper-vowel-not-Υ : ∀ {v} → v vowel → v ≢ υ′ → v ⟦ upper ⟧-smooth

data _rough : Letter → Set where
  add-rough-vowel : ∀ {v} → v vowel → v rough
  add-rough-ρ : ρ′ rough

data _iota-subscript : Letter → Set where
  add-iota-subscript : ∀ {v} → v vowel → v ∈ iota-subscript-letters → v iota-subscript

data _⟦_⟧-breathing : Letter → Case → Set where
  add-smooth : ∀ {ℓ c} → ℓ ⟦ c ⟧-smooth → ℓ ⟦ c ⟧-breathing
  add-rough : ∀ {ℓ c} → ℓ rough → ℓ ⟦ c ⟧-breathing

data _long-vowel : Letter → Set where
  make-long-vowel : ∀ {v} → v vowel → ¬ v always-short → v long-vowel

data _accent : Letter → Set where
  add-acute : ∀ {ℓ} → ℓ vowel → ℓ accent
  add-grave : ∀ {ℓ} → ℓ vowel → ℓ accent
  add-circumflex : ∀ {ℓ} → ℓ long-vowel → ℓ accent

data Token : Letter → Case → Set where
  unmarked : ∀ {ℓ c} → Token ℓ c
  with-accent : ∀ {ℓ c} → ℓ accent → Token ℓ c
  with-breathing : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → Token ℓ c
  with-accent-breathing : ∀ {ℓ c} → ℓ accent → ℓ ⟦ c ⟧-breathing → Token ℓ c
  with-accent-breathing-iota : ∀ {ℓ c} → ℓ accent → ℓ ⟦ c ⟧-breathing → ℓ iota-subscript → Token ℓ c
  with-diaeresis : ∀ {ℓ c} → ℓ diaeresis → Token ℓ c
  with-accent-diaeresis : ∀ {ℓ c} → ℓ accent → ℓ diaeresis → Token ℓ c
  with-accent-iota : ∀ {ℓ c} → ℓ accent → ℓ iota-subscript → Token ℓ c
  with-breathing-iota : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → ℓ iota-subscript → Token ℓ c
  with-iota : ∀ {ℓ c} → ℓ iota-subscript → Token ℓ c
  final : ∀ {ℓ c} → ℓ ⟦ c ⟧-final → Token ℓ c

-- Constructions

-- Α α
α-vowel : α′ vowel
α-vowel = is-vowel here

¬α-always-short : ¬ α′ always-short
¬α-always-short (is-always-short α-vowel (there (there ())))

α-long-vowel : α′ long-vowel
α-long-vowel = make-long-vowel α-vowel ¬α-always-short

α-acute : α′ accent
α-acute = add-acute α-vowel

α-grave : α′ accent
α-grave = add-grave α-vowel

α-circumflex : α′ accent
α-circumflex = add-circumflex α-long-vowel

α-smooth : α′ ⟦ lower ⟧-breathing
α-smooth = add-smooth (add-smooth-lower-vowel α-vowel)

Α-smooth : α′ ⟦ upper ⟧-breathing
Α-smooth = add-smooth (add-smooth-upper-vowel-not-Υ α-vowel (λ ()))

α-rough : α′ ⟦ lower ⟧-breathing
α-rough = add-rough (add-rough-vowel α-vowel)

Α-rough : α′ ⟦ upper ⟧-breathing
Α-rough = add-rough (add-rough-vowel α-vowel)

α-iota-subscript : α′ iota-subscript
α-iota-subscript = add-iota-subscript α-vowel here

-- Ε ε
ε-vowel : ε′ vowel
ε-vowel = is-vowel (there here)

ε-always-short : ε′ always-short
ε-always-short = is-always-short ε-vowel here

ε-acute : ε′ accent
ε-acute = add-acute ε-vowel

ε-grave : ε′ accent
ε-grave = add-grave ε-vowel

ε-smooth : ε′ ⟦ lower ⟧-breathing
ε-smooth = add-smooth (add-smooth-lower-vowel ε-vowel)

Ε-smooth : ε′ ⟦ upper ⟧-breathing
Ε-smooth = add-smooth (add-smooth-upper-vowel-not-Υ ε-vowel (λ ()))

ε-rough : ε′ ⟦ lower ⟧-breathing
ε-rough = add-rough (add-rough-vowel ε-vowel)

Ε-rough : ε′ ⟦ upper ⟧-breathing
Ε-rough = add-rough (add-rough-vowel ε-vowel)

-- Η η
η-vowel : η′ vowel
η-vowel = is-vowel (there (there here))

¬η-always-short : ¬ η′ always-short
¬η-always-short (is-always-short η-vowel (there (there ())))

η-long-vowel : η′ long-vowel
η-long-vowel = make-long-vowel η-vowel ¬η-always-short

η-acute : η′ accent
η-acute = add-acute η-vowel

η-grave : η′ accent
η-grave = add-grave η-vowel

η-circumflex : η′ accent
η-circumflex = add-circumflex η-long-vowel

η-smooth : η′ ⟦ lower ⟧-breathing
η-smooth = add-smooth (add-smooth-lower-vowel η-vowel)

Η-smooth : η′ ⟦ upper ⟧-breathing
Η-smooth = add-smooth (add-smooth-upper-vowel-not-Υ η-vowel (λ ()))

η-rough : η′ ⟦ lower ⟧-breathing
η-rough = add-rough (add-rough-vowel η-vowel)

Η-rough : η′ ⟦ upper ⟧-breathing
Η-rough = add-rough (add-rough-vowel η-vowel)

η-iota-subscript : η′ iota-subscript
η-iota-subscript = add-iota-subscript η-vowel (there here)

-- Ι ι

instance
  ι-vowel : ι′ vowel
  ι-vowel = is-vowel (there (there (there here)))

  ¬ι-always-short : ¬ ι′ always-short
  ¬ι-always-short (is-always-short ι-vowel (there (there ())))

  ι-long-vowel : ι′ long-vowel
  ι-long-vowel = make-long-vowel ι-vowel ¬ι-always-short

  ι-not-υ : ι′ ≢ υ′
  ι-not-υ ()

ι-acute : ι′ accent
ι-acute = add-acute ι-vowel

ι-grave : ι′ accent
ι-grave = add-grave ι-vowel

ι-circumflex : ι′ accent
ι-circumflex = add-circumflex ι-long-vowel

ι-smooth : ι′ ⟦ lower ⟧-breathing
ι-smooth = add-smooth (add-smooth-lower-vowel ι-vowel)

Ι-smooth : ι′ ⟦ upper ⟧-breathing
Ι-smooth = add-smooth (add-smooth-upper-vowel-not-Υ ι-vowel (λ ()))

ι-rough : ι′ ⟦ lower ⟧-breathing
ι-rough = add-rough (add-rough-vowel ι-vowel)

-- Ο ο
f : ∀ {ℓ} → {{ p : ℓ vowel }} → ℓ accent
f {{ p }} = add-acute p

ι-acutes : Token ι′ lower
ι-acutes = with-accent f

-- Unicode
-- U+0390 - U+03CE
ΐ : Token ι′ lower -- U+0390 GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
ΐ = unmarked
Α : Token α′ upper -- U+0391 GREEK CAPITAL LETTER ALPHA
Α = unmarked
Β : Token β′ upper -- U+0392 GREEK CAPITAL LETTER BETA
Β = unmarked
Γ : Token γ′ upper -- U+0393 GREEK CAPITAL LETTER GAMMA
Γ = unmarked
Δ : Token δ′ upper -- U+0394 GREEK CAPITAL LETTER DELTA
Δ = unmarked
Ε : Token ε′ upper -- U+0395 GREEK CAPITAL LETTER EPSILON
Ε = unmarked
Ζ : Token ζ′ upper -- U+0396 GREEK CAPITAL LETTER ZETA
Ζ = unmarked
Η : Token η′ upper -- U+0397 GREEK CAPITAL LETTER ETA
Η = unmarked
Θ : Token θ′ upper -- U+0398 GREEK CAPITAL LETTER THETA
Θ = unmarked
Ι : Token ι′ upper -- U+0399 GREEK CAPITAL LETTER IOTA
Ι = unmarked
Κ : Token κ′ upper -- U+039A GREEK CAPITAL LETTER KAPPA
Κ = unmarked
Λ : Token λ′ upper -- U+039B GREEK CAPITAL LETTER LAMDA
Λ = unmarked
Μ : Token μ′ upper -- U+039C GREEK CAPITAL LETTER MU
Μ = unmarked
Ν : Token ν′ upper -- U+039D GREEK CAPITAL LETTER NU
Ν = unmarked
Ξ : Token ξ′ upper -- U+039E GREEK CAPITAL LETTER XI
Ξ = unmarked
Ο : Token ο′ upper -- U+039F GREEK CAPITAL LETTER OMICRON
Ο = unmarked
Π : Token π′ upper -- U+03A0 GREEK CAPITAL LETTER PI
Π = unmarked
Ρ : Token ρ′ upper -- U+03A1 GREEK CAPITAL LETTER RHO
Ρ = unmarked
                  -- U+03A2 <reserved>
Σ : Token σ′ upper -- U+03A3 GREEK CAPITAL LETTER SIGMA
Σ = unmarked
Τ : Token τ′ upper -- U+03A4 GREEK CAPITAL LETTER TAU
Τ = unmarked
Υ : Token υ′ upper -- U+03A5 GREEK CAPITAL LETTER UPSILON
Υ = unmarked
Φ : Token φ′ upper -- U+03A6 GREEK CAPITAL LETTER PHI
Φ = unmarked
Χ : Token χ′ upper -- U+03A7 GREEK CAPITAL LETTER CHI
Χ = unmarked
Ψ : Token ψ′ upper -- U+03A8 GREEK CAPITAL LETTER PSI
Ψ = unmarked
Ω : Token ω′ upper -- U+03A9 GREEK CAPITAL LETTER OMEGA
Ω = unmarked
Ϊ : Token ι′ upper -- U+03AA GREEK CAPITAL LETTER IOTA WITH DIALYTIKA
Ϊ = unmarked
Ϋ : Token υ′ upper -- U+03AB GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA
Ϋ = unmarked
ά : Token α′ lower -- U+03AC GREEK SMALL LETTER ALPHA WITH TONOS
ά = unmarked
έ : Token ε′ lower -- U+03AD GREEK SMALL LETTER EPSILON WITH TONOS
έ = unmarked
ή : Token η′ lower -- U+03AE GREEK SMALL LETTER ETA WITH TONOS
ή = unmarked
ί : Token ι′ lower -- U+03AF GREEK SMALL LETTER IOTA WITH TONOS
ί = unmarked
ΰ : Token υ′ lower -- U+03B0 GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
ΰ = unmarked
α : Token α′ lower -- U+03B1 GREEK SMALL LETTER ALPHA
α = unmarked
β : Token β′ lower -- U+03B2 GREEK SMALL LETTER BETA
β = unmarked
γ : Token γ′ lower -- U+03B3 GREEK SMALL LETTER GAMMA
γ = unmarked
δ : Token δ′ lower -- U+03B4 GREEK SMALL LETTER DELTA
δ = unmarked
ε : Token ε′ lower -- U+03B5 GREEK SMALL LETTER EPSILON
ε = unmarked
ζ : Token ζ′ lower -- U+03B6 GREEK SMALL LETTER ZETA
ζ = unmarked
η : Token η′ lower -- U+03B7 GREEK SMALL LETTER ETA
η = unmarked
θ : Token θ′ lower -- U+03B8 GREEK SMALL LETTER THETA
θ = unmarked
ι : Token ι′ lower -- U+03B9 GREEK SMALL LETTER IOTA
ι = unmarked
κ : Token κ′ lower -- U+03BA GREEK SMALL LETTER KAPPA
κ = unmarked
∙λ : Token λ′ lower -- U+03BB GREEK SMALL LETTER LAMDA
∙λ = unmarked
μ : Token μ′ lower -- U+03BC GREEK SMALL LETTER MU
μ = unmarked
ν : Token ν′ lower -- U+03BD GREEK SMALL LETTER NU
ν = unmarked
ξ : Token ξ′ lower -- U+03BE GREEK SMALL LETTER XI
ξ = unmarked
ο : Token ο′ lower -- U+03BF GREEK SMALL LETTER OMICRON
ο = unmarked
π : Token π′ lower -- U+03C0 GREEK SMALL LETTER PI
π = unmarked
ρ : Token ρ′ lower -- U+03C1 GREEK SMALL LETTER RHO
ρ = unmarked
ς : Token σ′ lower -- U+03C2 GREEK SMALL LETTER FINAL SIGMA
ς = unmarked
σ : Token σ′ lower -- U+03C3 GREEK SMALL LETTER SIGMA
σ = unmarked
τ : Token τ′ lower -- U+03C4 GREEK SMALL LETTER TAU
τ = unmarked
υ : Token υ′ lower -- U+03C5 GREEK SMALL LETTER UPSILON
υ = unmarked
φ : Token φ′ lower -- U+03C6 GREEK SMALL LETTER PHI
φ = unmarked
χ : Token χ′ lower -- U+03C7 GREEK SMALL LETTER CHI
χ = unmarked
ψ : Token ψ′ lower -- U+03C8 GREEK SMALL LETTER PSI
ψ = unmarked
ω : Token ω′ lower -- U+03C9 GREEK SMALL LETTER OMEGA
ω = unmarked
ϊ : Token ι′ lower -- U+03CA GREEK SMALL LETTER IOTA WITH DIALYTIKA
ϊ = unmarked
ϋ : Token υ′ lower -- U+03CB GREEK SMALL LETTER UPSILON WITH DIALYTIKA
ϋ = unmarked
ό : Token ο′ lower -- U+03CC GREEK SMALL LETTER OMICRON WITH TONOS
ό = unmarked
ύ : Token υ′ lower -- U+03CD GREEK SMALL LETTER UPSILON WITH TONOS
ύ = unmarked
ώ : Token ω′ lower -- U+03CE GREEK SMALL LETTER OMEGA WITH TONOS
ώ = unmarked

ἀ : Token α′ lower
ἀ = with-breathing α-smooth
ἁ : Token α′ lower
ἁ = with-breathing α-rough
ἂ : Token α′ lower
ἂ = with-accent-breathing α-grave α-smooth
ἃ : Token α′ lower
ἃ = with-accent-breathing α-grave α-rough
ἄ : Token α′ lower
ἄ = with-accent-breathing α-acute α-smooth
ἅ : Token α′ lower
ἅ = with-accent-breathing α-acute α-rough
ἆ : Token α′ lower
ἆ = with-accent-breathing α-circumflex α-smooth
ἇ : Token α′ lower
ἇ = with-accent-breathing α-circumflex α-rough
Ἀ : Token α′ upper
Ἀ = with-breathing Α-smooth
Ἁ : Token α′ upper
Ἁ = with-breathing Α-rough
Ἂ : Token α′ upper
Ἂ = with-accent-breathing α-grave Α-smooth
Ἃ : Token α′ upper
Ἃ = with-accent-breathing α-grave Α-rough
Ἄ : Token α′ upper
Ἄ = with-accent-breathing α-acute Α-smooth
Ἅ : Token α′ upper
Ἅ = with-accent-breathing α-acute Α-rough
Ἆ : Token α′ upper
Ἆ = with-accent-breathing α-circumflex Α-smooth
Ἇ : Token α′ upper
Ἇ = with-accent-breathing α-circumflex Α-rough

-- U+1F7x
ὰ : Token α′ lower
ὰ = with-accent α-grave
ά : Token α′ lower
ά = with-accent α-acute

-- U+1F8x
ᾀ : Token α′ lower
ᾀ = with-breathing-iota α-smooth α-iota-subscript
ᾁ : Token α′ lower
ᾁ = with-breathing-iota α-rough α-iota-subscript
ᾂ : Token α′ lower
ᾂ = with-accent-breathing-iota α-grave α-smooth α-iota-subscript
ᾃ : Token α′ lower
ᾃ = with-accent-breathing-iota α-grave α-rough α-iota-subscript
ᾄ : Token α′ lower
ᾄ = with-accent-breathing-iota α-acute α-smooth α-iota-subscript
ᾅ : Token α′ lower
ᾅ = with-accent-breathing-iota α-acute α-rough α-iota-subscript
ᾆ : Token α′ lower
ᾆ = with-accent-breathing-iota α-circumflex α-smooth α-iota-subscript
ᾇ : Token α′ lower
ᾇ = with-accent-breathing-iota α-circumflex α-rough α-iota-subscript
ᾈ : Token α′ upper
ᾈ = with-breathing-iota Α-smooth α-iota-subscript
ᾉ : Token α′ upper
ᾉ = with-breathing-iota Α-rough α-iota-subscript
ᾊ : Token α′ upper
ᾊ = with-accent-breathing-iota α-grave Α-smooth α-iota-subscript
ᾋ : Token α′ upper
ᾋ = with-accent-breathing-iota α-grave Α-rough α-iota-subscript
ᾌ : Token α′ upper
ᾌ = with-accent-breathing-iota α-acute Α-smooth α-iota-subscript
ᾍ : Token α′ upper
ᾍ = with-accent-breathing-iota α-acute Α-rough α-iota-subscript
ᾎ : Token α′ upper
ᾎ = with-accent-breathing-iota α-circumflex Α-smooth α-iota-subscript
ᾏ : Token α′ upper
ᾏ = with-accent-breathing-iota α-circumflex Α-rough α-iota-subscript

-- U+1FBx
-- ᾰ
-- ᾱ
ᾲ : Token α′ lower
ᾲ = with-accent-iota α-grave α-iota-subscript
ᾳ : Token α′ lower
ᾳ = with-iota α-iota-subscript
ᾴ : Token α′ lower
ᾴ = with-accent-iota α-acute α-iota-subscript
ᾶ : Token α′ lower
ᾶ = with-accent α-circumflex
ᾷ : Token α′ lower
ᾷ = with-accent-iota α-circumflex α-iota-subscript
-- Ᾰ
-- Ᾱ
Ὰ : Token α′ upper
Ὰ = with-accent α-grave
Ά : Token α′ upper
Ά = with-accent α-acute
ᾼ : Token α′ upper
ᾼ = with-iota α-iota-subscript

-- Mapping

data Accent : Set where
  acute-mark grave-mark circumflex-mark : Accent

letter-to-accent : ∀ {v} → v accent → Accent
letter-to-accent (add-acute x) = acute-mark
letter-to-accent (add-grave x) = grave-mark
letter-to-accent (add-circumflex x) = circumflex-mark

get-accent : ∀ {ℓ c} → Token ℓ c → Maybe Accent
get-accent (with-accent a) = just (letter-to-accent a)
get-accent (with-accent-breathing a _) = just (letter-to-accent a)
get-accent (with-accent-breathing-iota a _ _) = just (letter-to-accent a)
get-accent (with-accent-diaeresis a _) = just (letter-to-accent a)
get-accent (with-accent-iota a _) = just (letter-to-accent a)
get-accent _ = nothing

data Breathing : Set where
  smooth-mark rough-mark : Breathing

letter-to-breathing : ∀ {ℓ c} → ℓ ⟦ c ⟧-breathing → Breathing
letter-to-breathing (add-smooth x) = smooth-mark
letter-to-breathing (add-rough x) = rough-mark

get-breathing : ∀ {ℓ c} → Token ℓ c → Maybe Breathing
get-breathing (with-breathing x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing _ x) = just (letter-to-breathing x)
get-breathing (with-accent-breathing-iota _ x _) = just (letter-to-breathing x)
get-breathing (with-breathing-iota x _) = just (letter-to-breathing x)
get-breathing _ = nothing

data IotaSubscript : Set where
  iota-subscript-mark : IotaSubscript

get-iota-subscript : ∀ {ℓ c} → Token ℓ c → Maybe IotaSubscript
get-iota-subscript (with-accent-breathing-iota _ _ _) = just iota-subscript-mark
get-iota-subscript (with-accent-iota _ _) = just iota-subscript-mark
get-iota-subscript (with-breathing-iota _ _) = just iota-subscript-mark
get-iota-subscript _ = nothing

data Diaeresis : Set where
  diaeresis-mark : Diaeresis

get-diaeresis : ∀ {ℓ c} → Token ℓ c → Maybe Diaeresis
get-diaeresis (with-diaeresis _) = just diaeresis-mark
get-diaeresis (with-accent-diaeresis _ _) = just diaeresis-mark
get-diaeresis _ = nothing

data FinalForm : Set where
  final-form : FinalForm

get-final-form : ∀ {ℓ c} → Token ℓ c → Maybe FinalForm
get-final-form (final _) = just final-form
get-final-form _ = nothing