scraps towards #14

scraps towards #14

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

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

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter (CECong eps er)) = {!!}
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong x₁ er) = {!!}
  ve (BVVal x) (CECong x₁ er) = ve (lem-valfill x x₁) er
    where
    lem-valfill : ∀{ε d d'} → d val → d == ε ⟦ d' ⟧ → d' boxedval
    lem-valfill VConst FHOuter = BVVal VConst
    lem-valfill VLam FHOuter = BVVal VLam

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

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

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

    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err
    ie (INEHole x) (CECong FHOuter err) = fe x (lem err)
      where
      lem : ∀{d u σ} → ⦇ d ⦈⟨ u , σ ⟩ casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHNEHole x₁) ce) = CECong x₁ ce
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err)
      with lem err
      where
      lem : ∀{d1 d2} → (d1 ∘ d2) casterr → (d1 casterr + d2 casterr)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHAp1 x₂) ce) = Inl (CECong x₂ ce)
      lem (CECong (FHAp2 x₂ x₃) ce) = Inr (CECong x₃ ce)
    ... | Inl d1err = ie indet d1err
    ... | Inr d2err = fe x₁ d2err
      where
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ1 τ2 τ3 τ4} → (d ⟨ τ1 ==> τ2 ⇒ τ3 ==> τ4 ⟩) casterr → d casterr
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ τ ⇒ ⦇⦈ ⟩) casterr → d casterr
      lem (CECastFail x₁ x₂ () x₄)
      lem (CECong FHOuter ce) = lem ce
      lem (CECong (FHCast x₁) ce) = CECong x₁ ce
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = ie indet (lem err)
      where
      lem : ∀{d τ} → (d ⟨ ⦇⦈ ⇒ τ ⟩) casterr → d casterr
      lem (CECastFail x₂ x₃ x₄ x₅) = {!!}
      lem (CECong x₂ ce) = {!!}
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

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

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

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

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

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

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

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

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

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es er stp = {!!}

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

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

  -- boxed values and errors are disjoint
  ve : ∀{d} → d boxedval → d casterr → ⊥
  ve (BVVal ()) (CECastFail x₁ x₂ x₃ x₄)
  ve (BVHoleCast x bv) (CECastFail x₁ x₂ () x₄)
  ve (BVArrCast x bv) (CECong FHOuter (CECong eps er)) = {!!}
  ve (BVArrCast x bv) (CECong (FHCast x₁) er) = ve bv (CECong x₁ er)
  ve (BVHoleCast x bv) (CECong x₁ er) = {!!}
  ve (BVVal x) (CECong x₁ er) = ve (lem-valfill x x₁) er
    where
    lem-valfill : ∀{ε d d'} → d val → d == ε ⟦ d' ⟧ → d' boxedval
    lem-valfill VConst FHOuter = BVVal VConst
    lem-valfill VLam FHOuter = BVVal VLam

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

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

  mutual
    -- indeterminates and errors are disjoint
    ie : ∀{d} → d indet → d casterr → ⊥
    ie IEHole (CECong FHOuter err) = ie IEHole err -- this feels extremely strange
    ie (INEHole x) (CECong FHOuter err) = {!!}
    ie (INEHole x) (CECong (FHNEHole x₁) err) = fe x (CECong x₁ err)
    ie (IAp x indet x₁) (CECong FHOuter err) = {!!}
    ie (IAp x indet x₁) (CECong (FHAp1 x₂) err) = ie indet (CECong x₂ err)
    ie (IAp x indet x₁) (CECong (FHAp2 x₂ x₃) err) = fe x₁ (CECong x₃ err)
    ie (ICastArr x indet) (CECong FHOuter err) = {!!}
    ie (ICastArr x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastGroundHole x indet) (CECastFail x₁ x₂ () x₄)
    ie (ICastGroundHole x indet) (CECong FHOuter err) = {!!}
    ie (ICastGroundHole x indet) (CECong (FHCast x₁) err) = ie indet (CECong x₁ err)
    ie (ICastHoleGround x indet x₁) (CECastFail x₂ x₃ x₄ x₅) = x _ _ refl
    ie (ICastHoleGround x indet x₁) (CECong FHOuter err) = {!!}
    ie (ICastHoleGround x indet x₁) (CECong (FHCast x₂) err) = ie indet (CECong x₂ err)

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

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

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

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

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

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

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

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

  -- errors and expressions that step are disjoint
  es : ∀{d} → d casterr → (Σ[ d' ∈ dhexp ] (d ↦ d')) → ⊥
  es er stp = {!!}


Make some arguments of validVar explicit.

Old-commit-hash: dc6d178e02b8bdd4f772dddbba1bf337f3b1d74c

module Denotation.Specification.Canon-Popl14 where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality
⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (dρ : ΔEnv Γ) → Change τ

-- better name is: ⟦_⟧Δ reacts to future arguments
validity : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ) →
  valid {τ} (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)

