{-# OPTIONS --without-K #-}

open import Prelude
import GSeTT.Syntax
import GSeTT.Rules
open import CaTT.Ps-contexts
open import CaTT.Relation
open import CaTT.Uniqueness-Derivations-Ps
open import CaTT.Decidability-ps
open import CaTT.Fullness
import GSeTT.Typed-Syntax

module CaTT.CaTT where
   J : Set₁
   J = Σ (ps-ctx × Ty) λ {(Γ , A) → A is-full-in Γ }

   open import Globular-TT.Syntax J

   Ty→Pre-Ty : Ty → Pre-Ty
   Tm→Pre-Tm : Tm → Pre-Tm
   Sub→Pre-Sub : Sub → Pre-Sub

   Ty→Pre-Ty ∗ = ∗
   Ty→Pre-Ty (⇒ A t u) = ⇒ (Ty→Pre-Ty A) (Tm→Pre-Tm t) (Tm→Pre-Tm u)

   Tm→Pre-Tm (v x) = Var x
   Tm→Pre-Tm (coh Γ A Afull γ) = Tm-constructor (((Γ , A)) , Afull) (Sub→Pre-Sub γ)

   Sub→Pre-Sub <> = <>
   Sub→Pre-Sub < γ , x ↦ t > = < Sub→Pre-Sub γ , x ↦ Tm→Pre-Tm t >

   _[_]Ty : Ty → Sub → Ty
   _[_]Tm : Tm → Sub → Tm
   _∘ₛ_ : Sub → Sub → Sub

   ∗ [ σ ]Ty = ∗
   ⇒ A t u [ σ ]Ty = ⇒ (A [ σ ]Ty) (t [ σ ]Tm) (u [ σ ]Tm)
   v x [ <> ]Tm = v x
   v x [ < σ , y ↦ t > ]Tm = if x ≡ y then t else ((v x) [ σ ]Tm)
   coh Γ A full γ [ σ ]Tm = coh Γ A full (γ ∘ₛ σ)
   <> ∘ₛ γ = <>
   < γ , x ↦ t > ∘ₛ δ = < γ ∘ₛ δ , x ↦ t [ δ ]Tm >

   GPre-Ty→Ty : GSeTT.Syntax.Pre-Ty → Ty
   GPre-Ty→Ty GSeTT.Syntax.∗ = ∗
   GPre-Ty→Ty (GSeTT.Syntax.⇒ A (GSeTT.Syntax.Var x) (GSeTT.Syntax.Var y)) = ⇒ (GPre-Ty→Ty A) (v x) (v y)

   Ty→Pre-Ty[] : ∀ {A γ} → ((GPre-Ty A) [ Sub→Pre-Sub γ ]Pre-Ty) == Ty→Pre-Ty ((GPre-Ty→Ty A) [ γ ]Ty)
   Tm→Pre-Tm[] : ∀ {x γ} → ((Var x) [ Sub→Pre-Sub γ ]Pre-Tm) == Tm→Pre-Tm ((v x) [ γ ]Tm)
   Ty→Pre-Ty[] {GSeTT.Syntax.∗} {γ} = idp
   Ty→Pre-Ty[] {GSeTT.Syntax.⇒ A (GSeTT.Syntax.Var x) (GSeTT.Syntax.Var y)} {γ} = ap³ ⇒ Ty→Pre-Ty[] (Tm→Pre-Tm[] {x} {γ}) (Tm→Pre-Tm[] {y} {γ})
   Tm→Pre-Tm[] {x} {<>} = idp
   Tm→Pre-Tm[] {x} {< γ , y ↦ t >} with eqdecℕ x y
   ... | inl idp = idp
   ... | inr _ = Tm→Pre-Tm[] {x} {γ}

   dim-Pre-Ty[] : ∀ {A γ} → dim (Ty→Pre-Ty ((GPre-Ty→Ty A) [ γ ]Ty)) == dim (GPre-Ty A)
   dim-Pre-Ty[] {GSeTT.Syntax.∗} {γ} = idp
   dim-Pre-Ty[] {GSeTT.Syntax.⇒ A (GSeTT.Syntax.Var _) (GSeTT.Syntax.Var _)} {γ} = ap S dim-Pre-Ty[]

   rule : J → GSeTT.Typed-Syntax.Ctx × Pre-Ty
   rule ((Γ , A) , _) = (fst Γ , Γ⊢ps→Γ⊢ (snd Γ)) , Ty→Pre-Ty A

   open GSeTT.Typed-Syntax
   open import Sets ℕ eqdecℕ

   open import Globular-TT.Rules J rule
   open import Globular-TT.CwF-Structure J rule

   eqdecJ : eqdec J
   eqdecJ ((Γ , A) , Afull) ((Γ' , A') , A'full) with eqdec-ps Γ Γ' | CaTT.Fullness.eqdec-Ty A A'
   ...                                           | inl idp | inl idp = inl (ap (λ X → ((Γ , A) , X)) (is-prop-has-all-paths (is-prop-full Γ A) Afull A'full))
   ...                                           | inr Γ≠Γ' | _ = inr λ{idp → Γ≠Γ' idp}
   ...                                           | inl idp | inr A≠A' = inr λ{A=A' → A≠A' (snd (=, (fst-is-inj A=A')))}

   open import Globular-TT.Uniqueness-Derivations J rule eqdecJ
   open import Globular-TT.Disks J rule eqdecJ

   dim-tm : ∀ {Γ x A} → Γ ⊢t Var x # A → ℕ
   dim-tm {Γ} {x} {A} _ = dim A

   GdimT : ∀ {A} → GSeTT.Syntax.dim A == dim (GPre-Ty A)
   GdimT {GSeTT.Syntax.∗} = idp
   GdimT {GSeTT.Syntax.⇒ A _ _} = ap S GdimT

   GdimC : ∀ {Γ} → GSeTT.Syntax.dimC Γ == dimC (GPre-Ctx Γ)
   GdimC {nil} = idp
   GdimC {Γ :: (x , A)} = ap² max (GdimC {Γ}) GdimT

   G#∈ : ∀ {Γ x A} → x GSeTT.Syntax.# A ∈ Γ → x # (GPre-Ty A) ∈ (GPre-Ctx Γ)
   G#∈ {Γ :: a} (inl x∈Γ) = inl (G#∈ x∈Γ)
   G#∈ {Γ :: a} (inr (idp , idp)) = inr (idp , idp)

   G∈ : ∀ {Γ x} → x GSeTT.Syntax.∈ Γ → x ∈-set (varC Γ)
   G∈ {Γ :: (a , _)} (inl x∈Γ) = ∈-∪₁ {A = varC Γ} {B = singleton a} (G∈ x∈Γ)
   G∈ {Γ :: (x , _)} (inr idp) = ∈-∪₂ {A = varC Γ} {B = singleton x} (∈-singleton x)

   private
     every-term-has-variables : ∀ {Γ t A} → Γ ⊢t (Tm→Pre-Tm t) # A → Σ ℕ λ x → x ∈-set vart t
     every-term-has-variables {Γ} {v x} {A} Γ⊢t = x , ∈-singleton x
     every-term-has-variables {Γ} {coh (nil , (ps Δ⊢ps)) _ _ γ} {A} (tm _ Γ⊢γ idp) = ⊥-elim (∅-is-not-ps _ _ Δ⊢ps)
     every-term-has-variables {Γ} {coh ((_ :: _) , Δ⊢ps) _ _ <>} {A} (tm _ () idp)
     every-term-has-variables {Γ} {coh ((_ :: _) , Δ⊢ps) _ _ < γ , _ ↦ u >} {A} (tm _ (sc _ _ Γ⊢u _) idp) with every-term-has-variables Γ⊢u
     ... | (x , x∈) = x , ∈-∪₂ {A = varS γ} {B = vart u} x∈

     side-cond₁-not𝔻0 : ∀ Γ Γ⊢ps A t → (GPre-Ctx Γ) ⊢t (Tm→Pre-Tm t) # (Ty→Pre-Ty A) → ((varT A) ∪-set (vart t)) ⊂ (src-var (Γ , Γ⊢ps)) → Γ ≠ (nil :: (0 , GSeTT.Syntax.∗))
     side-cond₁-not𝔻0 .(nil :: (0 , GSeTT.Syntax.∗)) (ps pss) A t Γ⊢t incl idp with every-term-has-variables Γ⊢t | dec-≤ 0 0
     ... | x , x∈A | inl _ = incl _ (∈-∪₂ {A = varT A} {B = vart t} x∈A)
     ... | x , x∈A | inr _ = incl _ (∈-∪₂ {A = varT A} {B = vart t} x∈A)
     side-cond₁-not𝔻0 .(nil :: (0 , GSeTT.Syntax.∗)) (ps (psd Γ⊢psf)) A t Γ⊢t incl idp = ⇒≠∗ (𝔻0-type _ _ (psvar Γ⊢psf))

   max-srcᵢ-var-def : ∀ {Γ x A i} → (Γ⊢psx : Γ ⊢ps x # A) → 0 < i → ℕ × Pre-Ty
   max-srcᵢ-var-def pss _ = 0 , ∗
   max-srcᵢ-var-def (psd Γ⊢psx) 0<i = max-srcᵢ-var-def Γ⊢psx 0<i
   max-srcᵢ-var-def {_} {x} {A} {i} (pse Γ⊢psx idp idp idp idp idp) 0<i  with dec-≤ i (GSeTT.Syntax.dim A)
   ... | inl i≤dA = max-srcᵢ-var-def Γ⊢psx 0<i
   ... | inr dA<i with dec-≤ (GSeTT.Syntax.dim A) (dim (snd (max-srcᵢ-var-def Γ⊢psx 0<i)))
   ... | inl _ = max-srcᵢ-var-def Γ⊢psx 0<i
   ... | inr _ = x , GPre-Ty A

   max-srcᵢ-var-∈ : ∀ {Γ x A i} → (Γ⊢psx : Γ ⊢ps x # A) → (0<i : 0 < i) → fst (max-srcᵢ-var-def Γ⊢psx 0<i) ∈-list (srcᵢ-var i Γ⊢psx)
   max-srcᵢ-var-∈ pss 0<i = transport {B = 0 ∈-list_} (simplify-if 0<i ^) (inr idp)
   max-srcᵢ-var-∈ (psd Γ⊢psx) 0<i = max-srcᵢ-var-∈ Γ⊢psx 0<i
   max-srcᵢ-var-∈ {Γ} {x} {A} {i} (pse Γ⊢psx idp idp idp idp idp) 0<i with dec-≤ i (GSeTT.Syntax.dim A)
   ... | inl _ = max-srcᵢ-var-∈ Γ⊢psx 0<i
   ... | inr _  with dec-≤ (GSeTT.Syntax.dim A) (dim (snd (max-srcᵢ-var-def Γ⊢psx 0<i)))
   ... | inl _ = inl (inl (max-srcᵢ-var-∈ Γ⊢psx 0<i))
   ... | inr _ = inr idp

   max-srcᵢ-var-⊢ : ∀ {Γ x A i} → (Γ⊢psx : Γ ⊢ps x # A) → (0<i : 0 < i) → GPre-Ctx Γ ⊢t Var (fst (max-srcᵢ-var-def Γ⊢psx 0<i)) # snd (max-srcᵢ-var-def Γ⊢psx 0<i)
   max-srcᵢ-var-⊢ pss 0<i = var (cc ec (ob ec) idp) (inr (idp , idp))
   max-srcᵢ-var-⊢ (psd Γ⊢psx) 0<i = max-srcᵢ-var-⊢ Γ⊢psx 0<i
   max-srcᵢ-var-⊢ {Γ} {x} {A} {i} Γ+⊢ps@(pse Γ⊢psx idp idp idp idp idp) 0<i with dec-≤ i (GSeTT.Syntax.dim A)
   ... | inl _ = wkt (wkt (max-srcᵢ-var-⊢ Γ⊢psx 0<i) ((GCtx _ (GSeTT.Rules.Γ,x:A⊢→Γ⊢ (psv Γ+⊢ps))))) (GCtx _ (psv Γ+⊢ps))
   ... | inr _  with dec-≤ (GSeTT.Syntax.dim A) (dim (snd (max-srcᵢ-var-def Γ⊢psx 0<i)))
   ... | inl _ = wkt (wkt (max-srcᵢ-var-⊢ Γ⊢psx 0<i) ((GCtx _ (GSeTT.Rules.Γ,x:A⊢→Γ⊢ (psv Γ+⊢ps))))) (GCtx _ (psv Γ+⊢ps))
   ... | inr _ = var (GCtx _ (psv Γ+⊢ps)) (inr (idp , idp))

   max-srcᵢ-var-dim : ∀ {Γ x A i} → (Γ⊢psx : Γ ⊢ps x # A) → (0<i : 0 < i) →  min i (S (dimC (GPre-Ctx Γ))) == S (dim (snd (max-srcᵢ-var-def Γ⊢psx 0<i)))
   max-srcᵢ-var-dim pss 0<i = simplify-min-r 0<i
   max-srcᵢ-var-dim (psd Γ⊢psx) 0<i = max-srcᵢ-var-dim Γ⊢psx 0<i
   max-srcᵢ-var-dim {Γ} {x} {A} {i} (pse {Γ = Δ} Γ⊢psx idp idp idp idp idp) 0<i with dec-≤ i (GSeTT.Syntax.dim A)
   ... | inl i≤dA = simplify-min-l (n≤m→n≤Sm (≤T (≤-= i≤dA (GdimT {A})) (m≤max (max (dimC (GPre-Ctx Δ)) _) (dim (GPre-Ty A))) )) >> (simplify-min-l (≤T i≤dA (≤-= (S≤ (dim-dangling Γ⊢psx)) (ap S (GdimC {Δ})))) ^) >> max-srcᵢ-var-dim Γ⊢psx 0<i
   max-srcᵢ-var-dim {Γ} {x} {A} {i} (pse {Γ = Δ} Γ⊢psx idp idp idp idp idp) 0<i | inr dA<i with dec-≤ (GSeTT.Syntax.dim A) (dim (snd (max-srcᵢ-var-def Γ⊢psx 0<i)))
   ... | inl dA≤m = let dA<dΔ = (S≤S (≤T (=-≤-= (ap S (GdimT {A} ^)) (S≤ dA≤m) (max-srcᵢ-var-dim Γ⊢psx 0<i ^)) (min≤m i (S (dimC (GPre-Ctx Δ)))))) in
                    ap (min i)
                    (ap S (simplify-max-l {max (dimC (GPre-Ctx Δ)) _} {dim (GPre-Ty A)} (≤T dA<dΔ (n≤max _ _))
                           >> simplify-max-l {dimC (GPre-Ctx Δ)} {_} (Sn≤m→n≤m dA<dΔ)))
                    >> max-srcᵢ-var-dim Γ⊢psx 0<i
   ... | inr m<dA = simplify-min-r {i} {S (max (max (dimC (GPre-Ctx Δ)) _) (dim (GPre-Ty A)))}
                      (up-maxS {max (dimC (GPre-Ctx Δ)) _} {dim (GPre-Ty A)}
                               (up-maxS {dimC (GPre-Ctx Δ)} {_}
                                  (min<l (=-≤ (ap S (max-srcᵢ-var-dim Γ⊢psx 0<i)) (≤T (S≤ (≰ m<dA)) (≰ dA<i))))
                                  (=-≤ (GdimT {A} ^) (≤T (n≤Sn _) (≰ dA<i))))
                               (=-≤ (ap S (GdimT {A}) ^) (≰ dA<i)))
                    >> ap S (simplify-max-r {max (dimC (GPre-Ctx Δ)) _} {dim (GPre-Ty A)}
                            (up-max {dimC (GPre-Ctx Δ)} {_} (≤-= (Sn≤m→n≤m (greater-than-min-r (≰ dA<i) (=-≤ (max-srcᵢ-var-dim Γ⊢psx 0<i) (≰ m<dA)))) (ap S GdimT)) (n≤Sn _)))

   max-srcᵢ-var : ∀ {Γ x A i} → (Γ⊢psx : Γ ⊢ps x # A) → 0 < i → Σ (Σ (ℕ × Pre-Ty) (λ {(x , B) → GPre-Ctx Γ ⊢t Var x # B})) (λ {((x , B) , Γ⊢x) → (x ∈-list (srcᵢ-var i Γ⊢psx)) × (min i (S (dimC (GPre-Ctx Γ))) == S (dim-tm Γ⊢x))})
   max-srcᵢ-var Γ⊢psx 0<i = (max-srcᵢ-var-def Γ⊢psx 0<i , max-srcᵢ-var-⊢ Γ⊢psx 0<i) , (max-srcᵢ-var-∈ Γ⊢psx 0<i , max-srcᵢ-var-dim Γ⊢psx 0<i)

   max-src-var : ∀ Γ → (Γ⊢ps : Γ ⊢ps) → (Γ ≠ (nil :: (0 , GSeTT.Syntax.∗))) → Σ (Σ (ℕ × Pre-Ty) (λ {(x , B) → GPre-Ctx Γ ⊢t Var x # B})) (λ {((x , B) , Γ⊢x) → (x ∈-set (src-var (Γ , Γ⊢ps))) × (dimC (GPre-Ctx Γ) == S (dim-tm Γ⊢x))})
   max-src-var Γ Γ⊢ps@(ps Γ⊢psx) Γ≠𝔻0 with max-srcᵢ-var {i = GSeTT.Syntax.dimC Γ} Γ⊢psx (dim-ps-not-𝔻0 Γ⊢ps Γ≠𝔻0)
   ... | ((x , B) , (x∈ , p)) = (x , B) , (∈-list-∈-set _ _ x∈ , (ap (λ n → min n (S (dimC (GPre-Ctx Γ)))) (GdimC {Γ}) >> simplify-min-l (n≤Sn _) ^ >> p) )

   full-term-have-max-variables : ∀ {Γ A Γ⊢ps} → GPre-Ctx Γ ⊢T (Ty→Pre-Ty A) → A is-full-in ((Γ , Γ⊢ps)) →
     Σ (Σ (ℕ × Pre-Ty) (λ {(x , B) → GPre-Ctx Γ ⊢t Var x # B})) (λ {((x , B) , Γ⊢x) → (x ∈-set varT A) × (dimC (GPre-Ctx Γ) ≤ S (dim-tm Γ⊢x))})
   full-term-have-max-variables {Γ} {_} {Γ⊢ps} Γ⊢A (side-cond₁ .(_ , _) A t u (incl , incl₂) _) with max-src-var Γ Γ⊢ps (side-cond₁-not𝔻0 _ Γ⊢ps A t (Γ⊢src Γ⊢A) incl₂)
   ... | ((x , B) , Γ⊢x) , (x∈src , dimΓ=Sdimx) = ((x , B) , Γ⊢x) , (A∪B⊂A∪B∪C (varT A) (vart t) (vart u) _ (incl _ x∈src) , transport {B = λ x → (dimC (GPre-Ctx Γ)) ≤ x} dimΓ=Sdimx (n≤n _))
   full-term-have-max-variables {Γ} {_} {Γ⊢ps@(ps Γ⊢psx)} _ (side-cond₂ .(_ , _) _ (incl , _)) with max-var {Γ} Γ⊢ps
   ... | (x , B) , (x∈Γ , dimx) = ((x , (GPre-Ty B)) , var (GCtx Γ (psv Γ⊢psx)) (G#∈ x∈Γ)) , (incl _ (G∈ (x#A∈Γ→x∈Γ x∈Γ)) , ≤-= (=-≤ ((GdimC {Γ} ^) >> dimx) (n≤Sn _)) (ap S GdimT))

   dim-∈-var : ∀ {Γ A x B} → Γ ⊢t Var x # B → Γ ⊢T (Ty→Pre-Ty A) → x ∈-set varT A → dim B < dim (Ty→Pre-Ty A)
   dim-∈-var-t : ∀ {Γ t A x B} → Γ ⊢t Var x # B → Γ ⊢t (Tm→Pre-Tm t) # (Ty→Pre-Ty A) → x ∈-set vart t → dim B ≤ dim (Ty→Pre-Ty A)
   dim-∈-var-S : ∀ {Δ γ Γ x B} → Δ ⊢t Var x # B → Δ ⊢S (Sub→Pre-Sub γ) > (GPre-Ctx Γ) → x ∈-set varS γ → dim B ≤ dimC (GPre-Ctx Γ)
   dim-full-ty : ∀ {Γ A} → (Γ⊢ps : Γ ⊢ps) → (GPre-Ctx Γ) ⊢T (Ty→Pre-Ty A) → A is-full-in (Γ , Γ⊢ps) → dimC (GPre-Ctx Γ) ≤ dim (Ty→Pre-Ty A)

   dim-∈-var {Γ} {A⇒@(⇒ A t u)} {x} {B} Γ⊢x (ar Γ⊢A Γ⊢t Γ⊢u) x∈A⇒ with ∈-∪ {varT A} {vart t ∪-set vart u} x∈A⇒
   ... | inl x∈A = n≤m→n≤Sm (dim-∈-var Γ⊢x Γ⊢A x∈A)
   ... | inr x∈t∪u with ∈-∪ {vart t} {vart u} x∈t∪u
   ... | inl x∈t = S≤ (dim-∈-var-t Γ⊢x Γ⊢t x∈t)
   ... | inr x∈u = S≤ (dim-∈-var-t Γ⊢x Γ⊢u x∈u)
   dim-∈-var-t {t = v x} Γ⊢x Γ⊢t (inr idp) with unique-type Γ⊢x Γ⊢t (ap Var idp)
   ... | idp = n≤n _
   dim-∈-var-t {t = coh Γ A Afull γ} Γ⊢x (tm Γ⊢A Δ⊢γ:Γ p) x∈t = ≤-= (≤T (dim-∈-var-S Γ⊢x Δ⊢γ:Γ x∈t) (dim-full-ty (snd Γ) Γ⊢A Afull) ) ((dim[] _ _ ^) >> ap dim (p ^))
   dim-∈-var-S {Δ} {< γ , y ↦ t >} {Γ :: (_ , A)} {x} {B} Δ⊢x (sc Δ⊢γ:Γ Γ+⊢ Δ⊢t idp) x∈γ+ with ∈-∪ {varS γ} {vart t} x∈γ+
   ... | inl x∈γ = ≤T (dim-∈-var-S Δ⊢x Δ⊢γ:Γ x∈γ) (n≤max _ _)
   ... | inr x∈t = ≤T (dim-∈-var-t Δ⊢x (transport {B = Δ ⊢t (Tm→Pre-Tm t) #_} Ty→Pre-Ty[] Δ⊢t) x∈t) (=-≤ (dim-Pre-Ty[]) (m≤max (dimC (GPre-Ctx Γ)) (dim (GPre-Ty A))))
   dim-full-ty Γ⊢ps Γ⊢A Afull with full-term-have-max-variables Γ⊢A Afull
   ... | ((x , B) , Γ⊢x) , (x∈A , dimx) = ≤T dimx (dim-∈-var Γ⊢x Γ⊢A x∈A)

   well-foundedness : well-founded
   well-foundedness ((Γ , A) , Afull) Γ⊢A with full-term-have-max-variables Γ⊢A Afull
   ... |((x , B) , Γ⊢x) , (x∈Γ , dimΓ≤Sdimx) = ≤T dimΓ≤Sdimx (dim-∈-var Γ⊢x Γ⊢A x∈Γ)

   open import Globular-TT.Dec-Type-Checking J rule well-foundedness eqdecJ


open import Data.Product using ( _,_ ; proj₁ ; proj₂ )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Relation.Binary.PropositionalEquality using ( refl )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.ABox using ( ABox ; _,_ ; ⟨ABox⟩ )
open import Web.Semantic.DL.ABox.Interp using ( Interp ; _,_ ; ⌊_⌋ ; ind ; _*_ )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; _,_ ; ≲⌊_⌋ ; ≲-resp-ind ; _**_ ; ≡³-impl-≈ ; ≡³-impl-≲ )
open import Web.Semantic.DL.ABox.Model using
  ( _⊨a_ ; _⊨b_ ; bnodes ; on-bnode ; _,_
  ; ⟨ABox⟩-resp-⊨ ; ⊨a-resp-≲ ; *-resp-⟨ABox⟩ )
open import Web.Semantic.DL.Category.Morphism using
  ( _⇒_ ; _⇒_w/_ ; _,_ ; BN ; impl ; impl✓ )
open import Web.Semantic.DL.Category.Object using
  ( Object ; _,_ ; IN ; fin ; iface )
open import Web.Semantic.DL.Integrity using
  ( _⊕_⊨_ ; Unique ; Mediated ; Mediator ; Initial
  ; _,_ ; extension ; ext-init ; ext-⊨ ; ext✓ ; init-≲ )
open import Web.Semantic.DL.KB using ( _,_ )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox ; _,_ )
open import Web.Semantic.DL.TBox.Interp using
  ( Δ ; _⊨_≈_ ; ≈-refl ; ≈-sym ; ≈-trans )
open import Web.Semantic.DL.TBox.Model using ( _⊨t_ )
open import Web.Semantic.DL.TBox.Interp.Morphism using
  ( ≲-image ; ≲-resp-≈ ; ≲-trans ) renaming ( _≲_ to _≲′_ )
open import Web.Semantic.Util using
  ( _∘_ ; Finite ; ⊎-resp-Fin ; _⊕_⊕_ ; inode ; bnode ; enode ; up ; down ; vmerge )

module Web.Semantic.DL.Category.Tensor {Σ : Signature} where

_&_ : ∀ {X₁ X₂} → ABox Σ X₁ → ABox Σ X₂ → ABox Σ (X₁ ⊎ X₂)
A₁ & A₂ = (⟨ABox⟩ inj₁ A₁ , ⟨ABox⟩ inj₂ A₂)

_⊗_ : ∀ {S T : TBox Σ} → Object S T → Object S T →  Object S T
A₁ ⊗ A₂ =
  ( (IN A₁ ⊎ IN A₂)
  , ⊎-resp-Fin (fin A₁) (fin A₂)
  , iface A₁ & iface A₂ )

_⟨&⟩_ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} →
  ABox Σ (X₁ ⊕ V₁ ⊕ Y₁) → ABox Σ (X₂ ⊕ V₂ ⊕ Y₂) →
    ABox Σ ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))
F₁ ⟨&⟩ F₂ = (⟨ABox⟩ up F₁ , ⟨ABox⟩ down F₂)

⊨a-intro-⟨&⟩ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} →
  (I : Interp Σ ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))) →
    (F₁ : ABox Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (F₂ : ABox Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
      (up * I ⊨a F₁) → (down * I ⊨a F₂) → (I ⊨a F₁ ⟨&⟩ F₂)
⊨a-intro-⟨&⟩ (I , i) F₁ F₂ I₁⊨F₁ I₂⊨F₂ =
  ( ⟨ABox⟩-resp-⊨ up (λ x → ≈-refl I) F₁ I₁⊨F₁
  , ⟨ABox⟩-resp-⊨ down (λ x → ≈-refl I) F₂ I₂⊨F₂ )

⊨b-intro-⟨&⟩ : ∀ {V₁ V₂ W₁ W₂ X₁ X₂ Y₁ Y₂} →
  (I : Interp Σ ((X₁ ⊎ X₂) ⊕ (W₁ ⊎ W₂) ⊕ (Y₁ ⊎ Y₂))) →
    (F₁ : ABox Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (F₂ : ABox Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
      (up * I ⊨b F₁) → (down * I ⊨b F₂) → (I ⊨b F₁ ⟨&⟩ F₂)
⊨b-intro-⟨&⟩ {V₁} {V₂} I F₁ F₂ (f₁ , I₁⊨F₁) (f₂ , I₂⊨F₂) =
  (f , I⊨F₁F₂) where

  f : (V₁ ⊎ V₂) → Δ ⌊ I ⌋
  f (inj₁ v) = f₁ v
  f (inj₂ v) = f₂ v

  I⊨F₁F₂ : bnodes I f ⊨a F₁ ⟨&⟩ F₂
  I⊨F₁F₂ =
    ( ⟨ABox⟩-resp-⊨ up
        (≡³-impl-≈ ⌊ I ⌋ (on-bnode f₁ (ind I ∘ up))
          (on-bnode f (ind I) ∘ up) refl)
        F₁ I₁⊨F₁
    , ⟨ABox⟩-resp-⊨ down
        (≡³-impl-≈ ⌊ I ⌋ (on-bnode f₂ (ind I ∘ down))
          (on-bnode f (ind I) ∘ down) refl)
        F₂ I₂⊨F₂ )

go₂ : ∀ {V₁ X₁ X₂ Y₁} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (⌊ I ⌋ ≲′ ⌊ J₁ ⌋) →
    Interp Σ X₂
go₂ I J₁ I≲J = (⌊ J₁ ⌋ , ≲-image I≲J ∘ ind I ∘ inj₂)

go₂-≳ : ∀ {V₁ X₁ X₂ Y₁} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (I≲J : ⌊ I ⌋ ≲′ ⌊ J₁ ⌋) →
    (inj₂ * I ≲ go₂ I J₁ I≲J)
go₂-≳ I (J , j₁) I≲J = (I≲J , λ x → ≈-refl J)

go₂-≲ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) →
    (L : Interp Σ ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))) →
      (I₁≲J₁ : inj₁ * I ≲ inode * J₁) → (I≲L : I ≲ inode * L) →
        (Mediated (inj₁ * I) J₁ (up * L) I₁≲J₁ (inj₁ ** I≲L)) →
          (go₂ I J₁ ≲⌊ I₁≲J₁ ⌋ ≲ inode * (down * L))
go₂-≲ (I , i) (J , j₁) (L , l) (I≲J , i₁≲j₁) (I≲L , i≲l)
  ((J≲L , j₁≲l₁) , I≲L≋I≲J≲L , J₁≲L₁-uniq) =
    (J≲L , λ x → ≈-trans L (≈-sym L (I≲L≋I≲J≲L (i (inj₂ x)))) (i≲l (inj₂ x)))

par : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) →
  (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) → (⌊ J₁ ⌋ ≲′ ⌊ K₂ ⌋) →
    Interp Σ ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))
par J₁ K₂ J≲K =
  (⌊ K₂ ⌋ , vmerge (≲-image J≲K ∘ ind J₁) (ind K₂))

par-inj₁ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) →
  (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) → (J≲K : ⌊ J₁ ⌋ ≲′ ⌊ K₂ ⌋) →
    (J₁ ≲ up * par J₁ K₂ J≲K)
par-inj₁ (J , j₁) (K , k₂) J≲K =
  ( J≲K
  , ≡³-impl-≈ K
      (≲-image J≲K ∘ j₁)
      (vmerge (≲-image J≲K ∘ j₁) k₂ ∘ up)
      refl )

par-inj₂ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) →
  (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) → (J≲K : ⌊ J₁ ⌋ ≲′ ⌊ K₂ ⌋) →
    (K₂ ≲ down * par J₁ K₂ J≲K)
par-inj₂ (J , j₁) (K , k₂) J≲K =
  ≡³-impl-≲ (K , k₂) (vmerge (≲-image J≲K ∘ j₁) k₂ ∘ down) refl

par-exp : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) →
  (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) → (J≲K : ⌊ J₁ ⌋ ≲′ ⌊ K₂ ⌋) →
    (T : TBox Σ) → (B₁ : ABox Σ Y₁) → (B₂ : ABox Σ Y₂) →
      (enode * J₁ ⊨ T , B₁) → (enode * K₂ ⊨ T , B₂) →
        (enode * (par J₁ K₂ J≲K) ⊨ T , (B₁ & B₂))
par-exp J₁ K₂ J≲K T B₁ B₂ (J⊨T , J₁⊨B₁) (K⊨T , K₂⊨B₂) =
  ( K⊨T
  , ⟨ABox⟩-resp-⊨ inj₁ (λ y → ≈-refl ⌊ K₂ ⌋) B₁
      (⊨a-resp-≲ (enode ** par-inj₁ J₁ K₂ J≲K) B₁ J₁⊨B₁)
  , ⟨ABox⟩-resp-⊨ inj₂ (λ y → ≈-refl ⌊ K₂ ⌋) B₂ K₂⊨B₂)

par-≳ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
    (I₁≲J₁ : inj₁ * I ≲ inode * J₁) →
      (J₂≲K₂ : go₂ I J₁ ≲⌊ I₁≲J₁ ⌋ ≲ inode * K₂) →
        (I ≲ inode * par J₁ K₂ ≲⌊ J₂≲K₂ ⌋)
par-≳ I J₁ K₂ (I≲J , i₁≲j₁) (J≲K , j₂≲k₂) =
  ( ≲-trans I≲J J≲K , lemma ) where

  lemma : ∀ x → ⌊ K₂ ⌋ ⊨
    ≲-image J≲K (≲-image I≲J (ind I x)) ≈
      vmerge (≲-image J≲K ∘ ind J₁) (ind K₂) (inode x)
  lemma (inj₁ x) = ≲-resp-≈ J≲K (i₁≲j₁ x)
  lemma (inj₂ x) = j₂≲k₂ x

par-impl : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) →
  (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) → (J≲K : ⌊ J₁ ⌋ ≲′ ⌊ K₂ ⌋) →
    (F₁ : ABox Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (F₂ : ABox Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
      (J₁ ⊨a F₁) → (K₂ ⊨a F₂) →
        (par J₁ K₂ J≲K ⊨a F₁ ⟨&⟩ F₂)
par-impl J₁ K₂ J≲K F₁ F₂ J₁⊨F₁ K₂⊨F₂ =
  ( ⟨ABox⟩-resp-⊨ up (λ x → ≈-refl ⌊ K₂ ⌋) F₁
      (⊨a-resp-≲ (par-inj₁ J₁ K₂ J≲K) F₁ J₁⊨F₁)
  , ⟨ABox⟩-resp-⊨ down (λ x → ≈-refl ⌊ K₂ ⌋) F₂
      (⊨a-resp-≲ (par-inj₂ J₁ K₂ J≲K) F₂ K₂⊨F₂) )

par-mediated : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
    (L : Interp Σ ((X₁ ⊎ X₂) ⊕ (V₁ ⊎ V₂) ⊕ (Y₁ ⊎ Y₂))) →
      (I₁≲J₁ : inj₁ * I ≲ inode * J₁) → (I≲L : I ≲ inode * L) →
        (J₂≲K₂ : go₂ I J₁ ≲⌊ I₁≲J₁ ⌋ ≲ inode * K₂) →
          (m : Mediated (inj₁ * I) J₁ (up * L) I₁≲J₁ (inj₁ ** I≲L)) →
            (Mediated (go₂ I J₁ ≲⌊ I₁≲J₁ ⌋) K₂ (down * L) J₂≲K₂ (go₂-≲ I J₁ L I₁≲J₁ I≲L m)) →
              (Mediated I (par J₁ K₂ ≲⌊ J₂≲K₂ ⌋) L (par-≳ I J₁ K₂ I₁≲J₁ J₂≲K₂) I≲L)
par-mediated (I , i) (J , j₁) (K , k₂) (L , l) (I≲J , i₁≲j₁) (I≲L , i≲l) (J≲K , j₂≲k₂)
  ((J≲L , j₁≲l₁) , I≲L≋I≲J≲L , J₁≲L₁-uniq) ((K≲L , k₂≲l₂) , J≲L≋J≲K≲L , K₂≲L₂-uniq) =
    ((K≲L , k≲l) , I≲L≋I≲K≲L , K≲L-uniq) where

  k = vmerge (≲-image J≲K ∘ j₁) k₂

  I≲K : I ≲′ K
  I≲K = ≲-trans I≲J J≲K

  i≲k : ∀ x → K ⊨ ≲-image I≲K (i x) ≈ k (inode x)
  i≲k = ≲-resp-ind (par-≳ (I , i) (J , j₁) (K , k₂) (I≲J , i₁≲j₁) (J≲K , j₂≲k₂))

  k≲l : ∀ x → L ⊨ ≲-image K≲L (k x) ≈ l x
  k≲l (inode (inj₁ x)) = ≈-trans L (≈-sym L (J≲L≋J≲K≲L (j₁ (inode x)))) (j₁≲l₁ (inode x))
  k≲l (inode (inj₂ x)) = k₂≲l₂ (inode x)
  k≲l (bnode (inj₁ v)) = ≈-trans L (≈-sym L (J≲L≋J≲K≲L (j₁ (bnode v)))) (j₁≲l₁ (bnode v))
  k≲l (bnode (inj₂ v)) = k₂≲l₂ (bnode v)
  k≲l (enode (inj₁ y)) = ≈-trans L (≈-sym L (J≲L≋J≲K≲L (j₁ (enode y)))) (j₁≲l₁ (enode y))
  k≲l (enode (inj₂ y)) = k₂≲l₂ (enode y)

  I≲L≋I≲K≲L : ∀ x → L ⊨ ≲-image I≲L x ≈ ≲-image K≲L (≲-image I≲K x)
  I≲L≋I≲K≲L x = ≈-trans L (I≲L≋I≲J≲L x) (J≲L≋J≲K≲L (≲-image I≲J x))

  lemma₁ : ∀ (K≲L : (K , k) ≲ (L , l)) x → (L ⊨ ≲-image ≲⌊ K≲L ⌋ (≲-image J≲K (j₁ x)) ≈ l (up x))
  lemma₁ (K≲L' , k≲l) (inode x) = k≲l (inode (inj₁ x))
  lemma₁ (K≲L' , k≲l) (bnode v) = k≲l (bnode (inj₁ v))
  lemma₁ (K≲L' , k≲l) (enode y) = k≲l (enode (inj₁ y))

  lemma₂ : ∀ (K≲L : (K , k) ≲ (L , l)) x → (L ⊨ ≲-image ≲⌊ K≲L ⌋ (k₂ x) ≈ l (down x))
  lemma₂ (K≲L , k≲l) (inode x) = k≲l (inode (inj₂ x))
  lemma₂ (K≲L , k≲l) (bnode v) = k≲l (bnode (inj₂ v))
  lemma₂ (K≲L , k≲l) (enode y) = k≲l (enode (inj₂ y))

  K≲L-uniq : Unique (I , i) (K , k) (L , l) (I≲K , i≲k) (I≲L , i≲l)
  K≲L-uniq (K≲₁L , k≲₁l) (K≲₂L , k≲₂l) I≲L≋I≲K≲₁L I≲L≋I≲K≲₂L =
    K₂≲L₂-uniq (K≲₁L , lemma₂ (K≲₁L , k≲₁l)) (K≲₂L , lemma₂ (K≲₂L , k≲₂l))
      (J₁≲L₁-uniq (J≲L , j₁≲l₁) (≲-trans J≲K K≲₁L , lemma₁ (K≲₁L , k≲₁l)) I≲L≋I≲J≲L I≲L≋I≲K≲₁L)
      (J₁≲L₁-uniq (J≲L , j₁≲l₁) (≲-trans J≲K K≲₂L , lemma₁ (K≲₂L , k≲₂l)) I≲L≋I≲J≲L I≲L≋I≲K≲₂L)

par-mediator : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
    (I₁≲J₁ : inj₁ * I ≲ inode * J₁) →
      (J₂≲K₂ : go₂ I J₁ ≲⌊ I₁≲J₁ ⌋ ≲ inode * K₂) → (S : TBox Σ) →
        (F₁ : ABox Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (F₂ : ABox Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
          (Mediator (inj₁ * I) J₁ I₁≲J₁ (S , F₁)) →
            (Mediator (go₂ I J₁ ≲⌊ I₁≲J₁ ⌋) K₂ J₂≲K₂ (S , F₂)) →
              (Mediator I (par J₁ K₂ ≲⌊ J₂≲K₂ ⌋)
                (par-≳ I J₁ K₂ I₁≲J₁ J₂≲K₂) (S , (F₁ ⟨&⟩ F₂)))
par-mediator I J₁ K₂ I₁≲J₁ J₂≲K₂ S F₁ F₂ J₁-med K₂-med L I≲L (L⊨S , L⊨F₁ , L⊨F₂) =
  par-mediated I J₁ K₂ L I₁≲J₁ I≲L J₂≲K₂ I₁≲J₁≲L₁-med J₂≲K₂≲L₂-med where

  I₁≲J₁≲L₁-med : Mediated (inj₁ * I) J₁ (up * L) I₁≲J₁ (inj₁ ** I≲L)
  I₁≲J₁≲L₁-med = J₁-med (up * L) (inj₁ ** I≲L) (L⊨S , *-resp-⟨ABox⟩ up L F₁ L⊨F₁)

  J₂≲K₂≲L₂-med : Mediated (go₂ I J₁ ≲⌊ I₁≲J₁ ⌋) K₂ (down * L) J₂≲K₂ (go₂-≲ I J₁ L I₁≲J₁ I≲L I₁≲J₁≲L₁-med)
  J₂≲K₂≲L₂-med = K₂-med (down * L) (go₂-≲ I J₁ L I₁≲J₁ I≲L I₁≲J₁≲L₁-med) (L⊨S , *-resp-⟨ABox⟩ down L F₂ L⊨F₂)

par-init : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (I : Interp Σ (X₁ ⊎ X₂)) →
  (J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
    (S : TBox Σ) → (F₁ : ABox Σ (X₁ ⊕ V₁ ⊕ Y₁)) → (F₂ : ABox Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
      (J₁-init : J₁ ∈ Initial (inj₁ * I) (S , F₁)) →
        (K₂-init : K₂ ∈ Initial (go₂ I J₁ ≲⌊ init-≲ J₁-init ⌋) (S , F₂)) →
          (par J₁ K₂ ≲⌊ init-≲ K₂-init ⌋ ∈
            Initial I (S , (F₁ ⟨&⟩ F₂)))
par-init I J₁ K₂ S F₁ F₂
  (I₁≲J₁ , (J⊨S , J₁⊨F₁) , J₁-med) (J₂≲K₂ , (K⊨S , K₂⊨F₂) , K₂-med) =
    ( par-≳ I J₁ K₂ I₁≲J₁ J₂≲K₂
    , (K⊨S , par-impl J₁ K₂ ≲⌊ J₂≲K₂ ⌋ F₁ F₂ J₁⊨F₁ K₂⊨F₂)
    , par-mediator I J₁ K₂ I₁≲J₁ J₂≲K₂ S F₁ F₂ J₁-med K₂-med )

tensor-⊨ : ∀ {V₁ V₂ X₁ X₂ Y₁ Y₂} → (S T : TBox Σ) →
  (A₁ : ABox Σ X₁) → (A₂ : ABox Σ X₂) → (B₁ : ABox Σ Y₁) → (B₂ : ABox Σ Y₂) →
    (F₁ : ABox Σ (X₁ ⊕ V₁ ⊕ Y₁)) (F₂ : ABox Σ (X₂ ⊕ V₂ ⊕ Y₂)) →
      (∀ I → (I ⊨ (S , T) , A₁) → (I ⊕ S , F₁ ⊨ T , B₁)) →
        (∀ I → (I ⊨ (S , T) , A₂) → (I ⊕ S , F₂ ⊨ T , B₂)) →
          (∀ I → (I ⊨ (S , T) , (A₁ & A₂)) →
            (I ⊕ S , F₁ ⟨&⟩ F₂ ⊨ T , (B₁ & B₂)))
tensor-⊨ {V₁} {V₂} {X₁} {X₂} {Y₁} {Y₂}
  S T A₁ A₂ B₁ B₂ F₁ F₂ F₁✓ F₂✓ I (I⊨ST , (I⊨A₁ , I⊨A₂)) =
    ( par J₁ K₂ ≲⌊ J₂≲K₂ ⌋
    , par-init I J₁ K₂ S F₁ F₂ J₁-init K₂-init
    , par-exp J₁ K₂ ≲⌊ J₂≲K₂ ⌋ T B₁ B₂
        (ext-⊨ I₁⊕SF₁⊨TB₁) (ext-⊨ J₂⊕SF₂⊨TB₂) ) where

  I₁ : Interp Σ X₁
  I₁ = inj₁ * I

  I₂ : Interp Σ X₂
  I₂ = inj₂ * I

  I₁⊨A₁ : I₁ ⊨a A₁
  I₁⊨A₁ = *-resp-⟨ABox⟩ inj₁ I A₁ I⊨A₁

  I₂⊨A₂ : I₂ ⊨a A₂
  I₂⊨A₂ = *-resp-⟨ABox⟩ inj₂ I A₂ I⊨A₂

  I₁⊕SF₁⊨TB₁ : I₁ ⊕ S , F₁ ⊨ T , B₁
  I₁⊕SF₁⊨TB₁ = F₁✓ I₁ (I⊨ST , I₁⊨A₁)

  J₁ : Interp Σ (X₁ ⊕ V₁ ⊕ Y₁)
  J₁ = extension I₁⊕SF₁⊨TB₁

  J₁-init : J₁ ∈ Initial I₁ (S , F₁)
  J₁-init = ext-init I₁⊕SF₁⊨TB₁

  I₁≲J₁ : I₁ ≲ inode * J₁
  I₁≲J₁ = init-≲ J₁-init

  J₂ : Interp Σ X₂
  J₂ = go₂ I J₁ ≲⌊ I₁≲J₁ ⌋

  I₂≲J₂ : I₂ ≲ J₂
  I₂≲J₂ = go₂-≳ I J₁ ≲⌊ I₁≲J₁ ⌋

  J⊨ST : ⌊ J₂ ⌋ ⊨t (S , T)
  J⊨ST = proj₁ (ext✓ I₁⊕SF₁⊨TB₁)

  J₂⊨A₂ : J₂ ⊨a A₂
  J₂⊨A₂ = ⊨a-resp-≲ I₂≲J₂ A₂ I₂⊨A₂

  J₂⊕SF₂⊨TB₂ : J₂ ⊕ S , F₂ ⊨ T , B₂
  J₂⊕SF₂⊨TB₂ = F₂✓ J₂ (J⊨ST , J₂⊨A₂)

  K₂ : Interp Σ (X₂ ⊕ V₂ ⊕ Y₂)
  K₂ = extension J₂⊕SF₂⊨TB₂

  K₂-init : K₂ ∈ Initial J₂ (S , F₂)
  K₂-init = ext-init J₂⊕SF₂⊨TB₂

  J₂≲K₂ : J₂ ≲ inode * K₂
  J₂≲K₂ = init-≲ K₂-init

_⟨⊗⟩′_ : ∀ {S T : TBox Σ} {A₁ A₂ B₁ B₂ : Object S T} →
  (F₁ : A₁ ⇒ B₁) → (F₂ : A₂ ⇒ B₂) →
    ((A₁ ⊗ A₂) ⇒ (B₁ ⊗ B₂) w/ (BN F₁ ⊎ BN F₂))
_⟨⊗⟩′_ {S} {T} {X₁ , X₁∈Fin , A₁} {X₂ , X₂∈Fin , A₂} {Y₁ , Y₁∈Fin , B₁} {Y₂ , Y₂∈Fin , B₂}
  (V₁ , F₁ , F₁✓) (V₂ , F₂ , F₂✓) =
    (F₁ ⟨&⟩ F₂ , tensor-⊨ S T A₁ A₂ B₁ B₂ F₁ F₂ F₁✓ F₂✓)

_⟨⊗⟩_ : ∀ {S T : TBox Σ} {A₁ A₂ B₁ B₂ : Object S T} →
  (A₁ ⇒ B₁) → (A₂ ⇒ B₂) → ((A₁ ⊗ A₂) ⇒ (B₁ ⊗ B₂))
F₁ ⟨⊗⟩ F₂  = ( (BN F₁ ⊎ BN F₂) , F₁ ⟨⊗⟩′ F₂ )


module _ where

open import Common.Prelude hiding (_>>=_; _<$>_)
open import Common.Reflection

infixl 8 _<$>_
_<$>_ : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → TC A → TC B
f <$> m = m >>= λ x → returnTC (f x)

macro
  default : Tactic
  default hole =
    inferType hole >>= λ
    { (def (quote Nat) []) → unify hole (lit (nat 42))
    ; (def (quote Bool) []) → unify hole (con (quote false) [])
    ; (meta x _) → catchTC (blockOnMeta x) (typeError (strErr "impossible" ∷ []))
                                            -- check that the block isn't caught
    ; _ → typeError (strErr "No default" ∷ [])
    }

aNat : Nat
aNat = default

aBool : Bool
aBool = default

alsoNat : Nat

soonNat : _
soonNat = default

alsoNat = soonNat


open import MLib.Prelude.FromStdlib
open import Relation.Binary using (Decidable; IsStrictTotalOrder)

module MLib.Prelude.DFS
  {v p e} {V : Set v} (_⇒_ : V → V → Set e)
  {_<_ : V → V → Set p} (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_)
  where

open import MLib.Prelude.Path
open Bool using (T)
open import Function.Equivalence using (Equivalence)

import Data.AVL isStrictTotalOrder as Tree
open Tree using (Tree)

-- A (directed) graph is a map from vertices to the list of edges out of that
-- vertex.
Graph = Tree (λ x → List (∃ λ y → x ⇒ y))

private
  module Seen where
    -- Represents a set of vertices that have been seen. At most 'n' vertices
    -- have /not/ been seen.
    record SeenSet (n : ℕ) : Set (v ⊔ˡ e ⊔ˡ p) where
      constructor mkSeen
      field
        getSeen : Tree (λ _ → ⊤)

    isSeen : ∀ {n} → V → SeenSet n → Bool
    isSeen x (mkSeen t) = x Tree.∈? t

    -- Mark a vertex as seen, thus reducing the number of /unseen/ vertices.
    mark : ∀ {n} → V → SeenSet (Nat.suc n) → Maybe (SeenSet n)
    mark x u@(mkSeen t) = if Bool.not (isSeen x u) then just (mkSeen (Tree.insert x tt t)) else nothing

    -- Make a seen set for a particular graph. The number of unseen vertices in
    -- the result is bounded above by the number of vertices in the graph.
    forGraph : Graph → ∃ SeenSet
    forGraph gr = (countVertices gr , mkSeen Tree.empty)
      where
      -- this overcounts but that doesn't matter because the index is only there
      -- to ensure termination of the DFS
      countVertices : Graph → ℕ
      countVertices = List.foldr (λ { (_ , es) n → List.foldr (λ _ → Nat.suc) n es }) 0 ∘ Tree.toList

    inj : ∀ {n} → SeenSet n → SeenSet (Nat.suc n)
    inj (mkSeen t) = mkSeen t

open Seen using (SeenSet)

private
  infixl 1 _>>=ₛ_

  MonadDfs : ∀ {a} → ℕ → Set a → Set (v ⊔ˡ (p ⊔ˡ (e ⊔ˡ a)))
  MonadDfs n A = SeenSet n → A × SeenSet n

  runMonadDfs : ∀ {n a} {A : Set a} → MonadDfs n A → SeenSet n → A
  runMonadDfs f = proj₁ ∘ f

  _>>=ₛ_ : ∀ {n a b} {A : Set a} {B : Set b} → MonadDfs n A → (A → MonadDfs n B) → MonadDfs n B
  (f >>=ₛ g) s =
    let x , s′ = f s
    in g x s′

  returnₛ : ∀ {n a} {A : Set a} → A → MonadDfs n A
  returnₛ x s = x , s

  withMarked : ∀ {n a} {A : Set a} V → MonadDfs n A → MonadDfs (Nat.suc n) (Maybe A)
  withMarked v f s =
    case Seen.mark v s of λ
    { (just s′) →
      let x , s′′ = f s′
      in just x , Seen.inj s′′
    ; nothing → nothing , s
    }

module _ (graph : Graph) where

  private
    PathsFrom = List ∘ ∃ ∘ Path _⇒_

    -- Calculates paths from the given source to every reachable target not in
    -- the seen set. Returns the new seen set, the list of paths found, and
    -- a boolean indicating whether this source was previously in the seen
    -- set.
    pathsFromSource : ∀ {n} (source : V) → MonadDfs n (Maybe (PathsFrom source))

    -- Calculates paths from the given source to every reachable target not in
    -- the seen set, whose first edge is among the list given.
    pathsViaEdges : ∀ {n} {source : V} → List (∃ (λ dest → source ⇒ dest)) → MonadDfs n (PathsFrom source)

    -- Calculates paths via the edge given to every reachable target not in the
    -- seen set.
    pathsViaEdge : ∀ {n} {source dest : V} → source ⇒ dest → MonadDfs n (PathsFrom source)

    -- The base case of induction on the size of the seen set. This is only here
    -- to satisfy the termination checker.
    pathsFromSource {Nat.zero} source = returnₛ nothing
    pathsFromSource {Nat.suc _} source = withMarked source (
      case Tree.lookup source graph of λ
      -- We have a list of edges from this source to some other vertex. For
      -- each of these, a recursive call will only return paths from that
      -- vertex if it is yet unseen. Note the recursive call is on a seen set
      -- with an index one lower, satisfying Agda's termination checker.
      { (just es) → pathsViaEdges es >>=ₛ returnₛ ∘ just
      -- there are no edges from this source so nothing is reachable from it
      ; nothing → returnₛ (just [])
      }) >>=ₛ maybe returnₛ (returnₛ nothing)

    pathsViaEdges [] = returnₛ []
    pathsViaEdges ((d , e) ∷ es) =
      pathsViaEdge e >>=ₛ λ pathsVia-d →
      pathsViaEdges es >>=ₛ λ restPaths →
      returnₛ (pathsVia-d List.++ restPaths)

    pathsViaEdge {dest = d} e =
      pathsFromSource d >>=ₛ λ
      { (just pathsFrom-d) →
        let pathsVia-d = List.map (λ {(d′ , p) → d′ , connect (edge e) p}) pathsFrom-d
        in returnₛ ((_ , edge e) ∷ pathsVia-d)
      ; nothing → returnₛ []
      }

  -- Given a source vertex S, finds all vertices T such that there is a path
  -- from S to T, and returns the path. No target vertex is returned more than
  -- once.
  allTargetsFrom : (source : V) → List (∃ (Path _⇒_ source))
  allTargetsFrom source =
    let _ , seen = Seen.forGraph graph
    in maybe id [] (runMonadDfs (pathsFromSource source) seen)

module _ (graph : Graph) (matches : V → Bool) where

  private
    findMatchingFrom : ∀ {n} (source : V) → MonadDfs n (Maybe (∃ λ dest → Path _⇒_ source dest × T (matches dest)))
    findMatchingViaEdges : ∀ {n} {source : V} → List (∃ (λ inter → source ⇒ inter)) → MonadDfs n (Maybe (∃ λ dest → Path _⇒_ source dest × T (matches dest)))
    findMatchingViaEdge : ∀ {n} {source inter : V} → source ⇒ inter → MonadDfs n (Maybe (∃ λ dest → Path _⇒_ source dest × T (matches dest)))

    -- The base case of induction on the size of the seen set. This is only here
    -- to satisfy the termination checker.
    findMatchingFrom {Nat.zero} source = returnₛ nothing
    findMatchingFrom {Nat.suc _} source = withMarked source (
      case Tree.lookup source graph of λ
      -- We have a list of edges from this source to some other vertex. For
      -- each of these, a recursive call will only return paths from that
      -- vertex if it is yet unseen. Note the recursive call is on a seen set
      -- with an index one lower, satisfying Agda's termination checker.
      { (just es) → findMatchingViaEdges es
      -- there are no edges from this source so nothing is reachable from it
      ; nothing → returnₛ nothing
      }) >>=ₛ maybe returnₛ (returnₛ nothing)

    findMatchingViaEdges [] = returnₛ nothing
    findMatchingViaEdges ((d , e) ∷ es) =
      findMatchingViaEdge e >>=ₛ λ
      { (just r) → returnₛ (just r)
      ; nothing → findMatchingViaEdges es
      }

    findMatchingViaEdge {inter = d} e with matches d | ≡.inspect matches d
    findMatchingViaEdge {inter = _} e | true | ≡.[ eq ] = returnₛ (just (_ , edge e , Equivalence.from Bool.T-≡ ⟨$⟩ eq))
    findMatchingViaEdge {inter = d} e | false | _ =
      findMatchingFrom d >>=ₛ λ
      { (just (_ , p , q)) → returnₛ (just (_ , connect (edge e) p , q))
      ; nothing → returnₛ nothing
      }

  -- Given a source vertex S, finds all vertices T such that there is a path
  -- from S to T, and returns the path. No target vertex is returned more than
  -- once.
  findMatching : (source : V) → Maybe (∃ λ dest → Path _⇒_ source dest × T (matches dest))
  findMatching source =
    let _ , seen = Seen.forGraph graph
    in runMonadDfs (findMatchingFrom source) seen

module _ (graph : Graph) {dest} (isDest : ∀ v → Dec (v ≡ dest)) where
  -- Given a source vertex S, finds all vertices T such that there is a path
  -- from S to T, and returns the path. No target vertex is returned more than
  -- once.
  findDest : (source : V) → Maybe (Path _⇒_ source dest)
  findDest source with findMatching graph (⌊_⌋ ∘ isDest) source
  ... | just (dest′ , p , q) with isDest dest′
  ... | yes ≡.refl = just p
  findDest source | just (_ , _ , ()) | no _
  findDest source | nothing = nothing


open import Prelude hiding (All; module All; _>>=_; ⊥; sym)

module Implicits.Resolution.Infinite.Algorithm.Completeness where

open import Data.Bool
open import Data.Unit.Base
open import Data.Maybe as Maybe using (Is-just; to-witness)
open import Coinduction
open import Data.Fin.Substitution
open import Data.List.Any hiding (tail)
open Membership-≡
open import Data.Fin.Substitution
open import Relation.Binary.HeterogeneousEquality as H using ()
open import Induction.WellFounded

open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas.MetaType
open import Implicits.Syntax.Type.Unification
open import Implicits.Syntax.Type.Unification.Lemmas as Unification hiding (complete)
open import Implicits.Resolution.Infinite.Resolution
open import Implicits.Resolution.Infinite.Algorithm
open import Implicits.Resolution.Termination

private
  module HR = H.≅-Reasoning

open import Category.Monad.Partiality as P
open Workaround
open Workaround.Correct
open import Category.Monad.Partiality.All using (All; module Alternative)
open Alternative renaming (sound to AllP-sound) hiding (complete)

open import Category.Functor
private module MaybeFunctor {f} = RawFunctor (Maybe.functor {f})

private
  module M = MetaTypeMetaSubst

module Lemmas where

private
  open import Relation.Binary.PropositionalEquality as PEq using (_≡_)
  open module PartialEq = P.Equality  {A = Bool} _≡_
  open Lemmas

mutual
  {-# NO_TERMINATION_CHECK #-}
  delayed-resolve-complete : ∀ {ν} (Δ : ICtx ν) r → Δ ⊢ᵣ r → AllP (_≡_ true) (delayed-resolve Δ r)
  delayed-resolve-complete Δ r p = later (♯ (complete' Δ r p))

  resolve-context-complete : ∀ {ν m} (Δ : ICtx ν) a (u : Maybe (Sub (flip MetaType ν) m zero)) →
                            (p : Is-just u) →
                            Δ ⊢ᵣ (from-meta (a M./ (to-witness p))) →
                            AllP Is-just (resolve-context Δ a u)
  resolve-context-complete Δ a ._ (just {x = u} px) x =
    _ ≅⟨ resolve-context-comp Δ a u ⟩P
    delayed-resolve-complete Δ (from-meta (M._/_ a u)) x >>=-congP lem
    where
      lem : ∀ {b} → true ≡ b → AllP Is-just (map-bool u b)
      lem refl = now (just tt)

  lemx : ∀ {ν m} {Δ : ICtx ν} r c τ (u : M.MetaSub MetaType ν m zero) →
        Δ ⊢ from-meta (r M./ u M.↑tp) tp[/tp c ] ↓ τ →
        Δ ⊢ from-meta (open-meta r M./ (to-meta c ∷ u)) ↓ τ
  lemx r c τ u p = {!!}

  a/u-↓-unique : ∀ {ν m} {Δ} (a : MetaType m ν) {τ} u v →
                 Δ ⊢ from-meta (a M./ u) ↓ τ → Δ ⊢ from-meta (a M./ v) ↓ τ →
                 (a M./ u) ≡ (a M./ v)
  a/u-↓-unique (a ⇒ b) u v (i-iabs _ p) (i-iabs _ q) = {!a/u-↓-unique b u v p q!}
  a/u-↓-unique (∀' a) u v p q = {!!}
  a/u-↓-unique (simpl x) u v p q = {!!}

  match-u-complete' : ∀ {ν m} (Δ : ICtx ν) → (τ : SimpleType ν) → (r : MetaType m ν) → (ac : m<-Acc r) →
                    ∀ u → Δ ⊢ from-meta (r M./ u) ↓ τ →
                    AllP Is-just (match-u Δ τ r ac)
  match-u-complete' Δ τ (a ⇒ b) (acc f) u (i-iabs q p) =
    _
      ≅⟨ match-u-iabs-comp Δ τ a b f ⟩P
    match-u-complete' Δ τ b (f _ (b-m<-a⇒b a b)) u p >>=-congP lem
    where
      lem : ∀ {v : Maybe (Sub (flip MetaType _) _ zero)} → Is-just v →
            AllP Is-just (resolve-context Δ a v)
      lem x = resolve-context-complete Δ a _ x q'
        where
          -- from q : Δ ⊢ᵣ a / u
          -- we derive q' : Δ ⊢ᵣ a / x
          -- based on the idea that we have Δ ⊢ b / u ↓ τ and
          -- soundness gives us Δ ⊢ b / (to-witness x) ↓ τ.
          -- And assuming ⊢unamb b, we should have u ≡ (to-witness x)
          q' : Δ ⊢ᵣ from-meta (a M./ to-witness x )
          q' = subst (_⊢ᵣ_ Δ) {!!} q
  match-u-complete' {m = m} Δ τ (∀' r) (acc f) u (i-tabs c p) =
    _
      ≅⟨ match-u-tabs-comp Δ τ r f ⟩P
    (match-u-complete' Δ τ (open-meta r) (f _ _) (to-meta {zero} c ∷ u) (lemx r c τ u p))
      >>=-congP now∘tail-compl
    where
      now∘tail-compl : ∀ {ν} {v : Maybe (Sub (flip MetaType ν) (suc m) zero)} →
                      Is-just v →
                      AllP Is-just ((now ∘ (MaybeFunctor._<$>_ tail)) v)
      now∘tail-compl (just px) = now (just tt)

  -- Maybe surprisingly 'u' is ignored in the proofs below.
  -- But if you think about it, it makes sense: mgu doesn't necessarily find the same unifier.
  -- All we need to know is that there is a unifier u; the structure of Δ ⊢ (a / u) ↓ τ does the rest
  match-u-complete' Δ .(tvar x) (simpl (tvar x)) ac u (i-simp .(tvar x)) =
    now (Unification.complete (simpl (tvar x)) (tvar x) u refl)
  match-u-complete' Δ .(tc x) (simpl (tc x)) ac u (i-simp .(tc x)) =
    now (Unification.complete (simpl (tc x)) (tc x) u refl)
  match-u-complete' Δ τ (simpl (mvar x)) ac u p =
    let (u' , u'-uni) = mvar-unifiable x τ in
      now (Unification.complete (simpl (mvar x)) τ u' u'-uni)
  match-u-complete' Δ ._ (simpl (a →' b)) ac u (i-simp ._) =
    now (Unification.complete (simpl (a →' b)) _ u refl)

  -- the trivial predicate holds for all terminating problems
  trivial-allP : ∀ {a} {A : Set a} (a : A ⊥) → AllP (const ⊤) a
  trivial-allP (now x) = now tt
  trivial-allP (later x) = later (♯ (trivial-allP (♭ x)))

  -- Match succeeds if we have a proof Δ ⊢ r ↓ τ
  match-complete : ∀ {ν} (Δ : ICtx ν) → (τ : SimpleType ν) → (r : Type ν) → Δ ⊢ r ↓ τ →
                  AllP (_≡_ true) (match Δ τ r)
  match-complete Δ τ r p = _
      ≅⟨ match-comp Δ τ r ⟩P
    match-u-complete' Δ τ (to-meta {zero} r) (m<-well-founded _) []
      (subst (λ z → Δ ⊢ z ↓ τ) (Prelude.sym $ from-to-meta-/-vanishes) p)
      >>=-congP lem
    where
      lem : ∀ {ν} {v : Maybe (Sub (flip MetaType ν) zero zero)} →
            (Is-just v) → AllP (_≡_ true) (⟦ (now ∘ Maybe.is-just) v ⟧P)
      lem  (just tt) = now refl

  -- 'recovery' of a non failed match succeeds
  recover-true-complete : ∀ {ν} {Δ : ICtx ν} {ρs τ v} → v ≡ true →
                          AllP (_≡_ true) (match1st-recover Δ ρs τ v)
  recover-true-complete refl = now refl

  -- recovery of a failed match succeeds if we know that the recursive match1st succeeds
  recover-false-complete : ∀ {ν} (Δ : ICtx ν) ρs τ v → AllP (_≡_ true) (match1st Δ ρs τ) →
                          AllP (_≡_ true) (match1st-recover Δ ρs τ v)
  recover-false-complete Δ ρs τ true p = now refl
  recover-false-complete Δ ρs τ false p = p

  -- match1st succeeds if we have a proof that some r from the context
  -- should be a match
  match1st-complete : ∀ {ν} (Δ : ICtx ν) {r} →
                      (ρs : ICtx ν) → (τ : SimpleType ν) →
                      r List.∈ ρs → Δ ⊢ r ↓ τ →
                      AllP (_≡_ true) (match1st Δ ρs τ)
  match1st-complete Δ List.[] τ () r↓τ
  match1st-complete Δ (x List.∷ ρs) τ (here refl) r↓τ =
    _
      ≅⟨ match1st-comp Δ x ρs τ ⟩P
    match-complete Δ τ x r↓τ >>=-congP (λ{ v → recover-true-complete (Prelude.sym v)})
  match1st-complete Δ (x List.∷ ρs) τ (there r∈Δ) r↓τ =
    _
      ≅⟨ match1st-comp Δ x ρs τ ⟩P
    ((trivial-allP (match Δ τ x)) >>=-congP
      (λ {v} _ → recover-false-complete Δ ρs τ v (match1st-complete Δ ρs τ r∈Δ r↓τ)))

  -- Mirroring Abel & Altenkirch's work on partial type checking, we say:
  -- Because resolution without an additional termination condition
  -- seems to be undecidable, an appropriate completeness result would be:
  -- if Δ resolves r, then the resolution algorithm searching for a proof of that fact,
  -- will not fail finetely. I.e. the algorithm might diverge or succeed, but not report an error.
  -- We can make this formal using the *coinductive* resolution rules
  -- (Together with soundness we have a 'minimal' completeness result, because the rules allow
  -- for many derivations, while the algorithm will only find *one*.)
  complete' : ∀ {ν} (Δ : ICtx ν) r → Δ ⊢ᵣ r → AllP (_≡_ true) (resolve Δ r)
  complete' Δ (simpl x) (r-simp r∈Δ r↓τ) = (match1st-complete Δ Δ x r∈Δ r↓τ)
  complete' Δ (a ⇒ b) (r-iabs p) = complete' (a List.∷ Δ) b p
  complete' Δ (∀' r) (r-tabs p) = complete' (ictx-weaken Δ) r p

  complete : ∀ {ν} (Δ : ICtx ν) r → Δ ⊢ᵣ r → All (_≡_ true) (resolve Δ r)
  complete Δ r p = AllP-sound (complete' Δ r p)

module Test where

  open import Category.Monad.Partiality.All

  trivial-all : ∀ {a p} {A : Set a} (P : A → Set p) → All P never
  trivial-all p = later (♯ (trivial-all p))


-- Andreas, 2022-03-09, issue #5819, reported by Zilin Chen
--
-- This test uncovered an unsound optimization (8e0fca895b9c6740d9d6c1751ed1e0ecefe63473)
-- in the termination checker which replaced a (stripAllProjections . normalize)
-- by a (iteratively reduce . stripAllProjections).
-- Those reductions on now ill-formed terms triggered the __IMPOSSIBLE__:
-- Incomplete pattern matching when applying Issue5819.dl-iso

open import Agda.Builtin.Unit using (⊤; tt)
open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.Equality
open import Agda.Builtin.Sigma renaming (fst to proj₁; snd to proj₂)

data ⊥ : Set where

∃ : {A : Set} (B : A → Set) → Set
∃ B = Σ _ B

_×_ : (A B : Set) → Set
A × B = Σ A λ _ → B

sym : {A : Set} {x y : A} → x ≡ y → y ≡ x
sym refl = refl

_≢_ : {A : Set} (x y : A) → Set
x ≢ y = x ≡ y → ⊥

record Inverse (A B : Set) : Set where
  field
    f         : A → B
    f⁻¹       : B → A
    inverse   : ∀ x → f (f⁻¹ x) ≡ x
open Inverse

data DList : Set
Fresh : (a : ℕ) → (l : DList) → Set

data DList where
  dnil  : DList
  dcons : (a : ℕ) → (l : DList) → Fresh a l → DList

Fresh a dnil = ⊤
Fresh a (dcons b l _) = (a ≢ b) × Fresh a l

data List′ : Set where
  nil′  : List′
  cons′ : ℕ → List′ → List′

Fresh′ : ℕ → List′ → Set
Fresh′ a nil′ = ⊤
Fresh′ a (cons′ b l) = (a ≢ b) × Fresh′ a l

AllFresh : List′ → Set
AllFresh nil′ = ⊤
AllFresh (cons′ a l) = Fresh′ a l × AllFresh l

data DList′ : List′ → Set → Set₁ where
  dnil′  : DList′ nil′ ⊤
  dcons′ : ∀{l}{prf} → (a : ℕ) → DList′ l prf → DList′ (cons′ a l) (Fresh′ a l × prf)

data DList″ : Set where
  dl″ : (l : List′) → AllFresh l → DList″

undl″-l : DList″ → List′
undl″-l (dl″ l _) = l

undl″-p : DList″ → ∃ AllFresh
undl″-p (dl″ l p) = l , p

-- dl-iso : DList ↔ DList″
dl-iso : Inverse DList DList″
-- f-dl-iso : DList → DList″
-- g-dl-iso : DList″ → DList
-- inverse-dl-iso : ∀ x → f-dl-iso (g-dl-iso x) ≡ x

Fresh→Fresh′ : ∀{a}{l}{l″}
             → (f dl-iso l ≡ l″)
             → Fresh a l
             → Fresh′ a (undl″-l l″)

Fresh→AllFresh : ∀{a}{l}{l″}
               → (f dl-iso l ≡ l″)
               → Fresh a l
               → AllFresh (undl″-l l″)

All/Fresh′→Fresh : ∀{a}{l}{l″}
       → (l ≡ f⁻¹ dl-iso l″)
       → Fresh′ a (undl″-l l″) × AllFresh (undl″-l l″)
       → Fresh a l

f dl-iso dnil = dl″ nil′ tt
f dl-iso (dcons a l p)
  = dl″ (cons′ a (undl″-l (f dl-iso l)))
        ((Fresh→Fresh′ {l = l}{l″ = f dl-iso l} refl p) ,
         (Fresh→AllFresh {a = a}{l = l}{l″ = f dl-iso l} refl p))

f⁻¹ dl-iso (dl″ nil′ p) = dnil
f⁻¹ dl-iso (dl″ (cons′ a l′) p)
  = dcons a (f⁻¹ dl-iso (dl″ l′ (proj₂ p)))
            (All/Fresh′→Fresh {l″ = dl″ l′ (proj₂ p)} refl p)

-- Can't do any further, otherwise an Agda bug occurs.
inverse dl-iso x = invˡ
  where
  invˡ : ∀{x} → f dl-iso (f⁻¹ dl-iso x) ≡ x
  invˡ {dl″ nil′ _} = refl
  invˡ {dl″ (cons′ a l) p} rewrite invˡ {dl″ l {!!}} = {!!}  -- add "rewrite invˡ {dl″ l ?}" (w/o quotes) to the left of the = sign and C-c C-l

Fresh→Fresh′ {a} {dnil} eq p rewrite sym eq = tt
Fresh→Fresh′ {a} {dcons a₁ l x} eq p rewrite sym eq
  = proj₁ p ,  Fresh→Fresh′ {l″ = f dl-iso l} refl (proj₂ p)

Fresh→AllFresh {l = dnil} eq p rewrite sym eq = tt
Fresh→AllFresh {l = dcons a l x} eq p rewrite sym eq
  = (Fresh→Fresh′ {l″ = f dl-iso l} refl x) , Fresh→AllFresh {a = a}{l = l}{l″ = f dl-iso l} refl x

All/Fresh′→Fresh {a} {l″ = dl″ nil′ x} eq p rewrite eq = tt
All/Fresh′→Fresh {a} {l″ = dl″ (cons′ b l) x} eq p rewrite eq
  = (proj₁ (proj₁ p)) , {!All/Fresh′→Fresh!}  -- put "All/Fresh′→Fresh" in the hole and C-c C-r

-- WAS: internal error in reduction machinery
-- SHOULD: fail with termination error


open import Nat
open import Prelude
open import dynamics-core
open import contexts

open import binders-disjoint-checks
open import exchange
open import lemmas-consistency
open import lemmas-disjointness
open import lemmas-subst-ta
open import type-assignment-unicity
open import weakening

module preservation where
  -- if d and d' both result from filling the hole in ε with terms of the
  -- same type, they too have the same type.
  wt-different-fill : ∀{Δ Γ d ε d1 d2 d' τ τ1} →
                      d == ε ⟦ d1 ⟧ →
                      Δ , Γ ⊢ d :: τ →
                      Δ , Γ ⊢ d1 :: τ1 →
                      Δ , Γ ⊢ d2 :: τ1 →
                      d' == ε ⟦ d2 ⟧ →
                      Δ , Γ ⊢ d' :: τ
  wt-different-fill FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  wt-different-fill (FHPlus1 eps1) (TAPlus D1 D2) D3 D4 (FHPlus1 eps2) = TAPlus (wt-different-fill eps1 D1 D3 D4 eps2) D2
  wt-different-fill (FHPlus2 eps1) (TAPlus D1 D2) D3 D4 (FHPlus2 eps2) = TAPlus D1 (wt-different-fill eps1 D2 D3 D4 eps2)
  wt-different-fill (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (wt-different-fill eps D1 D3 D4 D5) D2
  wt-different-fill (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (wt-different-fill eps D2 D3 D4 D5)
  wt-different-fill (FHInl eps1) (TAInl D) D1 D2 (FHInl eps2) = TAInl (wt-different-fill eps1 D D1 D2 eps2)
  wt-different-fill (FHInr eps1) (TAInr D) D1 D2 (FHInr eps2) = TAInr (wt-different-fill eps1 D D1 D2 eps2)
  wt-different-fill (FHCase eps1) (TACase D x D₁ x₁ D₂) D1 D2 (FHCase eps2) = TACase (wt-different-fill eps1 D D1 D2 eps2) x D₁ x₁ D₂
  wt-different-fill (FHPair1 eps1) (TAPair D D₁) D1 D2 (FHPair1 eps2) = TAPair (wt-different-fill eps1 D D1 D2 eps2) D₁
  wt-different-fill (FHPair2 eps1) (TAPair D D₁) D1 D2 (FHPair2 eps2) = TAPair D (wt-different-fill eps1 D₁ D1 D2 eps2)
  wt-different-fill (FHFst eps1) (TAFst D) D1 D2 (FHFst eps2) = TAFst (wt-different-fill eps1 D D1 D2 eps2)
  wt-different-fill (FHSnd eps1) (TASnd D) D1 D2 (FHSnd eps2) = TASnd (wt-different-fill eps1 D D1 D2 eps2)
  wt-different-fill (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (wt-different-fill eps D1 D2 D3 D4) x₁
  wt-different-fill (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (wt-different-fill eps D1 D2 D3 D4) x
  wt-different-fill (FHFailedCast x) (TAFailedCast y x₁ x₂ x₃) D3 D4 (FHFailedCast eps) = TAFailedCast (wt-different-fill x y D3 D4 eps) x₁ x₂ x₃

  -- if a well typed term results from filling the hole in ε, then the term
  -- that filled the hole is also well typed
  wt-filling : ∀{ε Δ Γ d τ d'} →
               Δ , Γ ⊢ d :: τ →
               d == ε ⟦ d' ⟧ →
               Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  wt-filling TANum FHOuter = _ , TANum
  wt-filling (TAPlus ta ta₁) FHOuter = num , TAPlus ta ta₁
  wt-filling (TAPlus ta ta₁) (FHPlus1 eps) = wt-filling ta eps
  wt-filling (TAPlus ta ta₁) (FHPlus2 eps) = wt-filling ta₁ eps
  wt-filling (TAVar x₁) FHOuter = _ , TAVar x₁
  wt-filling (TALam f ta) FHOuter = _ , TALam f ta
  wt-filling (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  wt-filling (TAAp ta ta₁) (FHAp1 eps) = wt-filling ta eps
  wt-filling (TAAp ta ta₁) (FHAp2 eps) = wt-filling ta₁ eps
  wt-filling (TAInl ta) FHOuter = _ , TAInl ta
  wt-filling (TAInl ta) (FHInl eps) = wt-filling ta eps
  wt-filling (TAInr ta) FHOuter = _ , TAInr ta
  wt-filling (TAInr ta) (FHInr eps) = wt-filling ta eps
  wt-filling (TACase ta x ta₁ x₁ ta₂) FHOuter = _ , TACase ta x ta₁ x₁ ta₂
  wt-filling (TACase ta x ta₁ x₁ ta₂) (FHCase eps) = wt-filling ta eps
  wt-filling (TAPair ta ta₁) FHOuter = _ , TAPair ta ta₁
  wt-filling (TAPair ta ta₁) (FHPair1 eps) = wt-filling ta eps
  wt-filling (TAPair ta ta₁) (FHPair2 eps) = wt-filling ta₁ eps
  wt-filling (TAFst ta) FHOuter = _ , TAFst ta
  wt-filling (TAFst ta) (FHFst eps) = wt-filling ta eps
  wt-filling (TASnd ta) FHOuter = _ , TASnd ta
  wt-filling (TASnd ta) (FHSnd eps) = wt-filling ta eps
  wt-filling (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  wt-filling (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  wt-filling (TANEHole x ta x₁) (FHNEHole eps) = wt-filling ta eps
  wt-filling (TACast ta x) FHOuter = _ , TACast ta x
  wt-filling (TACast ta x) (FHCast eps) = wt-filling ta eps
  wt-filling (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  wt-filling (TAFailedCast x x₁ x₂ x₃) (FHFailedCast y) = wt-filling x y

  -- instruction transitions preserve type
  preserve-trans : ∀{Δ Γ d τ d'} →
                   binders-unique d →
                   Δ , Γ ⊢ d :: τ →
                   d →> d' →
                   Δ , Γ ⊢ d' :: τ
  preserve-trans bd TANum ()
  preserve-trans bd (TAPlus ta TANum) (ITPlus x) = TANum
  preserve-trans bd (TAVar x₁) ()
  preserve-trans bd (TALam _ ta) ()
  preserve-trans (BUAp (BULam bd x₁) bd₁ (BDLam x₂ x₃)) (TAAp (TALam apt ta) ta₁) ITLam = lem-subst apt x₂ bd₁ ta ta₁
  preserve-trans bd (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  preserve-trans bd (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  preserve-trans bd (TAEHole x x₁) ()
  preserve-trans bd (TANEHole x ta x₁) ()
  preserve-trans bd (TACast ta x) (ITCastID) = ta
  preserve-trans bd (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  preserve-trans bd (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  preserve-trans bd (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  preserve-trans bd (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  preserve-trans bd (TAFailedCast x y z q) ()
  preserve-trans bd (TAInl ta) ()
  preserve-trans bd (TAInr ta) ()
  preserve-trans (BUCase (BUInl bd) bd₁ bd₂ (BDInl x₂) x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀) (TACase (TAInl ta) x ta₁ x₁ ta₂) ITCaseInl = lem-subst x (binders-disjoint-sym x₂) bd ta₁ ta
  preserve-trans (BUCase (BUInr bd) bd₁ bd₂ (BDInr x₂) (BDInr x₃) x₄ x₅ x₆ x₇ x₈ x₉ x₁₀) (TACase (TAInr ta) x ta₁ x₁ ta₂) ITCaseInr = lem-subst x₁ (binders-disjoint-sym x₃) bd ta₂ ta
  preserve-trans (BUCase (BUCast bd) bd₁ bd₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁) (TACase {Γ = Γ} (TACast ta x₂) x ta₁ x₁ ta₂) ITCaseCast
    with ~sum x₂
  ... | τ1~τ2 , τ3~τ4 = TACase ta x (lem-subst-cast-ta {Γ = Γ} x bd₁ τ1~τ2 ta₁) x₁ (lem-subst-cast-ta {Γ = Γ} x₁ bd₂ τ3~τ4 ta₂)
  preserve-trans bd (TAPair ta ta₁) ()
  preserve-trans bd (TAFst (TAPair ta ta₁)) ITFstPair = ta
  preserve-trans bd (TAFst (TACast ta x)) ITFstCast
    with ~prod x
  ... | τ1~τ2 , τ3~τ4 = TACast (TAFst ta) τ1~τ2
  preserve-trans bd (TASnd (TAPair ta ta₁)) ITSndPair = ta₁
  preserve-trans bd (TASnd (TACast ta x)) ITSndCast
    with ~prod x
  ... | τ1~τ2 , τ3~τ4 = TACast (TASnd ta) τ3~τ4
  preserve-trans bd (TACast ta TCRefl) (ITExpand ())
  preserve-trans bd (TACast ta TCHole1) (ITGround (MGSum x₁)) = TACast (TACast ta (TCSum TCHole1 TCHole1)) TCHole1
  preserve-trans bd (TACast ta TCHole1) (ITExpand ())
  preserve-trans bd (TACast ta TCHole2) (ITExpand (MGSum x₁)) = TACast (TACast ta TCHole2) (TCSum TCHole2 TCHole2)
  preserve-trans bd (TACast ta TCHole1) (ITGround (MGProd x₁)) = TACast (TACast ta (TCProd TCHole1 TCHole1)) TCHole1
  preserve-trans bd (TACast ta TCHole2) (ITExpand (MGProd x)) = TACast (TACast ta TCHole2) (TCProd TCHole2 TCHole2)

  lem-bd-ε1 : ∀{d ε d0} → d == ε ⟦ d0 ⟧ →
              binders-unique d →
              binders-unique d0
  lem-bd-ε1 FHOuter bd = bd
  lem-bd-ε1 (FHPlus1 eps) (BUPlus bd bd₁ x) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHPlus2 eps) (BUPlus bd bd₁ x) = lem-bd-ε1 eps bd₁
  lem-bd-ε1 (FHAp1 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHAp2 eps) (BUAp bd bd₁ x) = lem-bd-ε1 eps bd₁
  lem-bd-ε1 (FHInl eps) (BUInl bd) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHInr eps) (BUInr bd) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHCase eps) (BUCase bd bd₁ bd₂ x x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHPair1 eps) (BUPair bd bd₁ x) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHPair2 eps) (BUPair bd bd₁ x) = lem-bd-ε1 eps bd₁
  lem-bd-ε1 (FHFst eps) (BUFst bd) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHSnd eps) (BUSnd bd) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHNEHole eps) (BUNEHole bd x) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHCast eps) (BUCast bd) = lem-bd-ε1 eps bd
  lem-bd-ε1 (FHFailedCast eps) (BUFailedCast bd) = lem-bd-ε1 eps bd

  -- this is the main preservation theorem, gluing together the above
  preservation : {Δ : hctx} {d d' : ihexp} {τ : htyp} {Γ : tctx} →
                 binders-unique d →
                 Δ , Γ ⊢ d :: τ →
                 d ↦ d' →
                 Δ , Γ ⊢ d' :: τ
  preservation bd D (Step x x₁ x₂)
    with wt-filling D x
  ... | (_ , wt) = wt-different-fill x D wt (preserve-trans (lem-bd-ε1 x bd) wt x₁) x₂

  -- note that the exact statement of preservation in the paper, where Γ is
  -- empty indicating that the terms are closed, is an immediate corrolary
  -- of the slightly more general statement above.
  preservation' : {Δ : hctx} {d d' : ihexp} {τ : htyp} →
                  binders-unique d →
                  Δ , ∅ ⊢ d :: τ →
                  d ↦ d' →
                  Δ , ∅ ⊢ d' :: τ
  preservation' = preservation


module is-free where

open import lib

open import cedille-types
open import ctxt-types
open import syntax-util
open import general-util

are-free-e = 𝔹
check-erased = tt
skip-erased = ff

are-free-in-t : Set → Set₁
are-free-in-t T = ∀{A} → are-free-e → trie A → T → 𝔹

are-free-in-term : are-free-in-t term
are-free-in-type : are-free-in-t type
are-free-in-kind : are-free-in-t kind
are-free-in-optClass : are-free-in-t optClass
-- are-free-in-optType : are-free-in-t optType
are-free-in-optTerm : are-free-in-t optTerm
are-free-in-optGuide : are-free-in-t optGuide
are-free-in-tk : are-free-in-t tk
are-free-in-liftingType : are-free-in-t liftingType
are-free-in-optType : are-free-in-t optType
are-free-in-args : are-free-in-t args
are-free-in-cases : are-free-in-t cases
are-free-in-varargs : are-free-in-t varargs

are-free-in-term ce x (App t Erased t') = are-free-in-term ce x t || (ce && are-free-in-term ce x t')
are-free-in-term ce x (App t NotErased t') = are-free-in-term ce x t || are-free-in-term ce x t'
are-free-in-term ce x (AppTp t tp) = are-free-in-term ce x t || (ce && are-free-in-type ce x tp)
are-free-in-term ce x (Hole x₁) = ff
are-free-in-term ce x (Lam _ b _ x' oc t) =
  (ce && are-free-in-optClass ce x oc)
  || are-free-in-term ce (trie-remove x x') t
are-free-in-term ce x (Let _ (DefTerm _ x' m t) t') =
  (ce && are-free-in-optType ce x m)
  || (are-free-in-term ce x t)
  || are-free-in-term ce (trie-remove x x') t'
are-free-in-term ce x (Let _ (DefType _ x' k t) t') =
  (ce && (are-free-in-kind ce x k || are-free-in-type ce x t))
  || are-free-in-term ce (trie-remove x x') t'
are-free-in-term ce x (Open _ _ t) = are-free-in-term ce x t -- return the same answer as the erasure of (Open ...)
are-free-in-term ce x (Parens x₁ t x₂) = are-free-in-term ce x t
are-free-in-term ce x (Var _ "_") = ff
are-free-in-term ce x (Var _ x') = trie-contains x x'
are-free-in-term ce x (Beta _ ot ot') = are-free-in-optTerm ce x ot' || (ce && are-free-in-optTerm ce x ot)
are-free-in-term ce x (IotaPair _ t1 t2 ot _) = are-free-in-term ce x t1 || (ce && (are-free-in-term ce x t2 || are-free-in-optGuide ce x ot))
are-free-in-term ce x (IotaProj t n _) = are-free-in-term ce x t
are-free-in-term ce x (Epsilon _ _ _ t) = are-free-in-term ce x t
are-free-in-term ce x (Sigma _ t) = are-free-in-term ce x t
are-free-in-term ce x (Phi _ t t₁ t₂ _) = (ce && are-free-in-term ce x t) || (ce && are-free-in-term ce x t₁) || are-free-in-term ce x t₂
are-free-in-term ce x (Rho _ _ _ t ot t') = (ce && (are-free-in-term ce x t || are-free-in-optGuide ce x ot)) || are-free-in-term ce x t'
are-free-in-term ce x (Chi _ T t') = (ce && are-free-in-optType ce x T) || are-free-in-term ce x t'
are-free-in-term ce x (Delta _ T t') = ce && (are-free-in-optType ce x T || are-free-in-term ce x t')
are-free-in-term ce x (Theta _ _ t ls) = are-free-in-term ce x t || are-free-in-lterms ce x ls
  where are-free-in-lterms : ∀{A} → are-free-e → trie A → lterms → 𝔹
        are-free-in-lterms ce x (LtermsNil _) = ff
        are-free-in-lterms ce x (LtermsCons Erased t ls) = (ce && are-free-in-term ce x t) || are-free-in-lterms ce x ls
        are-free-in-lterms ce x (LtermsCons NotErased t ls) = are-free-in-term ce x t || are-free-in-lterms ce x ls
are-free-in-term ce x (Mu _ x' t ot _ cs _) = (ce && are-free-in-optType ce x ot) || are-free-in-term ce (trie-remove x x') t || are-free-in-cases ce x cs
are-free-in-term ce x (Mu' _   t ot _ cs _) = (ce && are-free-in-optType ce x ot) || are-free-in-term ce x t || are-free-in-cases ce x cs

are-free-in-cases _ _  NoCase                    = ff
are-free-in-cases ce x (SomeCase _ c varargs t cs) = are-free-in-varargs ce x varargs || are-free-in-term ce x t || are-free-in-cases ce x cs

are-free-in-varargs ce x NoVarargs              = ff
are-free-in-varargs ce x (NormalVararg x' args) = trie-contains x x'         || are-free-in-varargs ce x args
are-free-in-varargs ce x (ErasedVararg x' args) = (ce && trie-contains x x') || are-free-in-varargs ce x args
are-free-in-varargs ce x (TypeVararg   x' args) = (ce && trie-contains x x') || are-free-in-varargs ce x args

{-# TERMINATING #-}
are-free-in-type ce x (Abs _ _ _ x' atk t) = are-free-in-tk ce x atk || are-free-in-type ce (trie-remove x x') t
are-free-in-type ce x (TpLambda _ _ x' atk t) = are-free-in-tk ce x atk || are-free-in-type ce (trie-remove x x') t
are-free-in-type ce x (Iota _ _ x' m t) = are-free-in-type ce x m || are-free-in-type ce (trie-remove x x') t
are-free-in-type ce x (Lft _ _ X t l) = are-free-in-liftingType ce x l || are-free-in-term ce (trie-remove x X) t
are-free-in-type ce x (TpApp t t') = are-free-in-type ce x t || are-free-in-type ce x t'
are-free-in-type ce x (TpAppt t t') = are-free-in-type ce x t || are-free-in-term ce x t'
are-free-in-type ce x (TpArrow t _ t') = are-free-in-type ce x t || are-free-in-type ce x t'
are-free-in-type ce x (TpEq _ t t' _) = are-free-in-term ce x t || are-free-in-term ce x t'
are-free-in-type ce x (TpParens x₁ t x₂) = are-free-in-type ce x t
are-free-in-type ce x (TpVar _ "_") = ff
are-free-in-type ce x (TpVar _ x') = trie-contains x x'
are-free-in-type ce x (NoSpans t _) = are-free-in-type ce x t
are-free-in-type ce x (TpHole _) = ff
are-free-in-type ce x (TpLet _ (DefTerm _ x' m t) T) =
  (ce && are-free-in-optType ce x m)
  || (are-free-in-term ce x t)
  || are-free-in-type ce (trie-remove x x') T
are-free-in-type ce x (TpLet _ (DefType _ x' k T) T') =
  (ce && (are-free-in-kind ce x k || are-free-in-type ce x T))
  || are-free-in-type ce (trie-remove x x') T'

are-free-in-kind ce x (KndArrow k k') = are-free-in-kind ce x k || are-free-in-kind ce x k'
are-free-in-kind ce x (KndParens x₁ k x₂) = are-free-in-kind ce x k
are-free-in-kind ce x (KndPi _ _ x' atk k) = are-free-in-tk ce x atk || are-free-in-kind ce (trie-remove x x') k
are-free-in-kind ce x (KndTpArrow t k) = are-free-in-type ce x t || are-free-in-kind ce x k
are-free-in-kind ce x (KndVar _ x' ys) = trie-contains x x' || are-free-in-args ce x ys
are-free-in-kind ce x (Star x₁) = ff

are-free-in-args ce x (ArgsCons (TermArg _ y) ys) = are-free-in-term ce x y || are-free-in-args ce x ys
are-free-in-args ce x (ArgsCons (TypeArg y) ys) = are-free-in-type ce x y || are-free-in-args ce x ys
are-free-in-args ce x ArgsNil = ff

are-free-in-optClass ce x NoClass = ff
are-free-in-optClass ce x (SomeClass atk) = are-free-in-tk ce x atk

are-free-in-optType ce x NoType = ff
are-free-in-optType ce x (SomeType t) = are-free-in-type ce x t

are-free-in-optTerm ce x NoTerm = ff
are-free-in-optTerm ce x (SomeTerm t _) = are-free-in-term ce x t

are-free-in-optGuide ce x NoGuide = ff
are-free-in-optGuide ce x (Guide _ v tp) = are-free-in-type ce (trie-remove x v) tp

are-free-in-tk ce x (Tkt t) = are-free-in-type ce x t
are-free-in-tk ce x (Tkk k) = are-free-in-kind ce x k

are-free-in-liftingType ce x (LiftArrow l l') = are-free-in-liftingType ce x l || are-free-in-liftingType ce x l'
are-free-in-liftingType ce x (LiftParens x₁ l x₂) = are-free-in-liftingType ce x l
are-free-in-liftingType ce x (LiftPi _ x' t l) =
  are-free-in-type ce x t || are-free-in-liftingType ce (trie-remove x x') l
are-free-in-liftingType ce x (LiftStar x₁) = ff
are-free-in-liftingType ce x (LiftTpArrow t l) = are-free-in-type ce x t || are-free-in-liftingType ce x l

are-free-in : {ed : exprd} → are-free-e → stringset → ⟦ ed ⟧ → 𝔹
are-free-in{TERM} e x t = are-free-in-term e x t
are-free-in{ARG} e x (TermArg _ t) = are-free-in-term e x t
are-free-in{TYPE} e x t = are-free-in-type e x t
are-free-in{ARG} e x (TypeArg t) = are-free-in-type e x t
are-free-in{KIND} e x t = are-free-in-kind e x t
are-free-in{TK} e x t = are-free-in-tk e x t
are-free-in{LIFTINGTYPE} e x t = are-free-in-liftingType e x t
are-free-in{QUALIF} e x (x' , as) = trie-contains x x' || are-free-in-args e x as

is-free-in : {ed : exprd} → are-free-e → var → ⟦ ed ⟧ → 𝔹
is-free-in{TERM} e x t = are-free-in-term e (stringset-singleton x) t
is-free-in{ARG} e x (TermArg _ t) = are-free-in-term e (stringset-singleton x) t
is-free-in{TYPE} e x t = are-free-in-type e (stringset-singleton x) t
is-free-in{ARG} e x (TypeArg t) = are-free-in-type e (stringset-singleton x) t
is-free-in{KIND} e x t = are-free-in-kind e (stringset-singleton x) t
is-free-in{LIFTINGTYPE} e x t = are-free-in-liftingType e (stringset-singleton x) t
is-free-in{QUALIF} e x (x' , as) = x =string x' || are-free-in-args e (stringset-singleton x) as
is-free-in{TK} e x t = are-free-in-tk e (stringset-singleton x) t

abs-tk : maybeErased → var → tk → type → type
abs-tk me x (Tkk k) tp = Abs posinfo-gen Erased posinfo-gen x (Tkk k) tp
abs-tk me x (Tkt tp') tp with are-free-in check-erased (stringset-singleton x) tp
abs-tk me x (Tkt tp') tp | tt = Abs posinfo-gen me posinfo-gen x (Tkt tp') tp
abs-tk me x (Tkt tp') tp | ff = TpArrow tp' me tp

absk-tk : var → tk → kind → kind
absk-tk x atk k with are-free-in check-erased (stringset-singleton x) k
absk-tk x atk k | tt = KndPi posinfo-gen posinfo-gen x atk k
absk-tk x (Tkt tp) k | ff = KndTpArrow tp k
absk-tk x (Tkk k') k | ff = KndArrow k' k

data abs  : Set where
  mk-abs : maybeErased → var → tk → (var-free-in-body : 𝔹) → type → abs

to-abs : type → maybe abs
to-abs (Abs _ me _ x atk tp) = just (mk-abs me x atk (are-free-in check-erased (stringset-singleton x) tp) tp)
to-abs (TpArrow tp1 me tp2) = just (mk-abs me dummy-var (Tkt tp1) ff tp2)
to-abs _ = nothing

record is-tpabs : Set where
  constructor mk-tpabs
  field
    is-tpabs-e?   : maybeErased
    is-tpabs-var  : var
    is-tpabs-kind : kind
    is-tpabs-body : type
open is-tpabs public

is-tpabs? = type ∨ is-tpabs

pattern yes-tpabs e? x k tp = inj₂ (mk-tpabs e? x k tp)
pattern not-tpabs tp = inj₁ tp

to-is-tpabs : type → is-tpabs?
to-is-tpabs tp with to-abs tp
... | nothing =
  not-tpabs tp
... | just (mk-abs _ _ (Tkt _) _ _)
  = not-tpabs tp
... | just (mk-abs e? x (Tkk k) var-free-in-body tp') =
  yes-tpabs e? x k tp'

data absk  : Set where
  mk-absk : var → tk → (var-free-in-body : 𝔹) → kind → absk

to-absk : kind → maybe absk
to-absk (KndPi _ _ x atk k) = just (mk-absk x atk (are-free-in check-erased (stringset-singleton x) k) k)
to-absk (KndArrow k1 k2) = just (mk-absk dummy-var (Tkk k1) ff k2)
to-absk (KndTpArrow tp k) = just (mk-absk dummy-var (Tkt tp) ff k)
to-absk _ = nothing

record is-tmabs : Set where
  constructor mk-tmabs
  field
    is-tmabs-binder : maybeErased
    is-tmabs-var    : var
    is-tmabs-dom    : type
    is-tmabs-var-in-body : 𝔹
    is-tmabs-cod    : type
open is-tmabs public

is-tmabs? = type ∨ is-tmabs

pattern yes-tmabs e? x dom occurs cod = inj₂ (mk-tmabs e? x dom occurs cod)
pattern not-tmabs tp = inj₁ tp

to-is-tmabs : type → is-tmabs?
to-is-tmabs (Abs _ e? _ x (Tkt dom) cod) =
  yes-tmabs e? x dom (is-free-in check-erased x cod) cod
to-is-tmabs (TpArrow dom e? cod) =
  yes-tmabs e? "_" dom ff cod
to-is-tmabs tp = not-tmabs tp

from-is-tmabs : is-tmabs → type
from-is-tmabs (mk-tmabs b x dom occ cod) =
  Abs posinfo-gen b posinfo-gen x (Tkt dom) cod


------------------------------------------------------------------------
-- Application of substitutions
------------------------------------------------------------------------

open import Data.Universe.Indexed

module deBruijn.Substitution.Data.Application.Application
  {i u e} {Uni : IndexedUniverse i u e} where

import deBruijn.Context; open deBruijn.Context Uni
open import deBruijn.Substitution.Data.Basics
open import deBruijn.Substitution.Data.Map
open import Level using (_⊔_)
import Relation.Binary.PropositionalEquality as P

-- Given an operation which applies substitutions to terms one can
-- define composition of substitutions.

record Application
  {t₁} (T₁ : Term-like t₁)
  {t₂} (T₂ : Term-like t₂) :
  Set (i ⊔ u ⊔ e ⊔ t₁ ⊔ t₂) where

  open Term-like T₂ renaming (_⊢_ to _⊢₂_; _≅-⊢_ to _≅-⊢₂_)

  field
    -- Application of substitutions to terms.
    app : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T₁ ρ̂ → [ T₂ ⟶ T₂ ] ρ̂

  -- Post-application of substitutions to terms.

  infixl 8 _/⊢_

  _/⊢_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Γ ⊢₂ σ → Sub T₁ ρ̂ → Δ ⊢₂ σ /̂ ρ̂
  t /⊢ ρ = app ρ · t

  -- Reverse composition. (Fits well with post-application.)

  infixl 9 _∘_

  _∘_ : ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} →
        Sub T₂ ρ̂₁ → Sub T₁ ρ̂₂ → Sub T₂ (ρ̂₁ ∘̂ ρ̂₂)
  ρ₁ ∘ ρ₂ = map (app ρ₂) ρ₁

  -- Application of multiple substitutions to terms.

  app⋆ : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Subs T₁ ρ̂ → [ T₂ ⟶ T₂ ] ρ̂
  app⋆ = fold [ T₂ ⟶ T₂ ] [id] (λ f ρ → app ρ [∘] f)

  infixl 8 _/⊢⋆_

  _/⊢⋆_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} → Γ ⊢₂ σ → Subs T₁ ρ̂ → Δ ⊢₂ σ /̂ ρ̂
  t /⊢⋆ ρs = app⋆ ρs · t

  -- Some congruence lemmas.

  app-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T₁ ρ̂₁}
               {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T₁ ρ̂₂} →
             ρ₁ ≅-⇨ ρ₂ → app ρ₁ ≅-⟶ app ρ₂
  app-cong P.refl = [ P.refl ]

  /⊢-cong :
    ∀ {Γ₁ Δ₁ σ₁} {t₁ : Γ₁ ⊢₂ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρ₁ : Sub T₁ ρ̂₁}
      {Γ₂ Δ₂ σ₂} {t₂ : Γ₂ ⊢₂ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρ₂ : Sub T₁ ρ̂₂} →
    t₁ ≅-⊢₂ t₂ → ρ₁ ≅-⇨ ρ₂ → t₁ /⊢ ρ₁ ≅-⊢₂ t₂ /⊢ ρ₂
  /⊢-cong P.refl P.refl = P.refl

  ∘-cong :
    ∀ {Γ₁ Δ₁ Ε₁} {ρ̂₁₁ : Γ₁ ⇨̂ Δ₁} {ρ̂₂₁ : Δ₁ ⇨̂ Ε₁}
      {ρ₁₁ : Sub T₂ ρ̂₁₁} {ρ₂₁ : Sub T₁ ρ̂₂₁}
      {Γ₂ Δ₂ Ε₂} {ρ̂₁₂ : Γ₂ ⇨̂ Δ₂} {ρ̂₂₂ : Δ₂ ⇨̂ Ε₂}
      {ρ₁₂ : Sub T₂ ρ̂₁₂} {ρ₂₂ : Sub T₁ ρ̂₂₂} →
    ρ₁₁ ≅-⇨ ρ₁₂ → ρ₂₁ ≅-⇨ ρ₂₂ → ρ₁₁ ∘ ρ₂₁ ≅-⇨ ρ₁₂ ∘ ρ₂₂
  ∘-cong P.refl P.refl = P.refl

  app⋆-cong : ∀ {Γ₁ Δ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T₁ ρ̂₁}
                {Γ₂ Δ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T₁ ρ̂₂} →
              ρs₁ ≅-⇨⋆ ρs₂ → app⋆ ρs₁ ≅-⟶ app⋆ ρs₂
  app⋆-cong P.refl = [ P.refl ]

  /⊢⋆-cong :
    ∀ {Γ₁ Δ₁ σ₁} {t₁ : Γ₁ ⊢₂ σ₁} {ρ̂₁ : Γ₁ ⇨̂ Δ₁} {ρs₁ : Subs T₁ ρ̂₁}
      {Γ₂ Δ₂ σ₂} {t₂ : Γ₂ ⊢₂ σ₂} {ρ̂₂ : Γ₂ ⇨̂ Δ₂} {ρs₂ : Subs T₁ ρ̂₂} →
    t₁ ≅-⊢₂ t₂ → ρs₁ ≅-⇨⋆ ρs₂ → t₁ /⊢⋆ ρs₁ ≅-⊢₂ t₂ /⊢⋆ ρs₂
  /⊢⋆-cong P.refl P.refl = P.refl

  abstract

    -- An unfolding lemma.

    ▻-∘ : ∀ {Γ Δ Ε} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε} {σ}
          (ρ₁ : Sub T₂ ρ̂₁) (t : Δ ⊢₂ σ / ρ₁) (ρ₂ : Sub T₁ ρ̂₂) →
          (ρ₁ ▻⇨[ σ ] t) ∘ ρ₂ ≅-⇨ ρ₁ ∘ ρ₂ ▻⇨[ σ ] t /⊢ ρ₂
    ▻-∘ ρ₁ t ρ₂ = map-▻ (app ρ₂) ρ₁ t

    -- Applying a composed substitution to a variable is equivalent to
    -- applying one substitution and then the other.

    /∋-∘ : ∀ {Γ Δ Ε σ} {ρ̂₁ : Γ ⇨̂ Δ} {ρ̂₂ : Δ ⇨̂ Ε}
           (x : Γ ∋ σ) (ρ₁ : Sub T₂ ρ̂₁) (ρ₂ : Sub T₁ ρ̂₂) →
           x /∋ ρ₁ ∘ ρ₂ ≅-⊢₂ x /∋ ρ₁ /⊢ ρ₂
    /∋-∘ x ρ₁ ρ₂ = /∋-map x (app ρ₂) ρ₁


module Tactic.Nat.Reflect where

open import Prelude hiding (abs)
open import Control.Monad.State
open import Control.Monad.Transformer

import Agda.Builtin.Nat as Builtin

open import Builtin.Reflection
open import Tactic.Reflection
open import Tactic.Reflection.Quote
open import Tactic.Reflection.Meta
open import Tactic.Deriving.Quotable
open import Tactic.Reflection.Equality

open import Tactic.Nat.Exp

R = StateT (Nat × List (Term × Nat)) TC

fail : ∀ {A} → R A
fail = lift (typeErrorS "reflection error")

liftMaybe : ∀ {A} → Maybe A → R A
liftMaybe = maybe fail pure

runR : ∀ {A} → R A → TC (Maybe (A × List Term))
runR r =
  maybeA (second (reverse ∘ map fst ∘ snd) <$> runStateT r (0 , []))

pattern `Nat = def (quote Nat) []

infixr 1 _`->_
infix  4 _`≡_

pattern _`≡_ x y = def (quote _≡_) (_ ∷ hArg `Nat ∷ vArg x ∷ vArg y ∷ [])
pattern _`->_ a b = pi (vArg a) (abs _ b)

pattern _`+_ x y = def₂ (quote Builtin._+_) x y
pattern _`*_ x y = def₂ (quote Builtin._*_) x y
pattern `0       = con₀ (quote Nat.zero)
pattern `suc n   = con₁ (quote Nat.suc) n

fresh : Term → R (Exp Var)
fresh t =
  get >>= uncurry′ λ i Γ →
   var i <$ put (suc i , (t , i) ∷ Γ)

⟨suc⟩ : ∀ {X} → Exp X → Exp X
⟨suc⟩ (lit n) = lit (suc n)
⟨suc⟩ (lit n ⟨+⟩ e) = lit (suc n) ⟨+⟩ e
⟨suc⟩ e = lit 1 ⟨+⟩ e

private
  forceInstance : Name → Term → R ⊤
  forceInstance i v = lift $ unify v (def₀ i)
  forceSemiring = forceInstance (quote SemiringNat)
  forceNumber   = forceInstance (quote NumberNat)

termToExpR : Term → R (Exp Var)
termToExpR (a `+ b) = ⦇ termToExpR a ⟨+⟩ termToExpR b ⦈
termToExpR (a `* b) = ⦇ termToExpR a ⟨*⟩ termToExpR b ⦈
termToExpR (def (quote Semiring._+_) (_ ∷ _ ∷ vArg i@(meta x _) ∷ vArg a ∷ vArg b ∷ [])) = do
  forceSemiring i
  ⦇ termToExpR a ⟨+⟩ termToExpR b ⦈
termToExpR (def (quote Semiring._*_) (_ ∷ _ ∷ vArg i@(meta x _) ∷ vArg a ∷ vArg b ∷ [])) = do
  lift $ unify i (def₀ (quote SemiringNat))
  ⦇ termToExpR a ⟨*⟩ termToExpR b ⦈
termToExpR (def (quote Semiring.zro) (_ ∷ _ ∷ vArg i@(meta x _) ∷ [])) = do
  forceSemiring i
  pure (lit 0)
termToExpR (def (quote Semiring.one) (_ ∷ _ ∷ vArg i@(meta x _) ∷ [])) = do
  forceSemiring i
  pure (lit 1)
termToExpR (def (quote Number.fromNat) (_ ∷ _ ∷ vArg i@(meta x _) ∷ vArg a ∷ _ ∷ [])) = do
  forceNumber i
  termToExpR a
termToExpR `0       = pure (lit 0)
termToExpR (`suc a) = ⟨suc⟩ <$> termToExpR a
termToExpR (lit (nat n)) = pure (lit n)
termToExpR (meta x _) = lift (blockOnMeta x)
termToExpR unknown  = fail
termToExpR t = do
  lift (ensureNoMetas t)
  just i ← gets (flip lookup t ∘ snd) where nothing → fresh t
  pure (var i)

private
  lower : Nat → Term → R Term
  lower 0 = pure
  lower i = liftMaybe ∘ strengthen i

termToEqR : Term → R (Exp Var × Exp Var)
termToEqR (lhs `≡ rhs) = ⦇ termToExpR lhs , termToExpR rhs ⦈
termToEqR (def (quote _≡_) (_ ∷ hArg (meta x _) ∷ _)) = lift (blockOnMeta x)
termToEqR (meta x _) = lift (blockOnMeta x)
termToEqR _ = fail

termToHypsR′ : Nat → Term → R (List (Exp Var × Exp Var))
termToHypsR′ i (hyp `-> a) = _∷_ <$> (termToEqR =<< lower i hyp) <*> termToHypsR′ (suc i) a
termToHypsR′ _ (meta x _) = lift (blockOnMeta x)
termToHypsR′ i a = [_] <$> (termToEqR =<< lower i a)

termToHypsR : Term → R (List (Exp Var × Exp Var))
termToHypsR = termToHypsR′ 0

termToHyps : Term → TC (Maybe (List (Exp Var × Exp Var) × List Term))
termToHyps t = runR (termToHypsR t)

termToEq : Term → TC (Maybe ((Exp Var × Exp Var) × List Term))
termToEq t = runR (termToEqR t)

buildEnv : List Nat → Env Var
buildEnv []        i      = 0
buildEnv (x ∷ xs)  zero   = x
buildEnv (x ∷ xs) (suc i) = buildEnv xs i

defaultArg : Term → Arg Term
defaultArg = arg (arg-info visible relevant)

data ProofError {a} : Set a → Set (lsuc a) where
  bad-goal : ∀ g → ProofError g

qProofError : Term → Term
qProofError v = con (quote bad-goal) (defaultArg v ∷ [])

implicitArg instanceArg : ∀ {A} → A → Arg A
implicitArg = arg (arg-info hidden relevant)
instanceArg = arg (arg-info instance′ relevant)

unquoteDecl QuotableExp = deriveQuotable QuotableExp (quote Exp)

stripImplicitArg : Arg Term → List (Arg Term)
stripImplicitArgs : List (Arg Term) → List (Arg Term)
stripImplicitAbsTerm : Abs Term → Abs Term
stripImplicitArgTerm : Arg Term → Arg Term

stripImplicit : Term → Term
stripImplicit (var x args) = var x (stripImplicitArgs args)
stripImplicit (con c args) = con c (stripImplicitArgs args)
stripImplicit (def f args) = def f (stripImplicitArgs args)
stripImplicit (meta x args) = meta x (stripImplicitArgs args)
stripImplicit (lam v t) = lam v (stripImplicitAbsTerm t)
stripImplicit (pi t₁ t₂) = pi (stripImplicitArgTerm t₁) (stripImplicitAbsTerm t₂)
stripImplicit (agda-sort x) = agda-sort x
stripImplicit (lit l) = lit l
stripImplicit (pat-lam cs args) = pat-lam cs (stripImplicitArgs args)
stripImplicit unknown = unknown

stripImplicitAbsTerm (abs x v) = abs x (stripImplicit v)

stripImplicitArgs [] = []
stripImplicitArgs (a ∷ as) = stripImplicitArg a ++ stripImplicitArgs as

stripImplicitArgTerm (arg i x) = arg i (stripImplicit x)

stripImplicitArg (arg (arg-info visible r) x) = arg (arg-info visible r) (stripImplicit x) ∷ []
stripImplicitArg (arg (arg-info hidden r) x) = []
stripImplicitArg (arg (arg-info instance′ r) x) = []

quotedEnv : List Term → Term
quotedEnv ts = def (quote buildEnv) $ defaultArg (quoteList $ map stripImplicit ts) ∷ []

QED : ∀ {a} {A : Set a} {x : Maybe A} → Set
QED {x = x} = IsJust x

get-proof : ∀ {a} {A : Set a} (prf : Maybe A) → QED {x = prf} → A
get-proof (just eq) _ = eq
get-proof nothing ()
{-# STATIC get-proof #-}

getProof : Name → Term → Term → Term
getProof err t proof =
  def (quote get-proof)
  $ vArg proof
  ∷ vArg (def err $ vArg (stripImplicit t) ∷ [])
  ∷ []

failedProof : Name → Term → Term
failedProof err t =
  def (quote get-proof)
  $ vArg (con (quote nothing) [])
  ∷ vArg (def err $ vArg (stripImplicit t) ∷ [])
  ∷ []

cantProve : Set → ⊤
cantProve _ = _

invalidGoal : Set → ⊤
invalidGoal _ = _


------------------------------------------------------------------------
-- An expression can be derived from at most one string
------------------------------------------------------------------------

open import Mixfix.Expr

module Mixfix.Cyclic.Uniqueness
         (i : PrecedenceGraphInterface)
         (g : PrecedenceGraphInterface.PrecedenceGraph i)
         where

open import Codata.Musical.Notation using (♭)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.List using (List; []; _∷_)
open import Data.List.Relation.Unary.Any using (here)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Product using (_,_; -,_; proj₂)
open import Relation.Binary.HeterogeneousEquality using (_≅_; refl)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open PrecedenceCorrect i g
open import TotalParserCombinators.Semantics hiding (_≅_)
open import Mixfix.Fixity
open import Mixfix.Operator
open import Mixfix.Cyclic.Lib as Lib
open Lib.Semantics
import Mixfix.Cyclic.Grammar
private module Grammar = Mixfix.Cyclic.Grammar i g

module Unique where

 data _≋_ {A : Set} {x₁ : A} {s₁ p₁} (∈ : x₁ ∈⟦ p₁ ⟧· s₁) :
          ∀ {x₂ : A} {s₂ p₂} → x₂ ∈⟦ p₂ ⟧· s₂ → Set where
   refl : ∈ ≋ ∈

 mutual

  precs : ∀ ps {s₁ s₂} {e₁ e₂ : Expr ps}
          (∈₁ : e₁ ∈⟦ Grammar.precs ps ⟧· s₁)
          (∈₂ : e₂ ∈⟦ Grammar.precs ps ⟧· s₂) →
          e₁ ≡ e₂ → ∈₁ ≋ ∈₂
  precs [] () () _
  precs (p ∷ ps) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                 (∣ʳ (<$>_ {x = (._ ∙ ._)}  ∈₂)) refl with precs ps ∈₁ ∈₂ refl
  precs (p ∷ ps) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                 (∣ʳ (<$>_ {x = (._ ∙ ._)} .∈₁)) refl | refl = refl
  precs (p ∷ ps) (∣ˡ (<$> ∈₁)) (∣ʳ (<$>_ {x = _ ∙ _} ∈₂)) ()
  precs (p ∷ ps) (∣ʳ (<$>_ {x = _ ∙ _} ∈₁)) (∣ˡ (<$> ∈₂)) ()
  precs (p ∷ ps) (∣ˡ (<$>_ {x = e₁} ∈₁)) (∣ˡ (<$>_ {x = e₂} ∈₂)) eq =
    helper (lemma₁ eq) (lemma₂ eq) ∈₁ ∈₂
    where
    lemma₁ : ∀ {assoc₁ assoc₂}
               {e₁ : ExprIn p assoc₁} {e₂ : ExprIn p assoc₂} →
             (Expr._∙_ (here {xs = ps} refl) e₁) ≡ (here refl ∙ e₂) →
             assoc₁ ≡ assoc₂
    lemma₁ refl = refl

    lemma₂ : ∀ {assoc₁ assoc₂}
               {e₁ : ExprIn p assoc₁} {e₂ : ExprIn p assoc₂} →
             (Expr._∙_ (here {xs = ps} refl) e₁) ≡ (here refl ∙ e₂) →
             e₁ ≅ e₂
    lemma₂ refl = refl

    helper : ∀ {assoc₁ assoc₂ s₁ s₂}
             {e₁ : ExprIn p assoc₁} {e₂ : ExprIn p assoc₂} →
             assoc₁ ≡ assoc₂ → e₁ ≅ e₂ →
             (∈₁ : (-, e₁) ∈⟦ Grammar.prec p ⟧· s₁) →
             (∈₂ : (-, e₂) ∈⟦ Grammar.prec p ⟧· s₂) →
             ∣ˡ {p₁ = (λ e → here refl ∙ proj₂ e) <$> Grammar.prec p}
                {p₂ = weakenE <$> Grammar.precs ps} (<$> ∈₁) ≋
             ∣ˡ {p₁ = (λ e → here refl ∙ proj₂ e) <$> Grammar.prec p}
                {p₂ = weakenE <$> Grammar.precs ps} (<$> ∈₂)
    helper refl refl ∈₁ ∈₂ with prec ∈₁ ∈₂
    helper refl refl ∈ .∈  | refl = refl

  prec : ∀ {p assoc s₁ s₂} {e : ExprIn p assoc}
         (∈₁ : (-, e) ∈⟦ Grammar.prec p ⟧· s₁)
         (∈₂ : (-, e) ∈⟦ Grammar.prec p ⟧· s₂) →
         ∈₁ ≋ ∈₂
  prec {p} ∈₁′ ∈₂′ = prec′ ∈₁′ ∈₂′ refl
    where
    module P = Grammar.Prec p

    preRight⁺ : ∀ {s₁ s₂} {e₁ e₂ : ExprIn p right}
                (∈₁ : e₁ ∈⟦ P.preRight⁺ ⟧· s₁)
                (∈₂ : e₂ ∈⟦ P.preRight⁺ ⟧· s₂) →
                e₁ ≡ e₂ → ∈₁ ≋ ∈₂
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ˡ (<$> ∈₁′)       ⊛∞ ∣ˡ (<$> ∈₂′)) refl with inner _   ∈₁ ∈₁′ refl | preRight⁺ ∈₂ ∈₂′ refl
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ˡ (<$> .∈₁)       ⊛∞ ∣ˡ (<$> .∈₂)) refl | refl | refl = refl
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ˡ (<$> ∈₁′)       ⊛∞ ∣ʳ (<$> ∈₂′)) refl with inner _ ∈₁ ∈₁′ refl | precs _ ∈₂ ∈₂′ refl
    preRight⁺ (∣ˡ (<$>  ∈₁)       ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ˡ (<$> .∈₁)       ⊛∞ ∣ʳ (<$> .∈₂)) refl | refl | refl = refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ʳ (<$> ∈₁′ ⊛ ∈₃′) ⊛∞ ∣ˡ (<$> ∈₂′)) refl with precs _   ∈₁ ∈₁′ refl | preRight⁺ ∈₂ ∈₂′ refl | inner _   ∈₃ ∈₃′ refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ˡ (<$>  ∈₂))
              (∣ʳ (<$> .∈₁ ⊛ .∈₃) ⊛∞ ∣ˡ (<$> .∈₂)) refl | refl | refl | refl = refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ʳ (<$> ∈₁′ ⊛ ∈₃′) ⊛∞ ∣ʳ (<$> ∈₂′)) refl with precs _ ∈₁ ∈₁′ refl | precs _ ∈₂ ∈₂′ refl | inner _ ∈₃ ∈₃′ refl
    preRight⁺ (∣ʳ (<$>  ∈₁ ⊛  ∈₃) ⊛∞ ∣ʳ (<$>  ∈₂))
              (∣ʳ (<$> .∈₁ ⊛ .∈₃) ⊛∞ ∣ʳ (<$> .∈₂)) refl | refl | refl | refl = refl

    preRight⁺ (∣ˡ (<$> _)     ⊛∞ _)
              (∣ʳ (<$> _ ⊛ _) ⊛∞ _)          ()
    preRight⁺ (∣ʳ (<$> _ ⊛ _) ⊛∞ _)
              (∣ˡ (<$> _)     ⊛∞ _)          ()
    preRight⁺ (∣ˡ (<$> _)     ⊛∞ ∣ˡ (<$> _))
              (∣ˡ (<$> _)     ⊛∞ ∣ʳ (<$> _)) ()
    preRight⁺ (∣ˡ (<$> _)     ⊛∞ ∣ʳ (<$> _))
              (∣ˡ (<$> _)     ⊛∞ ∣ˡ (<$> _)) ()
    preRight⁺ (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ˡ (<$> _))
              (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ʳ (<$> _)) ()
    preRight⁺ (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ʳ (<$> _))
              (∣ʳ (<$> _ ⊛ _) ⊛∞ ∣ˡ (<$> _)) ()

    postLeft⁺ : ∀ {s₁ s₂} {e₁ e₂ : ExprIn p left}
                (∈₁ : e₁ ∈⟦ P.postLeft⁺ ⟧· s₁)
                (∈₂ : e₂ ∈⟦ P.postLeft⁺ ⟧· s₂) →
                e₁ ≡ e₂ → ∈₁ ≋ ∈₂
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ˡ (<$> ∈₁′)) ⊛∞ ∣ˡ (<$> ∈₂′))       refl with postLeft⁺ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ˡ (<$> .∈₁)) ⊛∞ ∣ˡ (<$> .∈₂))       refl | refl | refl = refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ʳ (<$> ∈₁′)) ⊛∞ ∣ˡ (<$> ∈₂′))       refl with precs _ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ˡ (<$>  ∈₂))
              (<$> (∣ʳ (<$> .∈₁)) ⊛∞ ∣ˡ (<$> .∈₂))       refl | refl | refl = refl
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ˡ (<$> ∈₁′)) ⊛∞ ∣ʳ (<$> ∈₂′ ⊛ ∈₃′)) refl with postLeft⁺ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl | precs _ ∈₃ ∈₃′ refl
    postLeft⁺ (<$> (∣ˡ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ˡ (<$> .∈₁)) ⊛∞ ∣ʳ (<$> .∈₂ ⊛ .∈₃)) refl | refl | refl | refl = refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ʳ (<$> ∈₁′)) ⊛∞ ∣ʳ (<$> ∈₂′ ⊛ ∈₃′)) refl with precs _ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl | precs _ ∈₃ ∈₃′ refl
    postLeft⁺ (<$> (∣ʳ (<$>  ∈₁)) ⊛∞ ∣ʳ (<$>  ∈₂ ⊛  ∈₃))
              (<$> (∣ʳ (<$> .∈₁)) ⊛∞ ∣ʳ (<$> .∈₂ ⊛ .∈₃)) refl | refl | refl | refl = refl

    postLeft⁺ (<$> _            ⊛∞ ∣ˡ (<$> _))
              (<$> _            ⊛∞ ∣ʳ (<$> _ ⊛ _)) ()
    postLeft⁺ (<$> _            ⊛∞ ∣ʳ (<$> _ ⊛ _))
              (<$> _            ⊛∞ ∣ˡ (<$> _))     ()
    postLeft⁺ (<$> (∣ˡ (<$> _)) ⊛∞ ∣ˡ (<$> _))
              (<$> (∣ʳ (<$> _)) ⊛∞ ∣ˡ (<$> _))     ()
    postLeft⁺ (<$> (∣ʳ (<$> _)) ⊛∞ ∣ˡ (<$> _))
              (<$> (∣ˡ (<$> _)) ⊛∞ ∣ˡ (<$> _))     ()
    postLeft⁺ (<$> (∣ˡ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _))
              (<$> (∣ʳ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _)) ()
    postLeft⁺ (<$> (∣ʳ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _))
              (<$> (∣ˡ (<$> _)) ⊛∞ ∣ʳ (<$> _ ⊛ _)) ()

    prec′ : ∀ {assoc s₁ s₂} {e₁ e₂ : ExprIn p assoc} →
            (∈₁ : (-, e₁) ∈⟦ Grammar.prec p ⟧· s₁)
            (∈₂ : (-, e₂) ∈⟦ Grammar.prec p ⟧· s₂) →
            e₁ ≡ e₂ → ∈₁ ≋ ∈₂
    prec′ (∥ˡ (<$> ∈₁)) (∥ˡ (<$>  ∈₂)) refl with inner _ ∈₁ ∈₂ refl
    prec′ (∥ˡ (<$> ∈₁)) (∥ˡ (<$> .∈₁)) refl | refl = refl

    prec′ (∥ʳ (∥ˡ (<$> ∈₁  ⊛ ∈₂  ⊛∞ ∈₃ )))
          (∥ʳ (∥ˡ (<$> ∈₁′ ⊛ ∈₂′ ⊛∞ ∈₃′))) refl
      with precs _ ∈₁ ∈₁′ refl | inner _ ∈₂ ∈₂′ refl | precs _ ∈₃ ∈₃′ refl
    prec′ (∥ʳ (∥ˡ (<$>  ∈₁ ⊛  ∈₂ ⊛∞  ∈₃)))
          (∥ʳ (∥ˡ (<$> .∈₁ ⊛ .∈₂ ⊛∞ .∈₃))) refl | refl | refl | refl = refl

    prec′ (∥ʳ (∥ʳ (∥ˡ ∈₁))) (∥ʳ (∥ʳ (∥ˡ  ∈₂))) refl with preRight⁺ ∈₁ ∈₂ refl
    prec′ (∥ʳ (∥ʳ (∥ˡ ∈₁))) (∥ʳ (∥ʳ (∥ˡ .∈₁))) refl | refl = refl

    prec′ (∥ʳ (∥ʳ (∥ʳ (∥ˡ ∈₁)))) (∥ʳ (∥ʳ (∥ʳ (∥ˡ  ∈₂)))) refl with postLeft⁺ ∈₁ ∈₂ refl
    prec′ (∥ʳ (∥ʳ (∥ʳ (∥ˡ ∈₁)))) (∥ʳ (∥ʳ (∥ʳ (∥ˡ .∈₁)))) refl | refl = refl

    prec′ (∥ˡ (<$> _)) (∥ʳ (∥ˡ (<$> _ ⊛ _ ⊛∞ _))) ()
    prec′ (∥ʳ (∥ˡ (<$> _ ⊛ _ ⊛∞ _))) (∥ˡ (<$> _)) ()
    prec′ (∥ʳ (∥ʳ (∥ʳ (∥ʳ ())))) _ _
    prec′ _ (∥ʳ (∥ʳ (∥ʳ (∥ʳ ())))) _

  inner : ∀ {fix s₁ s₂} ops {e₁ e₂ : Inner {fix} ops}
          (∈₁ : e₁ ∈⟦ Grammar.inner ops ⟧· s₁)
          (∈₂ : e₂ ∈⟦ Grammar.inner ops ⟧· s₂) →
          e₁ ≡ e₂ → ∈₁ ≋ ∈₂
  inner [] () () _
  inner ((_ , op) ∷ ops) (∣ˡ (<$>  ∈₁))
                         (∣ˡ (<$>  ∈₂)) refl with inner′ _ _ ∈₁ ∈₂
  inner ((_ , op) ∷ ops) (∣ˡ (<$>  ∈₁))
                         (∣ˡ (<$> .∈₁)) refl | refl = refl
  inner ((_ , op) ∷ ops) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                         (∣ʳ (<$>_ {x = (._ ∙ ._)}  ∈₂)) refl with inner ops ∈₁ ∈₂ refl
  inner ((_ , op) ∷ ops) (∣ʳ (<$>_ {x = ( _ ∙  _)}  ∈₁))
                         (∣ʳ (<$>_ {x = (._ ∙ ._)} .∈₁)) refl | refl = refl
  inner ((_ , op) ∷ ops) (∣ˡ (<$> ∈₁)) (∣ʳ (<$>_ {x = (_ ∙ _)} ∈₂)) ()
  inner ((_ , op) ∷ ops) (∣ʳ (<$>_ {x = (_ ∙ _)} ∈₁)) (∣ˡ (<$> ∈₂)) ()

  inner′ : ∀ {arity s₁ s₂}
           (ns : Vec NamePart (1 + arity))
           (args : Vec (Expr anyPrecedence) arity)
           (∈₁ : args ∈⟦ Grammar.expr between ns ⟧· s₁)
           (∈₂ : args ∈⟦ Grammar.expr between ns ⟧· s₂) →
           ∈₁ ≋ ∈₂
  inner′ (n ∷ [])      []           between-[] between-[] = refl
  inner′ (n ∷ n′ ∷ ns) (arg ∷ args)
         (between-∷ ∈₁ ∈⋯₁) (between-∷ ∈₂ ∈⋯₂)
    with precs _ ∈₁ ∈₂ refl | inner′ (n′ ∷ ns) args ∈⋯₁ ∈⋯₂
  inner′ (n ∷ n′ ∷ ns) (arg ∷ args)
         (between-∷ ∈₁ ∈⋯₁) (between-∷ .∈₁ .∈⋯₁) | refl | refl = refl

-- There is at most one string representing a given expression.

unique : ∀ {e s₁ s₂} →
         e ∈ Grammar.expression · s₁ →
         e ∈ Grammar.expression · s₂ →
         s₁ ≡ s₂
unique ∈₁ ∈₂ with ∈₁′ | ∈₂′ | Unique.precs _ ∈₁′ ∈₂′ refl
  where
  ∈₁′ = Lib.Semantics.complete (♭ Grammar.expr) ∈₁
  ∈₂′ = Lib.Semantics.complete (♭ Grammar.expr) ∈₂
... | ∈ | .∈ | Unique.refl = refl


------------------------------------------------------------------------
-- Inversion of canonical subtyping in Fω with interval kinds
------------------------------------------------------------------------

{-# OPTIONS --safe --without-K #-}

module FOmegaInt.Kinding.Canonical.Inversion where

open import Data.Product using (_,_; _×_; proj₁; proj₂)
open import Data.Vec using ([]; _∷_; foldl)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂)
open import Relation.Nullary using (¬_)

open import FOmegaInt.Syntax
open import FOmegaInt.Kinding.Canonical
open import FOmegaInt.Kinding.Canonical.Validity

open Syntax
open ElimCtx
open Kinding
open ContextNarrowing

------------------------------------------------------------------------
-- Inversion of canonical subtyping (in the empty context).

-- NOTE.  The lemmas in this module only hold in the empty context
-- because we can not invert instances of the interval projection
-- rules (<:-⟨| and (<:-|⟩) in arbitrary contexts.  This is because
-- instances of these rules can reflect arbitrary subtyping
-- assumptions into the subtyping relation.  Consider, e.g.
--
--     Γ, X :: ⊤..⊥ ctx    Γ(X) = ⊥..⊤
--     ------------------------------- (∈-var)
--     Γ, X :: ⊤..⊥ ⊢ X :: ⊤..⊥
--     -------------------------- (<:-⟨|, <:-|⟩)
--     Γ, X :: ⊤..⊥ ⊢ ⊤ <: X <: ⊥
--
-- Which allows us to prove that ⊤ <: ⊥ using (<:-trans) under the
-- assumption (X : ⊤..⊥).  On the other hand, it is impossible to give
-- a transitivity-free proof of ⊤ <: ⊥.  In general, it is therefore
-- impossible to invert subtyping statements in non-empty contexts,
-- i.e. one cannot prove lemmas like (<:-→-inv) or (<:-∀-inv) below
-- for arbitrary contexts.

infix 4 ⊢_<!_

-- Top-level transitivity-free canonical subtyping in the empty
-- context.
data ⊢_<!_ : Elim 0 → Elim 0 → Set where
  <!-⊥ : ∀ {a} → [] ⊢Nf a ⇉ a ⋯ a → ⊢ ⊥∙ <! a
  <!-⊤ : ∀ {a} → [] ⊢Nf a ⇉ a ⋯ a → ⊢ a  <! ⊤∙
  <!-∀ : ∀ {k₁ k₂ a₁ a₂} → [] ⊢ k₂ <∷ k₁ → kd k₂ ∷ [] ⊢ a₁ <: a₂ →
         [] ⊢Nf ∀∙ k₁ a₁ ⇉ ∀∙ k₁ a₁ ⋯ ∀∙ k₁ a₁ → ⊢ ∀∙ k₁ a₁ <! ∀∙ k₂ a₂
  <!-→ : ∀ {a₁ a₂ b₁ b₂} → [] ⊢ a₂ <: a₁ → [] ⊢ b₁ <: b₂ →
         ⊢ a₁ ⇒∙ b₁ <! a₂ ⇒∙ b₂

-- Soundness of <! with respect to <: in the empty context.
sound-<! : ∀ {a b : Elim 0} → ⊢ a <! b → [] ⊢ a <: b
sound-<! (<!-⊥ a⇉a⋯a)         = <:-⊥ a⇉a⋯a
sound-<! (<!-⊤ a⇉a⋯a)         = <:-⊤ a⇉a⋯a
sound-<! (<!-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) =
  <:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁
sound-<! (<!-→ a₂<:a₁ b₁<:b₂) = <:-→ a₂<:a₁ b₁<:b₂

-- The only proper (top-level) subtype of ⊥ is ⊥ itself.
⊥-<!-min : ∀ {a : Elim 0} → ⊢ a <! ⊥∙ → a ≡ ⊥∙
⊥-<!-min (<!-⊥ _) = refl

-- The only proper (top-level) supertype of ⊤ is ⊤ itself.
⊤-<!-max : ∀ {a : Elim 0} → ⊢ ⊤∙ <! a → a ≡ ⊤∙
⊤-<!-max (<!-⊤ _) = refl

-- Arrows are not (top-level) subtypes of universals and vice-versa.

⇒-≮!-Π : ∀ {a : Elim 0} {k b₁ b₂} → ¬ ⊢ a ⇒∙ b₁ <! ∀∙ k b₂
⇒-≮!-Π ()

Π-≮!-⇒ : ∀ {a : Elim 0} {k b₁ b₂} → ¬ ⊢ ∀∙ k b₁ <! a ⇒∙ b₂
Π-≮!-⇒ ()

-- Validity of <!
<!-valid : ∀ {a b} → ⊢ a <! b → [] ⊢Nf a ⇉ a ⋯ a × [] ⊢Nf b ⇉ b ⋯ b
<!-valid a<!b = <:-valid (sound-<! a<!b)

-- Top-level transitivity of canonical subtyping is admissible.
<!-trans : ∀ {a b c} → [] ⊢ a <: b → ⊢ b <! c → ⊢ a <! c
<!-trans (<:-trans a<:b b<:c) c<!d = <!-trans a<:b (<!-trans b<:c c<!d)
<!-trans (<:-⊥ a⇉a⋯a) a<!d     = <!-⊥ (proj₂ (<!-valid a<!d))
<!-trans (<:-⊤ a⇉a⋯a) (<!-⊤ _) = <!-⊤ a⇉a⋯a
<!-trans (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) (<!-⊤ _) =
  <!-⊤ (proj₁ (<:-valid (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁)))
<!-trans (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) (<!-∀ k₃<∷k₂ a₂<:a₃ _) =
  <!-∀ (<∷-trans k₃<∷k₂ k₂<∷k₁)
       (<:-trans (⇓-<: k₃-kd k₃<∷k₂ a₁<:a₂) a₂<:a₃) Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁
  where k₃-kd = wf-kd-inv (wf-∷₁ (<:-ctx a₂<:a₃))
<!-trans (<:-→ a₂<:a₁ b₁<:b₂) (<!-⊤ a₂⇒b₂⇉a₂⇒b₂⋯a₂⇒b₂) =
  <!-⊤ (proj₁ (<:-valid (<:-→ a₂<:a₁ b₁<:b₂)))
<!-trans (<:-→ a₂<:a₁ b₁<:b₂) (<!-→ a₃<:a₂ b₂<:b₃) =
  <!-→ (<:-trans a₃<:a₂ a₂<:a₁) (<:-trans b₁<:b₂ b₂<:b₃)
<!-trans (<:-∙ {()} _ _)        b<!c
<!-trans (<:-⟨| (∈-∙ {()} _ _)) b<!c
<!-trans (<:-|⟩ (∈-∙ {()} _ _)) b<!c

-- Completeness of <! with respect to <: in the empty context.
complete-<! : ∀ {a b : Elim 0} → [] ⊢ a <: b → ⊢ a <! b
complete-<! (<:-trans a<:b b<:c) = <!-trans a<:b (complete-<! b<:c)
complete-<! (<:-⊥ a⇉a⋯a)         = <!-⊥ a⇉a⋯a
complete-<! (<:-⊤ a⇉a⋯a)         = <!-⊤ a⇉a⋯a
complete-<! (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) =
  <!-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁
complete-<! (<:-→ a₂<:a₁ b₁<:b₂) = <!-→ a₂<:a₁ b₁<:b₂
complete-<! (<:-∙ {()} _ _)
complete-<! (<:-⟨| (∈-∙ {()} _ _))
complete-<! (<:-|⟩ (∈-∙ {()} _ _))

-- The only proper (top-level) subtype of ⊥ is ⊥ itself.
⊥-<:-min : ∀ {a : Elim 0} → [] ⊢ a <: ⊥∙ → a ≡ ⊥∙
⊥-<:-min a<:⊥ = ⊥-<!-min (complete-<! a<:⊥)

-- The only proper (top-level) supertype of ⊤ is ⊤ itself.
⊤-<:-max : ∀ {a : Elim 0} → [] ⊢ ⊤∙ <: a → a ≡ ⊤∙
⊤-<:-max ⊤<:a = ⊤-<!-max (complete-<! ⊤<:a)

-- Inversion of canonical subtyping for universals and arrow types.

<:-∀-inv : ∀ {k₁ k₂ : Kind Elim 0} {a₁ a₂} → [] ⊢ ∀∙ k₁ a₁ <: ∀∙ k₂ a₂ →
           [] ⊢ k₂ <∷ k₁ × kd k₂ ∷ [] ⊢ a₁ <: a₂
<:-∀-inv Πk₁a₁<:Πk₂a₂ with complete-<! Πk₁a₁<:Πk₂a₂
<:-∀-inv Πk₁a₁<:Πk₂a₂ | <!-∀ k₂<∷k₁ a₁<:a₂ _ = k₂<∷k₁ , a₁<:a₂

<:-→-inv : ∀ {a₁ a₂ : Elim 0} {b₁ b₂} → [] ⊢ a₁ ⇒∙ b₁ <: a₂ ⇒∙ b₂ →
           [] ⊢ a₂ <: a₁ × [] ⊢ b₁ <: b₂
<:-→-inv a₁⇒b₁<:a₂⇒b₂ with complete-<! a₁⇒b₁<:a₂⇒b₂
<:-→-inv a₁⇒b₁<:a₂⇒b₂ | <!-→ a₂<∷a₁ b₁<:b₂ = a₂<∷a₁ , b₁<:b₂

-- Arrows are not canonical subtypes of universals and vice-versa.

⇒-≮:-Π : ∀ {a : Elim 0} {k b₁ b₂} → ¬ [] ⊢ a ⇒∙ b₁ <: ∀∙ k b₂
⇒-≮:-Π = ⇒-≮!-Π ∘ complete-<!

Π-≮:-⇒ : ∀ {a : Elim 0} {k b₁ b₂} → ¬ [] ⊢ ∀∙ k b₁ <: a ⇒∙ b₂
Π-≮:-⇒ = Π-≮!-⇒ ∘ complete-<!


-- Lifting of substitutions, and instance of strength for δ
module SOAS.Coalgebraic.Lift {T : Set} where

open import SOAS.Common
open import SOAS.Context {T}
open import SOAS.Variable
open import SOAS.Families.Core {T}
import SOAS.Families.Delta {T} as δ; open δ.Sorted
open import SOAS.Abstract.Hom {T}
import SOAS.Abstract.Box {T} as □ ; open □.Sorted
import SOAS.Abstract.Coalgebra {T} as →□ ; open →□.Sorted

open import SOAS.Coalgebraic.Map
open import SOAS.Coalgebraic.Strength

private
  variable
    Γ Δ Θ : Ctx
    α : T

module _ {𝒫 : Familyₛ} (𝒫ᴮ : Coalgₚ 𝒫) where
  open Coalgₚ 𝒫ᴮ

  -- General lifting over an arbitrary context
  lift : (Ξ : Ctx) → Γ ~[ 𝒫 ]↝ Δ → (Ξ ∔ Γ) ~[ 𝒫 ]↝ (Ξ ∔ Δ)
  lift ∅ σ v             = σ v
  lift (τ ∙ Ξ) σ new     = η new
  lift (τ ∙ Ξ) σ (old v) = r (lift Ξ σ v) old

  -- Single-variable lifting
  lift₁ : {τ : T} → Γ ~[ 𝒫 ]↝ Δ → (τ ∙ Γ) ~[ 𝒫 ]↝ (τ ∙ Δ)
  lift₁ {τ = τ} = lift ⌈ τ ⌋

-- General lifting of renaming
rlift : (Ξ : Ctx) → Γ ↝ Δ → (Ξ ∔ Γ) ↝ (Ξ ∔ Δ)
rlift Ξ = lift ℐᴮ Ξ

-- Strength for context extension
δ:Strength : (Ξ : Ctx) → Strength (δF Ξ)
δ:Strength Ξ = record
  { str = λ 𝒫ᴮ 𝒳 h σ → h (lift 𝒫ᴮ Ξ σ)
  ; str-nat₁ = λ fᴮ⇒ h σ → cong h (dext (str-nat₁ Ξ fᴮ⇒ σ))
  ; str-nat₂ = λ f h σ → refl
  ; str-unit = λ 𝒳 h → cong h (dext (str-unit Ξ 𝒳))
  ; str-assoc = λ 𝒳 fᶜ h σ ς → cong h (dext (str-assoc Ξ 𝒳 fᶜ σ ς))
  }
  where
  open ≡-Reasoning
  open Coalgₚ
  open Coalgₚ⇒

  str-nat₁ : (Ξ : Ctx){𝒫 𝒬 : Familyₛ} {𝒫ᴮ : Coalgₚ 𝒫}
             {𝒬ᴮ : Coalgₚ 𝒬} {f : 𝒬 ⇾̣ 𝒫}
           → Coalgₚ⇒ 𝒬ᴮ 𝒫ᴮ f
           → (σ : Γ ~[ 𝒬 ]↝ Δ)(v : ℐ α (Ξ ∔ Γ))
    → lift 𝒫ᴮ Ξ (f ∘ σ) v
    ≡ f (lift 𝒬ᴮ Ξ σ v)
  str-nat₁ ∅ fᴮ⇒ σ v = refl
  str-nat₁ (α ∙ Ξ) {𝒫ᴮ = 𝒫ᴮ} fᴮ⇒ σ new = sym (Coalgₚ⇒.⟨η⟩ fᴮ⇒)
  str-nat₁ (α ∙ Ξ) {𝒫ᴮ = 𝒫ᴮ} {𝒬ᴮ}{f}fᴮ⇒ σ (old v) = begin
       lift 𝒫ᴮ (α ∙ Ξ) (f ∘ σ) (old v)
     ≡⟨ congr (str-nat₁ Ξ fᴮ⇒ σ v) (λ - → r 𝒫ᴮ - old) ⟩
       r 𝒫ᴮ (f (lift 𝒬ᴮ Ξ σ v)) old
     ≡˘⟨ ⟨r⟩ fᴮ⇒ ⟩
       f (lift 𝒬ᴮ (α ∙ Ξ) σ (old v))
     ∎

  str-unit : (Ξ : Ctx) (𝒳 : Familyₛ) (v : ℐ α (Ξ ∔ Γ))
    → lift ℐᴮ Ξ id v ≡ v
  str-unit ∅ 𝒳 v = refl
  str-unit (α ∙ Ξ) 𝒳 new = refl
  str-unit (α ∙ Ξ) 𝒳 (old v) = cong old (str-unit Ξ 𝒳 v)

  str-assoc : (Ξ : Ctx) (𝒳 : Familyₛ) {𝒫 𝒬 ℛ : Familyₛ}
              {𝒫ᴮ : Coalgₚ 𝒫} {𝒬ᴮ : Coalgₚ 𝒬} {ℛᴮ : Coalgₚ ℛ}
              {f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
              (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f) (open Coalgebraic fᶜ)
              (σ : Γ ~[ 𝒫 ]↝ Δ) (ς : Δ ~[ 𝒬 ]↝ Θ)(v : ℐ α (Ξ ∔ Γ))
    → lift ℛᴮ Ξ (λ u → f (σ u) ς) v
    ≡ lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v (lift 𝒬ᴮ Ξ ς)
  str-assoc ∅ 𝒳 fᶜ σ ς v = refl
  str-assoc (β ∙ Ξ) 𝒳 {𝒫ᴮ = 𝒫ᴮ}{𝒬ᴮ}{ℛᴮ} {f} fᶜ σ ς new = begin
       η ℛᴮ new                          ≡˘⟨ f∘η ⟩
       f (η 𝒫ᴮ new) (η 𝒬ᴮ)               ≡⟨ eq-at-new refl ⟩
       f (η 𝒫ᴮ new) (lift 𝒬ᴮ (β ∙ Ξ) ς)  ∎
     where open Coalgebraic fᶜ

  str-assoc {Γ = Γ} (β ∙ Ξ)  𝒳 {𝒫 = 𝒫}{𝒬}{𝒫ᴮ = 𝒫ᴮ}{𝒬ᴮ}{ℛᴮ}{f} fᶜ σ ς (old v) =
     begin
         r ℛᴮ   (lift ℛᴮ Ξ (λ u → f (σ u) ς) v)   old
     ≡⟨ congr (str-assoc Ξ 𝒳 fᶜ σ ς v) (λ - → r ℛᴮ - old) ⟩
         r ℛᴮ (  lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v   (lift 𝒬ᴮ Ξ ς)) old
     ≡⟨ congr (str-nat₁ Ξ fᴮ⇒ (σ) v) (λ - → r ℛᴮ (- (lift 𝒬ᴮ Ξ ς)) old) ⟩
         r ℛᴮ (f (lift 𝒫ᴮ Ξ σ v) (lift 𝒬ᴮ Ξ ς)) old
     ≡⟨ r∘f ⟩
         f (lift 𝒫ᴮ Ξ σ v)   (λ u → r 𝒬ᴮ (lift 𝒬ᴮ Ξ ς u) old)
     ≡˘⟨ congr (str-nat₁ Ξ fᴮ⇒ σ v) (λ - → - (λ u → r 𝒬ᴮ (lift 𝒬ᴮ Ξ ς u) old)) ⟩
         lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v (λ u → r 𝒬ᴮ (lift 𝒬ᴮ Ξ ς u) old)
     ∎
     where open Coalgebraic fᶜ renaming (ᴮ⇒ to fᴮ⇒)

module δ:Str Θ = Strength (δ:Strength Θ)

-- Derived lifting properties
rlift-id : (𝒳 : Familyₛ)(Ξ : Ctx)(b : δ Ξ (□ 𝒳) α Γ)
         → b (rlift Ξ id) ≡ b id
rlift-id 𝒳 Ξ = Strength.str-unit (δ:Strength Ξ) 𝒳

lift-comp : {𝒫 𝒬 : Familyₛ}{𝒫ᴮ : Coalgₚ 𝒫}{𝒬ᴮ : Coalgₚ 𝒬}
            (𝒳 : Familyₛ)(Ξ : Ctx){f : 𝒬 ⇾̣ 𝒫}
            (fᴮ⇒ : Coalgₚ⇒ 𝒬ᴮ 𝒫ᴮ f)
            (h : δ Ξ 〖 𝒫 , 𝒳 〗 α Γ) (σ : Γ ~[ 𝒬 ]↝ Δ)
  → h (lift 𝒫ᴮ Ξ (f ∘ σ))
  ≡ h (f ∘ lift 𝒬ᴮ Ξ σ)
lift-comp 𝒳 Ξ fᴮ⇒ h σ = Strength.str-nat₁ (δ:Strength Ξ) {𝒳 = 𝒳} fᴮ⇒ h σ

lift-assoc : {𝒫 𝒬 ℛ : Familyₛ}
            {𝒫ᴮ : Coalgₚ 𝒫} {𝒬ᴮ : Coalgₚ 𝒬} {ℛᴮ : Coalgₚ ℛ}
            (𝒳 : Familyₛ)(Ξ : Ctx) {f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
            (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f)
            (open Coalgebraic fᶜ)
            (h : δ Ξ 〖 ℛ , 𝒳 〗 α Γ)
            (σ : Γ ~[ 𝒫 ]↝ Δ) (ς : Δ ~[ 𝒬 ]↝ Θ)
  → h (lift ℛᴮ Ξ (λ v → f (σ v) ς))
  ≡ h (λ v → lift 〖𝒫,𝒴〗ᴮ Ξ (f ∘ σ) v (lift 𝒬ᴮ Ξ ς))
lift-assoc 𝒳 Ξ fᶜ h σ ς = Strength.str-assoc (δ:Strength Ξ) 𝒳 fᶜ h σ ς

lift-dist : {𝒫 𝒬 ℛ : Familyₛ}{𝒫ᴮ : Coalgₚ 𝒫}{𝒬ᴮ : Coalgₚ 𝒬}{ℛᴮ : Coalgₚ ℛ}
            (𝒳 : Familyₛ){Ξ : Ctx}{f : 𝒫 ⇾̣ 〖 𝒬 , ℛ 〗}
            (fᶜ : Coalgebraic 𝒫ᴮ 𝒬ᴮ ℛᴮ f)
            (h : δ Ξ 〖 ℛ , 𝒳 〗 α Γ)
            (σ : Γ ~[ 𝒫 ]↝ Δ) (ς : Δ ~[ 𝒬 ]↝ Θ)
  → h (lift ℛᴮ Ξ (λ v → f (σ v) ς))
  ≡ h (λ v → f (lift 𝒫ᴮ Ξ σ v) (lift 𝒬ᴮ Ξ ς))
lift-dist 𝒳 {Ξ} = Strength.str-dist (δ:Strength Ξ) 𝒳