Implement DependentList on top of Data.List.All.

Old-commit-hash: 32c7c7edadf9940f3c013ca3d4ebfdc8b3cbc4f4

module Base.Data.DependentList where

open import Data.List.All public
  renaming
    ( All to DependentList
    ; _∷_ to _•_
    ; [] to ∅
    )

module Base.Data.DependentList where

open import Level

open import Data.Unit
open import Data.Product using (Σ ; _×_ ; _,_)

import Data.List as List
open List using (List ; [] ; _∷_)

data DependentList {a b} {A : Set a}
  (F : A → Set b) : (type-args : List A) → Set (a ⊔ b)
  where
  ∅ : DependentList F []
  _•_ : ∀ {type-arg} {other-type-args}
    (head : F type-arg)
    (tail : DependentList F other-type-args) →
    DependentList F (type-arg ∷ other-type-args)

infixr 5 _•_


add more composision with >>

add more composision with >>

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP using (Σ; _×_; _,_; first) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Two hiding (_≟_)
open import Data.Nat hiding (_⊔_)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _∙_; refl; ap; coe; coe!; !_ ; tr)-- renaming (subst to tr)
open import Function.Extensionality
open import HoTT
open Equivalences
open import Type.Identities

open import Control.Protocol.Core

module Control.Protocol.Sequence where

infixl 1 _>>=_ _>>_

_>>=_ : (P : Proto) → (Log P → Proto) → Proto
end     >>= Q = Q _
com q P >>= Q = com q λ m → P m >>= λ ms → Q (m , ms)

_>>_ : Proto → Proto → Proto
P >> Q = P >>= λ _ → Q

>>=-fst : ∀ P {Q} → ⟦ P >>= Q ⟧ → ⟦ P ⟧
>>=-fst end q = end
>>=-fst (recv P) pq = λ m → >>=-fst (P m) (pq m)
>>=-fst (send P) (m , pq) = m , >>=-fst (P m) pq

>>=-snd : ∀ P {Q}(pq : ⟦ P >>= Q ⟧)(p : ⟦ P ⊥⟧) → ⟦ Q (telecom P (>>=-fst P pq) p) ⟧
>>=-snd end      q        end     = q
>>=-snd (recv P) pq       (m , p) = >>=-snd (P m) (pq m) p
>>=-snd (send P) (m , pq) p       = >>=-snd (P m) pq (p m)

>>-snd : ∀ P {Q} (pq : ⟦ P >> Q ⟧)(p : ⟦ P ⊥⟧) → ⟦ Q ⟧
>>-snd P = >>=-snd P

[_]_>>>=_ : ∀ P {Q} → ⟦ P ⟧ → ((log : Log P) → ⟦ Q log ⟧) → ⟦ P >>= Q ⟧
[ end    ] p       >>>= q = q _
[ recv P ] p       >>>= q = λ m → [ P m ] p m >>>= λ log → q (m , log)
[ send P ] (m , p) >>>= q = m , [ P m ] p >>>= λ log → q (m , log)

[_]_>>>ᴸ_ : ∀ P {Q} → ⟦ P ⟧ → (Log P → ⟦ Q ⟧) → ⟦ P >> Q ⟧
[ P ] p >>>ᴸ q = [ P ] p >>>= q

[_]_>>>_ : ∀ P {Q} → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P >> Q ⟧
[ P ] p >>> q = [ P ] p >>>ᴸ (const q)