-- better name is: ⟦_⟧Δ reacts to free variables
correctness : ∀ {τ Γ} {t : Term Γ τ} {dρ : ΔEnv Γ}
  → ⟦ t ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ ≡ ⟦ t ⟧ (update dρ)

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → ΔEnv Γ → Change τ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] • dρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] • dρ) = ⟦ x ⟧ΔVar dρ

⟦_⟧Δ (intlit n) dρ = + 0
⟦_⟧Δ (add s t) dρ = ⟦ s ⟧Δ dρ + ⟦ t ⟧Δ dρ
⟦_⟧Δ (minus t) dρ = - ⟦ t ⟧Δ dρ
⟦_⟧Δ empty dρ = emptyBag
⟦_⟧Δ (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) dρ = ⟦ s ⟧Δ dρ ++ ⟦ t ⟧Δ dρ
⟦_⟧Δ (negate t) dρ = negateBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) dρ = sumBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (var x) dρ = ⟦ x ⟧ΔVar dρ
⟦_⟧Δ (app {σ} {τ} s t) dρ =
     (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)
  (validity {σ} t dρ))
⟦_⟧Δ (abs t) dρ = λ v →
  ⟦ t ⟧Δ (v • dρ)

validVar : ∀ {τ Γ} (x : Var Γ τ) →
  (dρ : ΔEnv Γ) → valid {τ} (⟦ x ⟧ (ignore dρ)) (⟦ x ⟧ΔVar dρ)
validVar this (cons v Δv R[v,Δv] • _) = R[v,Δv]
validVar {τ} (that x) (cons _ _ _ • dρ) = validVar {τ} x dρ

validity (intlit n)    dρ = tt
validity (add s t)     dρ = tt
validity (minus t)     dρ = tt
validity (empty)       dρ = tt
validity (insert s t)  dρ = tt
validity (union s t)   dρ = tt
validity (negate t)    dρ = tt
validity (flatmap s t) dρ = tt
validity (sum t)       dρ = tt

validity {τ} (var x) dρ = validVar {τ} x dρ

validity (app s t) dρ =
  let
    v = ⟦ t ⟧ (ignore dρ)
    Δv = ⟦ t ⟧Δ dρ
  in
    proj₁ (validity s dρ (cons v Δv (validity t dρ)))

validity {σ ⇒ τ} (abs t) dρ = λ v →
  let
    v′ = after {σ} v
    Δv′ = v′ ⊟₍ σ ₎ v′
    dρ₁ = v • dρ
    dρ₂ = nil-valid-change σ v′ • dρ
  in
    validity t dρ₁
    ,
    (begin
      ⟦ t ⟧ (ignore dρ₂) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₂
    ≡⟨ correctness {t = t} {dρ₂} ⟩
      ⟦ t ⟧ (update dρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (update dρ₁)
    ≡⟨ sym (correctness {t = t} {dρ₁}) ⟩
      ⟦ t ⟧ (ignore dρ₁) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {dρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ x ⟧ΔVar dρ ≡ ⟦ x ⟧ (update dρ)
correctVar {x = this  } {cons v dv R[v,dv] • dρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] • dρ} = correctVar {x = y} {dρ}

correctness {t = intlit n} = right-id-int n
correctness {t = add s t} {dρ} = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _+_ (correctness {t = s}) (correctness {t = t}))
correctness {t = minus t} {dρ} = trans
  (-m·-n=-mn {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong -_ (correctness {t = t}))

correctness {t = empty} = right-id-bag emptyBag
correctness {t = insert s t} {dρ} =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness {t = s}))
         (correctness {t = t}) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness {t = union s t} {dρ} = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _++_ (correctness {t = s}) (correctness {t = t}))
correctness {t = negate t} {dρ} = trans
  (-a·-b=-ab {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong negateBag (correctness {t = t}))

correctness {t = flatmap s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness {t = s}) (correctness {t = t}))
correctness {t = sum t} {dρ} =
  let
    b = ⟦ t ⟧ (ignore dρ)
    Δb = ⟦ t ⟧Δ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness {t = t}))

correctness {τ} {t = var x} = correctVar {τ} {x = x}
correctness {t = app {σ} {τ} s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ (ignore dρ)
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δu = ⟦ t ⟧Δ dρ
  in
    begin
      f u ⊞₍ τ ₎ Δf (cons u Δu (validity {σ} t dρ))
    ≡⟨ sym (proj₂ (validity {σ ⇒ τ} s dρ (cons u Δu (validity {σ} t dρ)))) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} {t = s} ⟨$⟩ correctness {σ} {t = t} ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} {abs t} {dρ} = ext (λ v →
  let
    dρ′ : ΔEnv (σ • Γ)
    dρ′ = nil-valid-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ′
    ≡⟨ correctness {τ} {t = t} {dρ′} ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv
corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {dρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore dρ) ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ dρ)
      (⟦ t ⟧ (ignore dρ) ⊞₍ σ ₎ ⟦ t ⟧Δ dρ)
  ≡ (⟦ s ⟧ (ignore dρ)) (⟦ t ⟧ (ignore dρ))
    ⊞₍ τ ₎
    (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ) (validity {σ} t dρ))

