Update binds

Update binds

{-# OPTIONS --without-K #-}
module ZK.PartialHeliosVerifier where

open import Type
open import Function hiding (case_of_)
open import Data.Bool.Base
open import Data.Product
open import Data.List.Base using (List; []; _∷_; and; foldr)
open import Data.String.Base  using (String)

open import FFI.JS as JS hiding (_+_; _/_; _*_; join)
open import FFI.JS.BigI as BigI
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS
open import FFI.JS.SHA1
open import FFI.JS.Proc
open import Control.Process.Type

join : String → List String → String
join sep []       = ""
join sep (x ∷ xs) = x ++ foldr (λ y z → sep ++ y ++ z) "" xs

{-
instance
  showBigI = mk λ _ → showString ∘ BigI.toString
-}

G  = BigI
ℤq = BigI

BigI▹G : BigI → G
BigI▹G = id

BigI▹ℤq : BigI → ℤq
BigI▹ℤq = id

non0I : BigI → BigI
non0I x with equals x 0I
... | true  = throw "Should be non zero!" 0I
... | false = x

module BigICG (p q : BigI) where
  _^_  : G  → ℤq → G
  _·_  : G  → G  → G
  _/_  : G  → G  → G
  _+_  : ℤq → ℤq → ℤq
  _*_  : ℤq → ℤq → ℤq
  _==_ : (x y : G) → Bool

  _^_ = λ x y → modPow x y p
  _·_ = λ x y → mod (multiply x y) p
  _/_ = λ x y → mod (multiply x (modInv (non0I y) p)) p
  _+_ = λ x y → mod (add x y) q
  _*_ = λ x y → mod (multiply x y) q
  _==_ = equals

  sumI : List BigI → BigI
  sumI = foldr _+_ 0I

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

{-
print : {A : Set}{{_ : Show A}} → A → Callback0
print = Console.log ∘ show
-}

PubKey         = G
EncRnd         = ℤq {- randomness used for encryption of ct -}
Message        = G {- plain text message -}
Challenge      = ℤq
Response       = ℤq
CommitmentPart = G
CipherTextPart = G

module HeliosVerifyV3 (g : G) p q (y : PubKey) where
  open BigICG p q

  verify-chaum-pedersen : (α β : CipherTextPart)(M : Message)(A B : G)(c : Challenge)(s : Response) → Bool
  verify-chaum-pedersen α β M A B c s
      = trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
        (g ^ s) == (A · (α ^ c))
      ∧ (y ^ s) == (B · ((β / M) ^ c))

  verify-individual-proof : (α β : CipherTextPart)(ix : Number)(π : JSValue) → Bool
  verify-individual-proof α β ix π
      = trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "commitmentA=" A λ _ →
        trace "commitmentB=" B λ _ →
        trace "challenge=" c λ _ →
        trace "response=" s λ _ →
        res
      where
        m  = bignum ix
        M  = g ^ m
        A  = bigdec (π ·« "commitment" » ·« "A" »)
        B  = bigdec (π ·« "commitment" » ·« "B" »)
        c  = bigdec (π ·« "challenge" »)
        s  = bigdec (π ·« "response" »)
        res = verify-chaum-pedersen α β M A B c s

  -- Conform to HeliosV3 but it is too weak.
  -- One should follow a "Strong Fiat Shamir" transformation
  -- from interactive ZK proof to non-interactive ZK proofs.
  -- Namely one should hash the statement as well.
  --
  -- SHA1(A0 + "," + B0 + "," + A1 + "," + B1 + ... + "Amax" + "," + Bmax)
  hash-commitments : JSArray JSValue → BigI
  hash-commitments πs =
    fromHex $
    trace-call "SHA1(commitments)=" SHA1       $
    trace-call "commitments="       (join ",") $
    decodeJSArray πs λ _ π →
      (castString (π ·« "commitment" » ·« "A" »))
      ++ "," ++
      (castString (π ·« "commitment" » ·« "B" »))

  sum-challenges : JSArray JSValue → BigI
  sum-challenges πs =
    sumI $ decodeJSArray πs λ _ π → bigdec (π ·« "challenge" »)

  verify-challenges : JSArray JSValue → Bool
  verify-challenges πs =
      trace "hash(commitments)=" h λ _ →
      trace "sum(challenge)="    c λ _ →
      h == c
    where
      h = hash-commitments πs
      c = sum-challenges   πs

  verify-choice : (v : JSValue)(πs : JSArray JSValue) → Bool
  verify-choice v πs =
      trace "α=" α λ _ →
      trace "β=" β λ _ →
      verify-challenges πs
      ∧
      and (decodeJSArray πs $ verify-individual-proof α β)
    where
      α = bigdec (v ·« "alpha" »)
      β = bigdec (v ·« "beta"  »)

  verify-choices : (choices πs : JSArray JSValue) → Bool
  verify-choices choices πs =
    trace "TODO: check the array size of choices πs together election data" "" λ _ →
    and $ decodeJSArray choices λ ix choice →
      trace "verify choice " ix λ _ →
      verify-choice choice (castJSArray (πs Array[ ix ]))

  verify-answer : (answer : JSValue) → Bool
  verify-answer answer =
      trace "TODO: CHECK the overall_proof" "" λ _ →
      verify-choices choices individual-proofs
    where
      choices           = answer ·« "choices" »A
      individual-proofs = answer ·« "individual_proofs" »A
      overall-proof     = answer ·« "overall_proof" »A

  verify-answers : (answers : JSArray JSValue) → Bool
  verify-answers answers =
    and $ decodeJSArray answers λ ix a →
      trace "verify answer " ix λ _ →
      verify-answer a

  {-
  verify-election-hash =
  ""
  -- notice the whitespaces and the alphabetical order of keys
  -- {"email": ["ben@adida.net", "ben@mit.edu"], "first_name": "Ben", "last_name": "Adida"}
    computed_hash = base64.b64encode(hash.new(election.toJSON()).digest())[:-1]
    computed_hash == vote.election_hash:
  ""
  -}

  -- module _ {-(election : JSValue)-} where
  verify-ballot : (ballot : JSValue) → Bool
  verify-ballot ballot =
        trace "TODO: CHECK the election_hash: " election_hash λ _ →
        trace "TODO: CHECK the election_uuid: " election_uuid λ _ →
        verify-answers answers
      where
        answers       = ballot ·« "answers" »A
        election_hash = ballot ·« "election_hash" »
        election_uuid = ballot ·« "election_uuid" »

  verify-ballots : (ballots : JSArray JSValue) → Bool
  verify-ballots ballots =
      and $ decodeJSArray ballots λ ix ballot →
        trace "verify ballot " ix λ _ →
        verify-ballot ballot

-- Many checks are still missing!
verify-helios-election : (arg : JSValue) → Bool
verify-helios-election arg = trace "res=" res id
 where
    ed = arg ·« "election_data" »
    bs = arg ·« "ballots" »A
    pk = ed  ·« "public_key" »
    g  = bigdec (pk ·« "g" »)
    p  = bigdec (pk ·« "p" »)
    q  = bigdec (pk ·« "q" »)
    y  = bigdec (pk ·« "y" »)
    res =
        trace "g=" g λ _ →
        trace "p=" p λ _ →
        trace "q=" q λ _ →
        trace "y=" y λ _ →
        HeliosVerifyV3.verify-ballots g p q y bs

srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (verify-helios-election q))
  end

-- Working around Agda.Primitive.lsuc being undefined
case_of_ : {A : Set} {B : Set} → A → (A → B) → B
case x of f = f x

main : JS!
main =
  Process.argv >>= λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
          server "127.0.0.1" "1337" srv >>= λ uri →
          Console.log (showURI uri)
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              let opts =
                 -- fromJSObject (fromObject (("encoding" , fromString "utf8") ∷ []))
                 -- nullJS
                    JSON-parse "{\"encoding\":\"utf8\"}"
              in
              Console.log ("readFile=" ++ arg) >>
              FS.readFile arg opts >>== λ err dat →
                Console.log ("readFile: err=" ++ JS.toString err) >>
                Console.log (Bool▹String (verify-helios-election (JSON-parse (castString dat))))
          ; _ →
              Console.log "usage"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module ZK.PartialHeliosVerifier where

open import Type
open import Function hiding (case_of_)
open import Data.Bool.Base
open import Data.Product
open import Data.List.Base using (List; []; _∷_; and; foldr)
open import Data.String.Base  using (String)

open import FFI.JS as JS hiding (_+_; _/_; _*_; join)
open import FFI.JS.BigI as BigI
import FFI.JS.Console as Console
import FFI.JS.Process as Process
import FFI.JS.FS as FS
open import FFI.JS.SHA1
open import FFI.JS.Proc
open import Control.Process.Type

join : String → List String → String
join sep []       = ""
join sep (x ∷ xs) = x ++ foldr (λ y z → sep ++ y ++ z) "" xs

{-
instance
  showBigI = mk λ _ → showString ∘ BigI.toString
-}

G  = BigI
ℤq = BigI

BigI▹G : BigI → G
BigI▹G = id

BigI▹ℤq : BigI → ℤq
BigI▹ℤq = id

non0I : BigI → BigI
non0I x with equals x 0I
... | true  = throw "Should be non zero!" 0I
... | false = x

module BigICG (p q : BigI) where
  _^_  : G  → ℤq → G
  _·_  : G  → G  → G
  _/_  : G  → G  → G
  _+_  : ℤq → ℤq → ℤq
  _*_  : ℤq → ℤq → ℤq
  _==_ : (x y : G) → Bool

  _^_ = λ x y → modPow x y p
  _·_ = λ x y → mod (multiply x y) p
  _/_ = λ x y → mod (multiply x (modInv (non0I y) p)) p
  _+_ = λ x y → mod (add x y) q
  _*_ = λ x y → mod (multiply x y) q
  _==_ = equals

  sumI : List BigI → BigI
  sumI = foldr _+_ 0I

bignum : Number → BigI
bignum n = bigI (Number▹String n) "10"

-- TODO check with undefined
bigdec : JSValue → BigI
bigdec v = bigI (castString v) "10"

{-
print : {A : Set}{{_ : Show A}} → A → Callback0
print = Console.log ∘ show
-}