module _ {{_ : FunExt}} where
    >>=-fst-inv : ∀ P {Q}(p : ⟦ P ⟧)(q : ((log : Log P) → ⟦ Q log ⟧)) → >>=-fst P {Q} ([ P ] p >>>= q) ≡ p
    >>=-fst-inv end      end     q = refl
    >>=-fst-inv (recv P) p       q = λ= λ m → >>=-fst-inv (P m) (p m) λ log → q (m , log)
    >>=-fst-inv (send P) (m , p) q = snd= (>>=-fst-inv (P m) p λ log → q (m , log))

    >>=-snd-inv : ∀ P {Q}(p : ⟦ P ⟧)(q : ((log : Log P) → ⟦ Q log ⟧))(p' : ⟦ P ⊥⟧)
                  → tr (λ x → ⟦ Q (telecom P x p') ⟧) (>>=-fst-inv P p q)
                       (>>=-snd P {Q} ([ P ] p >>>= q) p') ≡ q (telecom P p p')
    >>=-snd-inv end          end     q p' = refl
    >>=-snd-inv (recv P) {Q} p       q (m , p') =
      ap (flip _$_ (>>=-snd (P m) ([ P m ] p m >>>= (λ log → q (m , log))) p'))
                                                     (tr-λ= (λ z → ⟦ Q (m , telecom (P m) z p') ⟧)
                                                               (λ m → >>=-fst-inv (P m) {Q ∘ _,_ m} (p m) (q ∘ _,_ m)))
                                                ∙ >>=-snd-inv (P m) {Q ∘ _,_ m} (p m) (q ∘ _,_ m) p'
    >>=-snd-inv (send P) {Q} (m , p) q p' = tr-snd= (λ { (m , p) → ⟦ Q (m , telecom (P m) p (p' m)) ⟧ })
                                                    (>>=-fst-inv (P m) p (q ∘ _,_ m))
                                                    (>>=-snd (P m) {Q ∘ _,_ m} ([ P m ] p >>>= (q ∘ _,_ m)) (p' m))
                                          ∙ >>=-snd-inv (P m) {Q ∘ _,_ m} p (λ log → q (m , log)) (p' m)

    {- hmmm...
    >>=-uniq : ∀ P {Q} (pq : ⟦ P >>= Q ⟧)(p' : ⟦ P ⊥⟧) → pq ≡ [ P ] (>>=-fst P {Q} pq) >>>= (λ log → {!>>=-snd P {Q} pq p'!})
    >>=-uniq = {!!}
    -}

replicateᴾ : ℕ → Proto → Proto
replicateᴾ 0       P = end
replicateᴾ (suc n) P = P >> replicateᴾ n P

replicate-proc : ∀ n P → ⟦ P ⟧ → ⟦ replicateᴾ n P ⟧
replicate-proc zero    P p = end
replicate-proc (suc n) P p = [ P ] p >>> replicate-proc n P p

module _ {{_ : FunExt}}{{_ : UA}} where
  Log->>=-Σ : ∀ (P : Proto){Q} → Log (P >>= Q) ≡ Σ (Log P) (Log ∘ Q)
  Log->>=-Σ end       = ! (×= End-uniq refl ∙ 𝟙×-snd)
  Log->>=-Σ (com _ P) = Σ=′ _ (λ m → Log->>=-Σ (P m)) ∙ Σ-assoc

  Log->>-× : ∀ (P : Proto){Q} → Log (P >> Q) ≡ (Log P × Log Q)
  Log->>-× P = Log->>=-Σ P

  ++Log' : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
  ++Log' P p q = coe! (Log->>=-Σ P) (p , q)

-- Same as ++Log' but computes better
++Log : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
++Log end       _        ys = ys
++Log (com q P) (x , xs) ys = x , ++Log (P x) xs ys

module _ {{_ : FunExt}}{{_ : UA}} where
  ++Log≡++Log' : ∀ P {Q} xs ys  → ++Log P {Q} xs ys ≡ ++Log' P xs ys
  ++Log≡++Log' end xs ys
    = ! coe-β _ _
    ∙ ap (coe 𝟙×-snd) (! coe×= End-uniq refl)
    ∙ coe∘coe 𝟙×-snd (×= End-uniq refl) (xs , ys)
    ∙ coe-same (! (!-inv (×= End-uniq refl ∙ 𝟙×-snd))) (xs , ys)
  ++Log≡++Log' (com io P) (m , xs) ys
    = ap (_,_ m) (++Log≡++Log' (P m) xs ys)
    ∙ ! coe!Σ=′ _ (λ m → Log->>=-Σ (P m))
    ∙ ap (coe (! Σ=′ _ (λ m₁ → Log->>=-Σ (P m₁)))) (! coe!-β _ _)
    ∙ coe∘coe (! Σ=′ _ (λ m → Log->>=-Σ (P m))) (! Σ-assoc) ((m , xs) , ys)
    ∙ coe-same (! (hom-!-∙ (Σ=′ _ (λ m → Log->>=-Σ (P m))) Σ-assoc)) ((m , xs) , ys)

module _ {{_ : FunExt}} where
    >>-right-unit : ∀ P → (P >> end) ≡ P
    >>-right-unit end       = refl
    >>-right-unit (com q P) = com= refl refl λ m → >>-right-unit (P m)

    >>=-assoc : ∀ (P : Proto)(Q : Log P → Proto)(R : Log (P >>= Q) → Proto)
                → (P >>= (λ x → Q x >>= (λ y → R (++Log P x y)))) ≡ ((P >>= Q) >>= R)
    >>=-assoc end       Q R = refl
    >>=-assoc (com q P) Q R = com= refl refl λ m → >>=-assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

    ap->>= : ∀ P {Q₀ Q₁} → (∀ {log} → ⟦ Q₀ log ⟧ ≡ ⟦ Q₁ log ⟧) → ⟦ P >>= Q₀ ⟧ ≡ ⟦ P >>= Q₁ ⟧
    ap->>= end      Q= = Q=
    ap->>= (send P) Q= = Σ=′ _ λ m → ap->>= (P m) Q=
    ap->>= (recv P) Q= = Π=′ _ λ m → ap->>= (P m) Q=

    dual->> : ∀ P Q → dual (P >> Q) ≡ (dual P >> dual Q)
    dual->> end        Q = refl
    dual->> (com io P) Q = com= refl refl λ m → dual->> (P m) Q

    {- My coe-ap-fu is lacking...
    dual->>= : ∀ P (Q : Log P → Proto) → dual (P >>= Q) ≡ dual P >>= (dual ∘ Q ∘ coe (dual-Log P))
    dual->>= end Q = refl
    dual->>= (com io P) Q = com= refl refl λ m → dual->>= (P m) (Q ∘ _,_ m) ∙ ap (_>>=_ (dual (P m))) (λ= λ ms → ap (λ x → dual (Q x)) (pair= {!!} {!!}))
    -}

    dual-replicateᴾ : ∀ n P → dual (replicateᴾ n P) ≡ replicateᴾ n (dual P)
    dual-replicateᴾ zero    P = refl
    dual-replicateᴾ (suc n) P = dual->> P (replicateᴾ n P) ∙ ap (_>>_ (dual P)) (dual-replicateᴾ n P)

{- An incremental telecom function which makes processes communicate
   during a matching initial protocol. -}
>>=-telecom : (P : Proto){Q : Log P → Proto}{R : Log P → Proto}
            → ⟦ P >>= Q  ⟧
            → ⟦ P >>= R ⊥⟧
            → Σ (Log P) (λ t → ⟦ Q t ⟧ × ⟦ R t ⊥⟧)
>>=-telecom end      p0       p1       = _ , p0 , p1
>>=-telecom (send P) (m , p0) p1       = first (_,_ m) (>>=-telecom (P m) p0 (p1 m))
>>=-telecom (recv P) p0       (m , p1) = first (_,_ m) (>>=-telecom (P m) (p0 m) p1)

>>-telecom : (P : Proto){Q R : Proto}
           → ⟦ P >> Q  ⟧
           → ⟦ P >> R ⊥⟧
           → Log P × ⟦ Q ⟧ × ⟦ R ⊥⟧
>>-telecom P p q = >>=-telecom P p q

>>-compose : (P Q : Proto){R : Proto}
  → ⟦ P >> Q ⟧
  → ⟦ dual Q >> R ⟧
  → ⟦ P >> R ⟧
>>-compose end end p>>q q>>r = q>>r
>>-compose end (send P) (m , p>>q) q>>r = >>-compose end (P m) p>>q (q>>r m)
>>-compose end (recv P) p>>q (m , q>>r) = >>-compose end (P m) (p>>q m) q>>r
>>-compose (send P) Q (m , p>>q) q>>r = m , >>-compose (P m) Q p>>q q>>r
>>-compose (recv P) Q p>>q q>>r m = >>-compose (P m) Q (p>>q m) q>>r

{-# OPTIONS --without-K #-}
open import Function.NP
open import Type
open import Data.Product.NP using (Σ; _×_; _,_; first) renaming (proj₁ to fst; proj₂ to snd)
open import Data.Two hiding (_≟_)
open import Data.Nat hiding (_⊔_)
open import Relation.Binary.PropositionalEquality.NP using (_≡_; _∙_; refl; ap; coe; coe!; !_ ; tr)-- renaming (subst to tr)
open import Function.Extensionality
open import HoTT
open Equivalences
open import Type.Identities

open import Control.Protocol.Core

module Control.Protocol.Sequence where

infixl 1 _>>=_ _>>_

_>>=_ : (P : Proto) → (Log P → Proto) → Proto
end     >>= Q = Q _
com q P >>= Q = com q λ m → P m >>= λ ms → Q (m , ms)

_>>_ : Proto → Proto → Proto
P >> Q = P >>= λ _ → Q

>>=-fst : ∀ P {Q} → ⟦ P >>= Q ⟧ → ⟦ P ⟧
>>=-fst end q = end
>>=-fst (recv P) pq = λ m → >>=-fst (P m) (pq m)
>>=-fst (send P) (m , pq) = m , >>=-fst (P m) pq

>>=-snd : ∀ P {Q}(pq : ⟦ P >>= Q ⟧)(p : ⟦ P ⊥⟧) → ⟦ Q (telecom P (>>=-fst P pq) p) ⟧
>>=-snd end      q        end     = q
>>=-snd (recv P) pq       (m , p) = >>=-snd (P m) (pq m) p
>>=-snd (send P) (m , pq) p       = >>=-snd (P m) pq (p m)

[_]_>>>=_ : ∀ P {Q} → ⟦ P ⟧ → ((log : Log P) → ⟦ Q log ⟧) → ⟦ P >>= Q ⟧
[ end    ] p       >>>= q = q _
[ recv P ] p       >>>= q = λ m → [ P m ] p m >>>= λ log → q (m , log)
[ send P ] (m , p) >>>= q = m , [ P m ] p >>>= λ log → q (m , log)

[_]_>>>_ : ∀ P {Q} → ⟦ P ⟧ → ⟦ Q ⟧ → ⟦ P >> Q ⟧
[ P ] p >>> q = [ P ] p >>>= λ _ → q

module _ {{_ : FunExt}} where
    >>=-fst-inv : ∀ P {Q}(p : ⟦ P ⟧)(q : ((log : Log P) → ⟦ Q log ⟧)) → >>=-fst P {Q} ([ P ] p >>>= q) ≡ p
    >>=-fst-inv end      end     q = refl
    >>=-fst-inv (recv P) p       q = λ= λ m → >>=-fst-inv (P m) (p m) λ log → q (m , log)
    >>=-fst-inv (send P) (m , p) q = snd= (>>=-fst-inv (P m) p λ log → q (m , log))

    >>=-snd-inv : ∀ P {Q}(p : ⟦ P ⟧)(q : ((log : Log P) → ⟦ Q log ⟧))(p' : ⟦ P ⊥⟧)
                  → tr (λ x → ⟦ Q (telecom P x p') ⟧) (>>=-fst-inv P p q)
                       (>>=-snd P {Q} ([ P ] p >>>= q) p') ≡ q (telecom P p p')
    >>=-snd-inv end          end     q p' = refl
    >>=-snd-inv (recv P) {Q} p       q (m , p') =
      ap (flip _$_ (>>=-snd (P m) ([ P m ] p m >>>= (λ log → q (m , log))) p'))
                                                     (tr-λ= (λ z → ⟦ Q (m , telecom (P m) z p') ⟧)
                                                               (λ m → >>=-fst-inv (P m) {Q ∘ _,_ m} (p m) (q ∘ _,_ m)))
                                                ∙ >>=-snd-inv (P m) {Q ∘ _,_ m} (p m) (q ∘ _,_ m) p'
    >>=-snd-inv (send P) {Q} (m , p) q p' = tr-snd= (λ { (m , p) → ⟦ Q (m , telecom (P m) p (p' m)) ⟧ })
                                                    (>>=-fst-inv (P m) p (q ∘ _,_ m))
                                                    (>>=-snd (P m) {Q ∘ _,_ m} ([ P m ] p >>>= (q ∘ _,_ m)) (p' m))
                                          ∙ >>=-snd-inv (P m) {Q ∘ _,_ m} p (λ log → q (m , log)) (p' m)

    {- hmmm...
    >>=-uniq : ∀ P {Q} (pq : ⟦ P >>= Q ⟧)(p' : ⟦ P ⊥⟧) → pq ≡ [ P ] (>>=-fst P {Q} pq) >>>= (λ log → {!>>=-snd P {Q} pq p'!})
    >>=-uniq = {!!}
    -}

replicateᴾ : ℕ → Proto → Proto
replicateᴾ 0       P = end
replicateᴾ (suc n) P = P >> replicateᴾ n P

replicate-proc : ∀ n P → ⟦ P ⟧ → ⟦ replicateᴾ n P ⟧
replicate-proc zero    P p = end
replicate-proc (suc n) P p = [ P ] p >>> replicate-proc n P p

module _ {{_ : FunExt}}{{_ : UA}} where
  Log->>=-Σ : ∀ (P : Proto){Q} → Log (P >>= Q) ≡ Σ (Log P) (Log ∘ Q)
  Log->>=-Σ end       = ! (×= End-uniq refl ∙ 𝟙×-snd)
  Log->>=-Σ (com _ P) = Σ=′ _ (λ m → Log->>=-Σ (P m)) ∙ Σ-assoc

  Log->>-× : ∀ (P : Proto){Q} → Log (P >> Q) ≡ (Log P × Log Q)
  Log->>-× P = Log->>=-Σ P

  ++Log' : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
  ++Log' P p q = coe! (Log->>=-Σ P) (p , q)

-- Same as ++Log' but computes better
++Log : ∀ (P : Proto){Q : Log P → Proto} (xs : Log P) → Log (Q xs) → Log (P >>= Q)
++Log end       _        ys = ys
++Log (com q P) (x , xs) ys = x , ++Log (P x) xs ys

module _ {{_ : FunExt}}{{_ : UA}} where

module _ {{_ : FunExt}} where
    >>-right-unit : ∀ P → (P >> end) ≡ P
    >>-right-unit end       = refl
    >>-right-unit (com q P) = com= refl refl λ m → >>-right-unit (P m)

    >>=-assoc : ∀ (P : Proto)(Q : Log P → Proto)(R : Log (P >>= Q) → Proto)
                → (P >>= (λ x → Q x >>= (λ y → R (++Log P x y)))) ≡ ((P >>= Q) >>= R)
    >>=-assoc end       Q R = refl
    >>=-assoc (com q P) Q R = com= refl refl λ m → >>=-assoc (P m) (λ ms → Q (m , ms)) (λ ms → R (m , ms))

    ap->>= : ∀ P {Q₀ Q₁} → (∀ {log} → ⟦ Q₀ log ⟧ ≡ ⟦ Q₁ log ⟧) → ⟦ P >>= Q₀ ⟧ ≡ ⟦ P >>= Q₁ ⟧
    ap->>= end      Q= = Q=
    ap->>= (send P) Q= = Σ=′ _ λ m → ap->>= (P m) Q=
    ap->>= (recv P) Q= = Π=′ _ λ m → ap->>= (P m) Q=

    dual->> : ∀ P Q → dual (P >> Q) ≡ (dual P >> dual Q)
    dual->> end        Q = refl
    dual->> (com io P) Q = com= refl refl λ m → dual->> (P m) Q

    {- My coe-ap-fu is lacking...
    dual->>= : ∀ P (Q : Log P → Proto) → dual (P >>= Q) ≡ dual P >>= (dual ∘ Q ∘ coe (dual-Log P))
    dual->>= end Q = refl
    dual->>= (com io P) Q = com= refl refl λ m → dual->>= (P m) (Q ∘ _,_ m) ∙ ap (_>>=_ (dual (P m))) (λ= λ ms → ap (λ x → dual (Q x)) (pair= {!!} {!!}))
    -}

    dual-replicateᴾ : ∀ n P → dual (replicateᴾ n P) ≡ replicateᴾ n (dual P)
    dual-replicateᴾ zero    P = refl
    dual-replicateᴾ (suc n) P = dual->> P (replicateᴾ n P) ∙ ap (_>>_ (dual P)) (dual-replicateᴾ n P)

{- An incremental telecom function which makes processes communicate
   during a matching initial protocol. -}
>>=-telecom : (P : Proto){Q : Log P → Proto}{R : Log P → Proto}
            → ⟦ P >>= Q  ⟧
            → ⟦ P >>= R ⊥⟧
            → Σ (Log P) (λ t → ⟦ Q t ⟧ × ⟦ R t ⊥⟧)
>>=-telecom end      p0       p1       = _ , p0 , p1
>>=-telecom (send P) (m , p0) p1       = first (_,_ m) (>>=-telecom (P m) p0 (p1 m))
>>=-telecom (recv P) p0       (m , p1) = first (_,_ m) (>>=-telecom (P m) (p0 m) p1)

>>-telecom : (P : Proto){Q R : Proto}
           → ⟦ P >> Q  ⟧
           → ⟦ P >> R ⊥⟧
           → Log P × ⟦ Q ⟧ × ⟦ R ⊥⟧
>>-telecom P p q = >>=-telecom P p q


NaPa: Add precedence annotations

NaPa: Add precedence annotations

{-# OPTIONS --universe-polymorphism #-}
-- vim: iskeyword=a-z,A-Z,48-57,-,+,',#,/,~,],[,=,_,`,⊆
module NaPa where

import Level as L
-- open import Irrelevance
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; _≗_; module ≗-Reasoning; module ≡-Reasoning)
open import Data.Nat.NP as Nat using (ℕ; zero; suc; s≤s; z≤n; ≤-pred; pred; _<=_; module <=)
                            renaming (_+_ to _+ℕ_ ; _∸_ to _∸ℕ_ ; _==_ to _==ℕ_; ¬≤ to ¬≤ℕ;
                                      _<_ to _<ℕ_ ; _≤_ to _≤ℕ_; _≥_ to _≥ℕ_; _≤?_ to _≤?ℕ_)
open import Data.Nat.Logical using (⟦ℕ⟧; zero; suc; ⟦ℕ⟧-setoid; ⟦ℕ⟧-equality; ⟦ℕ⟧-cong)
                          renaming (_≟_ to _≟⟦ℕ⟧_)
import Data.Nat.Properties as Nat
open import Function
open import Function.Equality as ⟶≡ using (_⟶_; _⟨$⟩_)
open import Data.Sum.NP as Sum using (_⊎_; inl; inr; [_,_]′) renaming (map to ⊎-map)
open import Data.Bool using (Bool; true; false; if_then_else_; T; not)
open import Data.Two renaming (✓-not-¬ to T'not'¬)
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product.NP using (_,_)
open import Data.Maybe.NP using (Maybe; nothing; just; maybe; _→?_)
open import Relation.Binary.NP as Bin
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Binary.On as On
open import NomPa.Worlds
open import NomPa.Worlds.Syntax as WorldSyntax
open import NomPa.Subtyping
open ListBoolWorlds public hiding (_⊆_) renaming (_⊆′_ to _⊆_)
import Category.Monad as Cat
open Cat.RawMonad (Data.Maybe.NP.monad {L.zero})
open Data.Maybe.NP.FunctorLemmas

private
  module ℕs = Setoid ⟦ℕ⟧-setoid
  module ℕe = Equality ⟦ℕ⟧-equality

infixr 4 _,_
record Name α : Set where
  constructor _,_
  field
    name    : ℕ
    -- .poofname∈α : name ∈ α
    name∈α : name ∈ α

open Name public
{-
data Name α : Set where
  _,_ : (x : ℕ) → .(x ∈ α) → Name α
name : ∀ {α} (x : Name α) → ℕ
name (x , _) = x

.name∈α : ∀ {α} (x : Name α) → name x ∈ α
name∈α (_ , pf) = pf
-}

--mkName : ∀ {α} (x : ℕ) → Irr (x ∈ α) → Name α
--mkName x (irr pf) = x , pf
mkName : ∀ {α} (x : ℕ) → x ∈ α → Name α
mkName x pf = x , pf

--name∈α : ∀ {α} (x : Name α) → Irr (name x ∈ α)
--name∈α (_ , pf) = irr pf

infix 4 _≡ᴺ_ _≟ᴺ_ _==ᴺ_

-- prim
_≡ᴺ_ : ∀ {α} (x y : Name α) → Set
_≡ᴺ_ = ⟦ℕ⟧ on name

-- prim
_≟ᴺ_ : ∀ {α} → Decidable (_≡ᴺ_ {α})
x ≟ᴺ y = name x ≟⟦ℕ⟧ name y

-- prim
_==ᴺ_ : ∀ {α} (x y : Name α) → Bool
_==ᴺ_ x y = name x ==ℕ name y

name-injective : ∀ {α} {x y : Name α} → name x ≡ name y → x ≡ y
name-injective {α} {_ , p₁} {a , p₂} eq rewrite eq
--= ≡.refl {_} {_} {a , p₂}
  = ≡.cong (_,_ a) (∈-uniq α p₁ p₂)

Nm : World → Setoid L.zero L.zero
Nm α = On.setoid ⟦ℕ⟧-setoid (name {α})

≡ᴺ-equality : ∀ {α} → Equality (_≡ᴺ_ {α})
≡ᴺ-equality {α}
   = record { isEquivalence = Setoid.isEquivalence (Nm α)
              -- I would prefered not going to PropEq.≡
            ; subst = λ P → ≡.tr P ∘ name-injective ∘ Equality.to-propositional ⟦ℕ⟧-equality }

module NmEq {α} = Equality (≡ᴺ-equality {α})

≡ᴺ⇒≡ : ∀ {α} → _≡ᴺ_ {α} ⇒ _≡_
≡ᴺ⇒≡ = NmEq.to-propositional

≡ᴺ-cong : ∀ {α β} (f : Name α → Name β) → _≡ᴺ_ =[ f ]⇒ _≡ᴺ_
≡ᴺ-cong f = NmEq.reflexive ∘ ≡.cong f ∘ ≡ᴺ⇒≡

≡ᴺ-⟦ℕ⟧-cong : ∀ {α} (f : Name α → ℕ) → _≡ᴺ_ =[ f ]⇒ ⟦ℕ⟧
≡ᴺ-⟦ℕ⟧-cong f = ℕe.reflexive ∘ ≡.cong f ∘ ≡ᴺ⇒≡

≡-⟦ℕ⟧-cong : ∀ {a} {A : Set a} (f : A → ℕ) → _≡_ =[ f ]⇒ ⟦ℕ⟧
≡-⟦ℕ⟧-cong f = ℕe.reflexive ∘ ≡.cong f

≡ᴺ-≡-cong : ∀ {a α} {A : Set a} (f : Name α → A) → _≡ᴺ_ =[ f ]⇒ _≡_
≡ᴺ-≡-cong f = ≡.cong f ∘ ≡ᴺ⇒≡

⟦ℕ⟧-≡ᴺ-cong : ∀ {α} (f : ℕ → Name α) → ⟦ℕ⟧ =[ f ]⇒ _≡ᴺ_
⟦ℕ⟧-≡ᴺ-cong f = NmEq.reflexive ∘ ≡.cong f ∘ ℕe.to-propositional

⟦ℕ⟧-≡-cong : ∀ {a} {A : Set a} (f : ℕ → A) → ⟦ℕ⟧ =[ f ]⇒ _≡_
⟦ℕ⟧-≡-cong f = ≡.cong f ∘ ℕe.to-propositional

module ≡ᴺ-Reasoning {α} = Bin.Setoid-Reasoning (Nm α)

open WorldSymantics listBoolWorlds public
open WorldOps listBoolWorlds public
open WorldOps listBoolWorlds using ()
open NomPa.Subtyping.⊆-Pack ⊆′ᵇ-pack public hiding (_⊆_; _⊈_)
open NomPa.Subtyping.SyntacticOnBools ⊆′ᵇ-pack public hiding (minimalSymantics)

-- Here is a first set of core primitives easy to define

-- prim
zeroᴺ : ∀ {α} → Name (α ↑1)
zeroᴺ = 0 , _

-- prim
¬Nameø : ¬(Name ø)
¬Nameø (_ , ())

-- prim
addᴺ : ∀ {α} k (x : Name α) → Name (α +ᵂ k)
addᴺ {α} k x = k +ℕ name x , proof k where
  proof : ∀ k → k +ℕ name x ∈ α +ᵂ k
  proof zero    = name∈α x
  proof (suc k) = proof k

infixl 6 addᴺ
syntax addᴺ k x = x +ᴺ k

-- prim
subtractᴺ : ∀ {α} k (x : Name (α +ᵂ k)) → Name α
subtractᴺ k x = name x ∸ℕ k , proof (name x) k (name∈α x) where
  proof : ∀ {α} x k → (x ∈ α +ᵂ k) → (x ∸ℕ k ∈ α)
  proof x       zero = id
  proof zero    (suc k) = λ()
  proof (suc x) (suc k) = proof x k

infixl 4 subtractᴺ
syntax subtractᴺ k x = x ∸ᴺ k

-- prim
coerceᴺ : ∀ {α β} → α ⊆ β → Name α → Name β
coerceᴺ α⊆β x = name x , coe α⊆β (name x) (name∈α x)

-- Then we define some convenience functions on top of them.

infix 0 _⟨-because_-⟩
_⟨-because_-⟩ : ∀ {α β} → Name α → α ⊆ β → Name β
_⟨-because_-⟩ n pf = coerceᴺ pf n

addᴺ↑ : ∀ {α} ℓ → Name α → Name (α ↑ ℓ)
addᴺ↑ ℓ x = addᴺ ℓ x  ⟨-because ⊆-+-↑ ℓ -⟩

sucᴺ : ∀ {α} → Name α → Name (α +1)
sucᴺ = addᴺ 1

sucᴺ↑ : ∀ {α} → Name α → Name (α ↑1)
sucᴺ↑ = addᴺ↑ 1

-- Then comes <ᴺ and the necessary intermediate definitions

private
  lem-<ℓ : ∀ {α β x ℓ} → x ≤ℕ ℓ → x ∈ (α ↑ suc ℓ) → x ∈ (β ↑ suc ℓ)
  lem-<ℓ z≤n       = _
  lem-<ℓ (s≤s m≤n) = lem-<ℓ m≤n

  lem-≥ℓ : ∀ {α x ℓ} → x ≥ℕ ℓ → x ∈ α ↑ ℓ → x ∈ α +ᵂ ℓ
  lem-≥ℓ z≤n        = id
  lem-≥ℓ (s≤s m≤n)  = lem-≥ℓ m≤n

  lem-<ℓ? : ∀ {α β n} ℓ → n ∈ β ↑ ℓ → n ∈ (if suc n <= ℓ then α ↑ ℓ else β +ᵂ ℓ)
  lem-<ℓ? {n = n} ℓ with suc n <= ℓ | <=.sound (suc n) ℓ | <=.complete {suc n} {ℓ}
  ... | true  | n<ℓ | _    = lem-<ℓ (n<ℓ _)
  ... | false | _   | ¬n<ℓ = lem-≥ℓ (¬≤ℕ ¬n<ℓ)

-- prim
cmpᴺ-bool : ∀ {α} ℓ → Name (α ↑ ℓ) → Bool
cmpᴺ-bool ℓ x = suc (name x) <= ℓ

syntax cmpᴺ-bool k x = x <ᴺ-bool k

-- prim
cmpᴺ-name : ∀ {α} ℓ (x : Name (α ↑ ℓ)) → Name (if cmpᴺ-bool ℓ x then ø ↑ ℓ else α +ᵂ ℓ)
cmpᴺ-name ℓ x = name x , lem-<ℓ? ℓ (name∈α x)

syntax cmpᴺ-name ℓ x = x <ᴺ-name ℓ

-- prim
cmpᴺ-name∈α : ∀ {α} ℓ (x : Name (α ↑ ℓ)) → name x ∈ (if cmpᴺ-bool ℓ x then ø ↑ ℓ else α +ᵂ ℓ)
cmpᴺ-name∈α ℓ x = lem-<ℓ? ℓ (name∈α x)

syntax cmpᴺ-name∈α ℓ x = x <ᴺ-name∈α ℓ

-- prim
cmpᴺ : ∀ {α} ℓ → Name (α ↑ ℓ) → Name (ø ↑ ℓ) ⊎ Name (α +ᵂ ℓ)
cmpᴺ ℓ x with cmpᴺ-bool ℓ x | cmpᴺ-name∈α ℓ x
... | true  | pf = inl (name x , pf)
... | false | pf = inr (name x , pf)

infix 4 cmpᴺ
syntax cmpᴺ k x = x <ᴺ k

cmpᴺ-ind : ∀ {a α} ℓ (x : Name (α ↑ ℓ))
            (P : (Name (ø ↑ ℓ) ⊎ Name (α +ᵂ ℓ)) → Set a)
            (Pinl : T (cmpᴺ-bool ℓ x) → ∀ pf → P (inl (name x , pf)))
            (Pinr : T (not (cmpᴺ-bool ℓ x)) → ∀ pf → P (inr (name x , pf)))
          → P (cmpᴺ ℓ x)
cmpᴺ-ind ℓ x P p₁ p₂
 with cmpᴺ-bool ℓ x | cmpᴺ-name∈α ℓ x
... | true         | pf = p₁ _ pf
... | false        | pf = p₂ _ pf

easy-cmpᴺ : ∀ {α} ℓ → Name (α ↑ ℓ) → Name (ø ↑ ℓ) ⊎ Name (α +ᵂ ℓ)
easy-cmpᴺ zero x               = inr x
easy-cmpᴺ (suc _) (zero , _)   = inl (zero , _)
easy-cmpᴺ (suc ℓ) (suc x , pf) = ⊎-map sucᴺ↑ sucᴺ (easy-cmpᴺ ℓ (x , pf))

syntax easy-cmpᴺ ℓ x = x <ᴺ-easy ℓ

easy-cmpᴺ≗cmpᴺ : ∀ {α} ℓ → easy-cmpᴺ {α} ℓ ≗ cmpᴺ ℓ
easy-cmpᴺ≗cmpᴺ zero x = ≡.cong inr (name-injective ≡.refl)
easy-cmpᴺ≗cmpᴺ (suc n) (zero , _) = ≡.refl
easy-cmpᴺ≗cmpᴺ {α} (suc n) (suc x , pf) rewrite easy-cmpᴺ≗cmpᴺ n (x , pf) = helper n x pf
  where
    helper : ∀ ℓ x pf → ⊎-map sucᴺ↑ sucᴺ (cmpᴺ {α} ℓ (x , pf)) ≡ cmpᴺ (suc ℓ) (suc x , pf)
    helper ℓ x pf = cmpᴺ-ind ℓ (x , pf) (λ r → ⊎-map sucᴺ↑ sucᴺ r ≡ cmpᴺ (suc ℓ) (suc x , pf))
                      (λ h pf' → cmpᴺ-ind (suc ℓ) (suc x , pf) (λ r → inl (suc x , pf') ≡ r)
                                         (λ _ _ → ≡.cong inl (name-injective ≡.refl))
                                         (λ h' → ⊥-elim (T'not'¬ h' h)))
                      (λ h pf' → cmpᴺ-ind (suc ℓ) (suc x , pf) (λ r → inr (suc x , pf') ≡ r)
                                         (λ h' → ⊥-elim (T'not'¬ h h'))
                                         (λ _ _ → ≡.cong inr (name-injective ≡.refl)))

-- prim (could be defined with (cmpᴺ 1)
protect↑1 : ∀ {α β} → (Name α → Name β) → Name (α ↑1) → Name (β ↑1)
protect↑1 f x with name x | {-irr-} (name∈α x)
... | zero  | _  = zero , _
... | suc m | pf = sucᴺ↑ (f (m , {-cert-} pf))

-- mkName; _,_; name; name∈α are forbidden from now on (except in proofs).

zeroᴺ↑1+ : ∀ {α} ℓ → Name (α ↑ (1 +ℕ ℓ))
zeroᴺ↑1+ _ = zeroᴺ

infix 10 _ᴺ
_ᴺ : ∀ {α} ℓ → Name (α ↑ suc ℓ)
_ᴺ {α} ℓ = zeroᴺ +ᴺ ℓ ⟨-because (α ↑1 +ᵂ ℓ) ⊆⟨ ⊆-+-↑ ℓ ⟩
                                α ↑1 ↑  ℓ   ⊆⟨ ⊆-exch-↑-↑ ⊆-refl 1 ℓ ⟩
                                α ↑ suc ℓ ∎ -⟩
   where open ⊆-Reasoning

-- Handy name eliminator
subtractWithᴺ : ∀ {a α} {A : Set a} ℓ → A → (Name α → A) → Name (α ↑ ℓ) → A
subtractWithᴺ ℓ v f x = [ const v , f ∘′ subtractᴺ ℓ ]′ (x <ᴺ ℓ)

subtractᴺ? : ∀ {α} ℓ → Name (α ↑ ℓ) →? Name α
subtractᴺ? ℓ = subtractWithᴺ ℓ nothing just

infixl 4 subtractᴺ?
syntax subtractᴺ? k x = x ∸ᴺ? k

private
 module CoeExamples where
  Nameα+→Nameα↑ : ∀ {α} k → Name (α +ᵂ k) → Name (α ↑ k)
  Nameα+→Nameα↑ k = coerceᴺ (⊆-ctx-+↑ ⊆-refl k)
 module Unused where
  open import Data.List using ([]; _∷_; replicate; _++_)
  n∈trueⁿ⁺¹ : ∀ {α} n → n ∈ replicate (suc n) true ++ α
  n∈trueⁿ⁺¹ zero    = _
  n∈trueⁿ⁺¹ (suc n) = n∈trueⁿ⁺¹ n

predᴺ : ∀ {α} → Name (α +1) → Name α
predᴺ = subtractᴺ 1

predᴺ? : ∀ {α} → Name (α ↑1) →? Name α
predᴺ? = subtractᴺ? 1

Name→-to-Nm⟶ : ∀ {b₁ b₂ α} {B : Setoid b₁ b₂} →
                 (Name α → Setoid.Carrier B) → Nm α ⟶ B
Name→-to-Nm⟶ {α = α} {B} f = record { _⟨$⟩_ = f; cong = cong′ }
  where
  open Setoid B renaming (_≈_ to _≈B_)

  cong≡ : ∀ {x y} → x ≡ y → f x ≈B f y
  cong≡ ≡.refl = Setoid.refl B

  cong′ : ∀ {x y} → x ≡ᴺ y → f x ≈B f y
  cong′ = cong≡ ∘ Equality.to-propositional ≡ᴺ-equality
  -- cong′ = Setoid.reflexive ∘ Equality.to-propositional ≡ᴺ-equality

¬Name : ∀ {α} → α ⊆ ø → ¬(Name α)
¬Name α⊆ø = ¬Nameø ∘ coerceᴺ α⊆ø

Name-elim : ∀ {a} {A : Set a} {α} (α⊆ø : α ⊆ ø) (x : Name α) → A
Name-elim x y with ¬Name x y
... | ()

Nameø-elim : ∀ {a} {A : Set a} → Name ø → A
Nameø-elim = Name-elim ⊆-refl

¬Nameø+ : ∀ k → ¬(Name (ø +ᵂ k))
¬Nameø+ = ¬Name ∘ ⊆-ø+

Nameø+-elim : ∀ {a} {A : Set a} k → Name (ø +ᵂ k) → A
Nameø+-elim = Name-elim ∘ ⊆-ø+

Nameø↑→Nameα↑ : ∀ {ℓ} → Name (ø ↑ ℓ) → ∀ {α} → Name (α ↑ ℓ)
Nameø↑→Nameα↑ {ℓ} x = x ⟨-because ⊆-cong-↑ ⊆-ø ℓ -⟩

is0? : ∀ {α} → Name (α ↑1) → Bool
is0? = cmpᴺ-bool 1
-- is0? = [ const true , const false ]′ (x <ᴺ 1)

shiftℕ : ∀ (ℓ k n : ℕ) → ℕ
shiftℕ ℓ k n = if suc n <= ℓ then n else n +ℕ k

shiftᴺ : ∀ {α β} ℓ k → α +ᵂ k ⊆ β → Name (α ↑ ℓ) → Name (β ↑ ℓ)
shiftᴺ ℓ k pf n
  with n <ᴺ ℓ
...  | inl n′ = n′       ⟨-because ⊆-cong-↑ ⊆-ø ℓ -⟩
...  | inr n′ = n′ +ᴺ k  ⟨-because ⊆-trans (⊆-exch-+-+ ⊆-refl ℓ k) (⊆-ctx-+↑ pf ℓ) -⟩

module Singletons where

  SWorld : ℕ → World
  SWorld n = ø ↑1 +ᵂ n

  Nameˢ : ℕ → Set
  Nameˢ = Name ∘ SWorld

  _ˢ : ∀ n → Nameˢ n
  _ˢ n = zeroᴺ +ᴺ n

  addˢ : ∀ {n} k → Nameˢ n → Nameˢ (k +ℕ n)
  addˢ {n} k x = addᴺ k x  ⟨-because ⊆-assoc-+ ⊆-refl n k -⟩

  subtractˢ : ∀ {n} k → Nameˢ (k +ℕ n) → Nameˢ n
  subtractˢ {n} k x = subtractᴺ k (x ⟨-because ⊆-assoc-+′ ⊆-refl n k -⟩)

{-
shiftᴺ-1-1+-
  shiftᴺ 1 (suc k) pf n ≡ shiftᴺ 1 k ? (shiftᴺ 1 1 ? n)
-}

-- Properties

coerceᴺ-names : ∀ {α β} (α⊆β : α ⊆ β) → name ∘ coerceᴺ α⊆β ≗ name
coerceᴺ-names _ _ = ≡.refl

{-
<ᴺ-coerce : ∀ {α} ℓ (x : Name (α ↑ ℓ)) → [ coerceᴺ (⊆-cong-↑ ⊆-ø ℓ) , coerceᴺ (⊆-ctx-+↑ ⊆-refl ℓ) ]′ (x <ᴺ ℓ) ≡ x
<ᴺ-coerce ℓ x with x <ᴺ-bool ℓ | x <ᴺ-name∈α ℓ
... | true  | _ = name-injective ≡.refl
... | false | _ = name-injective ≡.refl
-}

<ᴺ-names : ∀ {α ℓ} {x : Name (α ↑ ℓ)} → [ name , name ]′ (x <ᴺ ℓ) ≡ name x
<ᴺ-names {α} {ℓ} {x} with x <ᴺ-bool ℓ | x <ᴺ-name∈α ℓ
... | true  | _ = ≡.refl
... | false | _ = ≡.refl

Dec-≡ᴺ→≡ : ∀ {α} → Decidable (_≡ᴺ_ {α}) → Decidable _≡_
Dec-≡ᴺ→≡ _≟_ x y with x ≟ y
... | yes x≡y = yes (≡ᴺ⇒≡ x≡y)
... | no  x≢y = no  (x≢y ∘′ ℕs.reflexive ∘′ ≡.cong name)

shiftᴺ-ℓ-0≡coerceᴺ : ∀ {α β} ℓ (pf : α ⊆ β) n → name (shiftᴺ ℓ 0 pf n) ≡ name n
shiftᴺ-ℓ-0≡coerceᴺ ℓ pf x with x <ᴺ-bool ℓ | x <ᴺ-name∈α ℓ
... | true  | _ = ≡.refl
... | false | _ = ≡.refl

pred-shiftℕ-comm : ∀ k x → pred (shiftℕ 1 k (suc x)) ≡ x +ℕ k
pred-shiftℕ-comm k x = ≡.refl

.shift11-predᴺ?-comm :
  ∀ {α β} (pf : α +1 ⊆ β) (x : Name (α ↑1)) →
  predᴺ? (shiftᴺ 1 1 pf x) ≡ (coerceᴺ pf ∘ sucᴺ <$> predᴺ? x)
shift11-predᴺ?-comm {α} pf x
   = <$>-injective₁ name-injective (≡.trans (helper (name x) {name∈α x} (suc (name x) ≤?ℕ 1)) (<$>-assoc (predᴺ? x)))
  where
    -- getting the name unpacked (and the Dec), works around an Agda bug in 2.2.8.
    .helper : ∀ n {pn : n ∈ α ↑1} → Dec (n <ℕ 1) → let x = n , pn in
             (name <$> (predᴺ? (shiftᴺ 1 1 pf x))) ≡ (name ∘ (coerceᴺ pf ∘ sucᴺ) <$> predᴺ? x)
    helper zero    (no ¬p)         = ⊥-elim (¬p (s≤s z≤n))
    helper .0      (yes (s≤s z≤n)) = ≡.refl
    helper (suc _) (no _)          = ≡.refl

1+ : ∀ {α} → Name α → Name (α +1)
1+ x = x +ᴺ 1

module Name↑⇔Fin where
  open import Data.Fin as Fin

  ⇒ : ∀ n → Name (ø ↑ n) → Fin n
  ⇒ zero    = Nameø-elim
  ⇒ (suc n) = maybe (suc ∘′ ⇒ n) zero ∘′ predᴺ?

  ⇐ : ∀ {α n} → Fin n → Name (α ↑ n)
  ⇐ (zero {n})  = zeroᴺ↑1+ n
  ⇐ (suc i)     = sucᴺ↑ (⇐ i)

{-
  open Singletons
  open ⊆-Reasoning
  f : ∀ {α n} → Fin n → Name (α ↑ n)
  f {α} {zero} ()
  f {α} {suc n} x = coerceᴺ c (sName x′) where
    x′ = Fin.toℕ x
    c′ = ø ↑1 +[ n ∸ℕ x′ ]   ⊆⟨ {!!} ⟩
         (ø +[ n ∸ℕ x′ ]) ↑1 ⊆⟨ ⊆-cong-↑1 (α+⊆ø→α⊆ø _ ⊆-refl) ⟩
         ø ↑1                 ⊆⟨ ⊆-cong-↑1 ⊆-ø ⟩
         α ↑1 ∎
    c : SWorld x′ ⊆ α ↑ (suc n)
    c = SWorld x′                ⊆⟨ refl ⟩
        ø ↑1 +[ x′ ]             ⊆⟨ {!!} ⟩
        ø ↑1 +[ n ∸ℕ x′ ] +[ n ] ⊆⟨ ⊆-ctx-+↑ c′ n ⟩
        α ↑1 ↑ n                 ⊆⟨ ⊆-exch-↑-↑ ⊆-refl 1 n ⟩
        α ↑ suc n ∎
-}

  -- ⇔ : ∀ n → Name (ø ↑ n) ⇔ Fin n
  -- ⇔ n = ?

{-
module Bug where
  record Fin′ (n : ℕ) : Set where
    constructor mkFin
    field
      x    : ℕ
      .x<n : x <ℕ n
  raise : ∀ {n m} → Fin′ n → n ≤ℕ m → Fin′ m
  raise (mkFin x x<n) n≤m = mkFin x (ℕ≤.trans x<n n≤m)
  raise-assoc : ∀ {n m o} p (q : m ≤ℕ o) (x : Fin′ n) → (raise (raise x p) q) ≡ (raise x (ℕ≤.trans p q))
  raise-assoc p q (mkFin x x<n) with raise-assoc p q (mkFin x x<n)
  ... | refl = ?
-}

{-
module Fin′ where
  record Fin′ (n : ℕ) : Set where
    constructor mkFin
    field
      x    : ℕ
      .x<n : x <ℕ n
  zeroF : ∀ {n} → Fin′ (suc n)
  zeroF = mkFin 0 (s≤s z≤n)
  sucF : ∀ {n} → Fin′ n → Fin′ (suc n)
  sucF (mkFin x x<n) = mkFin (suc x) (s≤s x<n)

  raise : ∀ {n} (x : Fin′ n) k → Fin′ (n +ℕ k)
  raise (mkFin x x<n) k = mkFin x (m≤n→m≤n+k x<n)
    where m≤n→m≤n+k : ∀ {m n k} → m ≤ℕ n → m ≤ℕ n +ℕ k
          m≤n→m≤n+k z≤n        = z≤n
          m≤n→m≤n+k (s≤s m≤n)  = s≤s (m≤n→m≤n+k m≤n)
-}

{-
(x : α +ᵂ n) → x ≥ n

(x : α +ᵂ suc n) → x ≢ zeroᴺ
-}

module ℕ⇒Name`α` where
  open WorldSyntax
  open WorldSyntax.El listBoolWorlds
  ⇒ : ∀ `α` x → x ∈ El `α` → Name (El `α`)
  ⇒ (`α` `↑1`) zero    _     = zero , _
  ⇒ (`α` `↑1`) (suc i) pf    = sucᴺ↑ (⇒ `α` i pf)
  ⇒ (`α` `+1`) zero    ()
  ⇒ (`α` `+1`) (suc i) pf    = sucᴺ (⇒ `α` i pf)
  ⇒ `ø`        _       ()

module Name`α`⇔Fin where
  open import Data.Fin as F renaming (_+_ to _+F_)
  open WorldSyntax
  open WorldSyntax.El listBoolWorlds
  open WorldSyntax.Properties listBoolWorlds
  mutual

    ⇒+1 : ∀ `α` → Name (El `α` +1) → Fin (suc (bnd `α`))
    ⇒+1 `α` = F.raise 1 ∘ ⇒ `α` ∘ predᴺ

    ⇒ : ∀ `α` → Name (El `α`) → Fin (bnd `α`)
    ⇒ (`α` `↑1`)  = [ inject+ _ ∘ Name↑⇔Fin.⇒ 1 , ⇒+1 `α` ]′ ∘ cmpᴺ 1
    ⇒ (`α` `+1`)  = ⇒+1 `α`
    ⇒ `ø`         = Nameø-elim

  ⇐₁ : ∀ {n} `α` → (x : Fin n) → toℕ x ∈ El `α` → Name (El `α`)
  ⇐₁ `α` = ℕ⇒Name`α`.⇒ `α` ∘ toℕ

  x∈ø↑x : ∀ {n} (x : Fin n) → toℕ x ∈ (ø ↑ n)
  x∈ø↑x zero    = _
  x∈ø↑x (suc n) = x∈ø↑x n

  ⇐₂ : ∀ {n} → (x : Fin n) → Name (ø ↑ n)
  ⇐₂ {n} x with x∈ø↑x x
  ...         | y       rewrite comm-El-↑ `ø` n = ⇐₁ (`ø` `↑` n) x y

  {- I would have prefered a local `where` here
  ⇐₂ : ∀ {n} → (x : Fin n) → Name (ø ↑ n)
  ⇐₂ {n} x where y = x∈ø↑x x rewrite comm-El-↑ `ø` n = ⇐₁ (`ø` `↑` n) x y
  -}

module WellFormedWorld where
  data WF : World → Set where
    `ø : WF ø
    _`+_ : ∀ {α} (`α : WF α) k → WF (α +ᵂ k)
    _`↑_ : ∀ {α} (`α : WF α) k → WF (α ↑ k)

_+↑ᴺ_ : ∀ {α} → Name α → ∀ ℓ → Name (α ↑ ℓ)
_+↑ᴺ_ x ℓ = coerceᴺ (⊆-ctx-+↑ ⊆-refl ℓ) (x +ᴺ ℓ)

subtractᴺ↑ : ∀ {α} ℓ → Name (α ↑ ℓ) → Name (ø ↑ ℓ) ⊎ Name α
subtractᴺ↑ ℓ x with x <ᴺ ℓ
... | inl x′ = inl x′
... | inr x′ = inr (x′ ∸ᴺ ℓ)

infixl 4 subtractᴺ↑
syntax subtractᴺ↑ ℓ x = x -↑ᴺ ℓ

data WithLim (R : (α β : World) → Set) : (α β : World) → Set where
  mkWithLim : ∀ {α₀ β₀} ℓ (Rα₀β₀ : R α₀ β₀) → WithLim R (α₀ ↑ ℓ) (β₀ ↑ ℓ)

withLim : ∀ {R α β} → R α β → WithLim R α β
withLim = mkWithLim 0

-- functions known to be ``bad'' and that we don't want to export
private
 module Bad where
  Name2ℕ : ∀ {α} → Name α → ℕ
  Name2ℕ = name
  isZero? : ∀ {α} → Name α → Bool
  isZero? (zero  , _) = true
  isZero? (suc _ , _) = false

{-# OPTIONS --universe-polymorphism #-}
-- vim: iskeyword=a-z,A-Z,48-57,-,+,',#,/,~,],[,=,_,`,⊆
module NaPa where

import Level as L
-- open import Irrelevance
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_; _≗_; module ≗-Reasoning; module ≡-Reasoning)
open import Data.Nat.NP as Nat using (ℕ; zero; suc; s≤s; z≤n; ≤-pred; pred; _<=_; module <=)
                            renaming (_+_ to _+ℕ_ ; _∸_ to _∸ℕ_ ; _==_ to _==ℕ_; ¬≤ to ¬≤ℕ;
                                      _<_ to _<ℕ_ ; _≤_ to _≤ℕ_; _≥_ to _≥ℕ_; _≤?_ to _≤?ℕ_)
open import Data.Nat.Logical using (⟦ℕ⟧; zero; suc; ⟦ℕ⟧-setoid; ⟦ℕ⟧-equality; ⟦ℕ⟧-cong)
                          renaming (_≟_ to _≟⟦ℕ⟧_)
import Data.Nat.Properties as Nat
open import Function
open import Function.Equality as ⟶≡ using (_⟶_; _⟨$⟩_)
open import Data.Sum.NP as Sum using (_⊎_; inl; inr; [_,_]′) renaming (map to ⊎-map)
open import Data.Bool using (Bool; true; false; if_then_else_; T; not)
open import Data.Two renaming (✓-not-¬ to T'not'¬)
open import Data.Unit using (⊤)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product.NP using (_,_)
open import Data.Maybe.NP using (Maybe; nothing; just; maybe; _→?_)
open import Relation.Binary.NP as Bin
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Binary.On as On
open import NomPa.Worlds
open import NomPa.Worlds.Syntax as WorldSyntax
open import NomPa.Subtyping
open ListBoolWorlds public hiding (_⊆_) renaming (_⊆′_ to _⊆_)
import Category.Monad as Cat
open Cat.RawMonad (Data.Maybe.NP.monad {L.zero})
open Data.Maybe.NP.FunctorLemmas

private
  module ℕs = Setoid ⟦ℕ⟧-setoid
  module ℕe = Equality ⟦ℕ⟧-equality

infixr 4 _,_
record Name α : Set where
  constructor _,_
  field
    name    : ℕ
    -- .poofname∈α : name ∈ α
    name∈α : name ∈ α

open Name public
{-
data Name α : Set where
  _,_ : (x : ℕ) → .(x ∈ α) → Name α
name : ∀ {α} (x : Name α) → ℕ
name (x , _) = x

.name∈α : ∀ {α} (x : Name α) → name x ∈ α
name∈α (_ , pf) = pf
-}

--mkName : ∀ {α} (x : ℕ) → Irr (x ∈ α) → Name α
--mkName x (irr pf) = x , pf
mkName : ∀ {α} (x : ℕ) → x ∈ α → Name α
mkName x pf = x , pf

--name∈α : ∀ {α} (x : Name α) → Irr (name x ∈ α)
--name∈α (_ , pf) = irr pf

infix 4 _≡ᴺ_ _≟ᴺ_ _==ᴺ_

-- prim
_≡ᴺ_ : ∀ {α} (x y : Name α) → Set
_≡ᴺ_ = ⟦ℕ⟧ on name

-- prim
_≟ᴺ_ : ∀ {α} → Decidable (_≡ᴺ_ {α})
x ≟ᴺ y = name x ≟⟦ℕ⟧ name y

-- prim
_==ᴺ_ : ∀ {α} (x y : Name α) → Bool
_==ᴺ_ x y = name x ==ℕ name y

name-injective : ∀ {α} {x y : Name α} → name x ≡ name y → x ≡ y
name-injective {α} {_ , p₁} {a , p₂} eq rewrite eq
--= ≡.refl {_} {_} {a , p₂}
  = ≡.cong (_,_ a) (∈-uniq α p₁ p₂)

Nm : World → Setoid L.zero L.zero
Nm α = On.setoid ⟦ℕ⟧-setoid (name {α})

≡ᴺ-equality : ∀ {α} → Equality (_≡ᴺ_ {α})
≡ᴺ-equality {α}
   = record { isEquivalence = Setoid.isEquivalence (Nm α)
              -- I would prefered not going to PropEq.≡
            ; subst = λ P → ≡.tr P ∘ name-injective ∘ Equality.to-propositional ⟦ℕ⟧-equality }

module NmEq {α} = Equality (≡ᴺ-equality {α})

≡ᴺ⇒≡ : ∀ {α} → _≡ᴺ_ {α} ⇒ _≡_
≡ᴺ⇒≡ = NmEq.to-propositional

≡ᴺ-cong : ∀ {α β} (f : Name α → Name β) → _≡ᴺ_ =[ f ]⇒ _≡ᴺ_
≡ᴺ-cong f = NmEq.reflexive ∘ ≡.cong f ∘ ≡ᴺ⇒≡

≡ᴺ-⟦ℕ⟧-cong : ∀ {α} (f : Name α → ℕ) → _≡ᴺ_ =[ f ]⇒ ⟦ℕ⟧
≡ᴺ-⟦ℕ⟧-cong f = ℕe.reflexive ∘ ≡.cong f ∘ ≡ᴺ⇒≡

≡-⟦ℕ⟧-cong : ∀ {a} {A : Set a} (f : A → ℕ) → _≡_ =[ f ]⇒ ⟦ℕ⟧
≡-⟦ℕ⟧-cong f = ℕe.reflexive ∘ ≡.cong f

≡ᴺ-≡-cong : ∀ {a α} {A : Set a} (f : Name α → A) → _≡ᴺ_ =[ f ]⇒ _≡_
≡ᴺ-≡-cong f = ≡.cong f ∘ ≡ᴺ⇒≡

⟦ℕ⟧-≡ᴺ-cong : ∀ {α} (f : ℕ → Name α) → ⟦ℕ⟧ =[ f ]⇒ _≡ᴺ_
⟦ℕ⟧-≡ᴺ-cong f = NmEq.reflexive ∘ ≡.cong f ∘ ℕe.to-propositional

⟦ℕ⟧-≡-cong : ∀ {a} {A : Set a} (f : ℕ → A) → ⟦ℕ⟧ =[ f ]⇒ _≡_
⟦ℕ⟧-≡-cong f = ≡.cong f ∘ ℕe.to-propositional

module ≡ᴺ-Reasoning {α} = Bin.Setoid-Reasoning (Nm α)

open WorldSymantics listBoolWorlds public
open WorldOps listBoolWorlds public
open WorldOps listBoolWorlds using ()
open NomPa.Subtyping.⊆-Pack ⊆′ᵇ-pack public hiding (_⊆_; _⊈_)
open NomPa.Subtyping.SyntacticOnBools ⊆′ᵇ-pack public hiding (minimalSymantics)

-- Here is a first set of core primitives easy to define

-- prim
zeroᴺ : ∀ {α} → Name (α ↑1)
zeroᴺ = 0 , _

-- prim
¬Nameø : ¬(Name ø)
¬Nameø (_ , ())

-- prim
addᴺ : ∀ {α} k (x : Name α) → Name (α +ᵂ k)
addᴺ {α} k x = k +ℕ name x , proof k where
  proof : ∀ k → k +ℕ name x ∈ α +ᵂ k
  proof zero    = name∈α x
  proof (suc k) = proof k

infixl 6 addᴺ
syntax addᴺ k x = x +ᴺ k

-- prim
subtractᴺ : ∀ {α} k (x : Name (α +ᵂ k)) → Name α
subtractᴺ k x = name x ∸ℕ k , proof (name x) k (name∈α x) where
  proof : ∀ {α} x k → (x ∈ α +ᵂ k) → (x ∸ℕ k ∈ α)
  proof x       zero = id
  proof zero    (suc k) = λ()
  proof (suc x) (suc k) = proof x k

infixl 4 subtractᴺ
syntax subtractᴺ k x = x ∸ᴺ k

-- prim
coerceᴺ : ∀ {α β} → α ⊆ β → Name α → Name β
coerceᴺ α⊆β x = name x , coe α⊆β (name x) (name∈α x)

-- Then we define some convenience functions on top of them.

infix 0 _⟨-because_-⟩
_⟨-because_-⟩ : ∀ {α β} → Name α → α ⊆ β → Name β
_⟨-because_-⟩ n pf = coerceᴺ pf n

addᴺ↑ : ∀ {α} ℓ → Name α → Name (α ↑ ℓ)
addᴺ↑ ℓ x = addᴺ ℓ x  ⟨-because ⊆-+-↑ ℓ -⟩

sucᴺ : ∀ {α} → Name α → Name (α +1)
sucᴺ = addᴺ 1

sucᴺ↑ : ∀ {α} → Name α → Name (α ↑1)
sucᴺ↑ = addᴺ↑ 1

-- Then comes <ᴺ and the necessary intermediate definitions

private
  lem-<ℓ : ∀ {α β x ℓ} → x ≤ℕ ℓ → x ∈ (α ↑ suc ℓ) → x ∈ (β ↑ suc ℓ)
  lem-<ℓ z≤n       = _
  lem-<ℓ (s≤s m≤n) = lem-<ℓ m≤n

  lem-≥ℓ : ∀ {α x ℓ} → x ≥ℕ ℓ → x ∈ α ↑ ℓ → x ∈ α +ᵂ ℓ
  lem-≥ℓ z≤n        = id
  lem-≥ℓ (s≤s m≤n)  = lem-≥ℓ m≤n

  lem-<ℓ? : ∀ {α β n} ℓ → n ∈ β ↑ ℓ → n ∈ (if suc n <= ℓ then α ↑ ℓ else β +ᵂ ℓ)
  lem-<ℓ? {n = n} ℓ with suc n <= ℓ | <=.sound (suc n) ℓ | <=.complete {suc n} {ℓ}
  ... | true  | n<ℓ | _    = lem-<ℓ (n<ℓ _)
  ... | false | _   | ¬n<ℓ = lem-≥ℓ (¬≤ℕ ¬n<ℓ)

-- prim
cmpᴺ-bool : ∀ {α} ℓ → Name (α ↑ ℓ) → Bool
cmpᴺ-bool ℓ x = suc (name x) <= ℓ

syntax cmpᴺ-bool k x = x <ᴺ-bool k

-- prim
cmpᴺ-name : ∀ {α} ℓ (x : Name (α ↑ ℓ)) → Name (if cmpᴺ-bool ℓ x then ø ↑ ℓ else α +ᵂ ℓ)
cmpᴺ-name ℓ x = name x , lem-<ℓ? ℓ (name∈α x)

syntax cmpᴺ-name ℓ x = x <ᴺ-name ℓ

-- prim
cmpᴺ-name∈α : ∀ {α} ℓ (x : Name (α ↑ ℓ)) → name x ∈ (if cmpᴺ-bool ℓ x then ø ↑ ℓ else α +ᵂ ℓ)
cmpᴺ-name∈α ℓ x = lem-<ℓ? ℓ (name∈α x)

syntax cmpᴺ-name∈α ℓ x = x <ᴺ-name∈α ℓ

-- prim
cmpᴺ : ∀ {α} ℓ → Name (α ↑ ℓ) → Name (ø ↑ ℓ) ⊎ Name (α +ᵂ ℓ)
cmpᴺ ℓ x with cmpᴺ-bool ℓ x | cmpᴺ-name∈α ℓ x
... | true  | pf = inl (name x , pf)
... | false | pf = inr (name x , pf)

infix 4 cmpᴺ
syntax cmpᴺ k x = x <ᴺ k

cmpᴺ-ind : ∀ {a α} ℓ (x : Name (α ↑ ℓ))
            (P : (Name (ø ↑ ℓ) ⊎ Name (α +ᵂ ℓ)) → Set a)
            (Pinl : T (cmpᴺ-bool ℓ x) → ∀ pf → P (inl (name x , pf)))
            (Pinr : T (not (cmpᴺ-bool ℓ x)) → ∀ pf → P (inr (name x , pf)))
          → P (cmpᴺ ℓ x)
cmpᴺ-ind ℓ x P p₁ p₂
 with cmpᴺ-bool ℓ x | cmpᴺ-name∈α ℓ x
... | true         | pf = p₁ _ pf
... | false        | pf = p₂ _ pf

easy-cmpᴺ : ∀ {α} ℓ → Name (α ↑ ℓ) → Name (ø ↑ ℓ) ⊎ Name (α +ᵂ ℓ)
easy-cmpᴺ zero x               = inr x
easy-cmpᴺ (suc _) (zero , _)   = inl (zero , _)
easy-cmpᴺ (suc ℓ) (suc x , pf) = ⊎-map sucᴺ↑ sucᴺ (easy-cmpᴺ ℓ (x , pf))

syntax easy-cmpᴺ ℓ x = x <ᴺ-easy ℓ

easy-cmpᴺ≗cmpᴺ : ∀ {α} ℓ → easy-cmpᴺ {α} ℓ ≗ cmpᴺ ℓ
easy-cmpᴺ≗cmpᴺ zero x = ≡.cong inr (name-injective ≡.refl)
easy-cmpᴺ≗cmpᴺ (suc n) (zero , _) = ≡.refl
easy-cmpᴺ≗cmpᴺ {α} (suc n) (suc x , pf) rewrite easy-cmpᴺ≗cmpᴺ n (x , pf) = helper n x pf
  where
    helper : ∀ ℓ x pf → ⊎-map sucᴺ↑ sucᴺ (cmpᴺ {α} ℓ (x , pf)) ≡ cmpᴺ (suc ℓ) (suc x , pf)
    helper ℓ x pf = cmpᴺ-ind ℓ (x , pf) (λ r → ⊎-map sucᴺ↑ sucᴺ r ≡ cmpᴺ (suc ℓ) (suc x , pf))
                      (λ h pf' → cmpᴺ-ind (suc ℓ) (suc x , pf) (λ r → inl (suc x , pf') ≡ r)
                                         (λ _ _ → ≡.cong inl (name-injective ≡.refl))
                                         (λ h' → ⊥-elim (T'not'¬ h' h)))
                      (λ h pf' → cmpᴺ-ind (suc ℓ) (suc x , pf) (λ r → inr (suc x , pf') ≡ r)
                                         (λ h' → ⊥-elim (T'not'¬ h h'))
                                         (λ _ _ → ≡.cong inr (name-injective ≡.refl)))

-- prim (could be defined with (cmpᴺ 1)
protect↑1 : ∀ {α β} → (Name α → Name β) → Name (α ↑1) → Name (β ↑1)
protect↑1 f x with name x | {-irr-} (name∈α x)
... | zero  | _  = zero , _
... | suc m | pf = sucᴺ↑ (f (m , {-cert-} pf))

-- mkName; _,_; name; name∈α are forbidden from now on (except in proofs).

zeroᴺ↑1+ : ∀ {α} ℓ → Name (α ↑ (1 +ℕ ℓ))
zeroᴺ↑1+ _ = zeroᴺ

infix 10 _ᴺ
_ᴺ : ∀ {α} ℓ → Name (α ↑ suc ℓ)
_ᴺ {α} ℓ = zeroᴺ +ᴺ ℓ ⟨-because (α ↑1 +ᵂ ℓ) ⊆⟨ ⊆-+-↑ ℓ ⟩
                                α ↑1 ↑  ℓ   ⊆⟨ ⊆-exch-↑-↑ ⊆-refl 1 ℓ ⟩
                                α ↑ suc ℓ ∎ -⟩
   where open ⊆-Reasoning

-- Handy name eliminator
subtractWithᴺ : ∀ {a α} {A : Set a} ℓ → A → (Name α → A) → Name (α ↑ ℓ) → A
subtractWithᴺ ℓ v f x = [ const v , f ∘′ subtractᴺ ℓ ]′ (x <ᴺ ℓ)

subtractᴺ? : ∀ {α} ℓ → Name (α ↑ ℓ) →? Name α
subtractᴺ? ℓ = subtractWithᴺ ℓ nothing just

infixl 4 subtractᴺ?
syntax subtractᴺ? k x = x ∸ᴺ? k

private
 module CoeExamples where
  Nameα+→Nameα↑ : ∀ {α} k → Name (α +ᵂ k) → Name (α ↑ k)
  Nameα+→Nameα↑ k = coerceᴺ (⊆-ctx-+↑ ⊆-refl k)
 module Unused where
  open import Data.List using ([]; _∷_; replicate; _++_)
  n∈trueⁿ⁺¹ : ∀ {α} n → n ∈ replicate (suc n) true ++ α
  n∈trueⁿ⁺¹ zero    = _
  n∈trueⁿ⁺¹ (suc n) = n∈trueⁿ⁺¹ n

predᴺ : ∀ {α} → Name (α +1) → Name α
predᴺ = subtractᴺ 1

predᴺ? : ∀ {α} → Name (α ↑1) →? Name α
predᴺ? = subtractᴺ? 1

Name→-to-Nm⟶ : ∀ {b₁ b₂ α} {B : Setoid b₁ b₂} →
                 (Name α → Setoid.Carrier B) → Nm α ⟶ B
Name→-to-Nm⟶ {α = α} {B} f = record { _⟨$⟩_ = f; cong = cong′ }
  where
  open Setoid B renaming (_≈_ to _≈B_)

  cong≡ : ∀ {x y} → x ≡ y → f x ≈B f y
  cong≡ ≡.refl = Setoid.refl B

  cong′ : ∀ {x y} → x ≡ᴺ y → f x ≈B f y
  cong′ = cong≡ ∘ Equality.to-propositional ≡ᴺ-equality
  -- cong′ = Setoid.reflexive ∘ Equality.to-propositional ≡ᴺ-equality

¬Name : ∀ {α} → α ⊆ ø → ¬(Name α)
¬Name α⊆ø = ¬Nameø ∘ coerceᴺ α⊆ø

Name-elim : ∀ {a} {A : Set a} {α} (α⊆ø : α ⊆ ø) (x : Name α) → A
Name-elim x y with ¬Name x y
... | ()

Nameø-elim : ∀ {a} {A : Set a} → Name ø → A
Nameø-elim = Name-elim ⊆-refl

¬Nameø+ : ∀ k → ¬(Name (ø +ᵂ k))
¬Nameø+ = ¬Name ∘ ⊆-ø+

Nameø+-elim : ∀ {a} {A : Set a} k → Name (ø +ᵂ k) → A
Nameø+-elim = Name-elim ∘ ⊆-ø+

Nameø↑→Nameα↑ : ∀ {ℓ} → Name (ø ↑ ℓ) → ∀ {α} → Name (α ↑ ℓ)
Nameø↑→Nameα↑ {ℓ} x = x ⟨-because ⊆-cong-↑ ⊆-ø ℓ -⟩

is0? : ∀ {α} → Name (α ↑1) → Bool
is0? = cmpᴺ-bool 1
-- is0? = [ const true , const false ]′ (x <ᴺ 1)

shiftℕ : ∀ (ℓ k n : ℕ) → ℕ
shiftℕ ℓ k n = if suc n <= ℓ then n else n +ℕ k

shiftᴺ : ∀ {α β} ℓ k → α +ᵂ k ⊆ β → Name (α ↑ ℓ) → Name (β ↑ ℓ)
shiftᴺ ℓ k pf n
  with n <ᴺ ℓ
...  | inl n′ = n′       ⟨-because ⊆-cong-↑ ⊆-ø ℓ -⟩
...  | inr n′ = n′ +ᴺ k  ⟨-because ⊆-trans (⊆-exch-+-+ ⊆-refl ℓ k) (⊆-ctx-+↑ pf ℓ) -⟩

module Singletons where

  SWorld : ℕ → World
  SWorld n = ø ↑1 +ᵂ n

  Nameˢ : ℕ → Set
  Nameˢ = Name ∘ SWorld

  _ˢ : ∀ n → Nameˢ n
  _ˢ n = zeroᴺ +ᴺ n

  addˢ : ∀ {n} k → Nameˢ n → Nameˢ (k +ℕ n)
  addˢ {n} k x = addᴺ k x  ⟨-because ⊆-assoc-+ ⊆-refl n k -⟩

  subtractˢ : ∀ {n} k → Nameˢ (k +ℕ n) → Nameˢ n
  subtractˢ {n} k x = subtractᴺ k (x ⟨-because ⊆-assoc-+′ ⊆-refl n k -⟩)

{-
shiftᴺ-1-1+-
  shiftᴺ 1 (suc k) pf n ≡ shiftᴺ 1 k ? (shiftᴺ 1 1 ? n)
-}

-- Properties

coerceᴺ-names : ∀ {α β} (α⊆β : α ⊆ β) → name ∘ coerceᴺ α⊆β ≗ name
coerceᴺ-names _ _ = ≡.refl

{-
<ᴺ-coerce : ∀ {α} ℓ (x : Name (α ↑ ℓ)) → [ coerceᴺ (⊆-cong-↑ ⊆-ø ℓ) , coerceᴺ (⊆-ctx-+↑ ⊆-refl ℓ) ]′ (x <ᴺ ℓ) ≡ x
<ᴺ-coerce ℓ x with x <ᴺ-bool ℓ | x <ᴺ-name∈α ℓ
... | true  | _ = name-injective ≡.refl
... | false | _ = name-injective ≡.refl
-}

<ᴺ-names : ∀ {α ℓ} {x : Name (α ↑ ℓ)} → [ name , name ]′ (x <ᴺ ℓ) ≡ name x
<ᴺ-names {α} {ℓ} {x} with x <ᴺ-bool ℓ | x <ᴺ-name∈α ℓ
... | true  | _ = ≡.refl
... | false | _ = ≡.refl

Dec-≡ᴺ→≡ : ∀ {α} → Decidable (_≡ᴺ_ {α}) → Decidable _≡_
Dec-≡ᴺ→≡ _≟_ x y with x ≟ y
... | yes x≡y = yes (≡ᴺ⇒≡ x≡y)
... | no  x≢y = no  (x≢y ∘′ ℕs.reflexive ∘′ ≡.cong name)

shiftᴺ-ℓ-0≡coerceᴺ : ∀ {α β} ℓ (pf : α ⊆ β) n → name (shiftᴺ ℓ 0 pf n) ≡ name n
shiftᴺ-ℓ-0≡coerceᴺ ℓ pf x with x <ᴺ-bool ℓ | x <ᴺ-name∈α ℓ
... | true  | _ = ≡.refl
... | false | _ = ≡.refl

pred-shiftℕ-comm : ∀ k x → pred (shiftℕ 1 k (suc x)) ≡ x +ℕ k
pred-shiftℕ-comm k x = ≡.refl

.shift11-predᴺ?-comm :
  ∀ {α β} (pf : α +1 ⊆ β) (x : Name (α ↑1)) →
  predᴺ? (shiftᴺ 1 1 pf x) ≡ coerceᴺ pf ∘ sucᴺ <$> predᴺ? x
shift11-predᴺ?-comm {α} pf x
   = <$>-injective₁ name-injective (≡.trans (helper (name x) {name∈α x} (suc (name x) ≤?ℕ 1)) (<$>-assoc (predᴺ? x)))
  where
    -- getting the name unpacked (and the Dec), works around an Agda bug in 2.2.8.
    .helper : ∀ n {pn : n ∈ α ↑1} → Dec (n <ℕ 1) → let x = n , pn in
             name <$> (predᴺ? (shiftᴺ 1 1 pf x)) ≡ name ∘ (coerceᴺ pf ∘ sucᴺ) <$> predᴺ? x
    helper zero    (no ¬p)         = ⊥-elim (¬p (s≤s z≤n))
    helper .0      (yes (s≤s z≤n)) = ≡.refl
    helper (suc _) (no _)          = ≡.refl

1+ : ∀ {α} → Name α → Name (α +1)
1+ x = x +ᴺ 1

module Name↑⇔Fin where
  open import Data.Fin as Fin

  ⇒ : ∀ n → Name (ø ↑ n) → Fin n
  ⇒ zero    = Nameø-elim
  ⇒ (suc n) = maybe (suc ∘′ ⇒ n) zero ∘′ predᴺ?

  ⇐ : ∀ {α n} → Fin n → Name (α ↑ n)
  ⇐ (zero {n})  = zeroᴺ↑1+ n
  ⇐ (suc i)     = sucᴺ↑ (⇐ i)

{-
  open Singletons
  open ⊆-Reasoning
  f : ∀ {α n} → Fin n → Name (α ↑ n)
  f {α} {zero} ()
  f {α} {suc n} x = coerceᴺ c (sName x′) where
    x′ = Fin.toℕ x
    c′ = ø ↑1 +[ n ∸ℕ x′ ]   ⊆⟨ {!!} ⟩
         (ø +[ n ∸ℕ x′ ]) ↑1 ⊆⟨ ⊆-cong-↑1 (α+⊆ø→α⊆ø _ ⊆-refl) ⟩
         ø ↑1                 ⊆⟨ ⊆-cong-↑1 ⊆-ø ⟩
         α ↑1 ∎
    c : SWorld x′ ⊆ α ↑ (suc n)
    c = SWorld x′                ⊆⟨ refl ⟩
        ø ↑1 +[ x′ ]             ⊆⟨ {!!} ⟩
        ø ↑1 +[ n ∸ℕ x′ ] +[ n ] ⊆⟨ ⊆-ctx-+↑ c′ n ⟩
        α ↑1 ↑ n                 ⊆⟨ ⊆-exch-↑-↑ ⊆-refl 1 n ⟩
        α ↑ suc n ∎
-}

  -- ⇔ : ∀ n → Name (ø ↑ n) ⇔ Fin n
  -- ⇔ n = ?

{-
module Bug where
  record Fin′ (n : ℕ) : Set where
    constructor mkFin
    field
      x    : ℕ
      .x<n : x <ℕ n
  raise : ∀ {n m} → Fin′ n → n ≤ℕ m → Fin′ m
  raise (mkFin x x<n) n≤m = mkFin x (ℕ≤.trans x<n n≤m)
  raise-assoc : ∀ {n m o} p (q : m ≤ℕ o) (x : Fin′ n) → (raise (raise x p) q) ≡ (raise x (ℕ≤.trans p q))
  raise-assoc p q (mkFin x x<n) with raise-assoc p q (mkFin x x<n)
  ... | refl = ?
-}

{-
module Fin′ where
  record Fin′ (n : ℕ) : Set where
    constructor mkFin
    field
      x    : ℕ
      .x<n : x <ℕ n
  zeroF : ∀ {n} → Fin′ (suc n)
  zeroF = mkFin 0 (s≤s z≤n)
  sucF : ∀ {n} → Fin′ n → Fin′ (suc n)
  sucF (mkFin x x<n) = mkFin (suc x) (s≤s x<n)

  raise : ∀ {n} (x : Fin′ n) k → Fin′ (n +ℕ k)
  raise (mkFin x x<n) k = mkFin x (m≤n→m≤n+k x<n)
    where m≤n→m≤n+k : ∀ {m n k} → m ≤ℕ n → m ≤ℕ n +ℕ k
          m≤n→m≤n+k z≤n        = z≤n
          m≤n→m≤n+k (s≤s m≤n)  = s≤s (m≤n→m≤n+k m≤n)
-}

{-
(x : α +ᵂ n) → x ≥ n

(x : α +ᵂ suc n) → x ≢ zeroᴺ
-}

module ℕ⇒Name`α` where
  open WorldSyntax
  open WorldSyntax.El listBoolWorlds
  ⇒ : ∀ `α` x → x ∈ El `α` → Name (El `α`)
  ⇒ (`α` `↑1`) zero    _     = zero , _
  ⇒ (`α` `↑1`) (suc i) pf    = sucᴺ↑ (⇒ `α` i pf)
  ⇒ (`α` `+1`) zero    ()
  ⇒ (`α` `+1`) (suc i) pf    = sucᴺ (⇒ `α` i pf)
  ⇒ `ø`        _       ()

module Name`α`⇔Fin where
  open import Data.Fin as F renaming (_+_ to _+F_)
  open WorldSyntax
  open WorldSyntax.El listBoolWorlds
  open WorldSyntax.Properties listBoolWorlds
  mutual

    ⇒+1 : ∀ `α` → Name (El `α` +1) → Fin (suc (bnd `α`))
    ⇒+1 `α` = F.raise 1 ∘ ⇒ `α` ∘ predᴺ

    ⇒ : ∀ `α` → Name (El `α`) → Fin (bnd `α`)
    ⇒ (`α` `↑1`)  = [ inject+ _ ∘ Name↑⇔Fin.⇒ 1 , ⇒+1 `α` ]′ ∘ cmpᴺ 1
    ⇒ (`α` `+1`)  = ⇒+1 `α`
    ⇒ `ø`         = Nameø-elim

  ⇐₁ : ∀ {n} `α` → (x : Fin n) → toℕ x ∈ El `α` → Name (El `α`)
  ⇐₁ `α` = ℕ⇒Name`α`.⇒ `α` ∘ toℕ

  x∈ø↑x : ∀ {n} (x : Fin n) → toℕ x ∈ (ø ↑ n)
  x∈ø↑x zero    = _
  x∈ø↑x (suc n) = x∈ø↑x n

  ⇐₂ : ∀ {n} → (x : Fin n) → Name (ø ↑ n)
  ⇐₂ {n} x with x∈ø↑x x
  ...         | y       rewrite comm-El-↑ `ø` n = ⇐₁ (`ø` `↑` n) x y

  {- I would have prefered a local `where` here
  ⇐₂ : ∀ {n} → (x : Fin n) → Name (ø ↑ n)
  ⇐₂ {n} x where y = x∈ø↑x x rewrite comm-El-↑ `ø` n = ⇐₁ (`ø` `↑` n) x y
  -}

module WellFormedWorld where
  data WF : World → Set where
    `ø : WF ø
    _`+_ : ∀ {α} (`α : WF α) k → WF (α +ᵂ k)
    _`↑_ : ∀ {α} (`α : WF α) k → WF (α ↑ k)

_+↑ᴺ_ : ∀ {α} → Name α → ∀ ℓ → Name (α ↑ ℓ)
_+↑ᴺ_ x ℓ = coerceᴺ (⊆-ctx-+↑ ⊆-refl ℓ) (x +ᴺ ℓ)

subtractᴺ↑ : ∀ {α} ℓ → Name (α ↑ ℓ) → Name (ø ↑ ℓ) ⊎ Name α
subtractᴺ↑ ℓ x with x <ᴺ ℓ
... | inl x′ = inl x′
... | inr x′ = inr (x′ ∸ᴺ ℓ)

infixl 4 subtractᴺ↑
syntax subtractᴺ↑ ℓ x = x -↑ᴺ ℓ

data WithLim (R : (α β : World) → Set) : (α β : World) → Set where
  mkWithLim : ∀ {α₀ β₀} ℓ (Rα₀β₀ : R α₀ β₀) → WithLim R (α₀ ↑ ℓ) (β₀ ↑ ℓ)

withLim : ∀ {R α β} → R α β → WithLim R α β
withLim = mkWithLim 0

-- functions known to be ``bad'' and that we don't want to export
private
 module Bad where
  Name2ℕ : ∀ {α} → Name α → ℕ
  Name2ℕ = name
  isZero? : ∀ {α} → Name α → Bool
  isZero? (zero  , _) = true
  isZero? (suc _ , _) = false


IDesc: enum (hard-coded)

IDesc: enum (hard-coded)


Fixed doc

Fixed doc

------------------------------------------------------------------------------
-- Definition of mutual inductive predicates
------------------------------------------------------------------------------

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

module FOTC.MutualInductivePredicates where

open import FOTC.Base

------------------------------------------------------------------------------
-- Using mutual inductive predicates

data Even : D → Set
data Odd  : D → Set

data Even where
  ezero : Even zero
  esucc : ∀ {n} → Odd n → Even (succ₁ n)

data Odd where
  osucc : ∀ {n} → Even n → Odd (succ₁ n)

-- Non-mutual induction principles

Even-ind : (A : D → Set) →
           A zero →
           (∀ {n} → Odd n → A (succ₁ n)) →
           ∀ {n} → Even n → A n
Even-ind A A0 h ezero      = A0
Even-ind A A0 h (esucc On) = h On

Odd-ind : (A : D → Set) →
          (∀ {n} → Even n → A (succ₁ n)) →
          ∀ {n} → Odd n → A n
Odd-ind A h (osucc En) = h En

-- Mutual induction principles (from Coq)
Even-mutual-ind :
  (A B : D → Set) →
  A zero →
  (∀ {n} → Odd n → B n → A (succ₁ n)) →
  (∀ {n} → Even n → A n → B (succ₁ n)) →
  ∀ {n} → Even n → A n

Odd-mutual-ind :
  (A B : D → Set) →
  A zero →
  (∀ {n} → Odd n → B n → A (succ₁ n)) →
  (∀ {n} → Even n → A n → B (succ₁ n)) →
  ∀ {n} → Odd n → B n

Even-mutual-ind A B A0 h₁ h₂ ezero      = A0
Even-mutual-ind A B A0 h₁ h₂ (esucc On) = h₁ On (Odd-mutual-ind A B A0 h₁ h₂ On)

Odd-mutual-ind A B A0 h₁ h₂ (osucc En) = h₂ En (Even-mutual-ind A B A0 h₁ h₂ En)

module DisjointSum where
  -- Using a single inductive predicate on D × D (see
  -- Blanchette (2013)).

  _+_ : Set → Set → Set
  _+_ = _∨_

  data EvenOdd : D + D → Set where
    eozero :                            EvenOdd (inj₁ zero)
    eoodd  : {n : D} → EvenOdd (inj₁ n) → EvenOdd (inj₂ (succ₁ n))
    eoeven : {n : D} → EvenOdd (inj₂ n) → EvenOdd (inj₁ (succ₁ n))

  -- Induction principle
  EvenOdd-ind : (A : D + D → Set) →
                A (inj₁ zero) →
                ({n : D} → A (inj₁ n) → A (inj₂ (succ₁ n))) →
                ({n : D} → A (inj₂ n) → A (inj₁ (succ₁ n))) →
                {n : D + D} → EvenOdd n → A n
  EvenOdd-ind A A0 h₁ h₂ eozero       = A0
  EvenOdd-ind A A0 h₁ h₂ (eoodd EOn)  = h₁ (EvenOdd-ind A A0 h₁ h₂ EOn)
  EvenOdd-ind A A0 h₁ h₂ (eoeven EOn) = h₂ (EvenOdd-ind A A0 h₁ h₂ EOn)

  -------------------------------------------------------------------------
  -- From the single inductive predicate to the mutual inductive predicates

  -- Even and Odd from EvenOdd.
  Even' : D → Set
  Even' n = EvenOdd (inj₁ n)

  Odd' : D → Set
  Odd' n = EvenOdd (inj₂ n)

  -- From Even/Odd to Even'/Odd'
  Even→Even' : ∀ {n} → Even n → Even' n
  Odd→Odd'   : ∀ {n} → Odd n → Odd' n

  Even→Even' ezero = eozero
  Even→Even' (esucc On) = eoeven (Odd→Odd' On)

  Odd→Odd' (osucc En) = eoodd (Even→Even' En)

  -- From Even'/Odd' to Even/Odd
  Even'→Even : ∀ {n} → Even' n → Even n
  Odd'→Odd : ∀ {n} → Odd' n → Odd n

  -- Requires K.
  Even'→Even eozero     = ezero
  Even'→Even (eoeven h) = esucc (Odd'→Odd h)

  Odd'→Odd (eoodd h) = osucc (Even'→Even h)

  -- TODO (03 December 2012). From EvenOdd-ind to Even-mutual-ind and
  -- Odd-mutual-ind.

module FunctionSpace where
-- Using a single inductive predicate on D → D

  data EvenOdd : D → D → Set where
    eozero :                         EvenOdd zero (succ₁ zero)
    eoodd  : ∀ {m n} → EvenOdd m n → EvenOdd m (succ₁ m)
    eoeven : ∀ {m n} → EvenOdd m n → EvenOdd (succ₁ n) n

  -- Even and Odd from EvenOdd.
  -- Even' : D → Set
  -- Even' n = EvenOdd zero (succ₁ zero) ∨ EvenOdd (succ₁ n) n

  -- Odd' : D → Set
  -- Odd' n = EvenOdd n (succ₁ n)

  -- -- From Even/Odd to Even'/Odd'
  -- Even→Even' : ∀ {n} → Even n → Even' n
  -- Odd→Odd'   : ∀ {n} → Odd n → Odd' n

  -- Even→Even' ezero      = inj₁ eozero
  -- Even→Even' (esucc On) = inj₂ (eoeven (Odd→Odd' On))

  -- Odd→Odd' (osucc En) = eoodd {!!}

  -- -- From Even'/Odd' to Even/Odd
  -- Even'→Even : ∀ {n} → Even' n → Even n
  -- Odd'→Odd : ∀ {n} → Odd' n → Odd n

  -- Even'→Even (inj₁ x) = {!!}
  -- Even'→Even (inj₂ x) = {!!}

  -- Odd'→Odd h = {!!}

------------------------------------------------------------------------------
-- References
--
-- Blanchette, Jasmin Christian (2013). Relational analysis of
-- (co)inductive predicates, (co)algebraic datatypes, and
-- (co)recursive functions. Software Quality Journal 21.1,
-- pp. 101–126.

------------------------------------------------------------------------------
-- Definition of mutual inductive predicates
------------------------------------------------------------------------------

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

module FOTC.MutualInductivePredicates where

open import FOTC.Base

------------------------------------------------------------------------------
-- Using mutual inductive predicates

data Even : D → Set
data Odd  : D → Set

data Even where
  ezero : Even zero
  esucc : ∀ {n} → Odd n → Even (succ₁ n)

data Odd where
  osucc : ∀ {n} → Even n → Odd (succ₁ n)

-- Non-mutual induction principles

Even-ind : (A : D → Set) →
           A zero →
           (∀ {n} → Odd n → A (succ₁ n)) →
           ∀ {n} → Even n → A n
Even-ind A A0 h ezero      = A0
Even-ind A A0 h (esucc On) = h On

Odd-ind : (A : D → Set) →
          (∀ {n} → Even n → A (succ₁ n)) →
          ∀ {n} → Odd n → A n
Odd-ind A h (osucc En) = h En

-- Mutual induction principles (from Coq)
Even-mutual-ind :
  (A B : D → Set) →
  A zero →
  (∀ {n} → Odd n → B n → A (succ₁ n)) →
  (∀ {n} → Even n → A n → B (succ₁ n)) →
  ∀ {n} → Even n → A n

Odd-mutual-ind :
  (A B : D → Set) →
  A zero →
  (∀ {n} → Odd n → B n → A (succ₁ n)) →
  (∀ {n} → Even n → A n → B (succ₁ n)) →
  ∀ {n} → Odd n → B n

Even-mutual-ind A B A0 h₁ h₂ ezero      = A0
Even-mutual-ind A B A0 h₁ h₂ (esucc On) = h₁ On (Odd-mutual-ind A B A0 h₁ h₂ On)

Odd-mutual-ind A B A0 h₁ h₂ (osucc En) = h₂ En (Even-mutual-ind A B A0 h₁ h₂ En)

module DisjointSum where
  -- Using a single inductive predicate on D × D (see Blanchette).

  _+_ : Set → Set → Set
  _+_ = _∨_

  data EvenOdd : D + D → Set where
    eozero :                            EvenOdd (inj₁ zero)
    eoodd  : {n : D} → EvenOdd (inj₁ n) → EvenOdd (inj₂ (succ₁ n))
    eoeven : {n : D} → EvenOdd (inj₂ n) → EvenOdd (inj₁ (succ₁ n))

  -- Induction principle
  EvenOdd-ind : (A : D + D → Set) →
                A (inj₁ zero) →
                ({n : D} → A (inj₁ n) → A (inj₂ (succ₁ n))) →
                ({n : D} → A (inj₂ n) → A (inj₁ (succ₁ n))) →
                {n : D + D} → EvenOdd n → A n
  EvenOdd-ind A A0 h₁ h₂ eozero       = A0
  EvenOdd-ind A A0 h₁ h₂ (eoodd EOn)  = h₁ (EvenOdd-ind A A0 h₁ h₂ EOn)
  EvenOdd-ind A A0 h₁ h₂ (eoeven EOn) = h₂ (EvenOdd-ind A A0 h₁ h₂ EOn)

  -------------------------------------------------------------------------
  -- From the single inductive predicate to the mutual inductive predicates

  -- Even and Odd from EvenOdd.
  Even' : D → Set
  Even' n = EvenOdd (inj₁ n)

  Odd' : D → Set
  Odd' n = EvenOdd (inj₂ n)

  -- From Even/Odd to Even'/Odd'
  Even→Even' : ∀ {n} → Even n → Even' n
  Odd→Odd'   : ∀ {n} → Odd n → Odd' n

  Even→Even' ezero = eozero
  Even→Even' (esucc On) = eoeven (Odd→Odd' On)

  Odd→Odd' (osucc En) = eoodd (Even→Even' En)

  -- From Even'/Odd' to Even/Odd
  Even'→Even : ∀ {n} → Even' n → Even n
  Odd'→Odd : ∀ {n} → Odd' n → Odd n

  -- Requires K.
  Even'→Even eozero     = ezero
  Even'→Even (eoeven h) = esucc (Odd'→Odd h)

  Odd'→Odd (eoodd h) = osucc (Even'→Even h)

  -- TODO (03 December 2012). From EvenOdd-ind to Even-mutual-ind and
  -- Odd-mutual-ind.

module FunctionSpace where
-- Using a single inductive predicate on D → D

  data EvenOdd : D → D → Set where
    eozero :                         EvenOdd zero (succ₁ zero)
    eoodd  : ∀ {m n} → EvenOdd m n → EvenOdd m (succ₁ m)
    eoeven : ∀ {m n} → EvenOdd m n → EvenOdd (succ₁ n) n

  -- Even and Odd from EvenOdd.
  -- Even' : D → Set
  -- Even' n = EvenOdd zero (succ₁ zero) ∨ EvenOdd (succ₁ n) n

  -- Odd' : D → Set
  -- Odd' n = EvenOdd n (succ₁ n)

  -- -- From Even/Odd to Even'/Odd'
  -- Even→Even' : ∀ {n} → Even n → Even' n
  -- Odd→Odd'   : ∀ {n} → Odd n → Odd' n

  -- Even→Even' ezero      = inj₁ eozero
  -- Even→Even' (esucc On) = inj₂ (eoeven (Odd→Odd' On))

  -- Odd→Odd' (osucc En) = eoodd {!!}

  -- -- From Even'/Odd' to Even/Odd
  -- Even'→Even : ∀ {n} → Even' n → Even n
  -- Odd'→Odd : ∀ {n} → Odd' n → Odd n

  -- Even'→Even (inj₁ x) = {!!}
  -- Even'→Even (inj₂ x) = {!!}

  -- Odd'→Odd h = {!!}

------------------------------------------------------------------------------
-- References
--
-- Blanchette, Jasmin Christian (2013). Relational analysis of
-- (co)inductive predicates, (co)algebraic datatypes, and
-- (co)recursive functions. Software Quality Journal 21.1,
-- pp. 101–126.


IDesc: our Hutton's razor

IDesc: our Hutton's razor


scraps

scraps

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import canonical-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    V : ∀{d Δ} → d val → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    E : ∀{d Δ} → Δ ⊢ d err → ok d Δ
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
  -- constants
  progress TAConst = V VConst

  -- variables
  progress (TAVar x) = abort (somenotnone (! x))

  -- lambdas
  progress (TALam D) = V VLam

  -- applications
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
    -- left applicand value
  progress (TAAp TAConst () D2) | V VConst | _
  progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | V x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FVal x₁)) {!!} )
  progress (TAAp {d2 = d2} D1 MAArr D2) | V (VLam {x = x} {d = d}) | I x₁ = S ([ d2 / x ] d , Step (FHAp1 (FVal VLam) {!!}) (ITLam (FIndet x₁)) {!!} )
    -- errors propagate
  progress (TAAp D1 x₂ D2) | V x | E x₁ = E (EAp2 (FVal x) x₁)
  progress (TAAp D1 x₂ D2) | I x | E x₁ = E (EAp2 (FIndet x) x₁)
  progress (TAAp D1 x₂ D2) | E x | E x₁ = E (EAp1 x) -- NB: could have picked the other one here, too; this is a source of non-determinism
  progress (TAAp D1 x₂ D2) | S x | E x₁ = S {!!}
  progress (TAAp D1 x₂ D2) | E x | _    = E (EAp1 x)
    -- indeterminates
  progress (TAAp D1 x₂ D2) | I i | V v = I (IAp i  (FVal v))
  progress (TAAp D1 x₂ D2) | I x | I x₁ = I (IAp x (FIndet x₁))
    -- either applicand steps
  progress (TAAp D1 x₃ D2) | S (d1' , Step x x₁ x₂)  | _ = S (_ , Step (FHAp2 x) x₁ (FHAp2 x₂))
  progress (TAAp D1 x₄ D2) | _ | S (d2' , Step x₁ x₂ x₃) = S (_ , Step (FHAp1 {!!} x₁) x₂ (FHAp1 {!!} x₃))

  -- empty holes
  progress (TAEHole x x₁) = I IEHole

  -- non-empty holes
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V v = I (INEHole (FVal v))
  progress (TANEHole x₁ D x₂) | I x = I (INEHole (FIndet x))
  progress (TANEHole x₁ D x₂) | E x = E (ENEHole x)
  progress (TANEHole x₃ D x₄) | S (_ , Step x x₁ x₂) = S (_ , Step (FHNEHole x) x₁ (FHNEHole x₂))

  -- casts
  progress (TACast D x)
    with progress D
  progress (TACast TAConst con) | V VConst = S (c , Step (FHCastFinal (FVal VConst)) (ITCast (FVal VConst) TAConst con) (FHFinal (FVal VConst)))
  progress (TACast D m)  | V VLam = S (_ , Step (FHCastFinal (FVal VLam)) (ITCast (FVal VLam) D m) (FHFinal (FVal VLam)))
  progress (TACast D x₁) | I x = I (ICast x)
  progress (TACast D x₁) | E x = E (ECastProp x)
  progress (TACast D x₃) | S (d , Step x x₁ x₂) = S (_ , Step (FHCast x) x₁ (FHCast x₂))


named sums -- im pretty sure its correct and only needs to be indexed by d not also Delta

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

module progress where

  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d')
  data ok : (d : dhexp) → Set where
    V : ∀{d} → d val → ok d
    I : ∀{d} → d indet → ok d
    E : ∀{d Δ} → d err[ Δ ] → ok d
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') → ok d

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ → ok d
  progress TAConst = V VConst
  progress (TAVar x) = abort (somenotnone (! x))
  progress (TALam D) = V VLam
  progress (TAAp D1 x D2)
    with progress D1 | progress D2
  progress (TAAp TAConst () D2) | V VConst | V x₁
  progress {Δ = Δ} (TAAp D1 x₂ D2) | V VLam | V x₁ = S {Δ = Δ} (_ , Step FRefl (ITLam (FVal x₁)) FRefl)
  progress (TAAp D1 x₂ D2) | V x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | V x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | V x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | I x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | E x | S x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | V x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | I x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | E x₁ = {!!}
  progress (TAAp D1 x₂ D2) | S x | S x₁ = {!!}
  progress (TAEHole x x₁) = I IEHole
  progress (TANEHole x D x₁)
    with progress D
  progress (TANEHole x₁ D x₂) | V x = {!!}
  progress (TANEHole x₁ D x₂) | I x = {!!}
  progress (TANEHole x₁ D x₂) | E x = {!!}
  progress (TANEHole x₁ D x₂) | S x = {!!}
  progress (TACast D x)
    with progress D
  progress (TACast D x₁) | V x = {!!}
  progress (TACast D x₁) | I x = {!!}
  progress (TACast D x₁) | E x = {!!}
  progress (TACast D x₁) | S x = {!!}

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

module progress where
  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d val + d indet + d err[ Δ ] + Σ[ d' ∈ dhexp ] (Δ ⊢ d ↦ d') -- todo : make this a record so this is readable
  progress TAConst = Inl VConst
  progress (TAVar x₁) = abort (somenotnone (! x₁))
  progress (TALam D) = Inl VLam
  progress (TAAp D x D₁) with progress D | progress D₁
  progress (TAAp D x₂ D₁) | Inl x | Inl x₁ = Inr (Inr (Inr (_ , (Step {!!} {!!} {!!}))))
  progress (TAAp D x₂ D₁) | Inl x | Inr (Inl x₁) = {!!}
  progress (TAAp D x₂ D₁) | Inl x | Inr (Inr (Inl x₁)) = {!!}
  progress (TAAp D x₂ D₁) | Inl x | Inr (Inr (Inr x₁)) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inl x) | Inl x₁ = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inl x)) | Inl x₁ = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inr x)) | Inl x₁ = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inl x) | Inr (Inl x₁) = {!!}
  progress (TAAp D x₁ D₁) | Inr (Inl x) | Inr (Inr ih2) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inl x)) | Inr (Inl x₁) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inr x)) | Inr (Inl x₁) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inl x)) | Inr (Inr (Inl x₁)) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inl x)) | Inr (Inr (Inr x₁)) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inr x)) | Inr (Inr (Inl x₁)) = {!!}
  progress (TAAp D x₂ D₁) | Inr (Inr (Inr x)) | Inr (Inr (Inr x₁)) = {!!}
  progress (TAEHole x x₁) = Inr (Inl IEHole)
  progress (TANEHole x D x₁) with progress D
  progress (TANEHole x₁ D x₂) | Inl x = {!!}
  progress (TANEHole x₁ D x₂) | Inr (Inl x) = {!!}
  progress (TANEHole x₁ D x₂) | Inr (Inr (Inl x)) = {!!}
  progress (TANEHole x₁ D x₂) | Inr (Inr (Inr x)) = {!!}
  progress (TACast D x) with progress D
  progress (TACast D x₁) | Inl x = Inr (Inr (Inr (_ , Step FRefl (ITCast (FVal x) D x₁) FRefl)))
  progress (TACast D x₁) | Inr (Inl x) = Inr (Inl (ICast x))
  progress (TACast D x₁) | Inr (Inr (Inl x)) = Inr (Inr (Inl {!!} ))
  progress (TACast D x₁) | Inr (Inr (Inr x)) = {!!}