corollary {σ} {τ} s t {dρ} = proj₂
  (validity {σ ⇒ τ} s dρ (cons (⟦ t ⟧ (ignore dρ))
     (⟦ t ⟧Δ dρ) (validity {σ} t dρ)))

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  (v : ValidChange σ)
  → ⟦ t ⟧ ∅ (after {σ} v)
  ≡ ⟦ t ⟧ ∅ (before {σ} v) ⊞₍ τ ₎ ⟦ t ⟧Δ ∅ v

corollary-closed {σ} {τ} {t = t} v =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅
  in
    begin
      f (after {σ} v)
    ≡⟨ cong (λ hole → hole (after {σ} v))
            (sym (correctness {σ ⇒ τ} {t = t})) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} v)
    ≡⟨ proj₂ (validity {σ ⇒ τ} t ∅ v) ⟩
      f (before {σ} v) ⊞₍ τ ₎ Δf v
    ∎ where open ≡-Reasoning

module Denotation.Specification.Canon-Popl14 where

-- Denotation-as-specification for Calculus Popl14
--
-- Contents
-- - ⟦_⟧Δ : binding-time-shifted derive
-- - Validity and correctness lemmas for ⟦_⟧Δ
-- - `corollary`: ⟦_⟧Δ reacts to both environment and arguments
-- - `corollary-closed`: binding-time-shifted main theorem

open import Popl14.Syntax.Term
open import Popl14.Denotation.Value
open import Popl14.Change.Validity
open import Popl14.Denotation.Evaluation public

open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Product
open import Data.Integer
open import Structure.Bag.Popl14
open import Theorem.Groups-Popl14
open import Theorem.CongApp
open import Postulate.Extensionality
⟦_⟧Δ : ∀ {τ Γ} → (t : Term Γ τ) (dρ : ΔEnv Γ) → Change τ

-- better name is: ⟦_⟧Δ reacts to future arguments
validity : ∀ {τ Γ} (t : Term Γ τ) (dρ : ΔEnv Γ) →
  valid {τ} (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)

-- better name is: ⟦_⟧Δ reacts to free variables
correctness : ∀ {τ Γ} {t : Term Γ τ} {dρ : ΔEnv Γ}
  → ⟦ t ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ ≡ ⟦ t ⟧ (update dρ)

⟦_⟧ΔVar : ∀ {τ Γ} → Var Γ τ → ΔEnv Γ → Change τ
⟦ this   ⟧ΔVar (cons v dv R[v,dv] • dρ) = dv
⟦ that x ⟧ΔVar (cons v dv R[v,dv] • dρ) = ⟦ x ⟧ΔVar dρ

⟦_⟧Δ (intlit n) dρ = + 0
⟦_⟧Δ (add s t) dρ = ⟦ s ⟧Δ dρ + ⟦ t ⟧Δ dρ
⟦_⟧Δ (minus t) dρ = - ⟦ t ⟧Δ dρ
⟦_⟧Δ empty dρ = emptyBag
⟦_⟧Δ (insert s t) dρ =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    (singletonBag (n ⊞₍ int ₎ Δn) ++ (b ⊞₍ bag ₎ Δb)) ⊟₍ bag ₎ (singletonBag n ++ b)
⟦_⟧Δ (union s t) dρ = ⟦ s ⟧Δ dρ ++ ⟦ t ⟧Δ dρ
⟦_⟧Δ (negate t) dρ = negateBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (flatmap s t) dρ =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    flatmapBag (f ⊞₍ int ⇒ bag ₎ Δf) (b ⊞₍ bag ₎ Δb) ⊟₍ bag ₎ flatmapBag f b
⟦_⟧Δ (sum t) dρ = sumBag (⟦ t ⟧Δ dρ)
⟦_⟧Δ (var x) dρ = ⟦ x ⟧ΔVar dρ
⟦_⟧Δ (app {σ} {τ} s t) dρ =
     (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ)
  (validity {σ} t dρ))
⟦_⟧Δ (abs t) dρ = λ v →
  ⟦ t ⟧Δ (v • dρ)

validVar : ∀ {τ Γ} (x : Var Γ τ) →
  ∀ {dρ : ΔEnv Γ} → valid {τ} (⟦ x ⟧ (ignore dρ)) (⟦ x ⟧ΔVar dρ)
validVar this {cons v Δv R[v,Δv] • _} = R[v,Δv]
validVar {τ} (that x) {cons _ _ _ • dρ} = validVar {τ} x

validity (intlit n)    dρ = tt
validity (add s t)     dρ = tt
validity (minus t)     dρ = tt
validity (empty)       dρ = tt
validity (insert s t)  dρ = tt
validity (union s t)   dρ = tt
validity (negate t)    dρ = tt
validity (flatmap s t) dρ = tt
validity (sum t)       dρ = tt

validity {τ} (var x) dρ = validVar {τ} x

validity (app s t) dρ =
  let
    v = ⟦ t ⟧ (ignore dρ)
    Δv = ⟦ t ⟧Δ dρ
  in
    proj₁ (validity s dρ (cons v Δv (validity t dρ)))