PubKey         = G
EncRnd         = ℤq {- randomness used for encryption of ct -}
Message        = G {- plain text message -}
Challenge      = ℤq
Response       = ℤq
CommitmentPart = G
CipherTextPart = G

module HeliosVerifyV3 (g : G) p q (y : PubKey) where
  open BigICG p q

  verify-chaum-pedersen : (α β : CipherTextPart)(M : Message)(A B : G)(c : Challenge)(s : Response) → Bool
  verify-chaum-pedersen α β M A B c s
      = trace "α=" α λ _ →
        trace "β=" β λ _ →
        trace "M=" M λ _ →
        trace "A=" A λ _ →
        trace "B=" B λ _ →
        trace "c=" c λ _ →
        trace "s=" s λ _ →
        (g ^ s) == (A · (α ^ c))
      ∧ (y ^ s) == (B · ((β / M) ^ c))

  verify-individual-proof : (α β : CipherTextPart)(ix : Number)(π : JSValue) → Bool
  verify-individual-proof α β ix π
      = trace "m=" m λ _ →
        trace "M=" M λ _ →
        trace "commitmentA=" A λ _ →
        trace "commitmentB=" B λ _ →
        trace "challenge=" c λ _ →
        trace "response=" s λ _ →
        res
      where
        m  = bignum ix
        M  = g ^ m
        A  = bigdec (π ·« "commitment" » ·« "A" »)
        B  = bigdec (π ·« "commitment" » ·« "B" »)
        c  = bigdec (π ·« "challenge" »)
        s  = bigdec (π ·« "response" »)
        res = verify-chaum-pedersen α β M A B c s

  -- Conform to HeliosV3 but it is too weak.
  -- One should follow a "Strong Fiat Shamir" transformation
  -- from interactive ZK proof to non-interactive ZK proofs.
  -- Namely one should hash the statement as well.
  --
  -- SHA1(A0 + "," + B0 + "," + A1 + "," + B1 + ... + "Amax" + "," + Bmax)
  hash-commitments : JSArray JSValue → BigI
  hash-commitments πs =
    fromHex $
    trace-call "SHA1(commitments)=" SHA1       $
    trace-call "commitments="       (join ",") $
    decodeJSArray πs λ _ π →
      (castString (π ·« "commitment" » ·« "A" »))
      ++ "," ++
      (castString (π ·« "commitment" » ·« "B" »))

  sum-challenges : JSArray JSValue → BigI
  sum-challenges πs =
    sumI $ decodeJSArray πs λ _ π → bigdec (π ·« "challenge" »)

  verify-challenges : JSArray JSValue → Bool
  verify-challenges πs =
      trace "hash(commitments)=" h λ _ →
      trace "sum(challenge)="    c λ _ →
      h == c
    where
      h = hash-commitments πs
      c = sum-challenges   πs

  verify-choice : (v : JSValue)(πs : JSArray JSValue) → Bool
  verify-choice v πs =
      trace "α=" α λ _ →
      trace "β=" β λ _ →
      verify-challenges πs
      ∧
      and (decodeJSArray πs $ verify-individual-proof α β)
    where
      α = bigdec (v ·« "alpha" »)
      β = bigdec (v ·« "beta"  »)

  verify-choices : (choices πs : JSArray JSValue) → Bool
  verify-choices choices πs =
    trace "TODO: check the array size of choices πs together election data" "" λ _ →
    and $ decodeJSArray choices λ ix choice →
      trace "verify choice " ix λ _ →
      verify-choice choice (castJSArray (πs Array[ ix ]))

  verify-answer : (answer : JSValue) → Bool
  verify-answer answer =
      trace "TODO: CHECK the overall_proof" "" λ _ →
      verify-choices choices individual-proofs
    where
      choices           = answer ·« "choices" »A
      individual-proofs = answer ·« "individual_proofs" »A
      overall-proof     = answer ·« "overall_proof" »A

  verify-answers : (answers : JSArray JSValue) → Bool
  verify-answers answers =
    and $ decodeJSArray answers λ ix a →
      trace "verify answer " ix λ _ →
      verify-answer a

  {-
  verify-election-hash =
  ""
  -- notice the whitespaces and the alphabetical order of keys
  -- {"email": ["ben@adida.net", "ben@mit.edu"], "first_name": "Ben", "last_name": "Adida"}
    computed_hash = base64.b64encode(hash.new(election.toJSON()).digest())[:-1]
    computed_hash == vote.election_hash:
  ""
  -}

  -- module _ {-(election : JSValue)-} where
  verify-ballot : (ballot : JSValue) → Bool
  verify-ballot ballot =
        trace "TODO: CHECK the election_hash: " election_hash λ _ →
        trace "TODO: CHECK the election_uuid: " election_uuid λ _ →
        verify-answers answers
      where
        answers       = ballot ·« "answers" »A
        election_hash = ballot ·« "election_hash" »
        election_uuid = ballot ·« "election_uuid" »

  verify-ballots : (ballots : JSArray JSValue) → Bool
  verify-ballots ballots =
      and $ decodeJSArray ballots λ ix ballot →
        trace "verify ballot " ix λ _ →
        verify-ballot ballot

-- Many checks are still missing!
verify-helios-election : (arg : JSValue) → Bool
verify-helios-election arg = trace "res=" res id
 where
    ed = arg ·« "election_data" »
    bs = arg ·« "ballots" »A
    pk = ed  ·« "public_key" »
    g  = bigdec (pk ·« "g" »)
    p  = bigdec (pk ·« "p" »)
    q  = bigdec (pk ·« "q" »)
    y  = bigdec (pk ·« "y" »)
    res =
        trace "g=" g λ _ →
        trace "p=" p λ _ →
        trace "q=" q λ _ →
        trace "y=" y λ _ →
        HeliosVerifyV3.verify-ballots g p q y bs

srv : URI → JSProc
srv d =
  recv d λ q →
  send d (fromBool (verify-helios-election q))
  end

-- Working around Agda.Primitive.lsuc being undefined
case_of_ : {A : Set} {B : Set} → A → (A → B) → B
case x of f = f x

main : JS!
main =
  Process.argv !₁ λ args →
  case JSArray▹ListString args of λ {
    (_node ∷ _run ∷ _test ∷ args') →
      case args' of λ {
        [] →
          server "127.0.0.1" "1337" srv !₁ λ uri →
          Console.log (showURI uri)
      ; (arg ∷ args'') →
          case args'' of λ {
            [] →
              let opts =
                 -- fromJSObject (fromObject (("encoding" , fromString "utf8") ∷ []))
                 -- nullJS
                    JSON-parse "{\"encoding\":\"utf8\"}"
              in
              Console.log ("readFile=" ++ arg) >>
              FS.readFile arg opts !₂ λ err dat →
                Console.log ("readFile: err=" ++ JS.toString err) >>
                Console.log (Bool▹String (verify-helios-election (JSON-parse (castString dat))))
          ; _ →
              Console.log "usage"
          }
      }
  ; _ →
      Console.log "usage"
  }
-- -}
-- -}
-- -}
-- -}
-- -}


Cosmetic changes.

Cosmetic changes.

Ignore-this: 280c70464ba8834c70dba89505eaa3e7

darcs-hash:20110211172355-3bd4e-da68e0330b95249a06ca8fa24c3ba199be3697d1.gz

-- Tested with the darcs version of the standard library on 11 February 2011.

module MirrorStdLib where

open import Algebra
open import Data.List as List hiding ( reverse )
open import Data.List.Properties

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

module LM {A : Set} = Monoid (List.monoid A)

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

reverse : {A : Set} → List A → List A
reverse []       = []
reverse (x ∷ xs) = reverse xs ++ x ∷ []

++-rightIdentity : {A : Set}(xs : List A) → xs ++ [] ≡ xs
++-rightIdentity []       = refl
++-rightIdentity (x ∷ xs) = cong (_∷_ x) (++-rightIdentity xs)

reverse-++ : {A : Set}(xs ys : List A) →
             reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++ [] ys       = sym (++-rightIdentity (reverse ys))
reverse-++ (x ∷ xs) [] = cong (λ x' → reverse x' ++ x ∷ []) (++-rightIdentity xs)
reverse-++ (x ∷ xs) (y ∷ ys) =
  begin
    reverse (xs ++ y ∷ ys) ++ x ∷ []
      ≡⟨ cong (λ x' → x' ++ x ∷ []) (reverse-++ xs (y ∷ ys)) ⟩
    (reverse (y ∷ ys) ++ reverse xs) ++ x ∷ []
      ≡⟨ LM.assoc (reverse (y ∷ ys)) (reverse xs) (x ∷ []) ⟩
    reverse (y ∷ ys) ++ reverse (x ∷ xs)
  ∎

data Tree (A : Set) : Set where
  treeT : A → List (Tree A) → Tree A

mirror : {A : Set} → Tree A → Tree A
mirror (treeT a ts) = treeT a (reverse (map mirror ts))

mutual
  mirror² : {A : Set} → (t : Tree A) → mirror (mirror t) ≡ t
  mirror² (treeT a [])       = refl
  mirror² (treeT a (t ∷ ts)) =
    begin
      treeT a (reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ [])))
        ≡⟨ subst (λ x → treeT a (reverse (map mirror (reverse (map mirror ts) ++
                                                      mirror t ∷ []))) ≡
                        treeT a x)
           (aux (t ∷ ts))
           refl
        ⟩
      treeT a (t ∷ ts)
    ∎

  aux : {A : Set} → (ts : List (Tree A)) →
        reverse (map mirror (reverse (map mirror ts))) ≡ ts
  aux []       = refl
  aux (t ∷ ts) =
    begin
      reverse (map mirror (reverse (map mirror ts) ++ mirror t ∷ []))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts) ++
                                              mirror t ∷ []))) ≡
                        reverse x)
           (map-++-commute mirror (reverse (map mirror ts)) (mirror t ∷ []))
           refl
        ⟩
      reverse (map mirror (reverse (map mirror ts)) ++
              (map mirror (mirror t ∷ [])))
        ≡⟨ subst (λ x → (reverse (map mirror (reverse (map mirror ts)) ++
                                             (map mirror (mirror t ∷ [])))) ≡
                        x)
                 (reverse-++ (map mirror (reverse (map mirror ts)))
                             (map mirror (mirror t ∷ [])))
                 refl
        ⟩
      reverse (map mirror (mirror t ∷ [])) ++
      reverse (map mirror (reverse (map mirror ts)))
              ≡⟨ refl ⟩
      mirror (mirror t) ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → (mirror (mirror t) ∷
                                reverse (map mirror (reverse (map mirror ts)))) ≡
                        (x ∷ reverse (map mirror (reverse (map mirror ts)))))
                 (mirror² t)  -- IH.
                 refl
        ⟩
      t ∷ reverse (map mirror (reverse (map mirror ts)))
        ≡⟨ subst (λ x → t ∷ reverse (map mirror (reverse (map mirror ts))) ≡
                        t ∷ x)
                 (aux ts)
                 refl
        ⟩
      t ∷ ts
    ∎


