{-# 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


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types

open import LibraBFT.Abstract.Types

open import LibraBFT.Yasm.Base
open import LibraBFT.Yasm.AvailableEpochs using (AvailableEpochs) renaming (lookup'' to EC-lookup)
import LibraBFT.Yasm.AvailableEpochs as AE

-- This module provides some definitions and properties that facilitate
-- proofs of properties about a distributed system modeled by Yasm.System
-- paramaterized by some SystemParameters.

module LibraBFT.Yasm.Properties (parms : SystemParameters) where
 open import LibraBFT.Yasm.System parms
 open SystemParameters parms
 open EpochConfig

 -- A ValidPartForPK collects the assumptions about what a /part/ in the outputs of an honest verifier
 -- satisfies: (i) the epoch field is consistent with the existent epochs and (ii) the verifier is
 -- a member of the associated epoch config, and (iii) has the given PK in that epoch.
 record ValidPartForPK {e}(𝓔s : AvailableEpochs e)(part : Part)(pk : PK) : Set₁ where
   constructor mkValidPartForPK
   field
     vp-epoch           : part-epoch part < e
     vp-ec              : EpochConfig
     vp-ec-≡            : AE.lookup'' 𝓔s vp-epoch ≡ vp-ec
     vp-member          : Member vp-ec
     vp-key             : getPubKey vp-ec vp-member ≡ pk
 open ValidPartForPK public

 -- A valid part remains valid when new epochs are added
 ValidPartForPK-stable-epoch : ∀{e part pk}{𝓔s : AvailableEpochs e}(𝓔 : EpochConfigFor e)
                          → ValidPartForPK 𝓔s part pk
                          → ValidPartForPK (AE.append 𝓔 𝓔s) part pk
 ValidPartForPK-stable-epoch {pk = pk} {𝓔s} 𝓔 (mkValidPartForPK e ec refl emem vpk) = record
   { vp-epoch           = ≤-step e
   ; vp-ec              = ec
   ; vp-ec-≡            = AE.lookup''-≤-step-lemma 𝓔s 𝓔 e
   ; vp-member          = emem
   ; vp-key             = vpk
   }

 -- A valid part remains valid
 ValidPartForPK-stable : ∀{e e'}{st : SystemState e}{st' : SystemState e'}
                    → Step* st st' → ∀{part pk}
                    → ValidPartForPK (availEpochs st) part pk
                    → ValidPartForPK (availEpochs st') part pk
 ValidPartForPK-stable step-0 v = v
 ValidPartForPK-stable (step-s st (step-epoch 𝓔)) v
   = ValidPartForPK-stable-epoch 𝓔 (ValidPartForPK-stable st v)
 ValidPartForPK-stable (step-s st (step-peer _)) v
   = ValidPartForPK-stable st v

 -- We say that an implementation produces only valid parts iff all parts of every message in the
 -- output of a 'StepPeerState' are either: (i) a valid new part (i.e., the part is valid and has
 -- not been included in a previously sent message with the same signature), or (ii) the part been
 -- included in a previously sent message with the same signature.
 StepPeerState-AllValidParts : Set₁
 StepPeerState-AllValidParts = ∀{e s m part pk outs α}{𝓔s : AvailableEpochs e}{st : SystemState e}
   → (r : ReachableSystemState st)
   → Meta-Honest-PK pk
   → StepPeerState α 𝓔s (msgPool st) (Map-lookup α (peerStates st)) s outs
   → m ∈ outs → part ⊂Msg m → (ver : WithVerSig pk part)
                                 -- NOTE: this doesn't DIRECTLY imply that nobody else has sent a
                                 -- message with the same signature just that the author of the part
                                 -- hasn't.
   → (ValidPartForPK 𝓔s part pk × ¬ (MsgWithSig∈ pk (ver-signature ver) (msgPool st)))
   ⊎ MsgWithSig∈ pk (ver-signature ver) (msgPool st)

 -- A /part/ was introduced by a specific step when:
 IsValidNewPart : ∀{e e'}{pre : SystemState e}{post : SystemState e'} → Signature → PK → Step pre post → Set₁
 IsValidNewPart _ _ (step-epoch _) = Lift (ℓ+1 0ℓ) ⊥
 -- said step is a /step-peer/ and
 IsValidNewPart {pre = pre} sig pk (step-peer pstep)
    -- the part has never been seen before
    = ¬ (MsgWithSig∈ pk sig (msgPool pre))
    × Σ (MsgWithSig∈ pk sig (msgPool (StepPeer-post pstep)))
        (λ m → ValidPartForPK (availEpochs pre) (msgPart m) pk)

 -- When we can prove that the implementation provided by 'parms' at the
 -- top of this module satisfies 'StepPeerState-AllValidParts', we can
 -- prove a number of useful structural properties:

 -- TODO-2: Refactor into a file (LibraBFT.Yasm.Properties.Structural) later on
 -- if this grows too large.
 module Structural (sps-avp      : StepPeerState-AllValidParts) where

     -- We can unwind the state and highlight the step where a part was
     -- originally sent. This 'unwind' function combined with Any-Step-elim
     -- enables a powerful form of reasoning. The 'honestVoteEpoch' below
     -- exemplifies this well.
     unwind : ∀{e}{st : SystemState e}(tr : ReachableSystemState st)
            → ∀{p m σ pk} → Meta-Honest-PK pk
            → p ⊂Msg m → (σ , m) ∈ msgPool st → (ver : WithVerSig pk p)
            → Any-Step ((IsValidNewPart (ver-signature ver) pk)) tr
     unwind (step-s tr (step-epoch _))    hpk p⊂m m∈sm sig
       = step-there (unwind tr hpk p⊂m m∈sm sig)
     unwind (step-s tr (step-peer {pid = β} {outs = outs} {pre = pre} sp)) hpk p⊂m m∈sm sig
       with Any-++⁻ (List-map (β ,_) outs) {msgPool pre} m∈sm
     ...| inj₂ furtherBack = step-there (unwind tr hpk p⊂m furtherBack sig)
     ...| inj₁ thisStep
       with sp
     ...| step-cheat fm isCheat
       with thisStep
     ...| here refl
       with isCheat p⊂m sig
     ...| inj₁ abs    = ⊥-elim (hpk abs)
     ...| inj₂ sentb4
       with unwind tr {p = msgPart sentb4} hpk (msg⊆ sentb4) (msg∈pool sentb4) (msgSigned sentb4)
     ...| res rewrite msgSameSig sentb4 = step-there res
     unwind (step-s tr (step-peer {pid = β} {outs = outs} {pre = pre} sp)) hpk p⊂m m∈sm sig
        | inj₁ thisStep
        | step-honest x
       with Any-satisfied-∈ (Any-map⁻ thisStep)
     ...| (m , refl , m∈outs)
       with sps-avp tr hpk x m∈outs p⊂m sig
     ...| inj₂ sentb4 with unwind tr {p = msgPart sentb4} hpk (msg⊆ sentb4) (msg∈pool sentb4) (msgSigned sentb4)
     ...| res rewrite msgSameSig sentb4 = step-there res

     unwind (step-s tr (step-peer {pid = β} {outs = outs} {pre = pre} sp)) {p} hpk p⊂m m∈sm sig
        | inj₁ thisStep
        | step-honest x
        | (m , refl , m∈outs)
        | inj₁ (valid-part , notBefore) =
               step-here tr (notBefore , MsgWithSig∈-++ˡ (mkMsgWithSig∈ _ _ p⊂m β thisStep sig refl)
                                       , valid-part)

     -- Unwind is inconvenient to use by itself because we have to do
     -- induction on Any-Step-elim. The 'honestPartValid' property below
     -- provides a fairly general result conveniently: for every part
     -- verifiable with an honest PK, there is a msg with the same
     -- signature that is valid for some pid.

     honestPartValid : ∀ {e st} → ReachableSystemState {e} st → ∀ {pk nm v sender}
                     → Meta-Honest-PK pk
                     → v ⊂Msg nm → (sender , nm) ∈ msgPool st → (ver : WithVerSig pk v)
                     → Σ (MsgWithSig∈ pk (ver-signature ver) (msgPool st))
                         (λ msg → (ValidPartForPK (availEpochs st) (msgPart msg) pk))
     honestPartValid {e} {st} r {pk = pk} hpk v⊂m m∈pool ver
     -- We extract two pieces of important information from the place where the part 'v'
     -- was first sent: (a) there is a message with the same signature /in the current pool/
     -- and (b) its epoch is less than e.
        = Any-Step-elim (λ { {st = step-epoch _} ()
                           ; {st = step-peer ps} (_ , new , valid) tr
                             →  MsgWithSig∈-Step* tr new
                                , ValidPartForPK-stable tr
                                    (subst (λ P → ValidPartForPK _ P pk)
                                           (MsgWithSig∈-Step*-part tr new) valid)
                           })
                        (unwind r hpk v⊂m m∈pool ver)

     -- Unforgeability is also an important property stating that every part that is
     -- verified with an honest public key has either been sent by α or is a replay
     -- of another message sent before.
     ext-unforgeability'
       : ∀{e α m part pk}{st : SystemState e} → ReachableSystemState st
       -- If a message m has been sent by α, containing part
       → (α , m) ∈ msgPool st → part ⊂Msg m
       -- And the part can be verified with an honest public key,
       → (sig : WithVerSig pk part) → Meta-Honest-PK pk
       -- then either the part is a valid part by α (meaning that α can
       -- sign the part itself) or a message with the same signature has
       -- been sent previously.
       → ValidPartForPK (availEpochs st) part pk
       ⊎ MsgWithSig∈ pk (ver-signature sig) (msgPool st)
     ext-unforgeability' (step-s st (step-epoch 𝓔)) m∈sm p⊆m sig hpk
       = ⊎-map (ValidPartForPK-stable-epoch 𝓔) id (ext-unforgeability' st m∈sm p⊆m sig hpk)
     ext-unforgeability' {part = part} (step-s st (step-peer {pid = β} {outs = outs} {pre = pre} sp)) m∈sm p⊆m sig hpk
       with Any-++⁻ (List-map (β ,_) outs) {msgPool pre} m∈sm
     ...| inj₂ furtherBack = MsgWithSig∈-++ʳ <⊎$> (ext-unforgeability' st furtherBack p⊆m sig hpk)
     ...| inj₁ thisStep
       with sp
     ...| step-cheat fm isCheat
       with thisStep
     ...| here refl
       with isCheat p⊆m sig
     ...| inj₁ abs    = ⊥-elim (hpk abs)
     ...| inj₂ sentb4 = inj₂ (MsgWithSig∈-++ʳ sentb4)
     ext-unforgeability' {m = m} {part = part} (step-s st (step-peer {pid = β} {outs = outs} {pre = pre} sp)) m∈sm p⊆m sig hpk
        | inj₁ thisStep
        | step-honest x
       with Any-satisfied-∈ (Any-map⁻ thisStep)
     ...| (m , refl , m∈outs) = ⊎-map proj₁ MsgWithSig∈-++ʳ (sps-avp st hpk x m∈outs p⊆m sig)

     -- The ext-unforgeability' property can be collapsed in a single clause.

     -- TODO-2: so far, ext-unforgeability is used only to get a MsgWithSig∈ that is passed to
     -- msgWithSigSentByAuthor, which duplicates some of the reasoning in the proof of
     -- ext-unforgeability'; should these properties possibly be combined into one simpler proof?
     ext-unforgeability
       : ∀{e α₀ m part pk}{st : SystemState e} → ReachableSystemState st
       → (α₀ , m) ∈ msgPool st → part ⊂Msg m
       → (sig : WithVerSig pk part) → Meta-Honest-PK pk
       → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
     ext-unforgeability {_} {α₀} {m} {st = st} rst m∈sm p⊂m sig hpk
       with ext-unforgeability' rst m∈sm p⊂m sig hpk
     ...| inj₁ p
        = mkMsgWithSig∈ _ _ p⊂m α₀ m∈sm sig refl
     ...| inj₂ sentb4 = sentb4

     ¬cheatForgeNew : ∀ {e pid pk vsig mst outs m}{st : SystemState e}
                    → (sp : StepPeer st pid mst outs)
                    → outs ≡ m ∷ []
                    → (ic : isCheat sp)
                    → Meta-Honest-PK pk
                    → MsgWithSig∈ pk vsig ((pid , m) ∷ msgPool st)
                    → MsgWithSig∈ pk vsig (msgPool st)
     ¬cheatForgeNew sc@(step-cheat fm isCheat) refl _ hpk mws
        with msg∈pool mws
     ...| there m∈pool = mkMsgWithSig∈ (msgWhole mws) (msgPart mws) (msg⊆ mws) (msgSender mws) m∈pool (msgSigned mws) (msgSameSig mws)
     ...| here m∈pool
        with isCheat (subst (msgPart mws ⊂Msg_) (cong proj₂ m∈pool) (msg⊆ mws)) (msgSigned mws)
     ...| inj₁ dis = ⊥-elim (hpk dis)
     ...| inj₂ mws' rewrite msgSameSig mws = mws'

     msgWithSigSentByAuthor : ∀ {e pk sig}{st : SystemState e}
                            → ReachableSystemState st
                            → Meta-Honest-PK pk
                            → MsgWithSig∈ pk sig (msgPool st)
                            → Σ (MsgWithSig∈ pk sig (msgPool st))
                                λ mws → ValidPartForPK (availEpochs st) (msgPart mws) pk
     msgWithSigSentByAuthor step-0 _ ()
     msgWithSigSentByAuthor (step-s {pre = pre} preach (step-epoch 𝓔)) hpk mws
       rewrite step-epoch-does-not-send pre 𝓔
          with msgWithSigSentByAuthor preach hpk mws
     ...| mws' , vpb =  mws' , ValidPartForPK-stable {st = pre} (step-s step-0 (step-epoch 𝓔)) vpb
     msgWithSigSentByAuthor {pk = pk} (step-s {pre = pre} preach (step-peer theStep@(step-cheat fm cheatCons))) hpk mws
        with (¬cheatForgeNew theStep refl unit hpk mws)
     ...| mws'
        with msgWithSigSentByAuthor preach hpk mws'
     ...| mws'' , vpb'' = MsgWithSig∈-++ʳ mws'' , vpb''
     msgWithSigSentByAuthor {e} (step-s {pre = pre} preach (step-peer {pid = pid} {outs = outs} (step-honest sps))) hpk mws
       with Any-++⁻ (List-map (pid ,_) outs) {msgPool pre} (msg∈pool mws)
     ...| inj₂ furtherBack
       with msgWithSigSentByAuthor preach hpk (MsgWithSig∈-transp mws furtherBack)
     ...| mws' , vpb' =  MsgWithSig∈-++ʳ mws' , vpb'

     msgWithSigSentByAuthor {e} (step-s {pre = pre} preach (step-peer {pid = pid} {outs = outs} (step-honest sps))) hpk mws
        | inj₁ thisStep
        with Any-satisfied-∈ (Any-map⁻ thisStep)
     ...| (m' , refl , m∈outs)
        with sps-avp preach hpk sps m∈outs (msg⊆ mws) (msgSigned mws)
     ...| inj₁ (vpbα₀ , _) = mws , vpbα₀
     ...| inj₂ mws'
        with msgWithSigSentByAuthor preach hpk mws'
     ...| mws'' , vpb'' rewrite sym (msgSameSig mws) = MsgWithSig∈-++ʳ mws'' , vpb''


{-# OPTIONS -v impossible:100 #-}
module Issue882a where

open import Common.Level
open import Common.Equality

private
 primitive
   primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y

-- trustMe {x = x} {y = y} evaluates to refl if x and y are
-- definitionally equal.
--
-- For an example of the use of trustMe, see Data.String._≟_.

trustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y
trustMe = primTrustMe

postulate
  S : Set
  B : Set
  b : B

M : Set
M = B -> S

out : M -> M
out m = o
  where

   s : S
   s = m b

   postulate
     mko : (mm : S) -> s ≡ mm -> M

   o : M
   o n = mko (m b) trustMe n

postulate
  unfold : (M -> M) -> M

inn : M
inn = unfold out

postulate
  n : B

iso1 : inn ≡ inn
iso1 rewrite refl {x = n} = {!!}
-- iso1 rewrite (refl {a = lzero}{A = B}{x = n}) = {!!}

{- Error

OLD:
An internal error has occurred. Please report this as a bug.
Location of the error: src/full/Agda/TypeChecking/Conversion.hs:636

NEW:
Some vomit about Setω not equal to Level when checking well-formedness
of with type.

NEWER (2013-11-30):
Cannot instantiate the metavariable _48 to solution m b since it
contains the variable m which is not in scope of the metavariable
or irrelevant in the metavariable but relevant in the solution
when checking that the type
B →
(w : _x_48 ≡ _x_48) →
unfold (λ m → _.mko m (m b) w) ≡ unfold (λ m → _.mko m (m b) w)
of the generated with function is well-formed

NOW (2014-05-17):
Rewriting with refl is a no-op, so no error is triggered any more.
Just an unresolved meta now.
-}


module StateSized.GUI.SpaceShipExtendedExample where

open import SizedIO.Base
open import StateSizedIO.GUI.BaseStateDependent

open import Data.Bool.Base
open import Data.List.Base
open import Data.Integer

open import Data.Product hiding (map)
open import SizedIO.Object
open import SizedIO.IOObject

open import NativeIO
open import Size

open import StateSizedIO.GUI.WxBindingsFFI
open import StateSizedIO.GUI.VariableList

open import StateSizedIO.GUI.WxGraphicsLib

open import StateSized.GUI.BitMaps

spaceShipMove = 10

data RockMethod : Set where
  move : RockMethod
  getPoint : RockMethod
  draw : DC → Rect → RockMethod

RockResult : RockMethod → Set
RockResult getPoint = Point
RockResult _        = Unit

RockInterface : Interface
Method RockInterface = RockMethod
Result RockInterface = RockResult

RockObject : ∀{i} → Set
RockObject {i} = IOObject GuiLev1Interface RockInterface i

rockObject : ∀{i} → Point → RockObject {i}
method (rockObject (x , y)) move =
  return ( _ , rockObject (x , (y + (+ 2))))
method (rockObject p) (draw dc rect) =
  exec (drawBitmap dc rock p true) λ _ →
  return (_ , rockObject p)
method (rockObject p) getPoint =
  return (p , rockObject p)

data SpaceshipMethod : Set where
  move : Point → SpaceshipMethod
  draw : DC → Rect → SpaceshipMethod
  collide : RockObject → SpaceshipMethod

SpaceshipResult : SpaceshipMethod  →  Set
SpaceshipResult _  = Unit

SpaceshipInterface : Interface
Method SpaceshipInterface = SpaceshipMethod
Result SpaceshipInterface = SpaceshipResult

SpaceshipObject : ∀{i} → Set
SpaceshipObject {i} = IOObject GuiLev1Interface SpaceshipInterface i

spaceshipObject : ∀{i} → Point → SpaceshipObject {i}
method (spaceshipObject (x , y)) (move (deltaX , deltaY)) =
  return ( _ , spaceshipObject ((x + deltaX) , (y + deltaY)))
method (spaceshipObject p) (draw dc rect) =
  exec (drawBitmap dc ship p true) λ _ →
       return (_ , spaceshipObject p)
method (spaceshipObject p) (collide rock) =
   return (_ , spaceshipObject p)

data GraphicServerMethod : Set where
  onPaintM                :   DC → Rect → GraphicServerMethod
  repaintM                :   Frame → GraphicServerMethod
  moveSpaceShipM          :   Point → GraphicServerMethod
  moveWorldM              :   GraphicServerMethod

GraphicServerResult : GraphicServerMethod  →  Set
GraphicServerResult _ = Unit

GraphicServerInterface : Interface
Method GraphicServerInterface  = GraphicServerMethod
Result GraphicServerInterface  = GraphicServerResult

GraphicServerObject : ∀{i} → Set
GraphicServerObject {i} = IOObject GuiLev1Interface GraphicServerInterface i

graphicServerObject : ∀{i} → SpaceshipObject → RockObject →
                             GraphicServerObject {i}
method (graphicServerObject ship rock) (onPaintM dc rect) =
               method ship (draw dc rect) >>= λ { (_ , ship') →
               method rock (draw dc rect) >>= λ { (_ , rock') →
               return (_ , graphicServerObject ship' rock') }}
method (graphicServerObject ship rock) (repaintM fra) =
               exec (repaint fra)                λ _ →
               return (_ , graphicServerObject ship rock)
method (graphicServerObject ship rock) (moveSpaceShipM (deltaX , deltaY)) =
               method ship (move (deltaX , deltaY)) >>= λ { (_ , ship') →
               return (_ , graphicServerObject ship' rock) }
method (graphicServerObject ship rock) moveWorldM =
               method rock move >>= λ { (_ , rock') →
               return (_ , graphicServerObject ship rock') }

VarType : Set
VarType = GraphicServerObject {∞}

varInit : VarType
varInit = graphicServerObject (spaceshipObject (+ 150 , + 150))
                              (rockObject (+ 20 , + 10))

onPaint  : ∀{i} → VarType → DC → Rect → IO GuiLev1Interface i VarType
onPaint obj dc rect = mapIO proj₂  (method obj (onPaintM dc rect))

moveSpaceShip : ∀{i} → Point → VarType  → IO GuiLev1Interface i VarType
moveSpaceShip p obj = mapIO proj₂ (method obj (moveSpaceShipM p))

moveWorld : ∀{i} → VarType  → IO GuiLev1Interface i VarType
moveWorld obj = mapIO proj₂ (method obj moveWorldM)

callRepaint  : ∀{i} → Frame → VarType  → IO GuiLev1Interface i VarType
callRepaint fra obj = mapIO proj₂ (method obj (repaintM fra))

program : ∀{i} → IOˢ GuiLev2Interface i (λ _ → Unit) []
program =  execˢ (level1C makeFrame)           λ fra →
           execˢ (level1C (makeButton fra))    λ bt →
           execˢ (level1C (addButton fra bt))  λ _ →
           execˢ (createVar varInit)           λ _ →
           execˢ (setButtonHandler bt (moveSpaceShip (+ 20 , + 0)
                                     ∷ [ callRepaint fra ])) λ _ →
           execˢ (setKeyHandler bt
             (moveSpaceShip (+ spaceShipMove , + 0)  ∷ [ callRepaint fra ])
             (moveSpaceShip (-[1+ spaceShipMove ] , + 0) ∷ [ callRepaint fra ])
             (moveSpaceShip (+ 0 , -[1+ spaceShipMove ]) ∷ [ callRepaint fra ])
             (moveSpaceShip (+ 0 , + spaceShipMove) ∷ [ callRepaint fra ]))
             λ _ →

           execˢ (setOnPaint fra ([ onPaint  ]))  λ _ →
           execˢ (setTimer fra (+ 50)
               (moveWorld ∷ [ callRepaint fra ]))  λ _ →
           returnˢ unit

main : NativeIO Unit
main = (start (translateLev2 program)) native>>= (λ _ → nativePutStrLn "stephan test2")


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


module Examples.InfiniteBind where

open import ActorMonad
open import Prelude

Box : InboxShape
Box = []

binder : ∀ {i} → ∞ActorM i Box ⊤₁ [] (λ _ → [])
binder .force = binder ∞>> binder


-- There was a problem with open public in parameterised modules.
module Issue165 where

postulate X : Set

module M where
  postulate P : Set

module R₀ (X : Set) where
  open M public

module R₁ (X : Set) where
  open R₀ X public

open R₁ X
postulate p : P


-- {-# OPTIONS -v tc.rec:100 -v tc.signature:20 #-}

module Issue414 where

record P : Set₁ where
  field
    q : Set

  x : P
  x = record { q = q }
-- Andreas 2011-05-19
-- record constructor should have been added to the signature
-- before record module is constructed!


module FileIOEffect where

open import Effect
import IO.Primitive as IO
open import Data.String using (String)
open import Data.Bool using (Bool ; if_then_else_ ; false ; true)
open import Data.Unit using (⊤ ; tt)
open import Category.Monad using (RawMonad)
open import Level using (zero)
open import Data.List using (List ; _∷_ ; [])
open import Data.List.All using (All ; lookup ; _∷_ ; [])
open import Data.List.Any using (here ; there)
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)
open import Membership-equality using (_∈_)
open import Data.Product using (Σ ; _,_ ; _×_)

data FileIOState : Set where
  opened closed : FileIOState

data FileHandle : Set where
  FH : String → FileHandle

data FileIOEff : Effect zero where
  `openFile  : String → FileIOEff Bool ⊤ λ ok → if ok then FileHandle else ⊤
  `closeFile : FileIOEff ⊤ FileHandle λ h → ⊤

-- Should we really use this now?
FileIO : EFFECT zero
FileIO = mkEff ⊤ FileIOEff

IOMonad : RawMonad IO.IO
IOMonad = record { return = IO.return ; _>>=_ = IO._>>=_ {zero} {zero}}

myOpClose : ∀ {m} → String → EffM m ⊤ (FileIO ∷ []) λ _ → (FileIO ∷ [])
myOpClose file = effect (here refl) (`openFile file) >>= λ
  { true → effect (here refl) `closeFile
  ; false → return tt}

main : IO.IO ⊤
main = run IO.IO (record { return = IO.return ; _>>=_ = IO._>>=_ }) (myOpClose ".gitignore") myEnv
  where
    FileIOHandler : Handler IO.IO FileIOEff
    FileIOHandler v (`openFile x) k = k true (FH x)
    FileIOHandler (FH x) `closeFile k = k tt tt
    myEnv : Env IO.IO (FileIO ∷ [])
    myEnv = (FileIOHandler , tt) ∷ []


{-# OPTIONS --without-K --safe --no-sized-types --no-guardedness #-}

module Agda.Builtin.String where

open import Agda.Builtin.Bool
open import Agda.Builtin.List
open import Agda.Builtin.Char
open import Agda.Builtin.Equality

postulate String : Set
{-# BUILTIN STRING String #-}

primitive
  primStringToList   : String → List Char
  primStringFromList : List Char → String
  primStringAppend   : String → String → String
  primStringEquality : String → String → Bool
  primShowChar       : Char → String
  primShowString     : String → String
  primStringToListInjective : ∀ a b → primStringToList a ≡ primStringToList b → a ≡ b

{-# COMPILE JS primStringToList = function(x) { return x.split(""); } #-}
{-# COMPILE JS primStringFromList = function(x) { return x.join(""); } #-}
{-# COMPILE JS primStringAppend = function(x) { return function(y) { return x+y; }; } #-}
{-# COMPILE JS primStringEquality = function(x) { return function(y) { return x===y; }; } #-}
{-# COMPILE JS primShowChar = function(x) { return JSON.stringify(x); } #-}
{-# COMPILE JS primShowString = function(x) { return JSON.stringify(x); } #-}


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


-- Andreas, 2020-02-18, issue #4450 raised by Nisse
--
-- ETA pragma should be considered unsafe, since type-checking may loop.

{-# OPTIONS --safe --guardedness #-}

open import Agda.Builtin.Equality

record R : Set where
 coinductive
 field
   force : R
open R

{-# ETA R #-}

foo : R
foo .force .force = foo

-- test : foo .force ≡ foo
-- test = refl

-- test makes type checker loop;
-- ETA with --safe is a soft error and only raised after
-- the whole file is processed.


module Issue329b where

abstract
  infixl 0 D Undeclared
  data D : Set where


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
-- TODO-2: The following import should be eliminated and replaced
-- with the necessary module parameters (PK and MetaHonestPK)
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
open import LibraBFT.Abstract.Types.EpochConfig

-- This module brings in the base types used through libra
-- and those necessary for the abstract model.
module LibraBFT.Abstract.Types
  (UID    : Set)
  (NodeId : Set)
  (𝓔      : EpochConfig UID NodeId)
  where
  open EpochConfig 𝓔

  -- A member of an epoch is considered "honest" iff its public key is honest.
  Meta-Honest-Member : EpochConfig.Member 𝓔 → Set
  Meta-Honest-Member α = Meta-Honest-PK (getPubKey α)

  -- Naturally, if two witnesses that two authors belong
  -- in the epoch are the same, then the authors are also the same.
  --
  -- This proof is very Galois-like, because of the way we structured
  -- our partial isos. It's actually pretty nice! :)
  member≡⇒author≡ : ∀{α β}
                  → (authorα : Is-just (isMember? α))
                  → (authorβ : Is-just (isMember? β))
                  → to-witness authorα ≡ to-witness authorβ
                  → α ≡ β
  member≡⇒author≡ {α} {β} a b prf
    with isMember? α | inspect isMember? α
  ...| nothing | [ _ ] = ⊥-elim (maybe-any-⊥ a)
  member≡⇒author≡ {α} {β} (just _) b prf
     | just ra | [ RA ]
    with isMember? β | inspect isMember? β
  ...| nothing | [ _ ] = ⊥-elim (maybe-any-⊥ b)
  member≡⇒author≡ {α} {β} (just _) (just _) prf
     | just ra | [ RA ]
     | just rb | [ RB ]
     = trans (sym (author-nodeid-id RA))
             (trans (cong toNodeId prf)
                    (author-nodeid-id RB))


{-# OPTIONS --prop #-}

{-# TERMINATING #-}
makeloop : {P : Prop} → P → P
makeloop p = makeloop p

postulate
  A : Set
  B C : A → Prop

record AB : Set where
  no-eta-equality  -- the problem goes away if this is left out
  constructor _,_
  field
    a : A
    b : B a
open AB public

-- -- Same problem if replacing the no-eta record by a datatype
-- data AB : Set where
--   _,_ : (a : A) → B a → AB

-- a : AB → A
-- a (x , y) = x

-- b : (z : AB) → B (a z)
-- b (x , y) = y

record ABC : Set where
  constructor _,_
  field
    ab : AB
    c : C (a ab)  -- the problem goes away if this field is left out
open ABC public

f : AB → ABC
f ab = (a ab , makeloop (b ab)) , {!!}

postulate
  P : ABC → Prop
  g : (ab : AB) → P (f ab)

works : (ab : AB) → P (f ab)
works ab = g ab

loops : (ab : AB) → P (f ab)
loops ab = g _

-- WAS: Agda loops while typechecking @loops@
-- SHOULD: succeed (with unsolved metas)


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


module Float where

import      Lvl
open import Type

postulate Float : Type{Lvl.𝟎}
{-# BUILTIN FLOAT Float #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Table.Relation.Binary.Equality directly.
------------------------------------------------------------------------

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

module Data.Table.Relation.Equality where

open import Data.Table.Relation.Binary.Equality public


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.Liveness.ProposerElection where

postulate -- TODO-1: Implement getValidProposer
  getValidProposer : ProposerElection → Round → Author

isValidProposerM : Author → Round → LBFT Bool
isValidProposer : ProposerElection → Author → Round → Bool

isValidProposalM : Block → LBFT (Either ObmNotValidProposerReason Unit)
isValidProposalM b =
  maybeSD (b ^∙ bAuthor) (bail ProposalDoesNotHaveAnAuthor) $ λ a → do
    -- IMPL-DIFF: `ifM` in Haskell means something else
    vp ← isValidProposerM a (b ^∙ bRound)
    ifD vp
      then ok unit
      else bail ProposerForBlockIsNotValidForThisRound

isValidProposerM a r = isValidProposer <$> use lProposerElection <*> pure a <*> pure r

isValidProposer pe a r = getValidProposer pe r == a


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


module L.Base.Sigma where

-- Reexport definitions
open import L.Base.Sigma.Core public


------------------------------------------------------------------------
-- 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 ρ₂) ρ₁