validity {σ ⇒ τ} (abs t) dρ = λ v →
  let
    v′ = after {σ} v
    Δv′ = v′ ⊟₍ σ ₎ v′
    dρ₁ = v • dρ
    dρ₂ = nil-valid-change σ v′ • dρ
  in
    validity t dρ₁
    ,
    (begin
      ⟦ t ⟧ (ignore dρ₂) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₂
    ≡⟨ correctness {t = t} {dρ₂} ⟩
      ⟦ t ⟧ (update dρ₂)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (update dρ₁)
    ≡⟨ sym (correctness {t = t} {dρ₁}) ⟩
      ⟦ t ⟧ (ignore dρ₁) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ₁
    ∎) where open ≡-Reasoning

correctVar : ∀ {τ Γ} {x : Var Γ τ} {dρ : ΔEnv Γ} →
  ⟦ x ⟧ (ignore dρ) ⊞₍ τ ₎ ⟦ x ⟧ΔVar dρ ≡ ⟦ x ⟧ (update dρ)
correctVar {x = this  } {cons v dv R[v,dv] • dρ} = refl
correctVar {x = that y} {cons v dv R[v,dv] • dρ} = correctVar {x = y} {dρ}

correctness {t = intlit n} = right-id-int n
correctness {t = add s t} {dρ} = trans
  (mn·pq=mp·nq
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _+_ (correctness {t = s}) (correctness {t = t}))
correctness {t = minus t} {dρ} = trans
  (-m·-n=-mn {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong -_ (correctness {t = t}))

correctness {t = empty} = right-id-bag emptyBag
correctness {t = insert s t} {dρ} =
  let
    n = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    n′ = ⟦ s ⟧ (update dρ)
    b′ = ⟦ t ⟧ (update dρ)
    Δn = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in
    begin
      (singletonBag n ++ b) ++
         (singletonBag (n ⊞₍ base base-int ₎ Δn) ++
           (b ⊞₍ base base-bag ₎ Δb)) \\ (singletonBag n ++ b)
    ≡⟨ a++[b\\a]=b ⟩
      singletonBag (n ⊞₍ base base-int ₎ Δn) ++
        (b ⊞₍ base base-bag ₎ Δb)
    ≡⟨ cong₂ _++_
         (cong singletonBag (correctness {t = s}))
         (correctness {t = t}) ⟩
      singletonBag n′ ++ b′
    ∎ where open ≡-Reasoning
correctness {t = union s t} {dρ} = trans
  (ab·cd=ac·bd
    {⟦ s ⟧ (ignore dρ)} {⟦ t ⟧ (ignore dρ)} {⟦ s ⟧Δ dρ} {⟦ t ⟧Δ dρ})
  (cong₂ _++_ (correctness {t = s}) (correctness {t = t}))
correctness {t = negate t} {dρ} = trans
  (-a·-b=-ab {⟦ t ⟧ (ignore dρ)} {⟦ t ⟧Δ dρ})
  (cong negateBag (correctness {t = t}))

correctness {t = flatmap s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    b = ⟦ t ⟧ (ignore dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δb = ⟦ t ⟧Δ dρ
  in trans
      (a++[b\\a]=b {flatmapBag f b}
        {flatmapBag (f ⊞₍ base base-int ⇒ base base-bag ₎ Δf)
                    (b ⊞₍ base base-bag ₎ Δb)})
      (cong₂ flatmapBag (correctness {t = s}) (correctness {t = t}))
correctness {t = sum t} {dρ} =
  let
    b = ⟦ t ⟧ (ignore dρ)
    Δb = ⟦ t ⟧Δ dρ
  in
    trans (sym homo-sum) (cong sumBag (correctness {t = t}))

correctness {τ} {t = var x} = correctVar {τ} {x = x}
correctness {t = app {σ} {τ} s t} {dρ} =
  let
    f = ⟦ s ⟧ (ignore dρ)
    g = ⟦ s ⟧ (update dρ)
    u = ⟦ t ⟧ (ignore dρ)
    v = ⟦ t ⟧ (update dρ)
    Δf = ⟦ s ⟧Δ dρ
    Δu = ⟦ t ⟧Δ dρ
  in
    begin
      f u ⊞₍ τ ₎ Δf (cons u Δu (validity {σ} t dρ))
    ≡⟨ sym (proj₂ (validity {σ ⇒ τ} s dρ (cons u Δu (validity {σ} t dρ)))) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (u ⊞₍ σ ₎ Δu)
    ≡⟨ correctness {σ ⇒ τ} {t = s} ⟨$⟩ correctness {σ} {t = t} ⟩
      g v
    ∎ where open ≡-Reasoning
correctness {σ ⇒ τ} {Γ} {abs t} {dρ} = ext (λ v →
  let
    dρ′ : ΔEnv (σ • Γ)
    dρ′ = nil-valid-change σ v • dρ
  in
    begin
      ⟦ t ⟧ (ignore dρ′) ⊞₍ τ ₎ ⟦ t ⟧Δ dρ′
    ≡⟨ correctness {τ} {t = t} {dρ′} ⟩
      ⟦ t ⟧ (update dρ′)
    ≡⟨ cong (λ hole → ⟦ t ⟧ (hole • update dρ)) (v+[u-v]=u {σ}) ⟩
      ⟦ t ⟧ (v • update dρ)
    ∎
  ) where open ≡-Reasoning

-- Corollary: (f ⊞ df) (v ⊞ dv) = f v ⊞ df v dv
corollary : ∀ {σ τ Γ}
  (s : Term Γ (σ ⇒ τ)) (t : Term Γ σ) {dρ : ΔEnv Γ} →
    (⟦ s ⟧ (ignore dρ) ⊞₍ σ ⇒ τ ₎ ⟦ s ⟧Δ dρ)
      (⟦ t ⟧ (ignore dρ) ⊞₍ σ ₎ ⟦ t ⟧Δ dρ)
  ≡ (⟦ s ⟧ (ignore dρ)) (⟦ t ⟧ (ignore dρ))
    ⊞₍ τ ₎
    (⟦ s ⟧Δ dρ) (cons (⟦ t ⟧ (ignore dρ)) (⟦ t ⟧Δ dρ) (validity {σ} t dρ))

corollary {σ} {τ} s t {dρ} = proj₂
  (validity {σ ⇒ τ} s dρ (cons (⟦ t ⟧ (ignore dρ))
     (⟦ t ⟧Δ dρ) (validity {σ} t dρ)))

corollary-closed : ∀ {σ τ} {t : Term ∅ (σ ⇒ τ)}
  (v : ValidChange σ)
  → ⟦ t ⟧ ∅ (after {σ} v)
  ≡ ⟦ t ⟧ ∅ (before {σ} v) ⊞₍ τ ₎ ⟦ t ⟧Δ ∅ v

corollary-closed {σ} {τ} {t = t} v =
  let
    f  = ⟦ t ⟧ ∅
    Δf = ⟦ t ⟧Δ ∅
  in
    begin
      f (after {σ} v)
    ≡⟨ cong (λ hole → hole (after {σ} v))
            (sym (correctness {σ ⇒ τ} {t = t})) ⟩
      (f ⊞₍ σ ⇒ τ ₎ Δf) (after {σ} v)
    ≡⟨ proj₂ (validity {σ ⇒ τ} t ∅ v) ⟩
      f (before {σ} v) ⊞₍ τ ₎ Δf v
    ∎ where open ≡-Reasoning


Use instance arguments for breathing.

Use instance arguments for breathing.

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 _with-rough : Letter → Set where
  add-rough-vowel : ∀ {v} → ⦃ p : v vowel ⦄ → v with-rough
  add-rough-ρ : ρ′ with-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
  smooth : ∀ {ℓ c} → ⦃ p : ℓ ⟦ c ⟧-smooth ⦄ → ℓ ⟦ c ⟧-breathing
  rough : ∀ {ℓ c} → ⦃ p : ℓ with-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
  circumflex : ∀ {ℓ} → ⦃ p : ℓ 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 ())))

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

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

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