removing some redundant lemmas and moving things around in disjointness

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import exchange
open import lemmas-freshness
open import weakening

module disjointness where
  mutual
    expand-new-disjoint-synth : ∀ { e u τ d Δ Γ Γ' τ'} →
                          hole-name-new e u →
                          Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                          Δ ## (■ (u , Γ' , τ'))
    expand-new-disjoint-synth HNConst ESConst = empty-disj (■ (_ , _ , _))
    expand-new-disjoint-synth (HNAsc hn) (ESAsc x) = expand-new-disjoint-ana hn x
    expand-new-disjoint-synth HNVar (ESVar x₁) = empty-disj (■ (_ , _ , _))
    expand-new-disjoint-synth (HNLam1 hn) ()
    expand-new-disjoint-synth (HNLam2 hn) (ESLam x₁ exp) = expand-new-disjoint-synth hn exp
    expand-new-disjoint-synth (HNHole x) ESEHole = disjoint-singles x
    expand-new-disjoint-synth (HNNEHole x hn) (ESNEHole x₁ exp) = disjoint-parts (expand-new-disjoint-synth hn exp) (disjoint-singles x)
    expand-new-disjoint-synth (HNAp hn hn₁) (ESAp x x₁ x₂ x₃ x₄ x₅) =
                                            disjoint-parts (expand-new-disjoint-ana hn x₄)
                                                  (expand-new-disjoint-ana hn₁ x₅)

    expand-new-disjoint-ana : ∀ { e u τ d Δ Γ Γ' τ' τ2} →
                              hole-name-new e u →
                              Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ →
                              Δ ## (■ (u , Γ' , τ'))
    expand-new-disjoint-ana hn (EASubsume x x₁ x₂ x₃) = expand-new-disjoint-synth hn x₂
    expand-new-disjoint-ana (HNLam1 hn) (EALam x₁ x₂ ex) = expand-new-disjoint-ana hn ex
    expand-new-disjoint-ana (HNHole x) EAEHole = disjoint-singles x
    expand-new-disjoint-ana (HNNEHole x hn) (EANEHole x₁ x₂) = disjoint-parts (expand-new-disjoint-synth hn x₂) (disjoint-singles x)

  mutual
    expand-disjoint-new-synth : ∀{ e τ d Δ u Γ Γ' τ'} →
                                Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                                Δ ## (■ (u , Γ' , τ')) →
                                hole-name-new e u
    expand-disjoint-new-synth ESConst disj = HNConst
    expand-disjoint-new-synth (ESVar x₁) disj = HNVar
    expand-disjoint-new-synth (ESLam x₁ ex) disj = HNLam2 (expand-disjoint-new-synth ex disj)
    expand-disjoint-new-synth (ESAp {Δ1 = Δ1} x x₁ x₂ x₃ x₄ x₅) disj
      with expand-disjoint-new-ana x₄ (disjoint-union1 disj) | expand-disjoint-new-ana x₅ (disjoint-union2 {Γ1 = Δ1} disj)
    ... | ih1 | ih2 = HNAp ih1 ih2
    expand-disjoint-new-synth {Γ = Γ} ESEHole disj = HNHole (singles-notequal disj)
    expand-disjoint-new-synth (ESNEHole {Δ = Δ} x ex) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj))
                                                                      (expand-disjoint-new-synth ex (disjoint-union1 disj))
    expand-disjoint-new-synth (ESAsc x) disj = HNAsc (expand-disjoint-new-ana x disj)

    expand-disjoint-new-ana : ∀{ e τ d Δ u Γ Γ' τ2 τ'} →
                                Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ →
                                Δ ## (■ (u , Γ' , τ')) →
                                hole-name-new e u
    expand-disjoint-new-ana (EALam x₁ x₂ ex) disj = HNLam1 (expand-disjoint-new-ana ex disj)
    expand-disjoint-new-ana (EASubsume x x₁ x₂ x₃) disj = expand-disjoint-new-synth x₂ disj
    expand-disjoint-new-ana EAEHole disj = HNHole (singles-notequal disj)
    expand-disjoint-new-ana (EANEHole {Δ = Δ} x x₁) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj))
                                                                    (expand-disjoint-new-synth x₁ (disjoint-union1 disj))

  -- collect up the hole names of a term as the indices of a trivial contex
  data holes : (e : hexp) (H : ⊤ ctx) → Set where
    HConst : holes c ∅
    HAsc   : ∀{e τ H} → holes e H → holes (e ·: τ) H
    HVar   : ∀{x} → holes (X x) ∅
    HLam1  : ∀{x e H} → holes e H → holes (·λ x e) H
    HLam2  : ∀{x e τ H} → holes e H → holes (·λ x [ τ ] e) H
    HEHole : ∀{u} → holes (⦇⦈[ u ]) (■ (u , <>))
    HNEHole : ∀{e u H} → holes e H → holes (⦇ e ⦈[ u ]) (H ,, (u , <>))
    HAp : ∀{e1 e2 H1 H2} → holes e1 H1 → holes e2 H2 → holes (e1 ∘ e2) (H1 ∪ H2)

  -- the above judgement has mode (∀,∃). this doesn't prove uniqueness; any
  -- contex that extends the one computed here will be indistinguishable
  -- but we'll treat this one as canonical
  find-holes : (e : hexp) → Σ[ H ∈ ⊤ ctx ](holes e H)
  find-holes c = ∅ , HConst
  find-holes (e ·: x) with find-holes e
  ... | (h , d)= h , (HAsc d)
  find-holes (X x) = ∅ , HVar
  find-holes (·λ x e) with find-holes e
  ... | (h , d) = h , HLam1 d
  find-holes (·λ x [ x₁ ] e) with find-holes e
  ... | (h , d) = h , HLam2 d
  find-holes ⦇⦈[ x ] = (■ (x , <>)) , HEHole
  find-holes ⦇ e ⦈[ x ] with find-holes e
  ... | (h , d) = h ,, (x , <>) , HNEHole d
  find-holes (e1 ∘ e2) with find-holes e1 | find-holes e2
  ... | (h1 , d1) | (h2 , d2)  = (h1 ∪ h2 ) , (HAp d1 d2)

  -- two contexts that may contain different mappings have the same domain
  dom-eq : {A B : Set} → A ctx → B ctx → Set
  dom-eq {A} {B} C1 C2 = ((n : Nat) → Σ[ x ∈ A ]( C1 n == Some x) → (Σ[ y ∈ B ](C2 n == Some y)))×
                         ((n : Nat) → Σ[ y ∈ B ]( C2 n == Some y) → (Σ[ x ∈ A ](C1 n == Some x)))

  -- the empty context has the same domain as itself
  dom-∅ : {A B : Set} → dom-eq (λ _ → None {A}) (λ _ → None {B})
  dom-∅ {A} {B} = (λ n x → abort (somenotnone (! (π2 x)))) , (λ n x → abort (somenotnone (! (π2 x))))

  -- todo: this seems like i would have proven it already? otw move to lemmas
  singleton-eq : {A : Set} {a : A} → ∀{x n y} → (■ (x , a)) n == Some y → x == n
  singleton-eq {A} {a} {x} {n} {y} eq with natEQ x n
  singleton-eq eq | Inl x₁ = x₁
  singleton-eq eq | Inr x₁ = abort (somenotnone (! eq))

  -- todo: this seems like i would have proven it already? otw move to lemmas
  singleton-lookup-refl : {A : Set} {n : Nat} {β : A} → (■ (n , β)) n == Some β
  singleton-lookup-refl {n = n} with natEQ n n
  singleton-lookup-refl | Inl refl = λ {β} → refl
  singleton-lookup-refl | Inr x = abort (x refl)

  -- the singleton contexts formed with any contents but the same index has
  -- the same domain
  dom-single : {A B : Set} (x : Nat) (a : A) (b : B) → dom-eq (■ (x , a)) (■ (x , b))
  dom-single {A} {B} x α β = (λ n x₁ → β , (ap1 (λ qq → (■ (qq , β)) n) (singleton-eq (π2 x₁)) · singleton-lookup-refl)) ,
                             (λ n x₁ → α , (ap1 (λ qq → (■ (qq , α)) n) (singleton-eq (π2 x₁)) · singleton-lookup-refl))

  -- todo: this seems like i would have proven it already? otw move to lemmas
  lem-dom-union-apt1 : {A : Set} {Δ1 Δ2 : A ctx} {x : Nat} {y : A} → x # Δ1 → ((Δ1 ∪ Δ2) x == Some y) → (Δ2 x == Some y)
  lem-dom-union-apt1 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x
  lem-dom-union-apt1 apt xin | Some x₁ = abort (somenotnone apt)
  lem-dom-union-apt1 apt xin | None = xin

  -- todo: this seems like i would have proven it already? otw move to lemmas
  lem-dom-union-apt2 : {A : Set} {Δ1 Δ2 : A ctx} {x : Nat} {y : A} → x # Δ2 → ((Δ1 ∪ Δ2) x == Some y) → (Δ1 x == Some y)
  lem-dom-union-apt2 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x
  lem-dom-union-apt2 apt xin | Some x₁ = xin
  lem-dom-union-apt2 apt xin | None = abort (somenotnone (! xin · apt))

  -- if two disjoint sets each share a domain with two other sets, those
  -- are also disjoint.
  dom-eq-disj : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} →
              H1 ## H2 →
              dom-eq Δ1 H1 →
              dom-eq Δ2 H2 →
              Δ1 ## Δ2
  dom-eq-disj {A} {B} {Δ1} {Δ2} {H1} {H2} (d1 , d2) (de1 , de2) (de3 , de4) = guts1 , guts2
    where
      guts1 : (n : Nat) → dom Δ1 n → n # Δ2
      guts1 n dom1 with ctxindirect H2 n
      guts1 n dom1 | Inl x = abort (somenotnone (! (π2 x) · d1 n (de1 n dom1)))
      guts1 n dom1 | Inr x with ctxindirect Δ2 n
      guts1 n dom1 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de3 n x)) · x₁))
      guts1 n dom1 | Inr x₁ | Inr x = x

      guts2 : (n : Nat) → dom Δ2 n → n # Δ1
      guts2 n dom2 with ctxindirect H1 n
      guts2 n dom2 | Inl x = abort (somenotnone (! (π2 x) · d2 n (de3 n dom2)))
      guts2 n dom2 | Inr x with ctxindirect Δ1 n
      guts2 n dom2 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de1 n x)) · x₁))
      guts2 n dom2 | Inr x₁ | Inr x = x

  -- if two sets share a domain with disjoint sets, then their union shares
  -- a domain with the union
  dom-union : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} →
                                     H1 ## H2 →
                                     dom-eq Δ1 H1 →
                                     dom-eq Δ2 H2 →
                                     dom-eq (Δ1 ∪ Δ2) (H1 ∪ H2)
  dom-union {A} {B} {Δ1} {Δ2} {H1} {H2} disj (p1 , p2) (p3 , p4) = guts1 , guts2
    where
      guts1 : (n : Nat) →
                 Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x) →
                 Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y)
      guts1 n (x , eq) with ctxindirect Δ1 n
      guts1 n (x₁ , eq) | Inl x with p1 n x
      ... | q1 , q2 = q1 , x∈∪l H1 H2 n q1 q2
      guts1 n (x₁ , eq) | Inr x with p3 n (_ , lem-dom-union-apt1 {Δ1 = Δ1} {Δ2 = Δ2} x eq)
      ... | q1 , q2 =  q1 , x∈∪r H1 H2 n q1 q2 (##-comm disj)

      guts2 : (n : Nat) →
                 Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y) →
                 Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x)
      guts2 n (x , eq) with ctxindirect H1 n
      guts2 n (x₁ , eq) | Inl x with p2 n x
      ... | q1 , q2 = q1 , x∈∪l Δ1 Δ2 n q1 q2
      guts2 n (x₁ , eq) | Inr x with p4 n (_ , lem-dom-union-apt2 {Δ1 = H2} {Δ2 = H1} x (tr (λ qq → qq n == Some x₁) (∪comm H1 H2 disj) eq))
      ... | q1 , q2 = q1 , x∈∪r Δ1 Δ2 n q1 q2 (##-comm (dom-eq-disj disj (p1 , p2) (p3 , p4)))

  -- if a hole name is new then it's apart from the collection of hole
  -- names
  lem-apart-new : ∀{e H u} → holes e H → hole-name-new e u → u # H
  lem-apart-new HConst HNConst = refl
  lem-apart-new (HAsc h) (HNAsc hn) = lem-apart-new h hn
  lem-apart-new HVar HNVar = refl
  lem-apart-new (HLam1 h) (HNLam1 hn) = lem-apart-new h hn
  lem-apart-new (HLam2 h) (HNLam2 hn) = lem-apart-new h hn
  lem-apart-new HEHole (HNHole x) = apart-singleton (flip x)
  lem-apart-new (HNEHole {u = u'} {H = H} h) (HNNEHole  {u = u}  x hn) = apart-parts H (■ (u' , <>)) u (lem-apart-new h hn) (apart-singleton (flip x))
  lem-apart-new (HAp {H1 = H1} {H2 = H2} h h₁) (HNAp hn hn₁) = apart-parts H1 H2 _ (lem-apart-new h hn) (lem-apart-new h₁ hn₁)

  -- todo: this seems like i would have proven it already? otw move to lemmas
  lem-dom-apt : {A : Set} {G : A ctx} {x y : Nat} → x # G → dom G y → x ≠ y
  lem-dom-apt {x = x} {y = y} apt dom with natEQ x y
  lem-dom-apt apt dom | Inl refl = abort (somenotnone (! (π2 dom) · apt))
  lem-dom-apt apt dom | Inr x₁ = x₁

  -- if the holes of two expressions are disjoint, so are their collections
  -- of hole names
  holes-disjoint-disjoint : ∀{ e1 e2 H1 H2} →
                    holes e1 H1 →
                    holes e2 H2 →
                    holes-disjoint e1 e2 →
                    H1 ## H2
  holes-disjoint-disjoint HConst he2 HDConst = empty-disj _
  holes-disjoint-disjoint (HAsc he1) he2 (HDAsc hd) = holes-disjoint-disjoint he1 he2 hd
  holes-disjoint-disjoint HVar he2 HDVar = empty-disj _
  holes-disjoint-disjoint (HLam1 he1) he2 (HDLam1 hd) = holes-disjoint-disjoint he1 he2 hd
  holes-disjoint-disjoint (HLam2 he1) he2 (HDLam2 hd) = holes-disjoint-disjoint he1 he2 hd
  holes-disjoint-disjoint HEHole he2 (HDHole x) = lem-apart-sing-disj (lem-apart-new he2 x)
  holes-disjoint-disjoint (HNEHole he1) he2 (HDNEHole x hd) = disjoint-parts (holes-disjoint-disjoint he1 he2 hd) (lem-apart-sing-disj (lem-apart-new he2 x))
  holes-disjoint-disjoint (HAp he1 he2) he3 (HDAp hd hd₁) = disjoint-parts (holes-disjoint-disjoint he1 he3 hd) (holes-disjoint-disjoint he2 he3 hd₁)

  -- the holes of an expression have the same domain as Δ; that is, we
  -- don't add any extra junk as we expand
  mutual
    holes-delta-ana : ∀{Γ H e τ d τ' Δ} →
                    holes e H →
                    Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                    dom-eq Δ H
    holes-delta-ana (HLam1 h) (EALam x₁ x₂ exp) = holes-delta-ana h exp
    holes-delta-ana h (EASubsume x x₁ x₂ x₃) = holes-delta-synth h x₂
    holes-delta-ana (HEHole {u = u}) EAEHole = dom-single u _ _
    holes-delta-ana (HNEHole {u = u} h) (EANEHole x x₁) with (holes-delta-synth h x₁)
    ... | ih = dom-union {!!} ih (dom-single u _ _ )

    holes-delta-synth : ∀{Γ H e τ d Δ} →
                    holes e H →
                    Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                    dom-eq Δ H
    holes-delta-synth HConst ESConst = dom-∅
    holes-delta-synth (HAsc h) (ESAsc x) = holes-delta-ana h x
    holes-delta-synth HVar (ESVar x₁) = dom-∅
    holes-delta-synth (HLam2 h) (ESLam x₁ exp) = holes-delta-synth h exp
    holes-delta-synth (HEHole {u = u}) ESEHole = dom-single u _ _
    holes-delta-synth (HNEHole {u = u} h) (ESNEHole x exp) = dom-union {!!} (holes-delta-synth h exp) (dom-single u _ _)
    holes-delta-synth (HAp h h₁) (ESAp x x₁ x₂ x₃ x₄ x₅) = dom-union (holes-disjoint-disjoint h h₁ x) (holes-delta-ana h x₄) (holes-delta-ana h₁ x₅)

  -- if you expand two hole-disjoint expressions analytically, the Δs
  -- produces are disjoint. note that this is likely true for synthetic
  -- expansions in much the same way, but we only prove "half" of the usual
  -- pair here. the proof technique is *not* structurally inductive on the
  -- expansion judgement, because of the missing weakness property, so this
  -- proof is somewhat unusual compared to the rest in this development.
  expand-ana-disjoint : ∀{ e1 e2 τ1 τ2 e1' e2' τ1' τ2' Γ Δ1 Δ2 } →
          holes-disjoint e1 e2 →
          Γ ⊢ e1 ⇐ τ1 ~> e1' :: τ1' ⊣ Δ1 →
          Γ ⊢ e2 ⇐ τ2 ~> e2' :: τ2' ⊣ Δ2 →
          Δ1 ## Δ2
  expand-ana-disjoint {e1} {e2} hd ana1 ana2
    with find-holes e1 | find-holes e2
  ... | (_ , he1) | (_ , he2) = dom-eq-disj (holes-disjoint-disjoint he1 he2 hd)
                                            (holes-delta-ana he1 ana1)
                                            (holes-delta-ana he2 ana2)

  -- these lemmas are all structurally recursive and quite
  -- mechanical. morally, they establish the properties about reduction
  -- that would be obvious / baked into Agda if holes-disjoint was defined
  -- as a function rather than a judgement (datatype), or if we had defined
  -- all the O(n^2) cases rather than relying on a little indirection to
  -- only have O(n) cases. that work has to go somewhwere, and we prefer
  -- that it goes here.
  ds-lem-asc : ∀{e1 e2 τ} → holes-disjoint e2 e1 → holes-disjoint e2 (e1 ·: τ)
  ds-lem-asc HDConst = HDConst
  ds-lem-asc (HDAsc hd) = HDAsc (ds-lem-asc hd)
  ds-lem-asc HDVar = HDVar
  ds-lem-asc (HDLam1 hd) = HDLam1 (ds-lem-asc hd)
  ds-lem-asc (HDLam2 hd) = HDLam2 (ds-lem-asc hd)
  ds-lem-asc (HDHole x) = HDHole (HNAsc x)
  ds-lem-asc (HDNEHole x hd) = HDNEHole (HNAsc x) (ds-lem-asc hd)
  ds-lem-asc (HDAp hd hd₁) = HDAp (ds-lem-asc hd) (ds-lem-asc hd₁)

  ds-lem-lam1 : ∀{e1 e2 x} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x e1)
  ds-lem-lam1 HDConst = HDConst
  ds-lem-lam1 (HDAsc hd) = HDAsc (ds-lem-lam1 hd)
  ds-lem-lam1 HDVar = HDVar
  ds-lem-lam1 (HDLam1 hd) = HDLam1 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDLam2 hd) = HDLam2 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDHole x₁) = HDHole (HNLam1 x₁)
  ds-lem-lam1 (HDNEHole x₁ hd) = HDNEHole (HNLam1 x₁) (ds-lem-lam1 hd)
  ds-lem-lam1 (HDAp hd hd₁) = HDAp (ds-lem-lam1 hd) (ds-lem-lam1 hd₁)

  ds-lem-lam2 : ∀{e1 e2 x τ} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x [ τ ] e1)
  ds-lem-lam2 HDConst = HDConst
  ds-lem-lam2 (HDAsc hd) = HDAsc (ds-lem-lam2 hd)
  ds-lem-lam2 HDVar = HDVar
  ds-lem-lam2 (HDLam1 hd) = HDLam1 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDLam2 hd) = HDLam2 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDHole x₁) = HDHole (HNLam2 x₁)
  ds-lem-lam2 (HDNEHole x₁ hd) = HDNEHole (HNLam2 x₁) (ds-lem-lam2 hd)
  ds-lem-lam2 (HDAp hd hd₁) = HDAp (ds-lem-lam2 hd) (ds-lem-lam2 hd₁)

  ds-lem-nehole : ∀{e e1 u} → holes-disjoint e e1 → hole-name-new e u → holes-disjoint e ⦇ e1 ⦈[ u ]
  ds-lem-nehole HDConst ν = HDConst
  ds-lem-nehole (HDAsc hd) (HNAsc ν) = HDAsc (ds-lem-nehole hd ν)
  ds-lem-nehole HDVar ν = HDVar
  ds-lem-nehole (HDLam1 hd) (HNLam1 ν) = HDLam1 (ds-lem-nehole hd ν)
  ds-lem-nehole (HDLam2 hd) (HNLam2 ν) = HDLam2 (ds-lem-nehole hd ν)
  ds-lem-nehole (HDHole x) (HNHole x₁) = HDHole (HNNEHole (flip x₁) x)
  ds-lem-nehole (HDNEHole x hd) (HNNEHole x₁ ν) = HDNEHole (HNNEHole (flip x₁) x) (ds-lem-nehole hd ν)
  ds-lem-nehole (HDAp hd hd₁) (HNAp ν ν₁) = HDAp (ds-lem-nehole hd ν) (ds-lem-nehole hd₁ ν₁)

  ds-lem-ap : ∀{e1 e2 e3} → holes-disjoint e3 e1 → holes-disjoint e3 e2 → holes-disjoint e3 (e1 ∘ e2)
  ds-lem-ap HDConst hd2 = HDConst
  ds-lem-ap (HDAsc hd1) (HDAsc hd2) = HDAsc (ds-lem-ap hd1 hd2)
  ds-lem-ap HDVar hd2 = HDVar
  ds-lem-ap (HDLam1 hd1) (HDLam1 hd2) = HDLam1 (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDLam2 hd1) (HDLam2 hd2) = HDLam2 (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDHole x) (HDHole x₁) = HDHole (HNAp x x₁)
  ds-lem-ap (HDNEHole x hd1) (HDNEHole x₁ hd2) = HDNEHole (HNAp x x₁) (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDAp hd1 hd2) (HDAp hd3 hd4) = HDAp (ds-lem-ap hd1 hd3) (ds-lem-ap hd2 hd4)

  -- holes-disjoint is symmetric
  disjoint-sym : (e1 e2 : hexp) → holes-disjoint e1 e2 → holes-disjoint e2 e1
  disjoint-sym .c c HDConst = HDConst
  disjoint-sym .c (e2 ·: x) HDConst = HDAsc (disjoint-sym _ _ HDConst)
  disjoint-sym .c (X x) HDConst = HDVar
  disjoint-sym .c (·λ x e2) HDConst = HDLam1 (disjoint-sym c e2 HDConst)
  disjoint-sym .c (·λ x [ x₁ ] e2) HDConst = HDLam2 (disjoint-sym c e2 HDConst)
  disjoint-sym .c ⦇⦈[ x ] HDConst = HDHole HNConst
  disjoint-sym .c ⦇ e2 ⦈[ x ] HDConst = HDNEHole HNConst (disjoint-sym c e2 HDConst)
  disjoint-sym .c (e2 ∘ e3) HDConst = HDAp (disjoint-sym c e2 HDConst) (disjoint-sym c e3 HDConst)

  disjoint-sym _ c (HDAsc hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x) (HDAsc hd) | HDAsc ih = HDAsc (ds-lem-asc ih)
  disjoint-sym _ (X x) (HDAsc hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDAsc hd) | HDLam1 ih = HDLam1 (ds-lem-asc ih)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) | HDLam2 ih = HDLam2 (ds-lem-asc ih)
  disjoint-sym _ ⦇⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x ] (HDAsc hd) | HDHole x₁ = HDHole (HNAsc x₁)
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDAsc hd) | HDNEHole x₁ ih = HDNEHole (HNAsc x₁) (ds-lem-asc ih)
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) | HDAp ih ih₁ = HDAp (ds-lem-asc ih) (ds-lem-asc ih₁)

  disjoint-sym _ c HDVar = HDConst
  disjoint-sym _ (e2 ·: x₁) HDVar = HDAsc (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (X x₁) HDVar = HDVar
  disjoint-sym _ (·λ x₁ e2) HDVar = HDLam1 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) HDVar = HDLam2 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ ⦇⦈[ x₁ ] HDVar = HDHole HNVar
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] HDVar = HDNEHole HNVar (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (e2 ∘ e3) HDVar = HDAp (disjoint-sym _ e2 HDVar) (disjoint-sym _ e3 HDVar)

  disjoint-sym _ c (HDLam1 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) | HDAsc ih = HDAsc (ds-lem-lam1 ih)
  disjoint-sym _ (X x₁) (HDLam1 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) | HDLam1 ih = HDLam1 (ds-lem-lam1 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) | HDLam2 ih = HDLam2 (ds-lem-lam1 ih)
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam1 hd) | HDHole x = HDHole (HNLam1 x)
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam1 hd) | HDNEHole x ih = HDNEHole (HNLam1 x) (ds-lem-lam1 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam1 ih) (ds-lem-lam1 ih₁)

  disjoint-sym _ c (HDLam2 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) | HDAsc ih = HDAsc (ds-lem-lam2 ih)
  disjoint-sym _ (X x₁) (HDLam2 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) | HDLam1 ih = HDLam1 (ds-lem-lam2 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) | HDLam2 ih = HDLam2 (ds-lem-lam2 ih)
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam2 hd) | HDHole x = HDHole (HNLam2 x)
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam2 hd) | HDNEHole x ih = HDNEHole (HNLam2 x) (ds-lem-lam2 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam2 ih) (ds-lem-lam2 ih₁)

  disjoint-sym _ c (HDHole x) = HDConst
  disjoint-sym _ (e2 ·: x) (HDHole (HNAsc x₁)) = HDAsc (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (X x) (HDHole x₁) = HDVar
  disjoint-sym _ (·λ x e2) (HDHole (HNLam1 x₁)) = HDLam1 (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDHole (HNLam2 x₂)) = HDLam2 (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₂))
  disjoint-sym _ ⦇⦈[ x ] (HDHole (HNHole x₁)) =  HDHole (HNHole (flip x₁))
  disjoint-sym _ ⦇ e2 ⦈[ u' ] (HDHole (HNNEHole x x₁)) = HDNEHole (HNHole (flip x)) (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (e2 ∘ e3) (HDHole (HNAp x x₁)) = HDAp (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x))
                                                    (disjoint-sym ⦇⦈[ _ ] e3 (HDHole x₁))

  disjoint-sym _ c (HDNEHole x hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e ·: x) (HDNEHole (HNAsc x₁) hd) | HDAsc ih = HDAsc (ds-lem-nehole ih x₁)
  disjoint-sym _ (X x) (HDNEHole x₁ hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDNEHole (HNLam1 x₁) hd) | HDLam1 ih = HDLam1 (ds-lem-nehole ih x₁)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole x₂ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole (HNLam2 x₂) hd) | HDLam2 ih = HDLam2 (ds-lem-nehole ih x₂)
  disjoint-sym _ ⦇⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x ] (HDNEHole (HNHole x₂) hd) | HDHole x₁ = HDHole (HNNEHole (flip x₂) x₁)
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDNEHole (HNNEHole x₂ x₃) hd) | HDNEHole x₁ ih = HDNEHole (HNNEHole (flip x₂) x₁) (ds-lem-nehole ih x₃)
  disjoint-sym _ (e2 ∘ e3) (HDNEHole x hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e1 ∘ e3) (HDNEHole (HNAp x x₁) hd) | HDAp ih ih₁ = HDAp (ds-lem-nehole ih x) (ds-lem-nehole ih₁ x₁)

  disjoint-sym _ c (HDAp hd hd₁) = HDConst
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) | HDAsc ih | HDAsc ih1 = HDAsc (ds-lem-ap ih ih1)
  disjoint-sym _ (X x) (HDAp hd hd₁) = HDVar
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) | HDLam1 ih | HDLam1 ih1 = HDLam1 (ds-lem-ap ih ih1)
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) | HDLam2 ih | HDLam2 ih1 = HDLam2 (ds-lem-ap ih ih1)
  disjoint-sym _ ⦇⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ ⦇⦈[ x ] (HDAp hd hd₁) | HDHole x₁ | HDHole x₂ = HDHole (HNAp x₁ x₂)
  disjoint-sym _ ⦇ e3 ⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ ⦇ e3 ⦈[ x ] (HDAp hd hd₁) | HDNEHole x₁ ih | HDNEHole x₂ ih1 = HDNEHole (HNAp x₁ x₂) (ds-lem-ap ih ih1)
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) | HDAp ih ih₁ | HDAp ih1 ih2 = HDAp (ds-lem-ap ih ih1) (ds-lem-ap ih₁ ih2)

  -- note that this is false, so holes-disjoint isn't transitive
  -- disjoint-new : ∀{e1 e2 u} → holes-disjoint e1 e2 → hole-name-new e1 u → hole-name-new e2 u

  -- it's also not reflexive, because ⦇⦈[ u ] isn't hole-disjoint with
  -- itself since refl : u == u; it's also not anti-reflexive, because the
  -- expression c *is* hole-disjoint with itself (albeit vacuously)

open import Prelude
open import Nat
open import core
open import contexts
open import lemmas-disjointness
open import exchange
open import lemmas-freshness
open import weakening

module disjointness where
  mutual
    expand-new-disjoint-synth : ∀ { e u τ d Δ Γ Γ' τ'} →
                          hole-name-new e u →
                          Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                          Δ ## (■ (u , Γ' , τ'))
    expand-new-disjoint-synth HNConst ESConst = empty-disj (■ (_ , _ , _))
    expand-new-disjoint-synth (HNAsc hn) (ESAsc x) = expand-new-disjoint-ana hn x
    expand-new-disjoint-synth HNVar (ESVar x₁) = empty-disj (■ (_ , _ , _))
    expand-new-disjoint-synth (HNLam1 hn) ()
    expand-new-disjoint-synth (HNLam2 hn) (ESLam x₁ exp) = expand-new-disjoint-synth hn exp
    expand-new-disjoint-synth (HNHole x) ESEHole = disjoint-singles x
    expand-new-disjoint-synth (HNNEHole x hn) (ESNEHole x₁ exp) = disjoint-parts (expand-new-disjoint-synth hn exp) (disjoint-singles x)
    expand-new-disjoint-synth (HNAp hn hn₁) (ESAp x x₁ x₂ x₃ x₄ x₅) =
                                            disjoint-parts (expand-new-disjoint-ana hn x₄)
                                                  (expand-new-disjoint-ana hn₁ x₅)

    expand-new-disjoint-ana : ∀ { e u τ d Δ Γ Γ' τ' τ2} →
                              hole-name-new e u →
                              Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ →
                              Δ ## (■ (u , Γ' , τ'))
    expand-new-disjoint-ana hn (EASubsume x x₁ x₂ x₃) = expand-new-disjoint-synth hn x₂
    expand-new-disjoint-ana (HNLam1 hn) (EALam x₁ x₂ ex) = expand-new-disjoint-ana hn ex
    expand-new-disjoint-ana (HNHole x) EAEHole = disjoint-singles x
    expand-new-disjoint-ana (HNNEHole x hn) (EANEHole x₁ x₂) = disjoint-parts (expand-new-disjoint-synth hn x₂) (disjoint-singles x)

  mutual
    expand-disjoint-new-synth : ∀{ e τ d Δ u Γ Γ' τ'} →
                                Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                                Δ ## (■ (u , Γ' , τ')) →
                                hole-name-new e u
    expand-disjoint-new-synth ESConst disj = HNConst
    expand-disjoint-new-synth (ESVar x₁) disj = HNVar
    expand-disjoint-new-synth (ESLam x₁ ex) disj = HNLam2 (expand-disjoint-new-synth ex disj)
    expand-disjoint-new-synth (ESAp {Δ1 = Δ1} x x₁ x₂ x₃ x₄ x₅) disj
      with expand-disjoint-new-ana x₄ (disjoint-union1 disj) | expand-disjoint-new-ana x₅ (disjoint-union2 {Γ1 = Δ1} disj)
    ... | ih1 | ih2 = HNAp ih1 ih2
    expand-disjoint-new-synth {Γ = Γ} ESEHole disj = HNHole (singles-notequal disj)
    expand-disjoint-new-synth (ESNEHole {Δ = Δ} x ex) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj))
                                                                      (expand-disjoint-new-synth ex (disjoint-union1 disj))
    expand-disjoint-new-synth (ESAsc x) disj = HNAsc (expand-disjoint-new-ana x disj)

    expand-disjoint-new-ana : ∀{ e τ d Δ u Γ Γ' τ2 τ'} →
                                Γ ⊢ e ⇐ τ ~> d :: τ2 ⊣ Δ →
                                Δ ## (■ (u , Γ' , τ')) →
                                hole-name-new e u
    expand-disjoint-new-ana (EALam x₁ x₂ ex) disj = HNLam1 (expand-disjoint-new-ana ex disj)
    expand-disjoint-new-ana (EASubsume x x₁ x₂ x₃) disj = expand-disjoint-new-synth x₂ disj
    expand-disjoint-new-ana EAEHole disj = HNHole (singles-notequal disj)
    expand-disjoint-new-ana (EANEHole {Δ = Δ} x x₁) disj = HNNEHole (singles-notequal (disjoint-union2 {Γ1 = Δ} disj))
                                                                    (expand-disjoint-new-synth x₁ (disjoint-union1 disj))

  -- collect up the hole names of a term as the indices of a trivial contex
  data holes : (e : hexp) (H : ⊤ ctx) → Set where
    HConst : holes c ∅
    HAsc   : ∀{e τ H} → holes e H → holes (e ·: τ) H
    HVar   : ∀{x} → holes (X x) ∅
    HLam1  : ∀{x e H} → holes e H → holes (·λ x e) H
    HLam2  : ∀{x e τ H} → holes e H → holes (·λ x [ τ ] e) H
    HEHole : ∀{u} → holes (⦇⦈[ u ]) (■ (u , <>))
    HNEHole : ∀{e u H} → holes e H → holes (⦇ e ⦈[ u ]) (H ,, (u , <>))
    HAp : ∀{e1 e2 H1 H2} → holes e1 H1 → holes e2 H2 → holes (e1 ∘ e2) (H1 ∪ H2)

  -- the above judgement has mode (∀,∃). this doesn't prove uniqueness; any
  -- contex that extends the one computed here will be indistinguishable
  -- but we'll treat this one as canonical
  find-holes : (e : hexp) → Σ[ H ∈ ⊤ ctx ](holes e H)
  find-holes c = ∅ , HConst
  find-holes (e ·: x) with find-holes e
  ... | (h , d)= h , (HAsc d)
  find-holes (X x) = ∅ , HVar
  find-holes (·λ x e) with find-holes e
  ... | (h , d) = h , HLam1 d
  find-holes (·λ x [ x₁ ] e) with find-holes e
  ... | (h , d) = h , HLam2 d
  find-holes ⦇⦈[ x ] = (■ (x , <>)) , HEHole
  find-holes ⦇ e ⦈[ x ] with find-holes e
  ... | (h , d) = h ,, (x , <>) , HNEHole d
  find-holes (e1 ∘ e2) with find-holes e1 | find-holes e2
  ... | (h1 , d1) | (h2 , d2)  = (h1 ∪ h2 ) , (HAp d1 d2)

  -- two contexts that may contain different mappings have the same domain
  dom-eq : {A B : Set} → A ctx → B ctx → Set
  dom-eq {A} {B} C1 C2 = ((n : Nat) → Σ[ x ∈ A ]( C1 n == Some x) → (Σ[ y ∈ B ](C2 n == Some y)))×
                         ((n : Nat) → Σ[ y ∈ B ]( C2 n == Some y) → (Σ[ x ∈ A ](C1 n == Some x)))

  -- the empty context has the same domain as itself
  dom-∅ : {A B : Set} → dom-eq (λ _ → None {A}) (λ _ → None {B})
  dom-∅ {A} {B} = (λ n x → abort (somenotnone (! (π2 x)))) , (λ n x → abort (somenotnone (! (π2 x))))

  -- todo: this seems like i would have proven it already? otw move to lemmas
  singleton-eq : {A : Set} {a : A} → ∀{x n y} → (■ (x , a)) n == Some y → x == n
  singleton-eq {A} {a} {x} {n} {y} eq with natEQ x n
  singleton-eq eq | Inl x₁ = x₁
  singleton-eq eq | Inr x₁ = abort (somenotnone (! eq))

  -- todo: this seems like i would have proven it already? otw move to lemmas
  singleton-lookup-refl : {A : Set} {n : Nat} {β : A} → (■ (n , β)) n == Some β
  singleton-lookup-refl {n = n} with natEQ n n
  singleton-lookup-refl | Inl refl = λ {β} → refl
  singleton-lookup-refl | Inr x = abort (x refl)

  -- the singleton contexts formed with any contents but the same index has
  -- the same domain
  dom-single : {A B : Set} (x : Nat) (a : A) (b : B) → dom-eq (■ (x , a)) (■ (x , b))
  dom-single {A} {B} x α β = (λ n x₁ → β , (ap1 (λ qq → (■ (qq , β)) n) (singleton-eq (π2 x₁)) · singleton-lookup-refl)) ,
                             (λ n x₁ → α , (ap1 (λ qq → (■ (qq , α)) n) (singleton-eq (π2 x₁)) · singleton-lookup-refl))

  lem-dom-union-apt1 : {A : Set} {Δ1 Δ2 : A ctx} {x : Nat} {y : A} → x # Δ1 → ((Δ1 ∪ Δ2) x == Some y) → (Δ2 x == Some y)
  lem-dom-union-apt1 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x
  lem-dom-union-apt1 apt xin | Some x₁ = abort (somenotnone apt)
  lem-dom-union-apt1 apt xin | None = xin

  lem-dom-union-apt2 : {A : Set} {Δ1 Δ2 : A ctx} {x : Nat} {y : A} → x # Δ2 → ((Δ1 ∪ Δ2) x == Some y) → (Δ1 x == Some y)
  lem-dom-union-apt2 {A} {Δ1} {Δ2} {x} {y} apt xin with Δ1 x
  lem-dom-union-apt2 apt xin | Some x₁ = xin
  lem-dom-union-apt2 apt xin | None = abort (somenotnone (! xin · apt))

  -- if two disjoint sets each share a domain with two other sets, those
  -- are also disjoint.
  dom-eq-disj : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} →
              H1 ## H2 →
              dom-eq Δ1 H1 →
              dom-eq Δ2 H2 →
              Δ1 ## Δ2
  dom-eq-disj {A} {B} {Δ1} {Δ2} {H1} {H2} (d1 , d2) (de1 , de2) (de3 , de4) = guts1 , guts2
    where
      guts1 : (n : Nat) → dom Δ1 n → n # Δ2
      guts1 n dom1 with ctxindirect H2 n
      guts1 n dom1 | Inl x = abort (somenotnone (! (π2 x) · d1 n (de1 n dom1)))
      guts1 n dom1 | Inr x with ctxindirect Δ2 n
      guts1 n dom1 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de3 n x)) · x₁))
      guts1 n dom1 | Inr x₁ | Inr x = x

      guts2 : (n : Nat) → dom Δ2 n → n # Δ1
      guts2 n dom2 with ctxindirect H1 n
      guts2 n dom2 | Inl x = abort (somenotnone (! (π2 x) · d2 n (de3 n dom2)))
      guts2 n dom2 | Inr x with ctxindirect Δ1 n
      guts2 n dom2 | Inr x₁ | Inl x = abort (somenotnone (! (π2 (de1 n x)) · x₁))
      guts2 n dom2 | Inr x₁ | Inr x = x

  dom-union : {A B : Set} {Δ1 Δ2 : A ctx} {H1 H2 : B ctx} →
                                     H1 ## H2 →
                                     dom-eq Δ1 H1 →
                                     dom-eq Δ2 H2 →
                                     dom-eq (Δ1 ∪ Δ2) (H1 ∪ H2)
  dom-union {A} {B} {Δ1} {Δ2} {H1} {H2} disj (p1 , p2) (p3 , p4) = guts1 , guts2
    where
      guts1 : (n : Nat) →
                 Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x) →
                 Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y)
      guts1 n (x , eq) with ctxindirect Δ1 n
      guts1 n (x₁ , eq) | Inl x with p1 n x
      ... | q1 , q2 = q1 , x∈∪l H1 H2 n q1 q2
      guts1 n (x₁ , eq) | Inr x with p3 n (_ , lem-dom-union-apt1 {Δ1 = Δ1} {Δ2 = Δ2} x eq)
      ... | q1 , q2 =  q1 , x∈∪r H1 H2 n q1 q2 (##-comm disj)

      guts2 : (n : Nat) →
                 Σ[ y ∈ B ] ((H1 ∪ H2) n == Some y) →
                 Σ[ x ∈ A ] ((Δ1 ∪ Δ2) n == Some x)
      guts2 n (x , eq) with ctxindirect H1 n
      guts2 n (x₁ , eq) | Inl x with p2 n x
      ... | q1 , q2 = q1 , x∈∪l Δ1 Δ2 n q1 q2
      guts2 n (x₁ , eq) | Inr x with p4 n (_ , lem-dom-union-apt2 {Δ1 = H2} {Δ2 = H1} x (tr (λ qq → qq n == Some x₁) (∪comm H1 H2 disj) eq))
      ... | q1 , q2 = q1 , x∈∪r Δ1 Δ2 n q1 q2 (##-comm (dom-eq-disj disj (p1 , p2) (p3 , p4)))

  -- the holes of an expression have the same domain as Δ; that is, we
  -- don't add any extra junk as we expand
  mutual
    holes-delta-ana : ∀{Γ H e τ d τ' Δ} →
                    holes e H →
                    Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                    dom-eq Δ H
    holes-delta-ana (HLam1 h) (EALam x₁ x₂ exp) = holes-delta-ana h exp
    holes-delta-ana h (EASubsume x x₁ x₂ x₃) = holes-delta-synth h x₂
    holes-delta-ana (HEHole {u = u}) EAEHole = dom-single u _ _
    holes-delta-ana (HNEHole {u = u} h) (EANEHole x x₁) = dom-union {!!} (holes-delta-synth h x₁) (dom-single u _ _ )

    holes-delta-synth : ∀{Γ H e τ d Δ} →
                    holes e H →
                    Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                    dom-eq Δ H
    holes-delta-synth HConst ESConst = dom-∅
    holes-delta-synth (HAsc h) (ESAsc x) = holes-delta-ana h x
    holes-delta-synth HVar (ESVar x₁) = dom-∅
    holes-delta-synth (HLam2 h) (ESLam x₁ exp) = holes-delta-synth h exp
    holes-delta-synth (HEHole {u = u}) ESEHole = dom-single u _ _
    holes-delta-synth (HNEHole {u = u} h) (ESNEHole x exp) = dom-union {!!} (holes-delta-synth h exp) (dom-single u _ _)
    holes-delta-synth (HAp h h₁) (ESAp x x₁ x₂ x₃ x₄ x₅) = dom-union {!!} (holes-delta-ana h x₄) (holes-delta-ana h₁ x₅)

  -- if a hole name is new then it's apart from the holes
  lem-apart-new : ∀{e H u} → holes e H → hole-name-new e u → u # H
  lem-apart-new HConst HNConst = refl
  lem-apart-new (HAsc h) (HNAsc hn) = lem-apart-new h hn
  lem-apart-new HVar HNVar = refl
  lem-apart-new (HLam1 h) (HNLam1 hn) = lem-apart-new h hn
  lem-apart-new (HLam2 h) (HNLam2 hn) = lem-apart-new h hn
  lem-apart-new HEHole (HNHole x) = apart-singleton (flip x)
  lem-apart-new (HNEHole {u = u'} {H = H} h) (HNNEHole  {u = u}  x hn) = apart-parts H (■ (u' , <>)) u (lem-apart-new h hn) (apart-singleton (flip x))
  lem-apart-new (HAp {H1 = H1} {H2 = H2} h h₁) (HNAp hn hn₁) = apart-parts H1 H2 _ (lem-apart-new h hn) (lem-apart-new h₁ hn₁)

  -- todo: lemmas file?
  lem-dom-apt : {A : Set} {G : A ctx} {x y : Nat} → x # G → dom G y → x ≠ y
  lem-dom-apt {x = x} {y = y} apt dom with natEQ x y
  lem-dom-apt apt dom | Inl refl = abort (somenotnone (! (π2 dom) · apt))
  lem-dom-apt apt dom | Inr x₁ = x₁

  -- if the holes of two expressions are disjoint, so are their collections
  -- of hole names
  holes-disjoint-disjoint : ∀{ e1 e2 H1 H2} →
                    holes e1 H1 →
                    holes e2 H2 →
                    holes-disjoint e1 e2 →
                    H1 ## H2
  holes-disjoint-disjoint HConst he2 HDConst = empty-disj _
  holes-disjoint-disjoint (HAsc he1) he2 (HDAsc hd) = holes-disjoint-disjoint he1 he2 hd
  holes-disjoint-disjoint HVar he2 HDVar = empty-disj _
  holes-disjoint-disjoint (HLam1 he1) he2 (HDLam1 hd) = holes-disjoint-disjoint he1 he2 hd
  holes-disjoint-disjoint (HLam2 he1) he2 (HDLam2 hd) = holes-disjoint-disjoint he1 he2 hd
  holes-disjoint-disjoint HEHole he2 (HDHole x) = lem-apart-sing-disj (lem-apart-new he2 x)
  holes-disjoint-disjoint (HNEHole he1) he2 (HDNEHole x hd) = disjoint-parts (holes-disjoint-disjoint he1 he2 hd) (lem-apart-sing-disj (lem-apart-new he2 x))
  holes-disjoint-disjoint (HAp he1 he2) he3 (HDAp hd hd₁) = disjoint-parts (holes-disjoint-disjoint he1 he3 hd) (holes-disjoint-disjoint he2 he3 hd₁)

  -- if two contexsts are disjoint and each share a domain with another
  -- context, those other two contexts are also disjoint
  domeq-disj : {A B : Set} {H1 H2 : A ctx} {Δ1 Δ2 : B ctx} →
               H1 ## H2 →
               dom-eq Δ1 H1 →
               dom-eq Δ2 H2 →
               Δ1 ## Δ2
  domeq-disj (π1 , π2) (π3 , π4) (π5 , π6) =
                   (λ n x → {!(π3 n x)!}) ,
                   (λ n x → {!!})

  -- if you expand two hole-disjoint expressions analytically, the Δs
  -- produces are disjoint
  expand-ana-disjoint : ∀{ e1 e2 τ1 τ2 e1' e2' τ1' τ2' Γ Δ1 Δ2 } →
          holes-disjoint e1 e2 →
          Γ ⊢ e1 ⇐ τ1 ~> e1' :: τ1' ⊣ Δ1 →
          Γ ⊢ e2 ⇐ τ2 ~> e2' :: τ2' ⊣ Δ2 →
          Δ1 ## Δ2
  expand-ana-disjoint {e1} {e2} hd ana1 ana2
    with find-holes e1 | find-holes e2
  ... | (_ , he1) | (_ , he2) = domeq-disj (holes-disjoint-disjoint he1 he2 hd)
                                           (holes-delta-ana he1 ana1)
                                           (holes-delta-ana he2 ana2)

  -- these lemmas are all structurally recursive and quite
  -- mechanical. morally, they establish the properties about reduction
  -- that would be obvious / baked into Agda if holes-disjoint was defined
  -- as a function rather than a judgement (datatype), or if we had defined
  -- all the O(n^2) cases rather than relying on a little indirection to
  -- only have O(n) cases. that work has to go somewhwere, and we prefer
  -- that it goes here.
  ds-lem-asc : ∀{e1 e2 τ} → holes-disjoint e2 e1 → holes-disjoint e2 (e1 ·: τ)
  ds-lem-asc HDConst = HDConst
  ds-lem-asc (HDAsc hd) = HDAsc (ds-lem-asc hd)
  ds-lem-asc HDVar = HDVar
  ds-lem-asc (HDLam1 hd) = HDLam1 (ds-lem-asc hd)
  ds-lem-asc (HDLam2 hd) = HDLam2 (ds-lem-asc hd)
  ds-lem-asc (HDHole x) = HDHole (HNAsc x)
  ds-lem-asc (HDNEHole x hd) = HDNEHole (HNAsc x) (ds-lem-asc hd)
  ds-lem-asc (HDAp hd hd₁) = HDAp (ds-lem-asc hd) (ds-lem-asc hd₁)

  ds-lem-lam1 : ∀{e1 e2 x} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x e1)
  ds-lem-lam1 HDConst = HDConst
  ds-lem-lam1 (HDAsc hd) = HDAsc (ds-lem-lam1 hd)
  ds-lem-lam1 HDVar = HDVar
  ds-lem-lam1 (HDLam1 hd) = HDLam1 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDLam2 hd) = HDLam2 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDHole x₁) = HDHole (HNLam1 x₁)
  ds-lem-lam1 (HDNEHole x₁ hd) = HDNEHole (HNLam1 x₁) (ds-lem-lam1 hd)
  ds-lem-lam1 (HDAp hd hd₁) = HDAp (ds-lem-lam1 hd) (ds-lem-lam1 hd₁)

  ds-lem-lam2 : ∀{e1 e2 x τ} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x [ τ ] e1)
  ds-lem-lam2 HDConst = HDConst
  ds-lem-lam2 (HDAsc hd) = HDAsc (ds-lem-lam2 hd)
  ds-lem-lam2 HDVar = HDVar
  ds-lem-lam2 (HDLam1 hd) = HDLam1 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDLam2 hd) = HDLam2 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDHole x₁) = HDHole (HNLam2 x₁)
  ds-lem-lam2 (HDNEHole x₁ hd) = HDNEHole (HNLam2 x₁) (ds-lem-lam2 hd)
  ds-lem-lam2 (HDAp hd hd₁) = HDAp (ds-lem-lam2 hd) (ds-lem-lam2 hd₁)

  ds-lem-nehole : ∀{e e1 u} → holes-disjoint e e1 → hole-name-new e u → holes-disjoint e ⦇ e1 ⦈[ u ]
  ds-lem-nehole HDConst ν = HDConst
  ds-lem-nehole (HDAsc hd) (HNAsc ν) = HDAsc (ds-lem-nehole hd ν)
  ds-lem-nehole HDVar ν = HDVar
  ds-lem-nehole (HDLam1 hd) (HNLam1 ν) = HDLam1 (ds-lem-nehole hd ν)
  ds-lem-nehole (HDLam2 hd) (HNLam2 ν) = HDLam2 (ds-lem-nehole hd ν)
  ds-lem-nehole (HDHole x) (HNHole x₁) = HDHole (HNNEHole (flip x₁) x)
  ds-lem-nehole (HDNEHole x hd) (HNNEHole x₁ ν) = HDNEHole (HNNEHole (flip x₁) x) (ds-lem-nehole hd ν)
  ds-lem-nehole (HDAp hd hd₁) (HNAp ν ν₁) = HDAp (ds-lem-nehole hd ν) (ds-lem-nehole hd₁ ν₁)

  ds-lem-ap : ∀{e1 e2 e3} → holes-disjoint e3 e1 → holes-disjoint e3 e2 → holes-disjoint e3 (e1 ∘ e2)
  ds-lem-ap HDConst hd2 = HDConst
  ds-lem-ap (HDAsc hd1) (HDAsc hd2) = HDAsc (ds-lem-ap hd1 hd2)
  ds-lem-ap HDVar hd2 = HDVar
  ds-lem-ap (HDLam1 hd1) (HDLam1 hd2) = HDLam1 (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDLam2 hd1) (HDLam2 hd2) = HDLam2 (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDHole x) (HDHole x₁) = HDHole (HNAp x x₁)
  ds-lem-ap (HDNEHole x hd1) (HDNEHole x₁ hd2) = HDNEHole (HNAp x x₁) (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDAp hd1 hd2) (HDAp hd3 hd4) = HDAp (ds-lem-ap hd1 hd3) (ds-lem-ap hd2 hd4)

  -- holes-disjoint is symmetric
  disjoint-sym : (e1 e2 : hexp) → holes-disjoint e1 e2 → holes-disjoint e2 e1
  disjoint-sym .c c HDConst = HDConst
  disjoint-sym .c (e2 ·: x) HDConst = HDAsc (disjoint-sym _ _ HDConst)
  disjoint-sym .c (X x) HDConst = HDVar
  disjoint-sym .c (·λ x e2) HDConst = HDLam1 (disjoint-sym c e2 HDConst)
  disjoint-sym .c (·λ x [ x₁ ] e2) HDConst = HDLam2 (disjoint-sym c e2 HDConst)
  disjoint-sym .c ⦇⦈[ x ] HDConst = HDHole HNConst
  disjoint-sym .c ⦇ e2 ⦈[ x ] HDConst = HDNEHole HNConst (disjoint-sym c e2 HDConst)
  disjoint-sym .c (e2 ∘ e3) HDConst = HDAp (disjoint-sym c e2 HDConst) (disjoint-sym c e3 HDConst)

  disjoint-sym _ c (HDAsc hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x) (HDAsc hd) | HDAsc ih = HDAsc (ds-lem-asc ih)
  disjoint-sym _ (X x) (HDAsc hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDAsc hd) | HDLam1 ih = HDLam1 (ds-lem-asc ih)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) | HDLam2 ih = HDLam2 (ds-lem-asc ih)
  disjoint-sym _ ⦇⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x ] (HDAsc hd) | HDHole x₁ = HDHole (HNAsc x₁)
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDAsc hd) | HDNEHole x₁ ih = HDNEHole (HNAsc x₁) (ds-lem-asc ih)
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) | HDAp ih ih₁ = HDAp (ds-lem-asc ih) (ds-lem-asc ih₁)

  disjoint-sym _ c HDVar = HDConst
  disjoint-sym _ (e2 ·: x₁) HDVar = HDAsc (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (X x₁) HDVar = HDVar
  disjoint-sym _ (·λ x₁ e2) HDVar = HDLam1 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) HDVar = HDLam2 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ ⦇⦈[ x₁ ] HDVar = HDHole HNVar
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] HDVar = HDNEHole HNVar (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (e2 ∘ e3) HDVar = HDAp (disjoint-sym _ e2 HDVar) (disjoint-sym _ e3 HDVar)

  disjoint-sym _ c (HDLam1 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) | HDAsc ih = HDAsc (ds-lem-lam1 ih)
  disjoint-sym _ (X x₁) (HDLam1 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) | HDLam1 ih = HDLam1 (ds-lem-lam1 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) | HDLam2 ih = HDLam2 (ds-lem-lam1 ih)
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam1 hd) | HDHole x = HDHole (HNLam1 x)
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam1 hd) | HDNEHole x ih = HDNEHole (HNLam1 x) (ds-lem-lam1 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam1 ih) (ds-lem-lam1 ih₁)

  disjoint-sym _ c (HDLam2 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) | HDAsc ih = HDAsc (ds-lem-lam2 ih)
  disjoint-sym _ (X x₁) (HDLam2 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) | HDLam1 ih = HDLam1 (ds-lem-lam2 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) | HDLam2 ih = HDLam2 (ds-lem-lam2 ih)
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x₁ ] (HDLam2 hd) | HDHole x = HDHole (HNLam2 x)
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x₁ ] (HDLam2 hd) | HDNEHole x ih = HDNEHole (HNLam2 x) (ds-lem-lam2 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam2 ih) (ds-lem-lam2 ih₁)

  disjoint-sym _ c (HDHole x) = HDConst
  disjoint-sym _ (e2 ·: x) (HDHole (HNAsc x₁)) = HDAsc (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (X x) (HDHole x₁) = HDVar
  disjoint-sym _ (·λ x e2) (HDHole (HNLam1 x₁)) = HDLam1 (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDHole (HNLam2 x₂)) = HDLam2 (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₂))
  disjoint-sym _ ⦇⦈[ x ] (HDHole (HNHole x₁)) =  HDHole (HNHole (flip x₁))
  disjoint-sym _ ⦇ e2 ⦈[ u' ] (HDHole (HNNEHole x x₁)) = HDNEHole (HNHole (flip x)) (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (e2 ∘ e3) (HDHole (HNAp x x₁)) = HDAp (disjoint-sym ⦇⦈[ _ ] e2 (HDHole x))
                                                    (disjoint-sym ⦇⦈[ _ ] e3 (HDHole x₁))

  disjoint-sym _ c (HDNEHole x hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e ·: x) (HDNEHole (HNAsc x₁) hd) | HDAsc ih = HDAsc (ds-lem-nehole ih x₁)
  disjoint-sym _ (X x) (HDNEHole x₁ hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDNEHole (HNLam1 x₁) hd) | HDLam1 ih = HDLam1 (ds-lem-nehole ih x₁)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole x₂ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole (HNLam2 x₂) hd) | HDLam2 ih = HDLam2 (ds-lem-nehole ih x₂)
  disjoint-sym _ ⦇⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⦈[ x ] (HDNEHole (HNHole x₂) hd) | HDHole x₁ = HDHole (HNNEHole (flip x₂) x₁)
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇ e2 ⦈[ x ] (HDNEHole (HNNEHole x₂ x₃) hd) | HDNEHole x₁ ih = HDNEHole (HNNEHole (flip x₂) x₁) (ds-lem-nehole ih x₃)
  disjoint-sym _ (e2 ∘ e3) (HDNEHole x hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e1 ∘ e3) (HDNEHole (HNAp x x₁) hd) | HDAp ih ih₁ = HDAp (ds-lem-nehole ih x) (ds-lem-nehole ih₁ x₁)

  disjoint-sym _ c (HDAp hd hd₁) = HDConst
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) | HDAsc ih | HDAsc ih1 = HDAsc (ds-lem-ap ih ih1)
  disjoint-sym _ (X x) (HDAp hd hd₁) = HDVar
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) | HDLam1 ih | HDLam1 ih1 = HDLam1 (ds-lem-ap ih ih1)
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) | HDLam2 ih | HDLam2 ih1 = HDLam2 (ds-lem-ap ih ih1)
  disjoint-sym _ ⦇⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ ⦇⦈[ x ] (HDAp hd hd₁) | HDHole x₁ | HDHole x₂ = HDHole (HNAp x₁ x₂)
  disjoint-sym _ ⦇ e3 ⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ ⦇ e3 ⦈[ x ] (HDAp hd hd₁) | HDNEHole x₁ ih | HDNEHole x₂ ih1 = HDNEHole (HNAp x₁ x₂) (ds-lem-ap ih ih1)
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) | HDAp ih ih₁ | HDAp ih1 ih2 = HDAp (ds-lem-ap ih ih1) (ds-lem-ap ih₁ ih2)

  -- note that this is false, so holes-disjoint isn't transitive
  -- disjoint-new : ∀{e1 e2 u} → holes-disjoint e1 e2 → hole-name-new e1 u → hole-name-new e2 u

  -- it's also not reflexive, because ⦇⦈[ u ] isn't hole-disjoint with
  -- itself since refl : u == u; it's also not anti-reflexive, because the
  -- expression c *is* hole-disjoint with itself (albeit vacuously)


Use shorter name for accent constructors.

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
  acute : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  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

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

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

η-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-υ ()

ι-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 acute = acute-mark
letter-to-accent 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} → ⦃ 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