instance α-rough : α′ with-rough
α-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

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

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

instance ε-rough : ε′ with-rough
ε-rough = add-rough-vowel

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

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

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

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

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

instance η-rough : η′ with-rough
η-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 ())))

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

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

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

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

instance ι-rough : ι′ with-rough
ι-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 circumflex = 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 smooth = smooth-mark
letter-to-breathing rough = 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
  acute : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  grave : ∀ {ℓ} → ⦃ p : ℓ vowel ⦄ → ℓ accent
  circumflex : ∀ {ℓ} → ⦃ p : ℓ 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 ())))

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

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

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

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

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

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

ι-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 circumflex = 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


Data.Indexed

Data.Indexed

open import Type            hiding (★)
open import Level           using (_⊔_; suc; Level)
open import Function.NP     using (id; const; _∘_; _∘′_; _ˢ_; _⟨_⟩°_)
open import Data.Sum        using (_⊎_; inj₁; inj₂)
open import Data.Bool       using (Bool; true; false)
open import Data.Unit       using (⊤)
open import Data.List       using (List; []; _∷_)
open import Data.Maybe      using (Maybe; nothing; just)
open import Data.Empty      using (⊥)
open import Data.Product.NP using (∃; _,_; _×_)

module Data.Indexed {i} {Ix : ★ i} where

★° : ∀ ℓ → ★ _
★° ℓ = Ix → ★ ℓ

★₀° : ★ _
★₀° = Ix → ★₀

★₁° : ★ _
★₁° = Ix → ★₂

∀° : ∀ {f} (F : ★° f) → ★ _
∀° F = ∀ {x} → F x

∃° : ∀ {f} (F : ★° f) → ★ _
∃° F = ∃[ x ] F x

pure° : ∀ {a} {A : ★ a} → A → (Ix → A)
pure° = const

-- an alias for pure°
K° : ∀ {a} (A : ★ a) → ★° _
K° = pure°

Cmp° : (F : ★° _) (i j : Ix) → ★₀
Cmp° F i j = F i → F j → Bool

Π° : ∀ {f g} (F : ★° f) (G : ∀ {i} → F i → ★° g) → ★° _
Π° F G i = (x : F i) → G x i

-- this version used to work (type-checking its uses) better than that
infixr 0 _→°_
_→°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° (f ⊔ g)
F →° G = Π° F (const G)
-- expanded: (F →° G) i = F i → G i

infixr 0 _↦°_
_↦°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★ _
(F ↦° G) = ∀°(F →° G)

id° : ∀ {f} {F : ★° f} → F ↦° F
id° = id

_∘°_ : ∀ {f g h} {F : ★° f} {G : ★° g} {H : ★° h} → G ↦° H → F ↦° G → F ↦° H
f ∘° g = f ∘ g

infixr 0 _$°_ _$°′_

_$°_ : ∀ {f g} {F : ★° f} {G : ∀ {i} → F i → ★° g}
        → Π° F G ↦° Π° F G
_$°_ = id

_$°′_ : ∀ {f g} {F : ★° f} {G : ★° g}
        → ∀° ((F →° G) →° F →° G)
_$°′_ = id

infixl 4 _⊛°_

_⊛°_ : ∀ {a b} {A : ★ a} {B : ★ b}
         → (Ix → A → B) → ((Ix → A) → (Ix → B))
_⊛°_ = _ˢ_

liftA° : ∀ {a b} {A : ★ a} {B : ★ b}
          → (A → B) → ((Ix → A) → (Ix → B))
liftA° = _∘′_
-- liftA° f x = pure° f ⊛° x

liftA₂° : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
           → (A → B → C)
           → ((Ix → A) → (Ix → B) → (Ix → C))
liftA₂° f x y = x ⟨ f ⟩° y
-- liftA₂° f x y = pure° f ⊛° x ⊛° y

List° : ∀ {a} → ★° a → ★° a
List° = liftA° List

[]° : ∀ {f} {F : ★° f} → ∀°(List° F)
[]° = []

_∷°_ : ∀ {f} {F : ★° f} → ∀°(F →° List° F →° List° F)
_∷°_ = _∷_

Maybe° : ∀ {a} → ★° a → ★° a
Maybe° = liftA° Maybe

nothing° : ∀ {f} {F : ★° f} → ∀°(Maybe° F)
nothing° = nothing

just° : ∀ {f} {F : ★° f} → ∀°(F →° Maybe° F)
just° = just

infixr 2 _×°_
_×°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° _
_×°_ = liftA₂° _×_

_,°_ : ∀ {f g} {F : ★° f} {G : ★° g} → ∀° (F →° G →° F ×° G)
_,°_ = _,_

pack° : ∀ {f} {F : ★° f} → (x : Ix) → F x → ∃° F
pack° = _,_

infixr 1 _⊎°_

_⊎°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° _
_⊎°_ = liftA₂° _⊎_

inj₁° : ∀ {f g} {F : ★° f} {G : ★° g} → F ↦° F ⊎° G
inj₁° = inj₁

inj₂° : ∀ {f g} {F : ★° f} {G : ★° g} → G ↦° F ⊎° G
inj₂° = inj₂

⊤° : ★° _
⊤° = pure° ⊤

⊥° : ★° _
⊥° = pure° ⊥

¬° : ∀ {ℓ} → ★° ℓ → ★° _
¬° F = F →° ⊥°

-- This is the type of |map| functions, the fmap function on Ix-indexed
-- functors.
Map° : ∀ {a a' b b'} (F : ★° a → ★° a')
                     (G : ★° b → ★° b') → ★ _
Map° F G = ∀ {A B} → (A ↦° B) → F A ↦° G B

map°-K° : ∀ {a a' b b'}
            {F : ★ a → ★ a'}
            {G : ★ b → ★ b'}
            (fmap : ∀ {A B} → (A → B) → F A → G B)
            {A B} → (K° A ↦° K° B) → K° (F A) ↦° K° (G B)
map°-K° fmap f {i} = fmap (f {i})

open import Type            hiding (★)
open import Level           using (_⊔_; suc; Level)
open import Function.NP     using (id; const; _∘_; _∘′_; _ˢ_; _⟨_⟩°_)
open import Data.Sum        using (_⊎_; inj₁; inj₂)
open import Data.Bool       using (Bool; true; false)
open import Data.Unit       using (⊤)
open import Data.List       using (List; []; _∷_)
open import Data.Maybe      using (Maybe; nothing; just)
open import Data.Empty      using (⊥)
open import Data.Product.NP using (∃; _,_; _×_)

module Data.Indexed {i} {Ix : ★ i} where

★° : ∀ ℓ → ★ _
★° ℓ = Ix → ★ ℓ

★₀° : ★ _
★₀° = Ix → ★

★₁° : ★ _
★₁° = Ix → ★₂

∀° : ∀ {f} (F : ★° f) → ★ _
∀° F = ∀ {x} → F x

∃° : ∀ {f} (F : ★° f) → ★ _
∃° F = ∃[ x ] F x

pure° : ∀ {a} {A : ★ a} → A → (Ix → A)
pure° = const

-- an alias for pure°
K° : ∀ {a} (A : ★ a) → ★° _
K° = pure°

Cmp° : (F : ★° _) (i j : Ix) → ★₀
Cmp° F i j = F i → F j → Bool

Π° : ∀ {f g} (F : ★° f) (G : ∀ {i} → F i → ★° g) → ★° _
Π° F G i = (x : F i) → G x i

-- this version used to work (type-checking its uses) better than that
infixr 0 _→°_
_→°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° (f ⊔ g)
F →° G = Π° F (const G)
-- expanded: (F →° G) i = F i → G i

infixr 0 _↦°_
_↦°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★ _
(F ↦° G) = ∀°(F →° G)

id° : ∀ {f} {F : ★° f} → F ↦° F
id° = id

_∘°_ : ∀ {f g h} {F : ★° f} {G : ★° g} {H : ★° h} → G ↦° H → F ↦° G → F ↦° H
f ∘° g = f ∘ g

infixr 0 _$°_ _$°′_

_$°_ : ∀ {f g} {F : ★° f} {G : ∀ {i} → F i → ★° g}
        → Π° F G ↦° Π° F G
_$°_ = id

_$°′_ : ∀ {f g} {F : ★° f} {G : ★° g}
        → ∀° ((F →° G) →° F →° G)
_$°′_ = id

infixl 4 _⊛°_

_⊛°_ : ∀ {a b} {A : ★ a} {B : ★ b}
         → (Ix → A → B) → ((Ix → A) → (Ix → B))
_⊛°_ = _ˢ_

liftA° : ∀ {a b} {A : ★ a} {B : ★ b}
          → (A → B) → ((Ix → A) → (Ix → B))
liftA° = _∘′_
-- liftA° f x = pure° f ⊛° x

liftA₂° : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c}
           → (A → B → C)
           → ((Ix → A) → (Ix → B) → (Ix → C))
liftA₂° f x y = x ⟨ f ⟩° y
-- liftA₂° f x y = pure° f ⊛° x ⊛° y

List° : ∀ {a} → ★° a → ★° a
List° = liftA° List

[]° : ∀ {f} {F : ★° f} → ∀°(List° F)
[]° = []

_∷°_ : ∀ {f} {F : ★° f} → ∀°(F →° List° F →° List° F)
_∷°_ = _∷_

Maybe° : ∀ {a} → ★° a → ★° a
Maybe° = liftA° Maybe

nothing° : ∀ {f} {F : ★° f} → ∀°(Maybe° F)
nothing° = nothing

just° : ∀ {f} {F : ★° f} → ∀°(F →° Maybe° F)
just° = just

infixr 2 _×°_
_×°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° _
_×°_ = liftA₂° _×_

_,°_ : ∀ {f g} {F : ★° f} {G : ★° g} → ∀° (F →° G →° F ×° G)
_,°_ = _,_

pack° : ∀ {f} {F : ★° f} → (x : Ix) → F x → ∃° F
pack° = _,_

infixr 1 _⊎°_

_⊎°_ : ∀ {f g} (F : ★° f) (G : ★° g) → ★° _
_⊎°_ = liftA₂° _⊎_

inj₁° : ∀ {f g} {F : ★° f} {G : ★° g} → F ↦° F ⊎° G
inj₁° = inj₁

inj₂° : ∀ {f g} {F : ★° f} {G : ★° g} → G ↦° F ⊎° G
inj₂° = inj₂

⊤° : ★° _
⊤° = pure° ⊤

⊥° : ★° _
⊥° = pure° ⊥

¬° : ∀ {ℓ} → ★° ℓ → ★° _
¬° F = F →° ⊥°

-- This is the type of |map| functions, the fmap function on Ix-indexed
-- functors.
Map° : ∀ {a a' b b'} (F : ★° a → ★° a')
                     (G : ★° b → ★° b') → ★ _
Map° F G = ∀ {A B} → (A ↦° B) → F A ↦° G B

map°-K° : ∀ {a a' b b'}
            {F : ★ a → ★ a'}
            {G : ★ b → ★ b'}
            (fmap : ∀ {A B} → (A → B) → F A → G B)
            {A B} → (K° A ↦° K° B) → K° (F A) ↦° K° (G B)
map°-K° fmap f {i} = fmap (f {i})


IDesc model: make that damned fix-point. Stuck with a dead lift to make most constructors.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

lift : {i : Level} -> Set i -> Set (suc i)
lift = {!!}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (l : Level)(I : Set l) : Set (suc l) where
  var : I -> IDesc l I
  const : Set l -> IDesc l I
  prod : IDesc l I -> IDesc l I -> IDesc l I
  sigma : (S : Set l) -> (S -> IDesc l I) -> IDesc l I
  pi : (S : Set l) -> (S -> IDesc l I) -> IDesc l I

--********************************************
-- Desc interpretation
--********************************************

desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
desc _ I (var i) P = P i
desc _ I (const X) P = X
desc x I (prod D D') P = desc x I D P * desc x I D' P
desc x I (sigma S T) P = Sigma S (\s -> desc x I (T s) P)
desc x I (pi S T) P = (s : S) -> desc x I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

{-
data IMu (I : Set)(R : I -> IDesc I) : IDesc I -> Set1 where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)
-}

data IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l where
  con : desc l I (R i) (\j -> IMu l I R j) -> IMu l I R i

--********************************************
-- Predicate: Box
--********************************************

box : (l : Level)(I : Set l)(D : IDesc l I)(P : I -> Set l) -> desc l I D P -> IDesc l (Sigma I P)
box _ I (var i)     P x        = var (i , x)
box _ I (const X)   P x        = const X
box x I (prod D D') P (d , d') = prod (box x I D P d) (box x I D' P d')
box x I (sigma S T) P (a , b)  = box x I (T a) P b
box x I (pi S T)    P f        = pi S (\s -> box x I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu l I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc l I) ->
           (xs : desc l I D (IMu l I R)) ->
           desc l (Sigma I (IMu l I R)) (box l I D (IMu l I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (l : Level)
            (I : Set l)
            (R : I -> IDesc l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu l I R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst (l : Level) : Set l where
  lvar   : DescDConst l
  lconst : DescDConst l
  lprod  : DescDConst l
  lpi    : DescDConst l
  lsigma : DescDConst l

descDChoice : (l : Level) -> Set l -> DescDConst (suc l) -> IDesc (suc l) Unit
descDChoice _ I lvar = const (lift I)
descDChoice x _ lconst = const (Set x)
descDChoice _ _ lprod = prod (var Void) (var Void)
descDChoice x _ lpi = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))
descDChoice x _ lsigma = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
descD x I = sigma (DescDConst (suc x)) (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (suc x) Unit (\_ -> descD x I) Void

{-
varl : (l : Level)(I : Set l) -> IDescl l I
varl x I = con (lvar , {!!})
-}

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lconst , X)

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lprod , (D , D'))


IDesc model: modelled up to elimination, with no crazy flag but a mutual definition.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
record One  {i : Level} : Set i where

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set1 where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : (I : Set) -> IDesc I -> (I -> Set) -> Set
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

{-
data IMu (I : Set)(R : I -> IDesc I) : IDesc I -> Set1 where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)
-}

data IMu (I : Set)(R : I -> IDesc I)(i : I) : Set where
  con : desc I (R i) (\j -> IMu I R j) -> IMu I R i

--********************************************
-- Predicate: Box
--********************************************

box : (I : Set)(D : IDesc I)(P : I -> Set) -> desc I D P -> IDesc (Sigma I P)
box I (var i)     P x        = var (i , x)
box I (const X)   P x        = const X
box I (prod D D') P (d , d') = prod (box I D P d) (box I D' P d')
box I (sigma S T) P (a , b)  = box I (T a) P b
box I (pi S T)    P f        = pi S (\s -> box I (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim (I : Set)
            (R : I -> IDesc I)
            (P : Sigma I (IMu I R) -> Set)
            (m : (i : I)(xs : desc I (R i) (IMu I R))(hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) -> P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu I R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) -> (xs : desc I D (IMu I R)) -> desc (Sigma I (IMu I R)) (box I D (IMu I R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : (I : Set)(R : I -> IDesc I)(P : Sigma I (IMu I R) -> Set)
            (m : (i : I)
                 (xs : desc I (R i) (IMu I R))
                 (hs : desc (Sigma I (IMu I R)) (box I (R i) (IMu I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu I R i) -> P ( i , x )
induction = Elim.induction

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
record One  {i : Level} : Set i where

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

data IDesc (I : Set) : Set1 where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : (I : Set) -> IDesc I -> (I -> Set) -> Set
desc I (var i) P = P i
desc I (const X) P = X
desc I (prod D D') P = desc I D P * desc I D' P
desc I (sigma S T) P = Sigma S (\s -> desc I (T s) P)
desc I (pi S T) P = (s : S) -> desc I (T s) P

--********************************************
-- Fixpoint construction
--********************************************

{-
data IMu (I : Set)(R : I -> IDesc I) : IDesc I -> Set1 where
  rec : (i : I) -> IMu I R (R i) -> IMu I R (var i)
  lambda : (S : Set i)(D : S -> IDesc I) -> ((s : S) -> IMu I R (D s)) -> IMu I R (pi S D)
  pair : (S : Set i)(D : S -> IDesc I) -> (Sigma S (\s -> IMu I R (D s))) -> IMu I R (sigma S D)


Revert "Convert to stdlib"

Revert "Convert to stdlib"

This reverts commit 68af677d56d4f0a4c1aaa95134ae06f0813500c1.

open import Agda.Builtin.Bool

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

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

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

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

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

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

infixr 5 _∷_

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

main = (closure proofs (5 ∷ ∘))

open import Data.Bool
open import Data.List
open import Data.Nat

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr = false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

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

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

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

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

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

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

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

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

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

main = (closure proofs (5 ∷ []))