{-# OPTIONS --rewriting #-}

module Luau.RuntimeError where

open import Agda.Builtin.Equality using (_≡_)
open import Luau.Heap using (Heap; _[_])
open import FFI.Data.Maybe using (just; nothing)
open import FFI.Data.String using (String)
open import Luau.Syntax using (BinaryOperator; Block; Expr; nil; var; val; addr; block_is_end; _$_; local_←_; return; done; _∙_; number; string; binexp; +; -; *; /; <; >; <=; >=; ··)
open import Luau.RuntimeType using (RuntimeType; valueType; function; number; string)
open import Properties.Equality using (_≢_)

data BinOpError : BinaryOperator → RuntimeType → Set where
  + : ∀ {t} → (t ≢ number) → BinOpError + t
  - : ∀ {t} → (t ≢ number) → BinOpError - t
  * : ∀ {t} → (t ≢ number) → BinOpError * t
  / : ∀ {t} → (t ≢ number) → BinOpError / t
  < : ∀ {t} → (t ≢ number) → BinOpError < t
  > : ∀ {t} → (t ≢ number) → BinOpError > t
  <= : ∀ {t} → (t ≢ number) → BinOpError <= t
  >= : ∀ {t} → (t ≢ number) → BinOpError >= t
  ·· : ∀ {t} → (t ≢ string) → BinOpError ·· t

data RuntimeErrorᴮ {a} (H : Heap a) : Block a → Set
data RuntimeErrorᴱ {a} (H : Heap a) : Expr a → Set

data RuntimeErrorᴱ H where
  FunctionMismatch : ∀ v w → (valueType v ≢ function) → RuntimeErrorᴱ H (val v $ val w)
  BinOpMismatch₁ : ∀ v w {op} → (BinOpError op (valueType v)) → RuntimeErrorᴱ H (binexp (val v) op (val w))
  BinOpMismatch₂ : ∀ v w {op} → (BinOpError op (valueType w)) → RuntimeErrorᴱ H (binexp (val v) op (val w))
  UnboundVariable : ∀ {x} → RuntimeErrorᴱ H (var x)
  SEGV : ∀ {a} → (H [ a ] ≡ nothing) → RuntimeErrorᴱ H (val (addr a))
  app₁ : ∀ {M N} → RuntimeErrorᴱ H M → RuntimeErrorᴱ H (M $ N)
  app₂ : ∀ {M N} → RuntimeErrorᴱ H N → RuntimeErrorᴱ H (M $ N)
  block : ∀ {b B} → RuntimeErrorᴮ H B → RuntimeErrorᴱ H (block b is B end)
  bin₁ : ∀ {M N op} → RuntimeErrorᴱ H M → RuntimeErrorᴱ H (binexp M op N)
  bin₂ : ∀ {M N op} → RuntimeErrorᴱ H N → RuntimeErrorᴱ H (binexp M op N)

data RuntimeErrorᴮ H where
  local : ∀ {x M B} → RuntimeErrorᴱ H M → RuntimeErrorᴮ H (local x ← M ∙ B)
  return : ∀ {M B} → RuntimeErrorᴱ H M → RuntimeErrorᴮ H (return M ∙ B)


------------------------------------------------------------------------
-- Canonically kinded hereditary substitutions in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Canonical.HereditarySubstitution where

open import Data.Fin using (Fin; zero; suc; raise; lift)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Typed
open import Data.Product as Prod using (∃; _,_; _×_; proj₁; proj₂)
open import Data.Vec as Vec using ([]; _∷_)
import Data.Vec.Properties as VecProps
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization
open import FOmegaInt.Kinding.Canonical as CanonicalKinding
open import FOmegaInt.Kinding.Simple    as SimpleKinding

open Syntax
open ElimCtx
open SimpleCtx          using (⌊_⌋Asc; kd; tp)
open ContextConversions using (⌊_⌋Ctx)
open Substitution       hiding (_↑; sub; subst)
open RenamingCommutes
open SimpHSubstLemmas
open SimpleKinding.Kinding using (_⊢_kds; kds-Π)
open CanonicalKinding.Kinding
open KindedHereditarySubstitution
  using (_⊢/⟨_⟩_∈_; ∈-hsub; ∈-H↑; kds-/⟨⟩; kds-[]-/⟨⟩-↑⋆)
open CanonicalKinding.KindedRenaming
  using (typedVarSubst; kd-/Var; ≃-/Var; <∷-/Var; kd-weaken; <∷-weaken)
module TV = TypedVarSubst typedVarSubst
open ContextNarrowing

----------------------------------------------------------------------
-- Ascription order: a wrapper judgment that combines subtyping and
-- subkinding.
--
-- NOTE. Subtyping instances are always trivial, i.e. they only
-- support (syntactic) reflexivity.

infix 4 _⊢_≤_

data _⊢_≤_ {n} (Γ : Ctx n) : ElimAsc n → ElimAsc n → Set where
  ≤-<∷   : ∀ {j k} → Γ ⊢ j <∷ k → Γ ⊢ k kd → Γ ⊢ kd j ≤ kd k
  ≤-refl : ∀ {a} → Γ ⊢ a ≤ a

-- Transitivity of the ascription order.

≤-trans : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢ a ≤ b → Γ ⊢ b ≤ c → Γ ⊢ a ≤ c
≤-trans (≤-<∷ j<∷k _)    (≤-<∷ k<∷l l-kd) = ≤-<∷ (<∷-trans j<∷k k<∷l) l-kd
≤-trans (≤-<∷ j<∷k k-kd) ≤-refl           = ≤-<∷ j<∷k k-kd
≤-trans ≤-refl           a≤c              = a≤c

-- Kinds in related ascriptions have the same shape.

≤-⌊⌋ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ kd j ≤ kd k → ⌊ j ⌋ ≡ ⌊ k ⌋
≤-⌊⌋ (≤-<∷ j<∷k _) = <∷-⌊⌋ j<∷k
≤-⌊⌋ ≤-refl        = refl

-- Renamings preserve the ascription order.

≤-/Var : ∀ {m n Γ Δ a b} {ρ : Sub Fin m n} →
         Γ ⊢ a ≤ b → Δ TV.⊢/Var ρ ∈ Γ → Δ ⊢ a ElimAsc/Var ρ ≤ b ElimAsc/Var ρ
≤-/Var (≤-<∷ j<∷k k-kd) ρ∈Γ = ≤-<∷ (<∷-/Var j<∷k ρ∈Γ) (kd-/Var k-kd ρ∈Γ)
≤-/Var ≤-refl           ρ∈Γ = ≤-refl

-- Admissible subsumption rules w.r.t. the ascription order.

Nf⇇-⇑-≤ : ∀ {n} {Γ : Ctx n} {a k j} →
          Γ ⊢Nf a ⇇ k → Γ ⊢ kd k ≤ kd j → Γ ⊢Nf a ⇇ j
Nf⇇-⇑-≤ a⇇k (≤-<∷ k<∷j j-kd) = Nf⇇-⇑ a⇇k k<∷j
Nf⇇-⇑-≤ a⇇k ≤-refl           = a⇇k

≃-⇑-≤ : ∀ {n} {Γ : Ctx n} {a b k j} →
        Γ ⊢ a ≃ b ⇇ k → Γ ⊢ kd k ≤ kd j → Γ ⊢ a ≃ b ⇇ j
≃-⇑-≤ a≃b⇇k (≤-<∷ k<∷j j-kd) = ≃-⇑ a≃b⇇k k<∷j j-kd
≃-⇑-≤ a≃b⇇k ≤-refl           = a≃b⇇k

-- An admissible variable rule based on the ascription order.

Var∈-⇑-≤  : ∀ {n} {Γ : Ctx n} {a k} x →
            Γ ctx → lookup Γ x ≡ a → Γ ⊢ a ≤ kd k → Γ ⊢Var x ∈ k
Var∈-⇑-≤ x Γ-ctx Γ[x]≡j (≤-<∷ j<∷k k-kd) = ⇇-⇑ (⇉-var x Γ-ctx Γ[x]≡j) j<∷k k-kd
Var∈-⇑-≤ x Γ-ctx Γ[x]≡k ≤-refl           = ⇉-var x Γ-ctx Γ[x]≡k

----------------------------------------------------------------------
-- Well-kinded hereditary substitutions (i.e. substitution lemmas) in
-- canonical types

infix 4 _⊢/⟨_⟩_⇇_ _⊢/⟨_⟩_≃_⇇_ _⊢?⟨_⟩_⇇_ _⊢?⟨_⟩_≃_⇇_

-- Well-kinded pointwise equality of hereditary substitutions and
-- their lookup results.

data _⊢/⟨_⟩_≃_⇇_ : ∀ {m n} →
                   Ctx n → SKind → SVSub m n → SVSub m n → Ctx m → Set where
  ≃-hsub : ∀ {n} {Γ : Ctx n} {k a b j} →
           Γ ⊢ a ≃ b ⇇ j → ⌊ j ⌋≡ k →
           Γ ⊢/⟨ k ⟩ sub a ≃ sub b ⇇ kd j ∷ Γ
  ≃-H↑   : ∀ {m n Δ k Γ} {σ τ : SVSub m n} {j l} →
           Δ ⊢ j ≅ l Kind/⟨ k ⟩ σ → Δ ⊢ j ≅ l Kind/⟨ k ⟩ τ →
           Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → kd j ∷ Δ ⊢/⟨ k ⟩ σ ↑ ≃ τ ↑ ⇇ kd l ∷ Γ

data _⊢?⟨_⟩_≃_⇇_ {n} (Γ : Ctx n) (k : SKind)
                 : SVRes n → SVRes n → ElimAsc n → Set where
  ≃-hit  : ∀ {a b j} →
           Γ ⊢ a ≃ b ⇇ j → ⌊ j ⌋≡ k → Γ ⊢?⟨ k ⟩ hit a ≃ hit b ⇇ kd j
  ≃-miss : ∀ y {a b} → Γ ctx → lookup Γ y ≡ a → Γ ⊢ a ≤ b →
           Γ ⊢?⟨ k ⟩ miss y ≃ miss y ⇇ b

-- Well-kinded suspended hereditary substations are just a degenerate
-- case of equal hereditary substitutions where the underlying
-- substitutions coincide (syntactically).

_⊢/⟨_⟩_⇇_ : ∀ {m n} → Ctx n → SKind → SVSub m n → Ctx m → Set
Δ ⊢/⟨ k ⟩ σ ⇇ Γ = Δ ⊢/⟨ k ⟩ σ ≃ σ ⇇ Γ

⇇-hsub : ∀ {n} {Γ : Ctx n} {k a j} →
         Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → ⌊ j ⌋≡ k →
         Γ ⊢/⟨ k ⟩ sub a ⇇ kd j ∷ Γ
⇇-hsub a⇇j j-kd ⌊j⌋≡k = ≃-hsub (≃-reflNf⇇ a⇇j j-kd) ⌊j⌋≡k

⇇-H↑ : ∀ {m n Δ k Γ} {σ : SVSub m n} {j l} →
       Δ ⊢ j ≅ l Kind/⟨ k ⟩ σ → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
       kd j ∷ Δ ⊢/⟨ k ⟩ σ ↑ ⇇ kd l ∷ Γ
⇇-H↑ j≅l/σ σ⇇Γ = ≃-H↑ j≅l/σ j≅l/σ σ⇇Γ

_⊢?⟨_⟩_⇇_ : ∀ {n} → Ctx n → SKind → SVRes n → ElimAsc n → Set
Δ ⊢?⟨ k ⟩ σ ⇇ Γ = Δ ⊢?⟨ k ⟩ σ ≃ σ ⇇ Γ

⇇-hit  : ∀ {n} {Γ : Ctx n} {k a j} →
         Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → ⌊ j ⌋≡ k → Γ ⊢?⟨ k ⟩ hit a ⇇ kd j
⇇-hit a⇇j j-kd ⌊j⌋≡k = ≃-hit (≃-reflNf⇇ a⇇j j-kd) ⌊j⌋≡k

⇇-miss = λ {n} {Γ} {k} → ≃-miss {n} {Γ} {k}

-- Renamings preserve equality of SV results.

?≃-/Var : ∀ {m n Γ k Δ r₁ r₂ a} {ρ : Sub Fin m n} →
          Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ a → Δ TV.⊢/Var ρ ∈ Γ →
          Δ ⊢?⟨ k ⟩ r₁ ?/Var ρ ≃ r₂ ?/Var ρ ⇇ a ElimAsc/Var ρ
?≃-/Var (≃-hit a≃b∈k ⌊j⌋≡k) ρ∈Γ =
  ≃-hit (≃-/Var a≃b∈k ρ∈Γ) (⌊⌋≡-/Var ⌊j⌋≡k)
?≃-/Var {Γ = Γ} {k} {Δ} {ρ = ρ} (≃-miss y {a} {b} _ Γ[x]≡a a≤b) ρ∈Γ =
  helper (cong (_ElimAsc/Var ρ) Γ[x]≡a) (TV.lookup ρ∈Γ y)
  where
    helper : ∀ {x c} → c ≡ a ElimAsc/Var ρ → Δ TV.⊢Var x ∈ c →
             Δ ⊢?⟨ k ⟩ miss x ≃ miss x ⇇ b ElimAsc/Var ρ
    helper Δ[x]≡a/ρ (TV.∈-var x Δ-ctx) =
      ≃-miss x (TV./∈-wf ρ∈Γ) Δ[x]≡a/ρ (≤-/Var a≤b ρ∈Γ)

?≃-weaken : ∀ {n} {Γ : Ctx n} {k r₁ r₂ a b} →
            Γ ⊢ a wf → Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ b →
            (a ∷ Γ) ⊢?⟨ k ⟩ weakenSVRes r₁ ≃ weakenSVRes r₂ ⇇ weakenElimAsc b
?≃-weaken a-wf r₁≃r₂⇇a = ?≃-/Var r₁≃r₂⇇a (TV.∈-wk a-wf)

-- Look up a variable in a pair of well-kinded pointwise equal
-- hereditary substitution.

lookup-/⟨⟩≃ : ∀ {m n Δ k Γ} {σ τ : SVSub m n} →
              Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → (x : Fin m) →
              Δ ⊢?⟨ k ⟩ lookupSV σ x ≃ lookupSV τ x ⇇ lookup Γ x Asc/⟨ k ⟩ σ
lookup-/⟨⟩≃ (≃-hsub {_} {Γ} {k} {a} {b} {j} a≃b⇇k ⌊j⌋≡k) zero =
  subst (Γ ⊢?⟨ k ⟩ hit a ≃ hit b ⇇_)
        (cong kd (sym (Kind/Var-wk-↑⋆-hsub-vanishes 0 j))) (≃-hit a≃b⇇k ⌊j⌋≡k)
lookup-/⟨⟩≃ (≃-hsub {Γ = Γ} {k} {a} {_} {j} a≃b⇇k ⌊j⌋≡k) (suc x) =
  subst (Γ ⊢?⟨ k ⟩ miss x ≃ miss x ⇇_) (begin
      lookup Γ x
    ≡˘⟨ Asc/Var-wk-↑⋆-hsub-vanishes 0 (lookup Γ x) ⟩
      weakenElimAsc (lookup Γ x) Asc/⟨ k ⟩ sub a
    ≡˘⟨ cong (_Asc/⟨ k ⟩ sub a) (VecProps.lookup-map x weakenElimAsc (toVec Γ)) ⟩
       lookup (kd j ∷ Γ) (suc x) Asc/⟨ k ⟩ sub a
    ∎) (≃-miss x (≃-ctx a≃b⇇k) refl ≤-refl)
lookup-/⟨⟩≃ (≃-H↑ {Δ = Δ} {k} {j = j} {l} j≅l/σ j≅l/τ σ≃τ⇇Γ) zero =
  let j-kd , l/σ-kd = ≅-valid j≅l/σ
      j-wf  = wf-kd j-kd
      j≤l/σ = ≤-<∷ (<∷-weaken j-wf (≅⇒<∷ j≅l/σ)) (kd-weaken j-wf l/σ-kd)
  in subst (kd j ∷ Δ ⊢?⟨ k ⟩ miss zero ≃ miss zero ⇇_)
           (sym (wk-Asc/⟨⟩-↑⋆ 0 (kd l)))
           (≃-miss zero (j-wf ∷ (kd-ctx j-kd)) refl j≤l/σ)
lookup-/⟨⟩≃ (≃-H↑ {k = k} {Γ} {σ} {_} {_} {l} j≅l/σ _ σ≃τ⇇Γ) (suc x) =
  subst (_ ⊢?⟨ k ⟩ _ ≃ _ ⇇_) (begin
      weakenElimAsc (lookup Γ x Asc/⟨ k ⟩ σ)
    ≡˘⟨ wk-Asc/⟨⟩-↑⋆ 0 (lookup Γ x) ⟩
      weakenElimAsc (lookup Γ x) Asc/⟨ k ⟩ σ ↑
    ≡˘⟨ cong (_Asc/⟨ k ⟩ σ ↑)
             (VecProps.lookup-map x weakenElimAsc (toVec Γ)) ⟩
      lookup (kd l ∷ Γ) (suc x) Asc/⟨ k ⟩ σ ↑
    ∎) (?≃-weaken (wf-kd (proj₁ (≅-valid j≅l/σ))) (lookup-/⟨⟩≃ σ≃τ⇇Γ x))

-- Equation and context validity lemmas for hereditary substitutions.

/⟨⟩≃-valid₁ : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
              Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ⊢/⟨ k ⟩ σ ⇇ Γ
/⟨⟩≃-valid₁ (≃-hsub a≃b⇇j ⌊j⌋≡k) =
  ⇇-hsub (proj₁ (≃-valid a≃b⇇j)) (≃-valid-kd a≃b⇇j) ⌊j⌋≡k
/⟨⟩≃-valid₁ (≃-H↑ a≅b/σ _ σ≃τ∈Γ) = ⇇-H↑ a≅b/σ (/⟨⟩≃-valid₁ σ≃τ∈Γ)

/⟨⟩≃-valid₂ : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
              Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ⊢/⟨ k ⟩ τ ⇇ Γ
/⟨⟩≃-valid₂ (≃-hsub a≃b⇇j ⌊j⌋≡k) =
  ⇇-hsub (proj₂ (≃-valid a≃b⇇j)) (≃-valid-kd a≃b⇇j) ⌊j⌋≡k
/⟨⟩≃-valid₂ (≃-H↑ _ a≅b/τ σ≃τ∈Γ) = ⇇-H↑ a≅b/τ (/⟨⟩≃-valid₂ σ≃τ∈Γ)

/⟨⟩≃-ctx : ∀ {k m n Γ Δ} {σ τ : SVSub m n} →
           Γ ctx → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ctx
/⟨⟩≃-ctx j∷Γ-ctx (≃-hsub a≃b⇇j ⌊j⌋≡k)     = wf-∷₂ j∷Γ-ctx
/⟨⟩≃-ctx l∷Γ-ctx (≃-H↑ j≅l/σ j≅l/τ σ≃τ⇇Γ) =
  let j-kd , _ = ≅-valid j≅l/σ
      Γ-ctx    = wf-∷₂ l∷Γ-ctx
  in (wf-kd j-kd) ∷ /⟨⟩≃-ctx Γ-ctx σ≃τ⇇Γ

-- Symmetry of hereditary substitution equality.

/⟨⟩≃-sym : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
           Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → Δ ⊢/⟨ k ⟩ τ ≃ σ ⇇ Γ
/⟨⟩≃-sym (≃-hsub a≃b⇇j ⌊j⌋≡k)     = ≃-hsub (≃-sym a≃b⇇j) ⌊j⌋≡k
/⟨⟩≃-sym (≃-H↑ a≅b/σ a≅b/τ σ≃τ∈Γ) = ≃-H↑ a≅b/τ a≅b/σ (/⟨⟩≃-sym σ≃τ∈Γ)

-- Simplification of kinded substitutions.
--
-- NOTE. The second substitution τ is ignored by the simplification.
-- It is tempting to rephrase the lemma in terms of _⊢/⟨_⟩_⇇_ instead
-- of _⊢/⟨_⟩_≃_⇇_ but that introduces extra constraints for the Agda
-- pattern matcher that require UIP (aka axiom K) to resolve.  Since
-- this assumption is unnecessary, we prove the more general version
-- instead. (See the Agda documentation about the --without-K option
-- for more info).

/⟨⟩⇇-/⟨⟩∈ : ∀ {k m n Δ Γ} {σ τ : SVSub m n} →
            Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ → ⌊ Δ ⌋Ctx ⊢/⟨ k ⟩ σ ∈ ⌊ Γ ⌋Ctx
/⟨⟩⇇-/⟨⟩∈ (≃-hsub a≃b⇇j ⌊j⌋≡k) =
  subst (_ ⊢/⟨_⟩ _ ∈ _) (⌊⌋≡⇒⌊⌋-≡ ⌊j⌋≡k)
        (∈-hsub (Nf⇇-Nf∈ (proj₁ (≃-valid a≃b⇇j))))
/⟨⟩⇇-/⟨⟩∈ (≃-H↑ {Δ = Δ} {k} {Γ} {σ} {_} {j} {l} j≅l/σ _ σ≃σ∈Γ) =
  subst ((_⊢/⟨ k ⟩ σ ↑ ∈ ⌊ kd l ∷ Γ ⌋Ctx) ∘ (_∷ ⌊ Δ ⌋Ctx)) (begin
          ⌊ kd l ⌋Asc              ≡˘⟨ ⌊⌋-Asc/⟨⟩ (kd l) ⟩
          ⌊ kd l Asc/⟨ k ⟩ σ ⌋Asc  ≡˘⟨ cong kd (≅-⌊⌋ j≅l/σ) ⟩
          ⌊ kd j ⌋Asc              ∎)
        (∈-H↑ (/⟨⟩⇇-/⟨⟩∈ σ≃σ∈Γ))

-- TODO: explain why we need to track shapes explicitly.

module TrackSimpleKindsSubst where

  -- TODO: explain how/why preservation of (sub)kinding/subtyping
  -- under reducing applications, hereditary substitution and equal
  -- hereditary substitutions circularly depend on each other.

  mutual

    -- Hereditary substitutions preserve well-formedness of kinds.

    kd-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {j} →
             Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ⇇ Γ → Δ ⊢ j Kind/⟨ k ⟩ σ kd
    kd-/⟨⟩ (kd-⋯ a⇉a⋯a b⇉b⋯b) σ⇇Γ =
      kd-⋯ (Nf⇉-/⟨⟩ a⇉a⋯a σ⇇Γ) (Nf⇉-/⟨⟩ b⇉b⋯b σ⇇Γ)
    kd-/⟨⟩ (kd-Π j-kd k-kd)   σ⇇Γ =
      let j/σ-kd = kd-/⟨⟩ j-kd σ⇇Γ
      in kd-Π j/σ-kd (kd-/⟨⟩ k-kd (⇇-H↑ (≅-refl j/σ-kd) σ⇇Γ))

    -- Hereditary substitutions preserve synthesized kinds of normal
    -- types.

    Nf⇉-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {a j} →
              Γ ⊢Nf a ⇉ j → Δ ⊢/⟨ k ⟩ σ ⇇ Γ → Δ ⊢Nf a /⟨ k ⟩ σ ⇉ j Kind/⟨ k ⟩ σ
    Nf⇉-/⟨⟩ (⇉-⊥-f Γ-ctx) σ⇇Γ = ⇉-⊥-f (/⟨⟩≃-ctx Γ-ctx σ⇇Γ)
    Nf⇉-/⟨⟩ (⇉-⊤-f Γ-ctx) σ⇇Γ = ⇉-⊤-f (/⟨⟩≃-ctx Γ-ctx σ⇇Γ)
    Nf⇉-/⟨⟩ (⇉-∀-f k-kd a⇉a⋯a)  σ⇇Γ =
      let k/σ-kd = kd-/⟨⟩ k-kd σ⇇Γ
      in ⇉-∀-f k/σ-kd (Nf⇉-/⟨⟩ a⇉a⋯a (⇇-H↑ (≅-refl k/σ-kd) σ⇇Γ))
    Nf⇉-/⟨⟩ (⇉-→-f a⇉a⋯a b⇉b⋯b) σ⇇Γ =
      ⇉-→-f (Nf⇉-/⟨⟩ a⇉a⋯a σ⇇Γ) (Nf⇉-/⟨⟩ b⇉b⋯b σ⇇Γ)
    Nf⇉-/⟨⟩ (⇉-Π-i k-kd a⇉a⋯a)  σ⇇Γ =
      let k/σ-kd = kd-/⟨⟩ k-kd σ⇇Γ
      in ⇉-Π-i k/σ-kd (Nf⇉-/⟨⟩ a⇉a⋯a (⇇-H↑ (≅-refl k/σ-kd) σ⇇Γ))
    Nf⇉-/⟨⟩ (⇉-s-i a∈b⋯c) σ⇇Γ = Nf⇇-s-i (Ne∈-/⟨⟩ a∈b⋯c σ⇇Γ)

    -- Neutral proper types kind-check against their synthesized kinds
    -- after substitution.

    Ne∈-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {a b c} →
              Γ ⊢Ne a ∈ b ⋯ c → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
              Δ ⊢Nf a /⟨ k ⟩ σ ⇇ b /⟨ k ⟩ σ ⋯ c /⟨ k ⟩ σ
    Ne∈-/⟨⟩ (∈-∙ {x} x∈j j⇉as⇉b⋯c) σ⇇Γ =
      let j-kds = kd-kds (Var∈-valid x∈j)
      in Var∈-/⟨⟩-⇑-?∙∙ x∈j σ⇇Γ ≤-refl (Sp⇉-/⟨⟩ j-kds j⇉as⇉b⋯c σ⇇Γ)

    Var∈-/⟨⟩-⇑-?∙∙ : ∀ {k m n Γ Δ} {σ : SVSub m n} {x j l as b c} →
                     Γ ⊢Var x ∈ j → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
                     Δ ⊢ kd j Asc/⟨ k ⟩ σ ≤ kd l → Δ ⊢ l ⇉∙ as ⇉ b ⋯ c →
                     Δ ⊢Nf lookupSV σ x ?∙∙⟨ k ⟩ as ⇇ b ⋯ c
    Var∈-/⟨⟩-⇑-?∙∙ (⇉-var x _ Γ[x]≡kd-j) σ⇇Γ j/σ≤l l⇉as⇉b⋯c =
      ?⇇-⇑-?∙∙ (subst (_ ⊢?⟨ _ ⟩ _ ⇇_) (cong (_Asc/⟨ _ ⟩ _) Γ[x]≡kd-j)
                      (lookup-/⟨⟩≃ σ⇇Γ x))
               j/σ≤l l⇉as⇉b⋯c
    Var∈-/⟨⟩-⇑-?∙∙ (⇇-⇑ x∈j₁ j₁<∷j₂ j₂-kd) σ⇇Γ j₂/σ≤l l⇉as⇉b⋯c =
      let j₁/σ≤j₂/σ = ≤-<∷ (<∷-/⟨⟩≃ j₁<∷j₂ σ⇇Γ) (kd-/⟨⟩ j₂-kd σ⇇Γ)
      in Var∈-/⟨⟩-⇑-?∙∙ x∈j₁ σ⇇Γ (≤-trans j₁/σ≤j₂/σ j₂/σ≤l) l⇉as⇉b⋯c

    -- Hereditary substitutions preserve synthesized kinds of spines.
    Sp⇉-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {as j₁ j₂} →
              ⌊ Γ ⌋Ctx ⊢ j₁ kds → Γ ⊢ j₁ ⇉∙ as ⇉ j₂ → Δ ⊢/⟨ k ⟩ σ ⇇ Γ →
              Δ ⊢ j₁ Kind/⟨ k ⟩ σ ⇉∙ as //⟨ k ⟩ σ ⇉ j₂ Kind/⟨ k ⟩ σ
    Sp⇉-/⟨⟩ _ ⇉-[] σ⇇Γ = ⇉-[]
    Sp⇉-/⟨⟩ {k} (kds-Π j₁-kds j₂-kds)
            (⇉-∷ {a} {_} {j₁} {j₂} a⇇j₁ j₁-kd j₂[a]⇉as⇉j₃) σ⇇Γ =
      ⇉-∷ (Nf⇇-/⟨⟩ a⇇j₁ σ⇇Γ) (kd-/⟨⟩ j₁-kd σ⇇Γ)
          (subst (_ ⊢_⇉∙ _ ⇉ _) j₂[a]/σ≡j₂/σ[a/σ]
                 (Sp⇉-/⟨⟩ (kds-/⟨⟩ j₂-kds (∈-hsub a∈⌊j₁⌋)) j₂[a]⇉as⇉j₃ σ⇇Γ))
      where
        a∈⌊j₁⌋ = Nf⇇-Nf∈ a⇇j₁

        j₂[a]/σ≡j₂/σ[a/σ] = begin
            j₂ Kind[ a ∈ ⌊ j₁ ⌋ ] Kind/⟨ k ⟩ _
          ≡⟨ kds-[]-/⟨⟩-↑⋆ [] j₂-kds a∈⌊j₁⌋ (/⟨⟩⇇-/⟨⟩∈ σ⇇Γ) ⟩
            j₂ Kind/⟨ k ⟩ _ ↑ Kind/⟨ ⌊ j₁ ⌋ ⟩ sub (a /⟨ k ⟩ _)
          ≡⟨ cong (_ Kind[ a /⟨ k ⟩ _ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j₁)) ⟩
            (j₂ Kind/⟨ k ⟩ _ ↑) Kind[ a /⟨ k ⟩ _ ∈ ⌊ j₁ Kind/⟨ k ⟩ _ ⌋ ]
          ∎

    -- Hereditary substitutions preserve checked kinds of normal
    -- types.
    Nf⇇-/⟨⟩ : ∀ {k m n Γ Δ} {σ : SVSub m n} {a j} →
              Γ ⊢Nf a ⇇ j → Δ ⊢/⟨ k ⟩ σ ⇇ Γ → Δ ⊢Nf a /⟨ k ⟩ σ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇇-/⟨⟩ (⇇-⇑ a⇉j j<∷k) σ⇇Γ = ⇇-⇑ (Nf⇉-/⟨⟩ a⇉j σ⇇Γ) (<∷-/⟨⟩≃ j<∷k σ⇇Γ)

    -- Equal hereditary substitutions well-formed kinds to subkinds.
    kd-/⟨⟩≃-<∷ : ∀ {m n Γ k Δ} {σ τ : SVSub m n} {j} →
                 Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ j Kind/⟨ k ⟩ σ <∷ j Kind/⟨ k ⟩ τ
    kd-/⟨⟩≃-<∷ (kd-⋯ a⇉a⋯a b⇉b⋯b) σ≃τ⇇Γ =
      <∷-⋯ (Nf⇉-⋯-/⟨⟩≃ a⇉a⋯a (/⟨⟩≃-sym σ≃τ⇇Γ)) (Nf⇉-⋯-/⟨⟩≃ b⇉b⋯b σ≃τ⇇Γ)
    kd-/⟨⟩≃-<∷ (kd-Π j-kd k-kd)   σ≃τ⇇Γ =
      let σ⇇Γ     = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ     = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ   = /⟨⟩≃-sym σ≃τ⇇Γ
          j/σ≅j/σ = kd-/⟨⟩≃-≅ j-kd σ⇇Γ
          j/τ≅j/τ = kd-/⟨⟩≃-≅ j-kd τ⇇Γ
          j/τ≅j/σ = kd-/⟨⟩≃-≅ j-kd τ≃σ⇇Γ
      in <∷-Π (kd-/⟨⟩≃-<∷ j-kd τ≃σ⇇Γ)
              (kd-/⟨⟩≃-<∷ k-kd (≃-H↑ j/τ≅j/σ j/τ≅j/τ σ≃τ⇇Γ))
              (kd-Π (kd-/⟨⟩ j-kd σ⇇Γ) (kd-/⟨⟩ k-kd (⇇-H↑ j/σ≅j/σ σ⇇Γ)))

    -- Equal hereditary substitutions map well-formed kinds to kind
    -- identities.
    kd-/⟨⟩≃-≅ : ∀ {m n Γ k Δ} {σ τ : SVSub m n} {j} →
                Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                Δ ⊢ j Kind/⟨ k ⟩ σ ≅ j Kind/⟨ k ⟩ τ
    kd-/⟨⟩≃-≅ k-kd σ≃τ⇇Γ =
      <∷-antisym (kd-/⟨⟩ k-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
                 (kd-/⟨⟩ k-kd (/⟨⟩≃-valid₂ σ≃τ⇇Γ))
                 (kd-/⟨⟩≃-<∷ k-kd σ≃τ⇇Γ) (kd-/⟨⟩≃-<∷ k-kd (/⟨⟩≃-sym σ≃τ⇇Γ))

    -- Equal hereditary substitutions map normal forms to subtypes.

    Nf⇉-⋯-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a b c} →
                 Γ ⊢Nf a ⇉ b ⋯ c → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ
    Nf⇉-⋯-/⟨⟩≃ (⇉-⊥-f Γ-ctx) σ≃τ⇇Γ =
      <:-⊥ (⇉-⊥-f (/⟨⟩≃-ctx Γ-ctx (/⟨⟩≃-valid₁ σ≃τ⇇Γ)))
    Nf⇉-⋯-/⟨⟩≃ (⇉-⊤-f Γ-ctx) σ≃τ⇇Γ =
      <:-⊤ (⇉-⊤-f (/⟨⟩≃-ctx Γ-ctx (/⟨⟩≃-valid₂ σ≃τ⇇Γ)))
    Nf⇉-⋯-/⟨⟩≃ (⇉-∀-f k-kd a⇉a⋯a) σ≃τ⇇Γ =
      let σ⇇Γ       = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ       = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ     = /⟨⟩≃-sym  σ≃τ⇇Γ
          k/τ≅k/τ   = kd-/⟨⟩≃-≅ k-kd τ⇇Γ
          k/σ≅k/σ   = kd-/⟨⟩≃-≅ k-kd σ⇇Γ
          k/τ≅k/σ   = kd-/⟨⟩≃-≅ k-kd τ≃σ⇇Γ
          σ≃τ⇇j/τ∷Γ = ≃-H↑ k/τ≅k/σ k/τ≅k/τ σ≃τ⇇Γ
      in <:-∀ (≅⇒<∷ k/τ≅k/σ) (Nf⇉-⋯-/⟨⟩≃ a⇉a⋯a σ≃τ⇇j/τ∷Γ)
              (⇉-∀-f (kd-/⟨⟩ k-kd σ⇇Γ)
                     (Nf⇉-/⟨⟩ a⇉a⋯a (⇇-H↑ k/σ≅k/σ σ⇇Γ)))
    Nf⇉-⋯-/⟨⟩≃ (⇉-→-f a⇉a⋯a b⇉b⋯b) σ≃τ⇇Γ =
      <:-→ (Nf⇉-⋯-/⟨⟩≃ a⇉a⋯a (/⟨⟩≃-sym σ≃τ⇇Γ)) (Nf⇉-⋯-/⟨⟩≃ b⇉b⋯b σ≃τ⇇Γ)
    Nf⇉-⋯-/⟨⟩≃ (⇉-s-i a∈b⋯c) σ≃τ⇇Γ = Ne∈-/⟨⟩≃ a∈b⋯c σ≃τ⇇Γ

    Nf⇉-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a j} →
               Γ ⊢Nf a ⇉ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇉-/⟨⟩≃ a⇉b⋯c (kd-⋯ b⇉b⋯b c⇉c⋯c) σ≃τ⇇Γ =
      let σ⇇Γ   = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ   = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
      in <:-⇇ (Nf⇉⇒Nf⇇ (Nf⇉-/⟨⟩ a⇉b⋯c σ⇇Γ))
              (⇇-⇑ (Nf⇉-/⟨⟩ a⇉b⋯c τ⇇Γ)
                   (<∷-⋯ (Nf⇉-⋯-/⟨⟩≃ b⇉b⋯b σ≃τ⇇Γ) (Nf⇉-⋯-/⟨⟩≃ c⇉c⋯c τ≃σ⇇Γ)))
              (Nf⇉-⋯-/⟨⟩≃ a⇉b⋯c σ≃τ⇇Γ)
    Nf⇉-/⟨⟩≃ (⇉-Π-i _ a⇉l) (kd-Π j-kd l-kd) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          σ⇇Γ   = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ   = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          j/σ-kd  = kd-/⟨⟩ j-kd σ⇇Γ
          j/τ-kd  = kd-/⟨⟩ j-kd τ⇇Γ
          j/σ≅j/σ = kd-/⟨⟩≃-≅ j-kd σ⇇Γ
          j/τ≅j/τ = kd-/⟨⟩≃-≅ j-kd τ⇇Γ
          j/σ≅j/τ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
          a/σ⇉l/σ = Nf⇉-/⟨⟩ a⇉l (⇇-H↑ j/σ≅j/σ σ⇇Γ)
          a/τ⇉l/τ = Nf⇉-/⟨⟩ a⇉l (⇇-H↑ j/τ≅j/τ τ⇇Γ)
          a/σ<:a/τ⇇l/σ = Nf⇉-/⟨⟩≃ a⇉l l-kd (≃-H↑ j/σ≅j/σ j/σ≅j/τ σ≃τ⇇Γ)
          Πjl/τ<∷Πjl/σ = kd-/⟨⟩≃-<∷ (kd-Π j-kd l-kd) τ≃σ⇇Γ
          Λja/σ⇇Πjl/σ = Nf⇉⇒Nf⇇ (⇉-Π-i j/σ-kd a/σ⇉l/σ)
          Λja/τ⇇Πjl/σ = ⇇-⇑ (⇉-Π-i j/τ-kd a/τ⇉l/τ) Πjl/τ<∷Πjl/σ
      in <:-λ a/σ<:a/τ⇇l/σ Λja/σ⇇Πjl/σ Λja/τ⇇Πjl/σ

    -- Equal hereditary substitutions map proper neutrals to subtypes.
    Ne∈-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a b c} →
               Γ ⊢Ne a ∈ b ⋯ c → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ
    Ne∈-/⟨⟩≃ (∈-∙ {x} x∈j j⇉as⇉b⋯c) σ≃τ⇇Γ =
      let j-kds = kd-kds (Var∈-valid x∈j)
      in Var∈-/⟨⟩≃-⇑-?∙∙ x∈j σ≃τ⇇Γ ≤-refl (Sp⇉-/⟨⟩≃ j-kds j⇉as⇉b⋯c σ≃τ⇇Γ)

    Var∈-/⟨⟩≃-⇑-?∙∙ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {x j l as bs b c} →
                      Γ ⊢Var x ∈ j → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                      Δ ⊢ kd j Asc/⟨ k ⟩ σ ≤ kd l → Δ ⊢ l ⇉∙ as ≃ bs ⇉ b ⋯ c →
                      Δ ⊢ lookupSV σ x ?∙∙⟨ k ⟩ as <: lookupSV τ x ?∙∙⟨ k ⟩ bs
    Var∈-/⟨⟩≃-⇑-?∙∙ (⇉-var x _ Γ[x]≡kd-j) σ≃τ⇇Γ j/σ≤l l⇉as≃bs⇉b⋯c =
      ?≃-⇑-?∙∙ (subst (_ ⊢?⟨ _ ⟩ _ ≃ _ ⇇_) (cong (_Asc/⟨ _ ⟩ _) Γ[x]≡kd-j)
                      (lookup-/⟨⟩≃ σ≃τ⇇Γ x))
               j/σ≤l l⇉as≃bs⇉b⋯c
    Var∈-/⟨⟩≃-⇑-?∙∙ (⇇-⇑ x∈j₁ j₁<∷j₂ j₂-kd) σ≃τ⇇Γ j₂/σ≤l l⇉as≃bs⇉b⋯c =
      let σ⇇Γ       = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          j₁/σ≤j₂/σ = ≤-<∷ (<∷-/⟨⟩≃ j₁<∷j₂ σ⇇Γ) (kd-/⟨⟩ j₂-kd σ⇇Γ)
      in Var∈-/⟨⟩≃-⇑-?∙∙ x∈j₁ σ≃τ⇇Γ (≤-trans j₁/σ≤j₂/σ j₂/σ≤l) l⇉as≃bs⇉b⋯c

    -- Equal hereditary substitutions map spines to spine identities.
    Sp⇉-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {as j₁ j₂} →
               ⌊ Γ ⌋Ctx ⊢ j₁ kds → Γ ⊢ j₁ ⇉∙ as ⇉ j₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ j₁ Kind/⟨ k ⟩ σ ⇉∙ as //⟨ k ⟩ σ ≃
                                      as //⟨ k ⟩ τ ⇉ j₂ Kind/⟨ k ⟩ σ
    Sp⇉-/⟨⟩≃ _ ⇉-[] σ⇇Γ = ≃-[]
    Sp⇉-/⟨⟩≃ {k} (kds-Π j₁-kds j₂-kds)
             (⇉-∷ {a} {_} {j₁} {j₂} a⇇j₁ j₁-kd j₂[a]⇉as⇉j₃) σ⇇Γ =
      ≃-∷ (Nf⇇-/⟨⟩≃-≃ a⇇j₁ j₁-kd σ⇇Γ)
          (subst (_ ⊢_⇉∙ _ ≃ _ ⇉ _) j₂[a]/σ≡j₂/σ[a/σ]
                 (Sp⇉-/⟨⟩≃ (kds-/⟨⟩ j₂-kds (∈-hsub a∈⌊j₁⌋)) j₂[a]⇉as⇉j₃ σ⇇Γ))
      where
        a∈⌊j₁⌋ = Nf⇇-Nf∈ a⇇j₁

        j₂[a]/σ≡j₂/σ[a/σ] = begin
            j₂ Kind[ a ∈ ⌊ j₁ ⌋ ] Kind/⟨ k ⟩ _
          ≡⟨ kds-[]-/⟨⟩-↑⋆ [] j₂-kds a∈⌊j₁⌋ (/⟨⟩⇇-/⟨⟩∈ (/⟨⟩≃-valid₁ σ⇇Γ)) ⟩
            j₂ Kind/⟨ k ⟩ _ ↑ Kind/⟨ ⌊ j₁ ⌋ ⟩ sub (a /⟨ k ⟩ _)
          ≡⟨ cong (_ Kind[ a /⟨ k ⟩ _ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j₁)) ⟩
            (j₂ Kind/⟨ k ⟩ _ ↑) Kind[ a /⟨ k ⟩ _ ∈ ⌊ j₁ Kind/⟨ k ⟩ _ ⌋ ]
          ∎

    -- Equal hereditary substitutions map checked normal forms to
    -- subtypes.
    Nf⇇-/⟨⟩≃-<: : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a j} →
                  Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                  Δ ⊢ a /⟨ k ⟩ σ <: a /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇇-/⟨⟩≃-<: (⇇-⇑ a⇉b₁⋯c₁ (<∷-⋯ b₂<:b₁ c₁<:c₂)) _ σ≃τ⇇Γ =
      let σ⇇Γ   = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ   = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
      in <:-⇇ (⇇-⇑ (Nf⇉-/⟨⟩ a⇉b₁⋯c₁ σ⇇Γ) (<∷-/⟨⟩≃ (<∷-⋯ b₂<:b₁ c₁<:c₂) σ⇇Γ))
              (⇇-⇑ (Nf⇉-/⟨⟩ a⇉b₁⋯c₁ τ⇇Γ) (<∷-/⟨⟩≃ (<∷-⋯ b₂<:b₁ c₁<:c₂) τ≃σ⇇Γ))
              (Nf⇉-⋯-/⟨⟩≃ a⇉b₁⋯c₁ σ≃τ⇇Γ)
    Nf⇇-/⟨⟩≃-<: (⇇-⇑ a⇉Πj₁l₁ (<∷-Π j₂<∷j₁ l₁<∷l₂ Πj₁l₁-kd)) Πj₂k₂-kd σ≃τ⇇Γ =
      let σ⇇Γ = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          Πj₁l₁/σ<∷Πj₂l₂/σ = <∷-/⟨⟩≃ (<∷-Π j₂<∷j₁ l₁<∷l₂ Πj₁l₁-kd) σ⇇Γ
          Πj₂l₂/σ-kd       = kd-/⟨⟩ Πj₂k₂-kd σ⇇Γ
      in <:⇇-⇑ (Nf⇉-/⟨⟩≃ a⇉Πj₁l₁ Πj₁l₁-kd σ≃τ⇇Γ) Πj₁l₁/σ<∷Πj₂l₂/σ Πj₂l₂/σ-kd

    -- Equal hereditary substitutions map checked normal forms to type
    -- identities.
    Nf⇇-/⟨⟩≃-≃ : ∀ {m n Γ k Δ} {σ τ : SVSub m n} {a j} →
                 Γ ⊢Nf a ⇇ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ a /⟨ k ⟩ σ ≃ a /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    Nf⇇-/⟨⟩≃-≃ a⇇k k-kd σ≃τ⇇Γ =
      let τ≃σ⇇Γ  = /⟨⟩≃-sym σ≃τ⇇Γ
          k/σ-kd = kd-/⟨⟩ k-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ)
      in <:-antisym k/σ-kd (Nf⇇-/⟨⟩≃-<: a⇇k k-kd σ≃τ⇇Γ)
                    (<:⇇-⇑ (Nf⇇-/⟨⟩≃-<: a⇇k k-kd τ≃σ⇇Γ)
                    (kd-/⟨⟩≃-<∷ k-kd τ≃σ⇇Γ) k/σ-kd)

    -- Equal hereditary substitutions preserve subkinding.
    <∷-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {j₁ j₂} →
              Γ ⊢ j₁ <∷ j₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
              Δ ⊢ j₁ Kind/⟨ k ⟩ σ <∷ j₂ Kind/⟨ k ⟩ τ
    <∷-/⟨⟩≃ (<∷-⋯ a₂<:a₁ b₁<:b₂) σ≃τ⇇Γ =
      <∷-⋯ (<:-/⟨⟩≃ a₂<:a₁ (/⟨⟩≃-sym σ≃τ⇇Γ)) (<:-/⟨⟩≃ b₁<:b₂ σ≃τ⇇Γ)
    <∷-/⟨⟩≃ (<∷-Π j₂<∷j₁ k₁<∷k₂ Πj₁k₁-kd) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          τ≃τ⇇Γ = /⟨⟩≃-valid₂ σ≃τ⇇Γ
      in <∷-Π (<∷-/⟨⟩≃ j₂<∷j₁ (/⟨⟩≃-sym σ≃τ⇇Γ))
              (<∷-/⟨⟩≃ k₁<∷k₂ (≃-H↑ (<∷-/⟨⟩≃-wf k₁<∷k₂ τ≃σ⇇Γ)
                                    (<∷-/⟨⟩≃-wf k₁<∷k₂ τ≃τ⇇Γ) σ≃τ⇇Γ))
              (kd-/⟨⟩ Πj₁k₁-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ))

    -- Equal hereditary substitutions preserve subtyping.

    <:-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a₁ a₂} →
              Γ ⊢ a₁ <: a₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
              Δ ⊢ a₁ /⟨ k ⟩ σ <: a₂ /⟨ k ⟩ τ
    <:-/⟨⟩≃ (<:-trans a<:b b<:c) σ≃τ⇇Γ =
      <:-trans (<:-/⟨⟩≃ a<:b (/⟨⟩≃-valid₁ σ≃τ⇇Γ)) (<:-/⟨⟩≃ b<:c σ≃τ⇇Γ)
    <:-/⟨⟩≃ (<:-⊥ a⇉a⋯a) σ≃τ⇇Γ = <:-⊥ (Nf⇉-/⟨⟩ a⇉a⋯a (/⟨⟩≃-valid₂ σ≃τ⇇Γ))
    <:-/⟨⟩≃ (<:-⊤ a⇉a⋯a) σ≃τ⇇Γ = <:-⊤ (Nf⇉-/⟨⟩ a⇉a⋯a (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
    <:-/⟨⟩≃ (<:-∀ k₂<∷k₁ a₁<:a₂ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          τ≃τ⇇Γ = /⟨⟩≃-valid₂ σ≃τ⇇Γ
      in <:-∀ (<∷-/⟨⟩≃ k₂<∷k₁ τ≃σ⇇Γ)
              (<:-/⟨⟩≃ a₁<:a₂ (≃-H↑ (<:-/⟨⟩≃-wf a₁<:a₂ τ≃σ⇇Γ)
                                    (<:-/⟨⟩≃-wf a₁<:a₂ τ≃τ⇇Γ) σ≃τ⇇Γ))
         (Nf⇉-/⟨⟩ Πk₁a₁⇉Πk₁a₁⋯Πk₁a₁ (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
    <:-/⟨⟩≃ (<:-→ a₂<:a₁ b₁<:b₂) σ≃τ⇇Γ =
      <:-→ (<:-/⟨⟩≃ a₂<:a₁ (/⟨⟩≃-sym σ≃τ⇇Γ)) (<:-/⟨⟩≃ b₁<:b₂ σ≃τ⇇Γ)
    <:-/⟨⟩≃ {σ = σ} (<:-∙ {x} x∈j j⇉as≃bs⇉c⋯d) σ≃τ⇇Γ =
      let j-kds = kd-kds (Var∈-valid x∈j)
      in Var∈-/⟨⟩≃-⇑-?∙∙ x∈j σ≃τ⇇Γ ≤-refl (Sp≃-/⟨⟩≃ j-kds j⇉as≃bs⇉c⋯d σ≃τ⇇Γ)
    <:-/⟨⟩≃ (<:-⟨| a∈b⋯c) σ≃τ⇇Γ =
      let a/σ⇉b/σ⋯c/σ = Ne∈-/⟨⟩ a∈b⋯c (/⟨⟩≃-valid₁ σ≃τ⇇Γ)
      in <:-trans (<:-⟨|-Nf⇇ a/σ⇉b/σ⋯c/σ) (Ne∈-/⟨⟩≃ a∈b⋯c σ≃τ⇇Γ)
    <:-/⟨⟩≃ (<:-|⟩ a∈b⋯c) σ≃τ⇇Γ =
      let a/τ⇉b/τ⋯c/τ = Ne∈-/⟨⟩ a∈b⋯c (/⟨⟩≃-valid₂ σ≃τ⇇Γ)
      in <:-trans (Ne∈-/⟨⟩≃ a∈b⋯c σ≃τ⇇Γ) (<:-|⟩-Nf⇇ a/τ⇉b/τ⋯c/τ)

    <:⇇-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a₁ a₂ j} →
               Γ ⊢ a₁ <: a₂ ⇇ j → Γ ⊢ j kd → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ a₁ /⟨ k ⟩ σ <: a₂ /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    <:⇇-/⟨⟩≃ (<:-⇇ a₁⇇b⋯c a₂⇇b⋯c a₁<:a₂) b⋯c-kd σ≃τ⇇Γ =
      let σ⇇Γ     = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ     = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ   = /⟨⟩≃-sym σ≃τ⇇Γ
      in <:-⇇ (Nf⇇-/⟨⟩ a₁⇇b⋯c σ⇇Γ)
              (Nf⇇-⇑ (Nf⇇-/⟨⟩ a₂⇇b⋯c τ⇇Γ) (kd-/⟨⟩≃-<∷ b⋯c-kd τ≃σ⇇Γ))
              (<:-/⟨⟩≃ a₁<:a₂ σ≃τ⇇Γ)
    <:⇇-/⟨⟩≃ (<:-λ a₁<:a₂⇇l Λj₁a₁⇇Πjl Λj₂a₂⇇Πjl) (kd-Π j-kd l-kd) σ≃τ⇇Γ =
      let σ⇇Γ     = /⟨⟩≃-valid₁ σ≃τ⇇Γ
          τ⇇Γ     = /⟨⟩≃-valid₂ σ≃τ⇇Γ
          τ≃σ⇇Γ   = /⟨⟩≃-sym σ≃τ⇇Γ
          j/σ≅j/σ = kd-/⟨⟩≃-≅ j-kd σ⇇Γ
          j/σ≅j/τ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
      in <:-λ (<:⇇-/⟨⟩≃ a₁<:a₂⇇l l-kd (≃-H↑ j/σ≅j/σ j/σ≅j/τ σ≃τ⇇Γ))
              (Nf⇇-/⟨⟩ Λj₁a₁⇇Πjl σ⇇Γ)
              (Nf⇇-⇑ (Nf⇇-/⟨⟩ Λj₂a₂⇇Πjl τ⇇Γ) (kd-/⟨⟩≃-<∷ (kd-Π j-kd l-kd) τ≃σ⇇Γ))

    -- Equal hereditary substitutions preserve spine equality.
    Sp≃-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {as₁ as₂ j₁ j₂} →
               ⌊ Γ ⌋Ctx ⊢ j₁ kds →
               Γ ⊢ j₁ ⇉∙ as₁ ≃ as₂ ⇉ j₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
               Δ ⊢ j₁ Kind/⟨ k ⟩ σ ⇉∙ as₁ //⟨ k ⟩ σ ≃
                                      as₂ //⟨ k ⟩ τ ⇉ j₂ Kind/⟨ k ⟩ σ
    Sp≃-/⟨⟩≃ _ ≃-[] σ≃τ⇇Γ = ≃-[]
    Sp≃-/⟨⟩≃ {k} (kds-Π j₁-kds j₂-kds)
             (≃-∷ {a} {j = j₁} {j₂} a≃b as≃bs) σ≃τ⇇Γ =
      let a∈⌊j₁⌋            = Nf⇇-Nf∈ (proj₁ (≃-valid a≃b))
          j₂[a]/σ≡j₂/σ[a/σ] = begin
              j₂ Kind[ a ∈ ⌊ j₁ ⌋ ] Kind/⟨ k ⟩ _
            ≡⟨ kds-[]-/⟨⟩-↑⋆ [] j₂-kds a∈⌊j₁⌋ (/⟨⟩⇇-/⟨⟩∈ (/⟨⟩≃-valid₁ σ≃τ⇇Γ)) ⟩
              j₂ Kind/⟨ k ⟩ _ ↑ Kind/⟨ ⌊ j₁ ⌋ ⟩ sub (a /⟨ k ⟩ _)
            ≡⟨ cong (_ Kind[ a /⟨ k ⟩ _ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j₁)) ⟩
              (j₂ Kind/⟨ k ⟩ _ ↑) Kind[ a /⟨ k ⟩ _ ∈ ⌊ j₁ Kind/⟨ k ⟩ _ ⌋ ]
            ∎
      in ≃-∷ (≃-/⟨⟩≃ a≃b σ≃τ⇇Γ)
             (subst (_ ⊢_⇉∙ _ ≃ _ ⇉ _) j₂[a]/σ≡j₂/σ[a/σ]
                    (Sp≃-/⟨⟩≃ (kds-/⟨⟩ j₂-kds (∈-hsub a∈⌊j₁⌋)) as≃bs σ≃τ⇇Γ))

    -- Equal hereditary substitutions preserve type equality.
    ≃-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {a₁ a₂ j} →
             Γ ⊢ a₁ ≃ a₂ ⇇ j → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
             Δ ⊢ a₁ /⟨ k ⟩ σ ≃ a₂ /⟨ k ⟩ τ ⇇ j Kind/⟨ k ⟩ σ
    ≃-/⟨⟩≃ (<:-antisym k-kd a<:b⇇k b<:a⇇k) σ≃τ⇇Γ =
      let τ≃σ⇇Γ = /⟨⟩≃-sym σ≃τ⇇Γ
          k/σ-kd = kd-/⟨⟩ k-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ)
      in <:-antisym k/σ-kd (<:⇇-/⟨⟩≃ a<:b⇇k k-kd σ≃τ⇇Γ)
                    (<:⇇-⇑ (<:⇇-/⟨⟩≃ b<:a⇇k k-kd τ≃σ⇇Γ)
                           (kd-/⟨⟩≃-<∷ k-kd τ≃σ⇇Γ) k/σ-kd)

    -- Applications in canonical kind checking are admissible.
    --
    -- NOTE. In the ?⇇-⇑-?∙∙ lemma, the second result r₂ is ignored.
    -- See the comment above on /⟨⟩⇇-/⟨⟩∈ for an explanation.

    ?⇇-⇑-?∙∙ : ∀ {k n} {Γ : Ctx n} {r₁ r₂ a j as b c} →
               Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ a → Γ ⊢ a ≤ kd j →
               Γ ⊢ j ⇉∙ as ⇉ b ⋯ c → Γ ⊢Nf r₁ ?∙∙⟨ k ⟩ as ⇇ b ⋯ c
    ?⇇-⇑-?∙∙ (≃-hit a≃a⇇j ⌊j⌋≡k) j≤l l⇉as⇉b⋯c =
      Nf⇇-∙∙ (Nf⇇-⇑-≤ (proj₁ (≃-valid a≃a⇇j)) j≤l) l⇉as⇉b⋯c
             (⌊⌋≡-trans (sym (≤-⌊⌋ j≤l)) ⌊j⌋≡k)
    ?⇇-⇑-?∙∙ (≃-miss y Γ-ctx Γ[y]≡a₁ a₁≤a₂) a₂≤l l⇉as⇉b⋯c =
      Nf⇇-ne (∈-∙ (Var∈-⇑-≤ y Γ-ctx Γ[y]≡a₁ (≤-trans a₁≤a₂ a₂≤l)) l⇉as⇉b⋯c)

    Nf⇇-∙∙ : ∀ {n} {Γ : Ctx n} {a as j₁ j₂ k} →
             Γ ⊢Nf a ⇇ j₁ → Γ ⊢ j₁ ⇉∙ as ⇉ j₂ → ⌊ j₁ ⌋≡ k →
             Γ ⊢Nf a ∙∙⟨ k ⟩ as ⇇ j₂
    Nf⇇-∙∙ a⇇j₁ ⇉-[] ⌊j₁⌋≡k = a⇇j₁
    Nf⇇-∙∙ a⇇Πj₁j₂ (⇉-∷ b⇇j₁ j₁-kd j₂[b]⇉as⇉j₃) (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) =
      Nf⇇-∙∙ (Nf⇇-Π-e a⇇Πj₁j₂ b⇇j₁ j₁-kd (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂))
             j₂[b]⇉as⇉j₃ (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)

    Nf⇇-Π-e : ∀ {n} {Γ : Ctx n} {a b j₁ j₂ k} →
              Γ ⊢Nf a ⇇ Π j₁ j₂ → Γ ⊢Nf b ⇇ j₁ → Γ ⊢ j₁ kd →
              ⌊ Π j₁ j₂ ⌋≡ k → Γ ⊢Nf a ⌜·⌝⟨ k ⟩ b ⇇ j₂ Kind[ b ∈ ⌊ j₁ ⌋ ]
    Nf⇇-Π-e {_} {Γ} {_} {b}
            (⇇-⇑ (⇉-Π-i j₁-kd a⇉l₁)
            (<∷-Π {j₁} {j₂} {l₁} {l₂} j₂<∷j₁ l₁<∷l₂ Πj₁l₁-kd))
            b⇇j₂ j₂-kd (is-⇒ {_} {_} {k₁} ⌊j₂⌋≡k₁ ⌊l₂⌋≡k₂) =
      let σ⇇j₂∷Γ = ⇇-hsub b⇇j₂ j₂-kd ⌊j₂⌋≡k₁
      in ⇇-⇑ (Nf⇉-/⟨⟩ (⇓-Nf⇉ j₂-kd j₂<∷j₁ a⇉l₁) σ⇇j₂∷Γ)
             (subst (λ k → Γ ⊢ l₁ Kind[ b ∈ k₁ ] <∷ l₂ Kind[ b ∈ k ])
                    (sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₂⌋≡k₁))
                    (<∷-/⟨⟩≃ l₁<∷l₂ σ⇇j₂∷Γ))

    -- Applications in checked type equality are admissible.

    ?≃-⇑-?∙∙ : ∀ {k n} {Γ : Ctx n} {r₁ r₂ a j as bs c d} →
               Γ ⊢?⟨ k ⟩ r₁ ≃ r₂ ⇇ a → Γ ⊢ a ≤ kd j →
               Γ ⊢ j ⇉∙ as ≃ bs ⇉ c ⋯ d →
               Γ ⊢ r₁ ?∙∙⟨ k ⟩ as <: r₂ ?∙∙⟨ k ⟩ bs
    ?≃-⇑-?∙∙ (≃-hit a≃b⇇j ⌊j⌋≡k) j≤l l⇉as≃bs⇉c⋯d =
      ≃⇒<:-⋯ (≃-∙∙ (≃-⇑-≤ a≃b⇇j j≤l) l⇉as≃bs⇉c⋯d
                   (⌊⌋≡-trans (sym (≤-⌊⌋ j≤l)) ⌊j⌋≡k))
    ?≃-⇑-?∙∙ (≃-miss y Γ-ctx Γ[y]≡a₁ a₁≤a₂) a₂≤l l⇉as≃bs⇉c⋯d =
      <:-∙ (Var∈-⇑-≤ y Γ-ctx Γ[y]≡a₁ (≤-trans a₁≤a₂ a₂≤l)) l⇉as≃bs⇉c⋯d

    ≃-∙∙ : ∀ {n} {Γ : Ctx n} {a b as bs j₁ j₂ k} →
           Γ ⊢ a ≃ b ⇇ j₁ → Γ ⊢ j₁ ⇉∙ as ≃ bs ⇉ j₂ → ⌊ j₁ ⌋≡ k →
           Γ ⊢ a ∙∙⟨ k ⟩ as ≃ b ∙∙⟨ k ⟩ bs ⇇ j₂
    ≃-∙∙ a≃b⇇j₁ ≃-[] ⌊j₁⌋≡k = a≃b⇇j₁
    ≃-∙∙ a≃b⇇Πj₁j₂ (≃-∷ c≃d⇇j₁ j₂[b]⇉cs≃ds⇉j₃) (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) =
      ≃-∙∙ (≃-Π-e a≃b⇇Πj₁j₂ c≃d⇇j₁ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂))
           j₂[b]⇉cs≃ds⇉j₃ (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)

    ≃-Π-e : ∀ {n} {Γ : Ctx n} {a₁ a₂ b₁ b₂ j₁ j₂ k} →
            Γ ⊢ a₁ ≃ a₂ ⇇ Π j₁ j₂ → Γ ⊢ b₁ ≃ b₂ ⇇ j₁ → ⌊ Π j₁ j₂ ⌋≡ k →
            Γ ⊢ a₁ ⌜·⌝⟨ k ⟩ b₁ ≃ a₂ ⌜·⌝⟨ k ⟩ b₂ ⇇ j₂ Kind[ b₁ ∈ ⌊ j₁ ⌋ ]
    ≃-Π-e a₁≃a₂⇇Πj₁j₂ b₁≃b₂⇇j₂ (is-⇒ ⌊j₂⌋≡k₁ ⌊j₂⌋≡k₂) with ≃-Π-can a₁≃a₂⇇Πj₁j₂
    ≃-Π-e {_} {Γ} {_} {_} {b₁} {b₂} Λl₁a₁≃Λl₂a₂⇇Πj₁j₂ b₁≃b₂⇇j₁
          (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂)
      | l₁ , a₁ , l₂ , a₂ , Λl₁a₁⇇Πj₁j₂ , Λl₂a₂⇇Πj₁j₂ , kd-Π j₁-kd j₂-kd ,
        j₁<∷l₁ , l₁≅l₂ , a₁<:a₂⇇j₂ , a₂<:a₁⇇j₂ , refl , refl =
        let ⌊Πj₁j₂⌋≡k     = is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂
            k₁≡⌊j₁⌋       = sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₁⌋≡k₁)
            b₁⇇j₁ , b₂⇇j₁ = ≃-valid b₁≃b₂⇇j₁
            σ≃τ⇇j₁∷Γ      = ≃-hsub b₁≃b₂⇇j₁ ⌊j₁⌋≡k₁
            τ≃σ⇇j₁∷Γ      = /⟨⟩≃-sym σ≃τ⇇j₁∷Γ
            σ⇇j₁∷Γ        = /⟨⟩≃-valid₁ σ≃τ⇇j₁∷Γ
        in <:-antisym (subst (λ k → _ ⊢ _ Kind[ _ ∈ k ] kd)
                             (sym (⌊⌋≡⇒⌊⌋-≡ ⌊j₁⌋≡k₁))
                             (kd-/⟨⟩ j₂-kd (/⟨⟩≃-valid₁ σ≃τ⇇j₁∷Γ)))
                      (subst (λ k → _ ⊢ _ <: _ ⇇ _ Kind[ _ ∈ k ]) k₁≡⌊j₁⌋
                             (<:⇇-/⟨⟩≃ a₁<:a₂⇇j₂ j₂-kd σ≃τ⇇j₁∷Γ))
                      (<:⇇-⇑ (<:⇇-/⟨⟩≃ a₂<:a₁⇇j₂ j₂-kd τ≃σ⇇j₁∷Γ)
                             (subst (λ k → Γ ⊢ _ <∷ _ Kind[ _ ∈ k ]) k₁≡⌊j₁⌋
                                    (kd-/⟨⟩≃-<∷ j₂-kd τ≃σ⇇j₁∷Γ))
                             (subst (λ k → Γ ⊢ _ Kind[ _ ∈ k ] kd) k₁≡⌊j₁⌋
                                    (kd-/⟨⟩ j₂-kd σ⇇j₁∷Γ)))

    -- Helpers (to satisfy the termination checker).
    --
    -- These are simply (manual) expansions of the form
    --
    --   XX-/⟨⟩≃-wf x σ≃τ⇇Γ  =  kd-/⟨⟩≃-≅ (wf-kd-inv (wf-∷₁ (XX-ctx x))) σ≃τ⇇Γ
    --
    -- to ensure the above definitions remain structurally recursive
    -- in the various derivations.

    kd-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j k} →
                 kd j ∷ Γ ⊢ k kd → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    kd-/⟨⟩≃-wf (kd-⋯ a⇉a⋯a _) σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    kd-/⟨⟩≃-wf (kd-Π j-kd _)  σ≃τ⇇Γ = kd-/⟨⟩≃-wf j-kd σ≃τ⇇Γ

    Nf⇉-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a k} →
                  kd j ∷ Γ ⊢Nf a ⇉ k → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                  Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    Nf⇉-/⟨⟩≃-wf (⇉-⊥-f (wf-kd j-kd ∷ Γ-ctx)) σ≃τ⇇Γ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-⊤-f (wf-kd j-kd ∷ Γ-ctx)) σ≃τ⇇Γ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-∀-f k-kd _)               σ≃τ⇇Γ = kd-/⟨⟩≃-wf k-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-→-f a⇉a⋯a _)              σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-Π-i j-kd _)               σ≃τ⇇Γ = kd-/⟨⟩≃-wf j-kd σ≃τ⇇Γ
    Nf⇉-/⟨⟩≃-wf (⇉-s-i a∈b⋯c)                σ≃τ⇇Γ = Ne∈-/⟨⟩≃-wf a∈b⋯c σ≃τ⇇Γ

    Ne∈-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a k} →
                  kd j ∷ Γ ⊢Ne a ∈ k → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                  Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    Ne∈-/⟨⟩≃-wf (∈-∙ x∈k _) σ≃τ⇇Γ = Var∈-/⟨⟩≃-wf x∈k σ≃τ⇇Γ

    Var∈-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a k} →
                   kd j ∷ Γ ⊢Var a ∈ k → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                   Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    Var∈-/⟨⟩≃-wf (⇉-var x (wf-kd j-kd ∷ Γ-ctx) _) σ≃τ⇇Γ = kd-/⟨⟩≃-≅ j-kd σ≃τ⇇Γ
    Var∈-/⟨⟩≃-wf (⇇-⇑ x∈k _ _)                    σ≃τ⇇Γ = Var∈-/⟨⟩≃-wf x∈k σ≃τ⇇Γ

    <∷-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j k₁ k₂} →
                 kd j ∷ Γ ⊢ k₁ <∷ k₂ → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                 Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    <∷-/⟨⟩≃-wf (<∷-⋯ a₂<:a₁ _)   σ≃τ⇇Γ = <:-/⟨⟩≃-wf a₂<:a₁ σ≃τ⇇Γ
    <∷-/⟨⟩≃-wf (<∷-Π j₁<∷j₂ _ _) σ≃τ⇇Γ = <∷-/⟨⟩≃-wf j₁<∷j₂ σ≃τ⇇Γ

    <:-/⟨⟩≃-wf : ∀ {m n Γ l Δ} {σ τ : SVSub m n} {j a₁ a₂} →
                kd j ∷ Γ ⊢ a₁ <: a₂ → Δ ⊢/⟨ l ⟩ σ ≃ τ ⇇ Γ →
                Δ ⊢ j Kind/⟨ l ⟩ σ ≅ j Kind/⟨ l ⟩ τ
    <:-/⟨⟩≃-wf (<:-trans a<:b _) σ≃τ⇇Γ = <:-/⟨⟩≃-wf a<:b σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-⊥ a⇉a⋯a)      σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-⊤ a⇉a⋯a)      σ≃τ⇇Γ = Nf⇉-/⟨⟩≃-wf a⇉a⋯a σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-∀ k₂<∷k₁ _ _) σ≃τ⇇Γ = <∷-/⟨⟩≃-wf k₂<∷k₁ σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-→ a₂<:a₁ _)   σ≃τ⇇Γ = <:-/⟨⟩≃-wf a₂<:a₁ σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-∙ x∈j _)      σ≃τ⇇Γ = Var∈-/⟨⟩≃-wf x∈j σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-⟨| a∈b⋯c)     σ≃τ⇇Γ = Ne∈-/⟨⟩≃-wf a∈b⋯c σ≃τ⇇Γ
    <:-/⟨⟩≃-wf (<:-|⟩ a∈b⋯c)     σ≃τ⇇Γ = Ne∈-/⟨⟩≃-wf a∈b⋯c σ≃τ⇇Γ

  -- Equal hereditary substitutions preserve kind equality.
  ≅-/⟨⟩≃ : ∀ {k m n Γ Δ} {σ τ : SVSub m n} {k₁ k₂} →
           Γ ⊢ k₁ ≅ k₂ → Δ ⊢/⟨ k ⟩ σ ≃ τ ⇇ Γ →
           Δ ⊢ k₁ Kind/⟨ k ⟩ σ ≅ k₂ Kind/⟨ k ⟩ τ
  ≅-/⟨⟩≃ (<∷-antisym j-kd k-kd j<∷k k<∷j) σ≃τ⇇Γ =
    <∷-antisym (kd-/⟨⟩ j-kd (/⟨⟩≃-valid₁ σ≃τ⇇Γ))
               (kd-/⟨⟩ k-kd (/⟨⟩≃-valid₂ σ≃τ⇇Γ))
               (<∷-/⟨⟩≃ j<∷k σ≃τ⇇Γ) (<∷-/⟨⟩≃ k<∷j (/⟨⟩≃-sym σ≃τ⇇Γ))


-- Syntactic kits from Conor McBride's
-- "Type-Preserving Renaming and Substitution"
module Syntax.Substitution.Kits where

open import Syntax.Types
open import Syntax.Context
open import Syntax.Terms

open import CategoryTheory.Categories

open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; sym)

-- Type of entities that we can traverse
-- (instantiated by variables and types)
Schema : Set₁
Schema = Context -> Judgement -> Set

-- Explicit substitution from term in context Δ to term in context Γ
-- E.g. from Γ ⌊ A ⌋ Γ′ ⊢ N : B to Γ ⌊⌋ Γ′ ⊢ N[σ] : B
-- using substitution Γ ⌊⌋ Γ′ ⊢ σ : Γ ⌊ A ⌋ Γ′
data Subst (𝒮 : Schema) : Context -> Context -> Set where
    -- Empty substitution
    ●   : ∀ {Δ}     -> Subst 𝒮 ∙ Δ
    -- Extending the domain of a substitution
    _▸_ : ∀ {A Γ Δ} -> (σ : Subst 𝒮 Γ Δ) -> (T : 𝒮 Δ A) -> Subst 𝒮 (Γ , A) Δ

-- Syntactic kit grouping together common operations on traversable
-- syntactic entities such as variables and terms
record Kit (𝒮 : Schema) : Set where
    field
        -- Convert a variable to the entity
        𝓋 : ∀ {Γ A} -> A ∈ Γ -> 𝒮 Γ A
        -- Convert the entity to a term
        𝓉 : ∀ {Γ A} -> 𝒮 Γ A -> Γ ⊢ A
        -- Weaken the entity
        𝓌 : ∀ {B Γ A} -> 𝒮 Γ A -> 𝒮 (Γ , B) A
        -- Stabilise the context of the entity
        𝒶 : ∀ {Γ A} -> 𝒮 Γ (A always) -> 𝒮 (Γ ˢ) (A always)

-- Substitutable kit
record SubstKit (𝒮 : Schema) : Set where
    field
        -- Underlying traversable kit
        𝓀 : Kit 𝒮
        -- Apply substitution to a kit
        𝓈 : ∀ {Γ Δ A} -> Subst 𝒮 Γ Δ -> 𝒮 Γ A -> 𝒮 Δ A

open Kit

-- | Combinators
-- | All take a syntactic (substitutable) kit as an argument
-- | which provides the necessary operations

-- Weakening a substitution
-- Δ ⊢ σ : Γ to (Δ , A) ⊢ σ : Γ
_⁺_ : ∀ {A 𝒮 Γ Δ} -> Subst 𝒮 Γ Δ -> Kit 𝒮 -> Subst 𝒮 Γ (Δ , A)
●       ⁺ _ = ●
(σ ▸ T) ⁺ k = (σ ⁺ k) ▸ 𝓌 k T
infixl 40 _⁺_

-- Lifting a substitution
-- Δ ⊢ σ : Γ to (Δ , A) ⊢ σ : (Γ , A)
_↑_ : ∀ {A 𝒮 Γ Δ} -> Subst 𝒮 Γ Δ -> Kit 𝒮 -> Subst 𝒮 (Γ , A) (Δ , A)
σ ↑ k = (σ ⁺ k) ▸ 𝓋 k top
infixl 40 _↑_

-- Stabilising a substitution
-- Δ ⊢ σ : Γ to Δ ˢ ⊢ σ : Γ ˢ
_↓ˢ_ : ∀ {𝒮 Γ Δ} -> Subst 𝒮 Γ Δ -> Kit 𝒮 -> Subst 𝒮 (Γ ˢ) (Δ ˢ)
●                    ↓ˢ _ = ●
(_▸_ {A now} σ T)    ↓ˢ k = σ ↓ˢ k
(_▸_ {A always} σ T) ↓ˢ k = (σ ↓ˢ k) ▸ 𝒶 k T
infixl 40 _↓ˢ_

-- Identity substitution
idₛ : ∀ {Γ 𝒮} -> Kit 𝒮 -> Subst 𝒮 Γ Γ
idₛ {∙}     k = ●
idₛ {Γ , _} k = idₛ k ↑ k

-- Composition of substitutions
_∘[_]ₛ_ : ∀ {𝒮 Γ Δ Ξ} -> Subst 𝒮 Δ Ξ -> SubstKit 𝒮 -> Subst 𝒮 Γ Δ -> Subst 𝒮 Γ Ξ
σ₂ ∘[ k ]ₛ ●        = ●
σ₂ ∘[ k ]ₛ (σ₁ ▸ T) = (σ₂ ∘[ k ]ₛ σ₁) ▸ SubstKit.𝓈 k σ₂ T

-- Substitution from an order-preserving embedding
-- Γ ⊆ Δ to Δ ⊢ σ : Γ
_⊆ₛ_ : ∀ {𝒮 Γ Δ} -> Γ ⊆ Δ -> Kit 𝒮 -> Subst 𝒮 Γ Δ
refl ⊆ₛ k     = idₛ k
(keep s) ⊆ₛ k = (s ⊆ₛ k) ↑ k
(drop s) ⊆ₛ k = (s ⊆ₛ k) ⁺ k

-- Substitution from propositional equality of contexts
_≡ₛ_ : ∀ {𝒮 Γ Δ} -> Γ ≡ Δ -> Kit 𝒮 -> Subst 𝒮 Γ Δ
refl ≡ₛ k = idₛ k

-- Substitution from idempotence of stabilisation
_ˢˢₛ_ : ∀ {𝒮} -> (Γ : Context) -> Kit 𝒮 -> Subst 𝒮 (Γ ˢ) (Γ ˢ ˢ)
∙ ˢˢₛ k = ●
(Γ , A now) ˢˢₛ k = Γ ˢˢₛ k
(Γ , A always) ˢˢₛ k = (Γ ˢˢₛ k) ↑ k

-- | Standard substitutions
-- | Common transformations between contexts

module _ {𝒮 : Schema} (sk : SubstKit 𝒮) where
    open SubstKit sk
    open Kit 𝓀

    -- | Weakening

    -- Weakening the top of the context
    weak-topₛ : ∀{A Γ} -> Subst 𝒮 Γ (Γ , A)
    weak-topₛ = idₛ 𝓀 ⁺ 𝓀

    -- Weakening the middle of the context
    weak-midₛ : ∀{A} Γ Γ′ -> Subst 𝒮 (Γ ⌊⌋ Γ′) (Γ ⌊ A ⌋ Γ′)
    weak-midₛ Γ ∙ = weak-topₛ
    weak-midₛ Γ (Γ′ , B) = weak-midₛ Γ Γ′ ↑ 𝓀

    -- General weakening from an OPE
    weakₛ : ∀{Γ Δ} -> Γ ⊆ Δ -> Subst 𝒮 Γ Δ
    weakₛ = _⊆ₛ 𝓀

    -- | Exchange

    -- Exchange on top
    ex-topₛ : ∀{A B} Γ -> Subst 𝒮 (Γ , A , B) (Γ , B , A)
    ex-topₛ Γ = (idₛ 𝓀 ⁺ 𝓀 ↑ 𝓀) ▸ (𝓋 𝓀 (pop top))

    -- General exchange lemma
    exₛ : ∀{A B} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊ B ⌋ Γ″) (Γ ⌊ B ⌋ Γ′ ⌊ A ⌋ Γ″)
    exₛ Γ ∙ ∙ = ex-topₛ Γ
    exₛ {A} {B} Γ (Γ′ , C) ∙ =
        (exₛ Γ Γ′ [ A ] ∘[ sk ]ₛ ex-topₛ (Γ , C ⌊⌋ Γ′)) ∘[ sk ]ₛ exₛ Γ Γ′ [ B ]
    exₛ Γ ∙ (Γ″ , D) = exₛ Γ ∙ Γ″ ↑ 𝓀
    exₛ Γ (Γ′ , C) (Γ″ , D) = exₛ Γ (Γ′ , C) Γ″ ↑ 𝓀

    -- | Contraction

    -- Contraction on top
    contr-topₛ : ∀{A Γ} -> Subst 𝒮 (Γ , A , A) (Γ , A)
    contr-topₛ = (idₛ 𝓀) ▸ (𝓋 𝓀 top)

    -- General contraction lemma (left)
    contr-lₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″) (Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″)
    contr-lₛ Γ ∙ ∙ = contr-topₛ
    contr-lₛ Γ (Γ′ , B) ∙ = (idₛ 𝓀) ▸ (𝓌 𝓀 (𝓈 (contr-lₛ Γ Γ′ ∙) (𝓋 𝓀 top)))
    contr-lₛ Γ ∙ (Γ″ , C) = contr-lₛ Γ ∙ Γ″ ↑ 𝓀
    contr-lₛ Γ (Γ′ , B) (Γ″ , C) = contr-lₛ Γ (Γ′ , B) Γ″ ↑ 𝓀

    -- General contraction lemma (right)
    contr-rₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″) (Γ ⌊⌋ Γ′ ⌊ A ⌋ Γ″)
    contr-rₛ Γ ∙ ∙ = contr-topₛ
    contr-rₛ {A} Γ (Γ′ , B) ∙ =
        (ex-topₛ (Γ ⌊⌋ Γ′) ∘[ sk ]ₛ contr-rₛ Γ Γ′ [ B ]) ∘[ sk ]ₛ ex-topₛ (Γ , A ⌊⌋ Γ′)
    contr-rₛ Γ ∙ (Γ″ , C) = contr-rₛ Γ ∙ Γ″ ↑ 𝓀
    contr-rₛ Γ (Γ′ , B) (Γ″ , C) = contr-rₛ Γ (Γ′ , B) Γ″ ↑ 𝓀

    -- | Movement

    -- Moving a variable to the right in the context
    move-rₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″) (Γ ⌊⌋ Γ′ ⌊ A ⌋ Γ″)
    move-rₛ {A} Γ Γ′ Γ″ = contr-rₛ Γ Γ′ Γ″ ∘[ sk ]ₛ weak-midₛ (Γ ⌊ A ⌋ Γ′) Γ″

    -- Moving a variable to the left in the context
    -- Bit verbose as we have to deal with associativity
    move-lₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ⌊⌋ Γ′ ⌊ A ⌋ Γ″) (Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″)
    move-lₛ {A} Γ Γ′ Γ″
        =        contr-lₛ Γ Γ′ Γ″
        ∘[ sk ]ₛ ((sym (⌊A⌋-assoc Γ Γ′ Γ″ A A) ≡ₛ 𝓀)
        ∘[ sk ]ₛ ((weak-midₛ {A} Γ (Γ′ ⌊ A ⌋ Γ″))
        ∘[ sk ]ₛ (⌊⌋-assoc Γ (Γ′ , A) Γ″ ≡ₛ 𝓀)))

    -- Moving a variable to the right in the stabilised context context
    moveˢ-rₛ : ∀{A} Γ Γ′ Γ″ -> Subst 𝒮 (Γ ˢ ⌊ A ⌋ (Γ′ ⌊⌋ Γ″) ˢ) ((Γ ⌊⌋ Γ′) ˢ ⌊ A ⌋ Γ″ ˢ)
    moveˢ-rₛ {A} Γ Γ′ Γ″
        rewrite ˢ-pres-⌊⌋ Γ Γ′
              | ˢ-pres-⌊⌋ Γ′ Γ″
              | sym (⌊⌋-assoc (Γ ˢ , A) (Γ′ ˢ) (Γ″ ˢ))
        = move-rₛ (Γ ˢ) (Γ′ ˢ) (Γ″ ˢ)

    -- | Substitution

    -- Substitution for the top of the context
    sub-topₛ : ∀{A Γ} -> 𝒮 Γ A -> Subst 𝒮 (Γ , A) Γ
    sub-topₛ T = (idₛ 𝓀) ▸ T

    -- Substitution for the top of a stabilised context
    sub-topˢₛ : ∀{Γ A} -> 𝒮 Γ A -> Subst 𝒮 (Γ ˢ , A) Γ
    sub-topˢₛ {Γ} T = (Γˢ⊆Γ Γ ⊆ₛ 𝓀) ▸ T

    -- Substitution for the middle of the context
    sub-midₛ : ∀{A} Γ Γ′ -> 𝒮 (Γ ⌊⌋ Γ′) A -> Subst 𝒮 (Γ ⌊ A ⌋ Γ′) (Γ ⌊⌋ Γ′)
    sub-midₛ Γ Γ′ T = sub-topₛ T ∘[ sk ]ₛ move-rₛ Γ Γ′ ∙


------------------------------------------------------------------------
-- Lemmas related to weak bisimilarity and CCS
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Prelude hiding (step-→)

module Bisimilarity.Weak.CCS {ℓ} {Name : Type ℓ} where

open import Equality.Propositional
open import Prelude.Size

open import Function-universe equality-with-J hiding (id; _∘_)

import Bisimilarity.CCS as SE
import Bisimilarity.Equational-reasoning-instances
import Bisimilarity.Weak.Equational-reasoning-instances
open import Equational-reasoning
import Expansion.CCS as E
import Expansion.Equational-reasoning-instances
open import Labelled-transition-system.CCS Name

import Bisimilarity CCS as S
open import Bisimilarity.Weak CCS
open import Expansion CCS using (_≳_; ≳:_)
import Labelled-transition-system.Equational-reasoning-instances CCS
  as Dummy

-- An instantiation of a module with helper lemmas.

private
  module CL {i} =
    E.Cong-lemmas
      [ i ]_≈′_ right-to-left (⇒̂→[]⇒ (λ ())) ⇒→⇒̂
      map-⇒̂ map-⇒̂′ zip-⇒̂
      (λ hyp {P Q} → λ where

        (silent s done) →
            _
          , (! P      →⟨ silent s done ⟩■)
          , (! P      ∼⟨ symmetric SE.6-1-2 ⟩
             ! P ∣ P  ∼≡⟨ refl ⟩■
             ! P ∣ Q)

        (silent s (step {q = R} s′ P⟶R R⇒Q)) →
            _
          , (! P      →⟨ ⟶→⇒ s′ (replication (par-right P⟶R)) ⟩
             ! P ∣ R  →⟨ silent s (map-⇒ par-right R⇒Q) ⟩■)
          , (! P ∣ Q  ■)

        (non-silent ¬s P⇒Q) →
            _
          , (! P  →⟨ non-silent ¬s (hyp P⇒Q) ⟩■)
          , (! P ∣ Q  ■))

mutual

  -- _∣_ preserves weak bisimilarity.

  infix 6 _∣-cong_ _∣-cong′_

  _∣-cong_ : ∀ {i P P′ Q Q′} →
             [ i ] P ≈ P′ → [ i ] Q ≈ Q′ → [ i ] P ∣ Q ≈ P′ ∣ Q′
  P≈P′ ∣-cong Q≈Q′ =
    ⟨ Σ-map id (Σ-map id symmetric) ∘
      rl (symmetric P≈P′) (symmetric Q≈Q′)
    , rl P≈P′ Q≈Q′
    ⟩
    where
    rl = CL.∣-cong _∣-cong′_

  _∣-cong′_ : ∀ {i P P′ Q Q′} →
              [ i ] P ≈′ P′ → [ i ] Q ≈′ Q′ → [ i ] P ∣ Q ≈′ P′ ∣ Q′
  force (P≈P′ ∣-cong′ Q≈Q′) = force P≈P′ ∣-cong force Q≈Q′

-- _·_ preserves weak bisimilarity.

infix 12 _·-cong_ _·-cong′_

_·-cong_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ≈′ force P′ → [ i ] μ · P ≈ μ′ · P′
_·-cong_ {i} refl P≈P′ =
  ⟨ Σ-map id (Σ-map id symmetric) ∘ rl (symmetric P≈P′)
  , rl P≈P′
  ⟩
  where
  rl = CL.·-cong {i = i}

_·-cong′_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ≈′ force P′ → [ i ] μ · P ≈′ μ′ · P′
force (μ≡μ′ ·-cong′ P≈P′) = μ≡μ′ ·-cong P≈P′

-- _∙_ preserves weak bisimilarity.

infix 12 _∙-cong_ _∙-cong′_

_∙-cong_ : ∀ {i μ μ′ P P′} →
           μ ≡ μ′ → [ i ] P ≈ P′ → [ i ] μ ∙ P ≈ μ′ ∙ P′
refl ∙-cong P≈P′ = refl ·-cong convert {a = ℓ} P≈P′

_∙-cong′_ : ∀ {i μ μ′ P P′} →
            μ ≡ μ′ → [ i ] P ≈′ P′ → [ i ] μ ∙ P ≈′ μ′ ∙ P′
force (μ≡μ′ ∙-cong′ P≈P′) = μ≡μ′ ∙-cong force P≈P′

-- _∙ turns equal actions into weakly bisimilar processes.

infix 12 _∙-cong _∙-cong′

_∙-cong : ∀ {μ μ′} → μ ≡ μ′ → μ ∙ ≈ μ′ ∙
refl ∙-cong = reflexive

_∙-cong′ : ∀ {μ μ′} → μ ≡ μ′ → μ ∙ ≈′ μ′ ∙
refl ∙-cong′ = reflexive

mutual

  -- ⟨ν_⟩ preserves weak bisimilarity.

  ⟨ν_⟩-cong : ∀ {i a a′ P P′} →
              a ≡ a′ → [ i ] P ≈ P′ → [ i ] ⟨ν a ⟩ P ≈ ⟨ν a′ ⟩ P′
  ⟨ν_⟩-cong {i} {a} {P = P} {P′} refl P≈P′ =
    ⟨ Σ-map id (Σ-map id symmetric) ∘
      CL.⟨ν⟩-cong ⟨ν refl ⟩-cong′ (symmetric P≈P′)
    , CL.⟨ν⟩-cong ⟨ν refl ⟩-cong′ P≈P′
    ⟩

  ⟨ν_⟩-cong′ : ∀ {i a a′ P P′} →
               a ≡ a′ → [ i ] P ≈′ P′ → [ i ] ⟨ν a ⟩ P ≈′ ⟨ν a′ ⟩ P′
  force (⟨ν a≡a′ ⟩-cong′ P≈P′) = ⟨ν a≡a′ ⟩-cong (force P≈P′)

mutual

  -- !_ preserves weak bisimilarity.

  infix 10 !-cong_ !-cong′_

  !-cong_ : ∀ {i P P′} →
            [ i ] P ≈ P′ → [ i ] ! P ≈ ! P′
  !-cong_ {i} {P} {P′} P≈P′ =
    ⟨ Σ-map id (Σ-map id symmetric) ∘
      CL.!-cong _∣-cong′_ !-cong′_ (symmetric P≈P′)
    , CL.!-cong _∣-cong′_ !-cong′_ P≈P′
    ⟩

  !-cong′_ : ∀ {i P P′} → [ i ] P ≈′ P′ → [ i ] ! P ≈′ ! P′
  force (!-cong′ P≈P′) = !-cong (force P≈P′)

-- _⊕_ does not, in general, preserve weak bisimilarity in its first
-- argument (assuming that Name is inhabited).

¬⊕-congˡ : Name → ¬ (∀ {P P′ Q} → P ≈ P′ → P ⊕ Q ≈ P′ ⊕ Q)
¬⊕-congˡ x =
  (∀ {P P′ Q} → P ≈ P′ → P ⊕ Q ≈ P′ ⊕ Q)  ↝⟨ _∘ ≳⇒≈ ⟩
  (∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≈ P′ ⊕ Q)  ↝⟨ E.¬⊕-congˡ-≳≈ x ⟩□
  ⊥                                       □

-- _⊕_ does not, in general, preserve weak bisimilarity in its second
-- argument (assuming that Name is inhabited).

¬⊕-congʳ : Name → ¬ (∀ {P Q Q′} → Q ≈ Q′ → P ⊕ Q ≈ P ⊕ Q′)
¬⊕-congʳ x =
  (∀ {P Q Q′} → Q ≈ Q′ → P ⊕ Q ≈ P ⊕ Q′)  ↝⟨ _∘ ≳⇒≈ ⟩
  (∀ {P Q Q′} → Q ≳ Q′ → P ⊕ Q ≈ P ⊕ Q′)  ↝⟨ E.¬⊕-congʳ-≳≈ x ⟩□
  ⊥                                       □

-- Some congruence lemmas for combinations of _⊕_ and _·_.

⊕·-cong :
  ∀ {i P μ Q Q′} →
  [ i ] force Q ≈′ force Q′ → [ i ] P ⊕ μ · Q ≈ P ⊕ μ · Q′
⊕·-cong {i} Q≈Q′ =
  ⟨ Σ-map id (Σ-map id symmetric) ∘ CL.⊕·-cong (symmetric Q≈Q′)
  , CL.⊕·-cong {i = i} Q≈Q′
  ⟩

⊕·-cong′ :
  ∀ {i P μ Q Q′} →
  [ i ] force Q ≈′ force Q′ → [ i ] P ⊕ μ · Q ≈′ P ⊕ μ · Q′
force (⊕·-cong′ Q≈Q′) = ⊕·-cong Q≈Q′

·⊕-cong : ∀ {i P P′ μ Q} →
          [ i ] force P ≈′ force P′ → [ i ] μ · P ⊕ Q ≈ μ · P′ ⊕ Q
·⊕-cong {P = P} {P′} {μ} {Q} P≈P′ =
  μ · P ⊕ Q   ∼⟨ SE.⊕-comm ⟩
  Q ⊕ μ · P   ∼′⟨ ⊕·-cong P≈P′ ⟩ S.∼:
  Q ⊕ μ · P′  ∼⟨ SE.⊕-comm ⟩■
  μ · P′ ⊕ Q

·⊕-cong′ :
  ∀ {i P P′ μ Q} →
  [ i ] force P ≈′ force P′ → [ i ] μ · P ⊕ Q ≈′ μ · P′ ⊕ Q
force (·⊕-cong′ P≈P′) = ·⊕-cong P≈P′

infix 8 _·⊕·-cong_ _·⊕·-cong′_

_·⊕·-cong_ :
  ∀ {i μ₁ μ₂ P₁ P₁′ P₂ P₂′} →
  [ i ] force P₁ ≈′ force P₁′ → [ i ] force P₂ ≈′ force P₂′ →
  [ i ] μ₁ · P₁ ⊕ μ₂ · P₂ ≈ μ₁ · P₁′ ⊕ μ₂ · P₂′
_·⊕·-cong_ {i} P₁≈P₁′ P₂≈P₂′ =
  ⟨ Σ-map id (Σ-map id symmetric) ∘
    CL.·⊕·-cong (symmetric P₁≈P₁′) (symmetric P₂≈P₂′)
  , CL.·⊕·-cong {i = i} P₁≈P₁′ P₂≈P₂′
  ⟩

_·⊕·-cong′_ :
  ∀ {i μ₁ μ₂ P₁ P₁′ P₂ P₂′} →
  [ i ] force P₁ ≈′ force P₁′ → [ i ] force P₂ ≈′ force P₂′ →
  [ i ] μ₁ · P₁ ⊕ μ₂ · P₂ ≈′ μ₁ · P₁′ ⊕ μ₂ · P₂′
force (P₁≈′P₁′ ·⊕·-cong′ P₂≈′P₂′) = P₁≈′P₁′ ·⊕·-cong P₂≈′P₂′

-- _[_] preserves weak bisimilarity for non-degenerate contexts. (This
-- result is similar to Theorem 6.5.25 in "Enhancements of the
-- bisimulation proof method" by Pous and Sangiorgi.)
--
-- TODO: This definition is very similar to E._[_]-cong. Find some way
-- to reduce the code duplication. (There was much less code
-- duplication before contexts were made coinductive.)

infix 5 _[_]-cong _[_]-cong′

_[_]-cong :
  ∀ {i n Ps Qs} {C : Context ∞ n} →
  Non-degenerate ∞ C → (∀ x → [ i ] Ps x ≈ Qs x) →
  [ i ] C [ Ps ] ≈ C [ Qs ]
hole     [ Ps≈Qs ]-cong = Ps≈Qs _
∅        [ Ps≈Qs ]-cong = reflexive
D₁ ∣ D₂  [ Ps≈Qs ]-cong = (D₁ [ Ps≈Qs ]-cong) ∣-cong (D₂ [ Ps≈Qs ]-cong)
action D [ Ps≈Qs ]-cong = refl ·-cong λ { .force → force D [ Ps≈Qs ]-cong }
⟨ν⟩ D    [ Ps≈Qs ]-cong = ⟨ν refl ⟩-cong (D [ Ps≈Qs ]-cong)
! D      [ Ps≈Qs ]-cong = !-cong (D [ Ps≈Qs ]-cong)
D₁ ⊕ D₂  [ Ps≈Qs ]-cong = ⊕-cong Ps≈Qs D₁ D₂
  where
  _[_]-cong′ :
    ∀ {i n Ps Qs} {C : Context ∞ n} →
    Non-degenerate′ ∞ C → (∀ x → [ i ] Ps x ≈ Qs x) →
    [ i ] C [ Ps ] ≈′ C [ Qs ]
  force (D [ Ps≈Qs ]-cong′) = force D [ Ps≈Qs ]-cong

  ⊕-cong :
    ∀ {i n Ps Qs} {C₁ C₂ : Context ∞ n} →
    (∀ x → [ i ] Ps x ≈ Qs x) →
    Non-degenerate-summand ∞ C₁ →
    Non-degenerate-summand ∞ C₂ →
    [ i ] (C₁ [ Ps ]) ⊕ (C₂ [ Ps ]) ≈ (C₁ [ Qs ]) ⊕ (C₂ [ Qs ])
  ⊕-cong {Ps = Ps} {Qs} Ps≈Qs = λ where
    (process P₁) (process P₂) →
      (context P₁ [ Ps ]) ⊕ (context P₂ [ Ps ])  ∼⟨ symmetric (SE.≡→∼ (context-[] P₁) SE.⊕-cong SE.≡→∼ (context-[] P₂)) ⟩
      P₁ ⊕ P₂                                    ∼⟨ SE.≡→∼ (context-[] P₁) SE.⊕-cong SE.≡→∼ (context-[] P₂) ⟩■
      (context P₁ [ Qs ]) ⊕ (context P₂ [ Qs ])

    (process P₁) (action {μ = μ₂} {C = C₂} D₂) →
      (context P₁ [ Ps ]) ⊕ μ₂ · (C₂ [ Ps ]′)  ∼⟨ symmetric (SE.≡→∼ (context-[] P₁)) SE.⊕-cong (_ ■) ⟩
      P₁ ⊕ μ₂ · (C₂ [ Ps ]′)                   ∼′⟨ ⊕·-cong (D₂ [ Ps≈Qs ]-cong′) ⟩ S.∼:
      P₁ ⊕ μ₂ · (C₂ [ Qs ]′)                   ∼⟨ SE.≡→∼ (context-[] P₁) SE.⊕-cong (_ ■) ⟩■
      (context P₁ [ Qs ]) ⊕ μ₂ · (C₂ [ Qs ]′)

    (action {μ = μ₁} {C = C₁} D₁) (process P₂) →
      μ₁ · (C₁ [ Ps ]′) ⊕ (context P₂ [ Ps ])  ∼⟨ (_ ■) SE.⊕-cong symmetric (SE.≡→∼ (context-[] P₂)) ⟩
      μ₁ · (C₁ [ Ps ]′) ⊕ P₂                   ∼′⟨ ·⊕-cong (D₁ [ Ps≈Qs ]-cong′) ⟩ S.∼:
      μ₁ · (C₁ [ Qs ]′) ⊕ P₂                   ∼⟨ (_ ■) SE.⊕-cong SE.≡→∼ (context-[] P₂) ⟩■
      μ₁ · (C₁ [ Qs ]′) ⊕ (context P₂ [ Qs ])

    (action {μ = μ₁} {C = C₁} D₁) (action {μ = μ₂} {C = C₂} D₂) →
      μ₁ · (C₁ [ Ps ]′) ⊕ μ₂ · (C₂ [ Ps ]′)  ∼⟨ (D₁ [ Ps≈Qs ]-cong′) ·⊕·-cong (D₂ [ Ps≈Qs ]-cong′) ⟩■
      μ₁ · (C₁ [ Qs ]′) ⊕ μ₂ · (C₂ [ Qs ]′)

_[_]-cong′ :
  ∀ {i n Ps Qs} {C : Context ∞ n} →
  Non-degenerate ∞ C → (∀ x → [ i ] Ps x ≈′ Qs x) →
  [ i ] C [ Ps ] ≈′ C [ Qs ]
force (C [ Ps≈Qs ]-cong′) = C [ (λ x → force (Ps≈Qs x)) ]-cong

-- A variant of _[_]-cong for weakly guarded contexts.
--
-- Note that the input uses the primed variant of weak bisimilarity.
--
-- I got the idea for this lemma from Lemma 23 in Schäfer and Smolka's
-- "Tower Induction and Up-to Techniques for CCS with Fixed Points".

[]-cong-w :
  ∀ {i n Ps Qs} {C : Context ∞ n} →
  Weakly-guarded C → Non-degenerate ∞ C → (∀ x → [ i ] Ps x ≈′ Qs x) →
  [ i ] C [ Ps ] ≈ C [ Qs ]
[]-cong-w ()        hole
[]-cong-w _         ∅          Ps≈Qs = reflexive
[]-cong-w (W₁ ∣ W₂) (D₁ ∣ D₂)  Ps≈Qs = []-cong-w W₁ D₁ Ps≈Qs ∣-cong
                                       []-cong-w W₂ D₂ Ps≈Qs
[]-cong-w action    (action D) Ps≈Qs = refl ·-cong
                                         (force D [ Ps≈Qs ]-cong′)
[]-cong-w (⟨ν⟩ W)   (⟨ν⟩ D)    Ps≈Qs = ⟨ν refl ⟩-cong
                                         ([]-cong-w W D Ps≈Qs)
[]-cong-w (! W)     (! D)      Ps≈Qs = !-cong []-cong-w W D Ps≈Qs
[]-cong-w {Ps = Ps} {Qs}
          (W₁ ⊕ W₂) (D₁ ⊕ D₂)  Ps≈Qs = case D₁ ,′ D₂ of λ where
  (process P₁ , process P₂) →
    (context P₁ [ Ps ]) ⊕ (context P₂ [ Ps ])  ∼⟨ symmetric (SE.≡→∼ (context-[] P₁) SE.⊕-cong SE.≡→∼ (context-[] P₂)) ⟩
    P₁ ⊕ P₂                                    ∼⟨ SE.≡→∼ (context-[] P₁) SE.⊕-cong SE.≡→∼ (context-[] P₂) ⟩■
    (context P₁ [ Qs ]) ⊕ (context P₂ [ Qs ])

  (process P₁ , action {μ = μ₂} {C = C₂} D₂) →
    (context P₁ [ Ps ]) ⊕ μ₂ · (C₂ [ Ps ]′)  ∼⟨ symmetric (SE.≡→∼ (context-[] P₁)) SE.⊕-cong (_ ■) ⟩
    P₁ ⊕ μ₂ · (C₂ [ Ps ]′)                   ∼′⟨ ⊕·-cong (force D₂ [ Ps≈Qs ]-cong′) ⟩ S.∼:
    P₁ ⊕ μ₂ · (C₂ [ Qs ]′)                   ∼⟨ SE.≡→∼ (context-[] P₁) SE.⊕-cong (_ ■) ⟩■
    (context P₁ [ Qs ]) ⊕ μ₂ · (C₂ [ Qs ]′)

  (action {μ = μ₁} {C = C₁} D₁ , process P₂) →
    μ₁ · (C₁ [ Ps ]′) ⊕ (context P₂ [ Ps ])  ∼⟨ (_ ■) SE.⊕-cong symmetric (SE.≡→∼ (context-[] P₂)) ⟩
    μ₁ · (C₁ [ Ps ]′) ⊕ P₂                   ∼′⟨ ·⊕-cong (force D₁ [ Ps≈Qs ]-cong′) ⟩ S.∼:
    μ₁ · (C₁ [ Qs ]′) ⊕ P₂                   ∼⟨ (_ ■) SE.⊕-cong SE.≡→∼ (context-[] P₂) ⟩■
    μ₁ · (C₁ [ Qs ]′) ⊕ (context P₂ [ Qs ])

  (action {μ = μ₁} {C = C₁} D₁ , action {μ = μ₂} {C = C₂} D₂) →
    μ₁ · (C₁ [ Ps ]′) ⊕ μ₂ · (C₂ [ Ps ]′)  ∼⟨ (force D₁ [ Ps≈Qs ]-cong′) ·⊕·-cong (force D₂ [ Ps≈Qs ]-cong′) ⟩■
    μ₁ · (C₁ [ Qs ]′) ⊕ μ₂ · (C₂ [ Qs ]′)

-- A generalisation to systems of inequations of the following
-- property: If two processes satisfy the same equation X ≳ C [ X ],
-- for a weakly guarded, non-degenerate context C, then the two
-- processes are weakly bisimilar (assuming extensionality).
--
-- This result is a variant of Bisimilarity.CCS.unique-solutions.
-- Proposition 4.4.4 in Milner's "Operational and Algebraic Semantics
-- of Concurrent Processes" is perhaps more useful in practice, as
-- well as some of the results in Sangiorgi's "Equations,
-- Contractions, and Unique Solutions".

module _ (ext : Proc-extensionality) where

  mutual

    unique-solutions :
      ∀ {i n} {Ps Qs : Fin n → Proc ∞} {C : Fin n → Context ∞ n} →
      (∀ x → Weakly-guarded (C x)) →
      (∀ x → Non-degenerate ∞ (C x)) →
      (∀ x → Ps x ≳ C x [ Ps ]) →
      (∀ x → Qs x ≳ C x [ Qs ]) →
      ∀ x → [ i ] Ps x ≈ Qs x
    unique-solutions {i} {Ps = Ps} {Qs} {C} w nd ≳C[Ps] ≳C[Qs] x =
      Ps x        ∼⟨ ≳C[Ps] x ⟩
      C x [ Ps ]  ∼′⟨ ≈: ⟨ lr ≳C[Ps] ≳C[Qs] , Σ-map id (Σ-map id symmetric) ∘ lr ≳C[Qs] ≳C[Ps] ⟩ ⟩ ≳:
      C x [ Qs ]  ∽⟨ ≳C[Qs] x ⟩■
      Qs x
      where
      lr :
        ∀ {Ps Qs μ P} →
        (∀ x → Ps x ≳ C x [ Ps ]) →
        (∀ x → Qs x ≳ C x [ Qs ]) →
        C x [ Ps ] [ μ ]⟶ P →
        ∃ λ Q → C x [ Qs ] [ μ ]⇒̂ Q × [ i ] P ≈′ Q
      lr {Ps} {Qs} {μ} ≳C[Ps] ≳C[Qs] ⟶P =
        case 6-2-15-nd ext (C x) (w x) (nd x) ⟶P of λ where
          (C′ , nd′ , refl , trs) →
              _
            , (C x [ Qs ]  →⟨ trs Qs ⟩■
               C′ [ Qs ])
            , (C′ [ Ps ]  ∼⟨ nd′ [ unique-solutions′ w nd ≳C[Ps] ≳C[Qs] ]-cong′ ⟩■
               C′ [ Qs ])

    unique-solutions′ :
      ∀ {i n} {Ps Qs : Fin n → Proc ∞} {C : Fin n → Context ∞ n} →
      (∀ x → Weakly-guarded (C x)) →
      (∀ x → Non-degenerate ∞ (C x)) →
      (∀ x → Ps x ≳ C x [ Ps ]) →
      (∀ x → Qs x ≳ C x [ Qs ]) →
      ∀ x → [ i ] Ps x ≈′ Qs x
    force (unique-solutions′ w nd ≳C[Ps] ≳C[Qs] x) =
      unique-solutions w nd ≳C[Ps] ≳C[Qs] x


{-# OPTIONS --without-K #-}
-- Rending the Program Runner
-- A proof of Lӧb′s theorem: quoted interpreters are inconsistent
-- Jason Gross

{- Title and some comments inspired by and drawn heavily from
   "Scooping the Loop Sniffer: A proof that the Halting Problem is
   undecidable", by Geoffrey K. Pullum
   (http://www.lel.ed.ac.uk/~gpullum/loopsnoop.html) -}

open import common

infixl 2 _▻_
infixl 3 _‘’_
infixr 1 _‘→’_

{- "Scooping the Loop Sniffer", with slight modifications for this
   code.

No general procedure for type-checking will do.
Now, I won’t just assert that, I’ll prove it to you.
I will prove that although you might work till you drop,
you cannot tell if computation will stop.

For imagine we have a procedure called P
that for specified input permits you to see
what specified source code, with all of its faults,
defines a routine that eventually halts.

You feed in your program, with suitable data,
and P gets to work, and a little while later
(in finite compute time) correctly infers
whether infinite looping behavior occurs.

If there will be no looping, then P prints out ‘Good.’
That means work on this input will halt, as it should.
But if it detects an unstoppable loop,
then P reports ‘Bad!’ — which means you’re in the soup.

Well, the truth is that P cannot possibly be,
because if you wrote it and gave it to me,
I could use it to set up a logical bind
that would shatter your reason and scramble your mind.

For a specified program, say ‶A″, one supplies,
the first step of this program called Q I devise
is to find out from P what’s the right thing to say
of the looping behavior of A run on ‶A″.

If P’s answer is ‘Bad!’, Q will suddenly stop.
But otherwise, Q will go back to the top,
and start off again, looping endlessly back,
till the universe dies and turns frozen and black.

And this program called Q wouldn’t stay on the shelf;
I would ask it to forecast its run on itself.
When it reads its own source code, just what will it do?
What’s the looping behavior of Q run on Q?

If P warns of infinite loops, Q will quit;
yet P is supposed to speak truly of it!
And if Q’s going to quit, then P should say ‘Good.’
Which makes Q start to loop! (P denied that it would.)

No matter how P might perform, Q will scoop it:
Q uses P’s output to make P look stupid.
Whatever P says, it cannot predict Q:
P is right when it’s wrong, and is false when it’s true!

I’ve created a paradox, neat as can be —
and simply by using your putative P.
When you posited P you stepped into a snare;
Your assumption has led you right into my lair.

So where can this argument possibly go?
I don’t have to tell you; I’m sure you must know.
A reductio: There cannot possibly be
a procedure that acts like the mythical P.

You can never find general mechanical means
for predicting the acts of computing machines;
it’s something that cannot be done. So we users
must find our own bugs. Our computers are losers! -}

{- Our program will act much like this Q, except that instead of saying that

  Q will go back to the top,
  and start off again, looping endlessly back,
  till the universe dies and turns frozen and black.

We would say something more like that

  Q will go back to the top,
  and ask for the output of A run on ‶A″,
  trusting P that execution will not run away.

Further more, we combine the type-checker and the interpreter; we show
there cannot be a well-typed quoted interpreter that interprets all
well-typed quoted terms directly, rather than having a separate phase
of type-checking.  Morally, they should be equivalent. -}

{- We start off by defining Contexts, Types, and Terms which are
well-typed by construction.

We will prove that assuming Lӧb′s theorem is consistent in a minimal
representation, and doesn′t require anything fancy to support it in a
model of the syntax.  Thus any reasonable syntax, which has a model,
will also have a model validating Lӧb′s theorem.

This last part is informal; it′s certainly conceivable that something
like internalized parametricity, which needs to do something special
with each constructor of the language, won't be able to do anything
with the quotation operator.

There's a much longer formalization of Lӧb′s theorem in this
repository which just assumes a quotation operator, and proves Lӧb′s
theorem by constructing it (though to build a quine, we end up needing
to decide equality of Contexts, which is fine); the quotation operator
is, in principle, definable, by stuffing the constructors of the
syntax into an initial context, and building up the quoted terms by
structural recursion.  This would be even more painful, though, unless
there′s a nice way to give specific quoted terms.

Now, down to business. -}

mutual
  -- Contexts are utterly standard
  data Context : Set where
    ε : Context
    _▻_ : (Γ : Context) → Type Γ → Context

  -- Types have standard substituition and non-dependent function
  -- types.
  data Type : Context → Set where
    _‘’_ : ∀ {Γ A} → Type (Γ ▻ A) → Term {Γ} A → Type Γ
    _‘→’_ : ∀ {Γ} → Type Γ → Type Γ → Type Γ
  -- We also require that there be a quotation of ‶Type ε″ (called
  -- ‘Typeε’), and a quotation of ‶Term ε″ (called ‘□’)
    ‘Typeε’ : Type ε
    ‘□’ : Type (ε ▻ ‘Typeε’)
  -- We don′t really need quoted versions of ⊤ and ⊥, but they are
  -- useful stating a few things after the proof of Lӧb′s theorem
    ‘⊤’ : ∀ {Γ} → Type Γ
    ‘⊥’ : ∀ {Γ} → Type Γ
  -- Note that you can add whatever other constructors to this data
  -- type you would like;

  data Term : {Γ : Context} → Type Γ → Set where
  -- We require the existence of a function (in the ambient language)
  -- that takes a type in the empty context, and returns the quotation
  -- of that type.
    ⌜_⌝ : Type ε → Term {ε} ‘Typeε’
  -- Finally, we assume Lӧb′s theorem; we will show that this syntax
  -- has a model.
    Lӧb : ∀ {X} → Term {ε} (‘□’ ‘’ ⌜ X ⌝ ‘→’ X) → Term {ε} X
  -- This is not strictly required, just useful for showing that some
  -- type is inhabited.
    ‘tt’ : ∀ {Γ} → Term {Γ} ‘⊤’

{- ‶□ T″ is read ‶T is provable″ or ‶T is inhabited″ or ‶the type of
syntactic terms of the syntactic type T″ or ‶the type of quoted terms
of the quoted type T″. -}

□ : Type ε → Set _
□ = Term {ε}

mutual
  {- Having an inhabitant of type ‶the interpretation of a given
  Context″ is having an inhabitant of the interpretation of every type
  in that Context.  If we wanted to represent more universes, we could
  sprinkle lifts and lowers, and it would not cause us trouble.  They
  are elided here for simplicity. -}
  Context⇓ : (Γ : Context) → Set
  Context⇓ ε = ⊤
  Context⇓ (Γ ▻ T) = Σ (Context⇓ Γ) (Type⇓ {Γ} T)

  -- Substitution and function types are interpreted standardly.
  Type⇓ : {Γ : Context} → Type Γ → Context⇓ Γ → Set
  Type⇓ (T ‘’ x) Γ⇓ = Type⇓ T (Γ⇓ , Term⇓ x Γ⇓)
  Type⇓ (A ‘→’ B) Γ⇓ = Type⇓ A Γ⇓ → Type⇓ B Γ⇓
  -- ‘Typeε’ is, unsurprisingly, interpreted as Type ε, the type of
  -- syntactic types in the empty context.
  Type⇓ ‘Typeε’ Γ⇓ = Type ε
  -- ‘□’ expects Term of Type ‘Typeε’ as the last element of the
  -- context, and represents the type of Terms of that Type.  We take
  -- the (already-interpreted) last element of the Context, and feed
  -- it to Term {ε}, to get the Set of Terms of that Type.
  Type⇓ ‘□’ Γ⇓ = Term {ε} (Σ.proj₂ Γ⇓)
  -- The rest of the interpreter, for types not formally needed in
  -- Lӧb′s theorem.
  Type⇓ ‘⊤’ Γ⇓ = ⊤
  Type⇓ ‘⊥’ Γ⇓ = ⊥

  Term⇓ : ∀ {Γ : Context} {T : Type Γ} → Term T → (Γ⇓ : Context⇓ Γ) → Type⇓ T Γ⇓
  -- Unsurprisingly, we interpret the quotation of a given source code
  -- as the source code itself.  (Defining the interpretation of
  -- quotation is really trivial.  Defining quotation itself is much
  -- tricker.)  Note that it is, I believe, essential, that every Type
  -- be quotable.  Otherwise Lӧb′s theorem cannot be internalized in
  -- our syntactic representation, and will require both being given
  -- both a type, and syntax which denotes to that type.
  Term⇓ ⌜ x ⌝ Γ⇓ = x
  -- Now, the interesting part.  Given an interpreter (P in the poem,
  -- □‘X’→X in this code), we validate Lӧb′s theorem (Q run on Q) by
  -- running the interpreter on ... Q run on Q!  It takes a bit of
  -- thinking to wrap your head around, but the types line up, and
  -- it′s beautifully simple.
  Term⇓ (Lӧb □‘X’→X) Γ⇓ = Term⇓ □‘X’→X Γ⇓ (Lӧb □‘X’→X)
  -- Inhabiting ⊤
  Term⇓ ‘tt’ Γ⇓ = tt

⌞_⌟ : Type ε → Set _
⌞ T ⌟ = Type⇓ T tt

‘¬’_ : ∀ {Γ} → Type Γ → Type Γ
‘¬’ T = T ‘→’ ‘⊥’

-- With our interpreter, we can chain Lӧb′s theorem with itself: if we
-- can prove that ‶proving ‘X’ is sufficient to make ‘X’ true″, then
-- we can already inhabit X.
lӧb : ∀ {‘X’} → □ (‘□’ ‘’ ⌜ ‘X’ ⌝ ‘→’ ‘X’) → ⌞ ‘X’ ⌟
lӧb f = Term⇓ (Lӧb f) tt

-- We can thus prove that it′s impossible to prove that contradictions
-- are unprovable.
incompleteness : ¬ □ (‘¬’ (‘□’ ‘’ ⌜ ‘⊥’ ⌝))
incompleteness = lӧb

-- We can also prove that contradictions are, in fact, unprovable.
soundness : ¬ □ ‘⊥’
soundness x = Term⇓ x tt

-- And we can prove that some things are provable, namely, ‘⊤’
non-emptyness : Σ (Type ε) (λ T → □ T)
non-emptyness = ‘⊤’ , ‘tt’


open import Prelude

module Implicits.Resolution.Stack.Algorithm where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Fin.Substitution
open import Data.Nat.Base using (_<′_)
open import Data.List.Any
open Membership-≡
open import Implicits.Syntax
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Implicits.Resolution.Stack.Resolution
open import Implicits.Resolution.Termination
open import Implicits.Syntax.Type.Unification
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Function.Equality hiding (cong; flip; const)
open import Data.List.Any.Properties using (Any↔)
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties
open import Relation.Binary using (module DecTotalOrder)
open DecTotalOrder decTotalOrder using () renaming (refl to ≤-refl)

module M = MetaTypeMetaSubst

module Lemmas where
  postulate lem₄ : ∀ {m ν} (a : MetaType m (suc ν)) u us → from-meta ((M.open-meta a) M./ (us M.↑) M./ (M.sub u)) ≡ (from-meta (a M./ (us M.↑tp))) tp[/tp from-meta u ]

open Lemmas

_s<'_ : ∀ {ν} → (∃ λ (Δ : ICtx ν) → Stack Δ) →  (∃ λ (Δ' : ICtx ν) → Stack Δ') → Set
s s<' t = {!!}

module Arg<-well-founded  where
  open Lexicographic (_s<_) (const _sρ<_)

  arg<-well-founded : Well-founded _<_
  arg<-well-founded = well-founded s<-well-founded sρ<-well-founded

  _arg<_ = _<_

open Lexicographic using (left; right)
open Arg<-well-founded

{-# NO_TERMINATION_CHECK #-}
mutual

  match' : ∀ {m ν ρ} (Δ : ICtx ν) s (r∈Δ : ρ List.∈ Δ) τ → (r : MetaType m ν) →
           Acc _arg<_ (s , (, simpl τ)) →
           Acc _m<_ (, , r) →
          Maybe (∃ λ u → Δ & s , r∈Δ ⊢ from-meta (r M./ u) ↓ τ)
  match' Δ s r∈Δ τ (simpl x) (acc f) _ with mgu (simpl x) τ
  match' Δ s r∈Δ τ (simpl x) (acc f) _ | just (u , p) =
    just (
      (asub u) ,
      subst (λ a → Δ & s , r∈Δ  ⊢ a ↓ τ) (sym $ mgu-unifies (simpl x) τ (u , p)) (i-simp τ)
    )
  match' Δ s r∈Δ τ (simpl x) (acc f) _ | nothing = nothing

  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) with match' Δ s r∈Δ τ b (acc f) (g _ (b-m<-a⇒b a b))
  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) | nothing = nothing
  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) with
    (from-meta (a M./ u)) for r∈Δ ?⊬dom s
  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | yes p
    with
      let a' = from-meta (a M./ u) in
        let s' = (s push a' for r∈Δ) in
          resolve' Δ s' a' (f (s' , _ , a') (left {!!}))
  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | yes p | just ⊢ᵣa = just (u , i-iabs p ⊢ᵣa b/u↓τ)
  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | yes p | nothing = nothing
  match' Δ s r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | no ¬p = nothing

  -- The following with clause fails to satisfy termination checking.
  -- Somehow we have to prove to Agda that (open-meta a) is structurally smaller than (∀' a)
  match' Δ s r∈Δ τ (∀' a) (acc f) (acc g) with
    match' Δ s r∈Δ τ (open-meta a) (acc f) (g _ (open-meta-a-m<-∀'a a))
  match' Δ s r∈Δ τ (∀' a) (acc f) (acc g) | just p = just $ lem p
    where
      lem : (∃ λ u → Δ & s , r∈Δ ⊢ (from-meta ((open-meta a) M./ u)) ↓ τ) →
          ∃ λ u' → Δ & s , r∈Δ ⊢ (from-meta (∀' a M./ u')) ↓ τ
      lem (u ∷ us , p) = us , (i-tabs (from-meta u) (subst (λ v → Δ & s , r∈Δ ⊢ v ↓ τ) (begin
            from-meta (M._/_ (open-meta a) (u ∷ us))
              ≡⟨ cong (λ v → from-meta (M._/_ (open-meta a) v)) (sym $ us↑-⊙-sub-u≡u∷us u us) ⟩
            from-meta ((open-meta a) M./ (us M.↑ M.⊙ (M.sub u)))
              ≡⟨ cong from-meta (/-⊙ (open-meta a)) ⟩
            from-meta ((open-meta a) M./ us M.↑ M./ (M.sub u))
              ≡⟨ lem₄ a u us ⟩
            from-meta (a M./ (us M.↑tp)) tp[/tp from-meta u ] ∎) p))
          where open MetaTypeMetaLemmas hiding (subst)
  match' Δ s r∈Δ τ (∀' r) (acc f) (acc g) | nothing = nothing

  -- match defers to match', which concerns itself with MetaTypes.
  -- If match' finds a match, we can use the fact that we have zero unification variables open here
  -- to show that we found the right thing.
  match : ∀ {ν ρ} (Δ : ICtx ν) s (r∈Δ : ρ List.∈ Δ) r τ → Acc _arg<_ (s , _ , simpl τ) →
          Maybe (Δ & s , r∈Δ ⊢ r ↓ τ)
  match Δ s r∈Δ a τ ac with match' Δ s r∈Δ τ (to-meta {zero} a) ac (m<-well-founded _)
  match Δ s r∈Δ a τ ac | just x = just (lem x)
    where
      eq : ∀ {ν} {a : Type ν} {s} → from-meta (to-meta {zero} a M./ s) ≡ a
      eq {a = a} {s = []} = begin
          from-meta (M._/_ (to-meta {zero} a) [])
          ≡⟨ cong (λ q → from-meta q) (MetaTypeMetaLemmas.id-vanishes (to-meta {zero} a)) ⟩
          from-meta (to-meta {zero} a)
          ≡⟨ to-meta-zero-vanishes ⟩
          a ∎
      lem : ∃ (λ u → Δ & s , r∈Δ ⊢ from-meta (to-meta {zero} a M./ u) ↓ τ) →
                Δ & s , r∈Δ ⊢ a ↓ τ
      lem ([] , proj₂) = subst (λ u → Δ & s , r∈Δ ⊢ u ↓ τ) eq proj₂
  match Δ s r∈Δ a τ ac | nothing = nothing

  match1st : ∀ {ν} (Δ : ICtx ν) (s : Stack Δ) τ → Acc _arg<_ (s , _ , simpl τ) →
             Maybe (∃₂ λ r (r∈Δ : r List.∈ Δ) → Δ & s , r∈Δ ⊢ r ↓ τ)
  match1st Δ s τ ac = match1st' Δ Δ Prelude.id s τ ac -- any (λ r → match Δ r τ)
    where
      match1st' : ∀ {ν} (Δ ρs : ICtx ν) → ρs ⊆ Δ → (s : Stack Δ) → (τ : SimpleType ν) →
                  Acc _arg<_ (s , _ , simpl τ) →
                  Maybe (∃₂ λ r (r∈Δ : r List.∈ Δ) → Δ & s , r∈Δ ⊢ r ↓ τ)
      match1st' Δ List.[] sub s τ ac = nothing
      match1st' Δ (x List.∷ xs) sub s τ ac with match Δ s (sub (here refl)) x τ ac
      match1st' Δ (x List.∷ xs) sub s τ ac | just px = just (x , ((sub (here refl)) , px))
      match1st' Δ (x List.∷ xs) sub s τ ac | nothing with
        match1st' Δ xs {!!} s τ ac
      match1st' Δ (x List.∷ xs) sub s τ ac | nothing | just p = just p
      match1st' Δ (x List.∷ xs) sub s τ ac | nothing | nothing = nothing

  resolve' : ∀ {ν} (Δ : ICtx ν) s r → Acc _arg<_ (s , _ , r) → (Maybe (Δ & s ⊢ᵣ r))
  resolve' Δ s (simpl x) ac with match1st Δ s x ac
  resolve' Δ s (simpl x) ac | just (_ , r∈Δ , r↓x) = just (r-simp r∈Δ r↓x)
  resolve' Δ s (simpl x) ac | nothing = nothing
    -- no (λ{ (r-simp x₁ x₂) → ¬p (_⟨$⟩_ (Inverse.to Any↔) (_ , (x₁ , x₂))) })
  resolve' Δ s (a ⇒ b) (acc f) with resolve' (a List.∷ Δ) (s prepend a) b {!f!}
  resolve' Δ s (a ⇒ b) (acc f) | just p = just (r-iabs p)
  resolve' Δ s (a ⇒ b) (acc f) | nothing = nothing -- no (λ{ (r-iabs x) → ¬p x })
  resolve' Δ s (∀' r) (acc f) with resolve' (ictx-weaken Δ) (stack-weaken s) r {!f ? ?!}
  resolve' Δ s (∀' r) (acc f) | just p = just (r-tabs p)
  resolve' Δ s (∀' r) (acc f) | nothing = nothing --no (λ{ (r-tabs x) → ¬p x })

  resolve : ∀ {ν} (Δ : ICtx ν) r → (Maybe (Δ ⊢ᵣ r))
  resolve Δ r = resolve' Δ (All.tabulate (const r)) r (arg<-well-founded _)


open import Data.Product using ( _×_ ; _,_ ; proj₁ ; proj₂ )
open import Data.Sum using ( inj₁ ; inj₂ )
open import Data.Unit using ( tt )
open import Relation.Binary.PropositionalEquality using ( refl )
open import Relation.Unary using ( _∈_ ; _⊆_ )
open import Web.Semantic.DL.ABox using
  ( ABox ; Assertions ; ε ; _,_ ; _∼_ ; _∈₁_ ; _∈₂_ )
open import Web.Semantic.DL.ABox.Interp using
  ( Interp ; _,_ ; ⌊_⌋ ; ind ; _*_ )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; _,_ ; ≲⌊_⌋ ; ≲-resp-ind ; _≋_ )
open import Web.Semantic.DL.ABox.Model using
  ( _⟦_⟧₀ ; _⊨a_ ; Assertions✓ )
open import Web.Semantic.DL.Concept using
  ( ⟨_⟩ ; ¬⟨_⟩ ; ⊤ ; ⊥ ; _⊓_ ; _⊔_ ; ∀[_]_ ; ∃⟨_⟩_ ; ≤1 ; >1 )
open import Web.Semantic.DL.Concept.Model using ( _⟦_⟧₁ ; ⟦⟧₁-resp-≈ )
open import Web.Semantic.DL.Integrity using
  ( Unique ; Mediator ; Initial ; _>>_ ; _⊕_⊨_ ; _,_ )
open import Web.Semantic.DL.KB using ( KB ; tbox ; abox )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Role using ( ⟨_⟩ ; ⟨_⟩⁻¹ )
open import Web.Semantic.DL.Role.Model using ( _⟦_⟧₂ ; ⟦⟧₂-resp-≈ )
open import Web.Semantic.DL.Sequent using
  ( Γ ; γ ; _⊕_⊢_∼_ ; _⊕_⊢_∈₁_ ; _⊕_⊢_∈₂_
  ; ∼-assert ; ∼-import ;∼-refl ; ∼-sym ; ∼-trans ; ∼-≤1
  ; ∈₂-assert ; ∈₂-import ; ∈₂-resp-∼ ; ∈₂-subsum
  ; ∈₂-refl ; ∈₂-trans ; ∈₂-inv-I ; ∈₂-inv-E
  ; ∈₁-assert ; ∈₁-import ; ∈₁-resp-∼ ; ∈₁-subsum
  ; ∈₁-⊤-I ; ∈₁-⊓-I ; ∈₁-⊓-E₁ ; ∈₁-⊓-E₂
  ; ∈₁-⊔-I₁ ; ∈₁-⊔-I₂ ; ∈₁-∃-I ; ∈₁-∀-E )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using
  ( TBox ; Axioms ; ε ; _,_ ;_⊑₁_ ; _⊑₂_ ; Tra )
open import Web.Semantic.DL.TBox.Interp using
  ( interp ; Δ ; _⊨_≈_ ; ≈-refl ; ≈-sym ; ≈-trans ; con-≈ ; rol-≈ ) renaming
  ( Interp to Interp′ )
open import Web.Semantic.DL.TBox.Interp.Morphism using
  ( morph ; ≲-image ; ≲-resp-≈ ; ≲-resp-con ; ≲-resp-rol )
open import Web.Semantic.DL.TBox.Minimizable using
  ( LHS ; RHS ; μTBox
  ; ⟨_⟩ ; ⊤ ; ⊥ ; _⊓_ ; _⊔_ ; ∀[_]_ ; ∃⟨_⟩_ ; ≤1
  ; ε ; _,_ ;_⊑₁_ ; _⊑₂_ ; Ref ; Tra )
open import Web.Semantic.DL.TBox.Model using ( _⊨t_ ; Axioms✓ )
open import Web.Semantic.Util using
  ( Subset ; ⊆-refl ; id ; _∘_ ; _⊕_⊕_ ; _[⊕]_[⊕]_ ; inode ; bnode ; enode )

module Web.Semantic.DL.Sequent.Model {Σ : Signature} {W X Y : Set} where

infix 5 _⊞_

minimal′ : Interp Σ X → KB Σ (X ⊕ W ⊕ Y) → Interp′ Σ
minimal′ I KB =
  interp (Γ I KB) (λ x y → (I ⊕ KB ⊢ x ∼ y)) ∼-refl ∼-sym ∼-trans
    (λ c x → I ⊕ KB ⊢ x ∈₁ ⟨ c ⟩) (λ r xy → I ⊕ KB ⊢ xy ∈₂ ⟨ r ⟩)
    (λ c → ∈₁-resp-∼) (λ r → ∈₂-resp-∼)

minimal : Interp Σ X → KB Σ (X ⊕ W ⊕ Y) → Interp Σ (X ⊕ W ⊕ Y)
minimal I KB = (minimal′ I KB , γ I KB)

complete₂ : ∀ I KB R {xy} → (xy ∈ minimal′ I KB ⟦ R ⟧₂) → (I ⊕ KB ⊢ xy ∈₂ R)
complete₂ I KB ⟨ r ⟩   {(x , y)} xy∈⟦r⟧ = xy∈⟦r⟧
complete₂ I KB ⟨ r ⟩⁻¹ {(x , y)} yx∈⟦r⟧ = ∈₂-inv-I yx∈⟦r⟧

complete₁ : ∀ I KB {C x} → (C ∈ LHS) → (x ∈ minimal′ I KB ⟦ C ⟧₁) →
  (I ⊕ KB ⊢ x ∈₁ C)
complete₁ I KB ⟨ c ⟩ x∈⟦c⟧ =
  x∈⟦c⟧
complete₁ I KB ⊤ _ =
  ∈₁-⊤-I
complete₁ I KB (C ⊓ D) (x∈⟦C⟧ , x∈⟦D⟧) =
  ∈₁-⊓-I (complete₁ I KB C x∈⟦C⟧) (complete₁ I KB D x∈⟦D⟧)
complete₁ I KB (C ⊔ D) (inj₁ x∈⟦C⟧) =
  ∈₁-⊔-I₁ (complete₁ I KB C x∈⟦C⟧)
complete₁ I KB (C ⊔ D) (inj₂ x∈⟦D⟧) =
  ∈₁-⊔-I₂ (complete₁ I KB D x∈⟦D⟧)
complete₁ I KB (∃⟨ R ⟩ C) (y , xy∈⟦R⟧ , y∈⟦C⟧) =
  ∈₁-∃-I (complete₂ I KB R xy∈⟦R⟧) (complete₁ I KB C y∈⟦C⟧)
complete₁ I KB ⊥ ()

sound₂ : ∀ I KB R {xy} → (I ⊕ KB ⊢ xy ∈₂ R) → (xy ∈ minimal′ I KB ⟦ R ⟧₂)
sound₂ I KB ⟨ r ⟩   {(x , y)} ⊢xy∈r  = ⊢xy∈r
sound₂ I KB ⟨ r ⟩⁻¹ {(x , y)} ⊢xy∈r⁻ = ∈₂-inv-E ⊢xy∈r⁻

sound₁ : ∀ I KB {C x} → (C ∈ RHS) → (I ⊕ KB ⊢ x ∈₁ C) →
  (x ∈ minimal′ I KB ⟦ C ⟧₁)
sound₁ I KB ⟨ c ⟩ ⊢x∈c =
  ⊢x∈c
sound₁ I KB ⊤ ⊢x∈⊤ =
  tt
sound₁ I KB (C ⊓ D) ⊢x∈C⊓D =
  (sound₁ I KB C (∈₁-⊓-E₁ ⊢x∈C⊓D) , sound₁ I KB D (∈₁-⊓-E₂ ⊢x∈C⊓D))
sound₁ I KB (∀[ R ] C) ⊢x∈∀RC = λ y xy∈⟦R⟧ →
  sound₁ I KB C (∈₁-∀-E ⊢x∈∀RC (complete₂ I KB R xy∈⟦R⟧))
sound₁ I KB (≤1 R) ⊢x∈≤1R = λ y z xy∈⟦R⟧ xz∈⟦R⟧ →
  ∼-≤1 ⊢x∈≤1R (complete₂ I KB R xy∈⟦R⟧) (complete₂ I KB R xz∈⟦R⟧)

minimal-⊨ : ∀ I KB → (tbox KB ∈ μTBox) → (minimal I KB ⊨ KB)
minimal-⊨ I KB μT =
  ( minimal-tbox μT (⊆-refl (Axioms (tbox KB)))
  , minimal-abox (abox KB) (⊆-refl (Assertions (abox KB)))) where

  minimal-tbox : ∀ {T} → (T ∈ μTBox) → (Axioms T ⊆ Axioms (tbox KB)) →
    minimal′ I KB ⊨t T
  minimal-tbox ε ε⊆T =
    tt
  minimal-tbox (U , V) UV⊆T =
    ( minimal-tbox U (λ u → UV⊆T (inj₁ u))
    , minimal-tbox V (λ v → UV⊆T (inj₂ v)) )
  minimal-tbox (C ⊑₁ D) C⊑₁D∈T = λ x∈⟦C⟧ →
    sound₁ I KB D (∈₁-subsum (complete₁ I KB C x∈⟦C⟧) (C⊑₁D∈T refl))
  minimal-tbox (Q ⊑₂ R) Q⊑₁R∈T = λ xy∈⟦Q⟧ →
    sound₂ I KB R (∈₂-subsum (complete₂ I KB Q xy∈⟦Q⟧) (Q⊑₁R∈T refl))
  minimal-tbox (Ref R) RefR∈T = λ x →
    sound₂ I KB R (∈₂-refl x (RefR∈T refl))
  minimal-tbox (Tra R) TraR∈T = λ xy∈⟦R⟧ yz∈⟦R⟧ →
    sound₂ I KB R (∈₂-trans
      (complete₂ I KB R xy∈⟦R⟧) (complete₂ I KB R yz∈⟦R⟧) (TraR∈T refl))

  minimal-abox : ∀ A → (Assertions A ⊆ Assertions (abox KB)) →
    minimal I KB ⊨a A
  minimal-abox ε ε⊆A =
    tt
  minimal-abox (B , C) BC⊆A =
    ( minimal-abox B (λ b → BC⊆A (inj₁ b))
    , minimal-abox C (λ c → BC⊆A (inj₂ c)) )
  minimal-abox (x ∼ y) x∼y⊆A =
    ∼-assert (x∼y⊆A refl)
  minimal-abox (x ∈₁ c) x∈C⊆A =
    sound₁ I KB ⟨ c ⟩ (∈₁-assert (x∈C⊆A refl))
  minimal-abox ((x , y) ∈₂ r) xy∈R⊆A =
    sound₂ I KB ⟨ r ⟩ (∈₂-assert (xy∈R⊆A refl))

minimal-≳ : ∀ I KB → (I ≲ inode * minimal I KB)
minimal-≳ I KB = (morph inode ∼-import ∈₁-import ∈₂-import , λ x → ∼-refl)

minimal-≲ : ∀ I KB J → (I ≲ inode * J) → (J ⊨ KB) → (minimal I KB ≲ J)
minimal-≲ I KB J I≲J (J⊨T , J⊨A) =
  (morph f minimal-≈ minimal-con minimal-rol , fγ≈j) where

    f : Γ I KB → Δ ⌊ J ⌋
    f = (≲-image ≲⌊ I≲J ⌋) [⊕] (ind J ∘ bnode) [⊕] (ind J ∘ enode)

    fγ≈j : ∀ x → ⌊ J ⌋ ⊨ f (γ I KB x) ≈ ind J x
    fγ≈j (inode x) = ≲-resp-ind I≲J x
    fγ≈j (bnode v) = ≈-refl ⌊ J ⌋
    fγ≈j (enode y) = ≈-refl ⌊ J ⌋

    mutual

      minimal-≈ : ∀ {x y} → (I ⊕ KB ⊢ x ∼ y) → (⌊ J ⌋ ⊨ f x ≈ f y)
      minimal-≈ (∼-assert x∼y∈A) =
        ≈-trans ⌊ J ⌋ (fγ≈j _)
          (≈-trans ⌊ J ⌋ (Assertions✓ J (abox KB) x∼y∈A J⊨A)
            (≈-sym ⌊ J ⌋ (fγ≈j _)))
      minimal-≈ (∼-import x≈y) =
        ≲-resp-≈ ≲⌊ I≲J ⌋ x≈y
      minimal-≈ ∼-refl =
        ≈-refl ⌊ J ⌋
      minimal-≈ (∼-sym x∼y) =
        ≈-sym ⌊ J ⌋ (minimal-≈ x∼y)
      minimal-≈ (∼-trans x∼y y∼z) =
        ≈-trans ⌊ J ⌋ (minimal-≈ x∼y) (minimal-≈ y∼z)
      minimal-≈ (∼-≤1 x∈≤1R xy∈R xz∈R) =
        minimal-con x∈≤1R _ _ (minimal-rol xy∈R) (minimal-rol xz∈R)

      minimal-con : ∀ {x C} → (I ⊕ KB ⊢ x ∈₁ C) → (f x ∈ ⌊ J ⌋ ⟦ C ⟧₁)
      minimal-con (∈₁-assert x∈c∈A) =
        con-≈ ⌊ J ⌋ _ (Assertions✓ J (abox KB) x∈c∈A J⊨A)
          (≈-sym ⌊ J ⌋ (fγ≈j _))
      minimal-con (∈₁-import x∈⟦c⟧) =
        ≲-resp-con ≲⌊ I≲J ⌋ x∈⟦c⟧
      minimal-con {x} {C} (∈₁-resp-∼ x∈C x∼y) =
        ⟦⟧₁-resp-≈ ⌊ J ⌋ C (minimal-con x∈C) (minimal-≈ x∼y)
      minimal-con (∈₁-subsum x∈C C⊑D∈T) =
        Axioms✓ ⌊ J ⌋ (tbox KB) C⊑D∈T J⊨T (minimal-con x∈C)
      minimal-con ∈₁-⊤-I =
        tt
      minimal-con (∈₁-⊓-I x∈C x∈D) =
        (minimal-con x∈C , minimal-con x∈D)
      minimal-con (∈₁-⊓-E₁ x∈C⊓D) =
        proj₁ (minimal-con x∈C⊓D)
      minimal-con (∈₁-⊓-E₂ x∈C⊓D) =
        proj₂ (minimal-con x∈C⊓D)
      minimal-con (∈₁-⊔-I₁ x∈C) =
        inj₁ (minimal-con x∈C)
      minimal-con (∈₁-⊔-I₂ x∈D) =
        inj₂ (minimal-con x∈D)
      minimal-con (∈₁-∀-E x∈[R]C xy∈R) =
        minimal-con x∈[R]C _ (minimal-rol xy∈R)
      minimal-con (∈₁-∃-I xy∈R y∈C) =
        (_ , minimal-rol xy∈R , minimal-con y∈C)

      minimal-rol : ∀ {x y R} → (I ⊕ KB ⊢ (x , y) ∈₂ R) →
        ((f x , f y) ∈ ⌊ J ⌋ ⟦ R ⟧₂)
      minimal-rol (∈₂-assert xy∈r∈A) =
        rol-≈ ⌊ J ⌋ _ (fγ≈j _) (Assertions✓ J (abox KB) xy∈r∈A J⊨A)
          (≈-sym ⌊ J ⌋ (fγ≈j _))
      minimal-rol (∈₂-import xy∈⟦r⟧) =
        ≲-resp-rol ≲⌊ I≲J ⌋ xy∈⟦r⟧
      minimal-rol {x} {y} {R} (∈₂-resp-∼ w∼x xy∈R y∼z) =
        ⟦⟧₂-resp-≈ ⌊ J ⌋ R (minimal-≈ w∼x) (minimal-rol xy∈R) (minimal-≈ y∼z)
      minimal-rol (∈₂-subsum xy∈Q Q⊑R∈T) =
        Axioms✓ ⌊ J ⌋ (tbox KB) Q⊑R∈T J⊨T (minimal-rol xy∈Q)
      minimal-rol (∈₂-refl x RefR∈T) =
        Axioms✓ ⌊ J ⌋ (tbox KB) RefR∈T J⊨T _
      minimal-rol (∈₂-trans xy∈R yz∈R TraR∈T) =
        Axioms✓ ⌊ J ⌋ (tbox KB) TraR∈T J⊨T
          (minimal-rol xy∈R) (minimal-rol yz∈R)
      minimal-rol (∈₂-inv-I xy∈r) =
        minimal-rol xy∈r
      minimal-rol (∈₂-inv-E xy∈r⁻) =
        minimal-rol xy∈r⁻

minimal-≋ : ∀ I KB K I≲K K⊨KB →
  (I≲K ≋ minimal-≳ I KB >> minimal-≲ I KB K I≲K K⊨KB)
minimal-≋ I KB K I≲K (K⊨T , K⊨A) = λ x → ≈-refl ⌊ K ⌋

minimal-uniq : ∀ I KB K I≲K →
  Unique I (minimal I KB) K (minimal-≳ I KB) I≲K
minimal-uniq I KB K I≲K J≲₁K J≲₂K I≲K≋I≲J≲₁K I≲K≋I≲J≲₂K (inode x) =
  ≈-trans ⌊ K ⌋ (≈-sym ⌊ K ⌋ (I≲K≋I≲J≲₁K x)) (I≲K≋I≲J≲₂K x)
minimal-uniq I KB K I≲K J≲₁K J≲₂K I≲K≋I≲J≲₁K I≲K≋I≲J≲₂K (bnode v) =
  ≈-trans ⌊ K ⌋ (≲-resp-ind J≲₁K (bnode v))
    (≈-sym ⌊ K ⌋ (≲-resp-ind J≲₂K (bnode v)))
minimal-uniq I KB K I≲K J≲₁K J≲₂K I≲K≋I≲J≲₁K I≲K≋I≲J≲₂K (enode y) =
  ≈-trans ⌊ K ⌋ (≲-resp-ind J≲₁K (enode y))
    (≈-sym ⌊ K ⌋ (≲-resp-ind J≲₂K (enode y)))

minimal-med : ∀ I KB → Mediator I (minimal I KB) (minimal-≳ I KB) KB
minimal-med I KB K I≲K K⊨KB =
  ( minimal-≲ I KB K I≲K K⊨KB
  , minimal-≋ I KB K I≲K K⊨KB
  , minimal-uniq I KB K I≲K)

minimal-init : ∀ I KB → (tbox KB ∈ μTBox) → Initial I KB (minimal I KB)
minimal-init I KB μKB =
  (minimal-≳ I KB
  , minimal-⊨ I KB μKB
  , minimal-med I KB)

_⊞_ : Interp Σ X → KB Σ (X ⊕ W ⊕ Y) → Interp Σ Y
I ⊞ KB = enode * minimal I KB

⊞-sound : ∀ I KB₁ KB₂ → (tbox KB₁ ∈ μTBox) → (I ⊞ KB₁ ⊨ KB₂) → (I ⊕ KB₁ ⊨ KB₂)
⊞-sound I KB₁ KB₂ μKB₁ ⊨KB₂ = (minimal I KB₁ , minimal-init I KB₁ μKB₁ , ⊨KB₂)


{-# OPTIONS --safe #-}

open import Generics.Prelude
open import Generics.Telescope
open import Generics.Desc
open import Generics.Mu
open import Generics.Mu.All

open import Data.Fin.Properties as Fin
open import Data.Product.Properties
open import Data.Empty
open import Relation.Nullary

module Generics.Mu.NoConfusion {P I n} {D : DataDesc P I n} where

private
  variable
    V : ExTele P
    p : ⟦ P ⟧tel tt
    v : ⟦ V ⟧tel p
    i : ⟦ I ⟧tel p

NoConfusionCon : (C : ConDesc P V I)
               → ⟦ C ⟧Conω (μ D) (p , v , i)
               → ⟦ C ⟧Conω (μ D) (p , v , i)
               → Setω
NoConfusionCon (var f) _ _ = ⊤ω
NoConfusionCon (π ai S C) (s₁ , x) (s₂ , y) =
  Σω (s₁ ≡ s₂) {!!}
NoConfusionCon (A ⊗ B) x y = {!!}

{-

module NoConfusion {P} {I : ExTele P} {n ℓ} (D : DataDesc P I ℓ n) where

  NoConfusionIndArg : ∀ {ℓ} (C : ConDesc P V I ℓ) {ℓ₂} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ₂)}
                    → ∀ {pv} → (x y : ⟦ C ⟧IndArg ℓ₂ X pv) → Set (ℓ ⊔ ℓ₂)

  NoConfusionIndArgᵇ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} (e : ℓ₁ ≡ ℓ₂ ⊔ ℓ₃) (i : ArgInfo)
                       {X : ⟦ P , I ⟧xtel → Set (ℓ₃ ⊔ ℓ₄)}
                       (S : ⟦ P , V ⟧xtel → Set ℓ₂)
                       (C : ConDesc P (V ⊢< i > S) I ℓ₃)
                     → ∀ {pv} (x y : IndArgᵇ ℓ₄ e i X S C pv) → Set (ℓ₁ ⊔ ℓ₄)

  NoConfusionIndArg (var i) x y = x ≡ y
  NoConfusionIndArg (A ⊗ B) (xa , xb) (ya , yb) = NoConfusionIndArg A xa ya × NoConfusionIndArg B xb yb
  NoConfusionIndArg (π p i S C) x y = NoConfusionIndArgᵇ p i S C x y

  NoConfusionIndArgᵇ refl i S C {pv} x y = x ≡ y

  NoConfusionConᵇ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} (e : ℓ₁ ≡ ℓ₂ ⊔ ℓ₃) (i : ArgInfo)
                       {X : ⟦ P , I ⟧xtel → Set (ℓ₃ ⊔ ℓ₄)}
                       (S : ⟦ P , V ⟧xtel → Set ℓ₂)
                       (C : ConDesc P (V ⊢< i > S) I ℓ₃)
                     → ∀ {pvi} (x y : Conᵇ ℓ₄ e i X S C pvi) → Set (ℓ₁ ⊔ ℓ₄)

  NoConfusionCon (var i) x y = Lift _ ⊤
  NoConfusionCon (π p i S C) x y = NoConfusionConᵇ p i S C x y
  NoConfusionCon (A ⊗ B) (xa , xb) (ya , yb) = NoConfusionIndArg A xa ya × NoConfusionCon B xb yb

  NoConfusionConᵇ refl i S C (xs , xd) (ys , yd) = Σ (xs ≡ ys) λ { refl → NoConfusionCon C xd yd }

  NoConf : ∀ {ℓ′} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ′)}
         → ∀ {pi} (x y : ⟦ D ⟧Data ℓ′ X pi) → Set (ℓ ⊔ ℓ′)
  NoConf (kx , x) (ky , y) with kx Fin.≟ ky
  ... | yes refl = NoConfusionCon (lookupCon D kx) x y
  ... | no _     = Lift _ ⊥

  noConfIndArg-refl : ∀ {ℓ} (C : ConDesc P V I ℓ) {ℓ₂} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ₂)}
                    → ∀ {pvi} → (x : ⟦ C ⟧IndArg ℓ₂ X pvi) → NoConfusionIndArg C x x

  noConfIndArgᵇ-refl : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} (e : ℓ₁ ≡ ℓ₂ ⊔ ℓ₃) (i : ArgInfo)
                       {X : ⟦ P , I ⟧xtel → Set (ℓ₃ ⊔ ℓ₄)}
                       (S : ⟦ P , V ⟧xtel → Set ℓ₂)
                       (C : ConDesc P (V ⊢< i > S) I ℓ₃)
                     → ∀ {pvi} (x : IndArgᵇ ℓ₄ e i X S C pvi) → NoConfusionIndArgᵇ e i S C x x

  noConfIndArg-refl (var i) x = refl
  noConfIndArg-refl (A ⊗ B) (xa , xb) = noConfIndArg-refl A xa , noConfIndArg-refl B xb
  noConfIndArg-refl (π p i S C) x = noConfIndArgᵇ-refl p i S C x

  noConfIndArgᵇ-refl refl i S C x = refl

  noConfCon-refl : ∀ {ℓ} (C : ConDesc P V I ℓ) {ℓ₂} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ₂)}
                    → ∀ {pvi} → (x : ⟦_⟧Con C ℓ₂ X pvi) → NoConfusionCon C x x

  noConfConᵇ-refl : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} (e : ℓ₁ ≡ ℓ₂ ⊔ ℓ₃) (i : ArgInfo)
                    {X : ⟦ P , I ⟧xtel → Set (ℓ₃ ⊔ ℓ₄)}
                    (S : ⟦ P , V ⟧xtel → Set ℓ₂)
                    (C : ConDesc P (V ⊢< i > S) I ℓ₃)
                  → ∀ {pvi} (x : Conᵇ ℓ₄ e i X S C pvi) → NoConfusionConᵇ e i S C x x

  noConfCon-refl (var i) x = lift tt
  noConfCon-refl (A ⊗ B) (xa , xb) = noConfIndArg-refl A xa , noConfCon-refl B xb
  noConfCon-refl (π p i S C) x = noConfConᵇ-refl p i S C x

  noConfConᵇ-refl refl i S C (_ , x) = refl , noConfCon-refl C x

  noConfIndArg : ∀ {ℓ} (C : ConDesc P V I ℓ) {ℓ₂} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ₂)}
               → ∀ {pvi} {x y : ⟦ C ⟧IndArg ℓ₂ X pvi} → NoConfusionIndArg C x y → x ≡ y

  noConfIndArgᵇ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} (e : ℓ₁ ≡ ℓ₂ ⊔ ℓ₃) (i : ArgInfo)
                  {X : ⟦ P , I ⟧xtel → Set (ℓ₃ ⊔ ℓ₄)}
                  (S : ⟦ P , V ⟧xtel → Set ℓ₂)
                  (C : ConDesc P (V ⊢< i > S) I ℓ₃)
                → ∀ {pvi} {x y : IndArgᵇ ℓ₄ e i X S C pvi} → NoConfusionIndArgᵇ e i S C x y → x ≡ y

  noConfIndArg (var i) nc = nc
  noConfIndArg (A ⊗ B) (nca , ncb) = cong₂ _,_ (noConfIndArg A nca) (noConfIndArg B ncb)
  noConfIndArg (π p i S C) nc = noConfIndArgᵇ p i S C nc

  noConfIndArgᵇ refl i S C nc = nc

  noConfCon : ∀ {ℓ} (C : ConDesc P V I ℓ) {ℓ₂} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ₂)}
            → ∀ {pvi} → {x y : ⟦_⟧Con C ℓ₂ X pvi} → NoConfusionCon C x y → x ≡ y

  noConfConᵇ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} (e : ℓ₁ ≡ ℓ₂ ⊔ ℓ₃) (i : ArgInfo)
               {X : ⟦ P , I ⟧xtel → Set (ℓ₃ ⊔ ℓ₄)}
               (S : ⟦ P , V ⟧xtel → Set ℓ₂)
               (C : ConDesc P (V ⊢< i > S) I ℓ₃)
             → ∀ {pvi} {x y : Conᵇ ℓ₄ e i X S C pvi} → NoConfusionConᵇ e i S C x y → x ≡ y

  noConfCon (var i) {x = lift refl} {lift refl} nc = refl
  noConfCon (A ⊗ B) (nca , ncb) = cong₂ _,_ (noConfIndArg A nca) (noConfCon B ncb)
  noConfCon (π p i S C) nc = noConfConᵇ p i S C nc

  noConfConᵇ refl i S C (refl , nc) = cong (_ ,_) (noConfCon C nc)

  noConf : ∀ {ℓ′} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ′)}
         → ∀ {pi} {x y : ⟦ D ⟧Data ℓ′ X pi} → x ≡ y → NoConf x y
  noConf {x = kx , x} {ky , _} refl with kx Fin.≟ ky
  ... | yes refl = noConfCon-refl (lookupCon D kx) x
  ... | no kx≢kx = lift (kx≢kx refl)

  noConf₂ : ∀ {ℓ′} {X : ⟦ P , I ⟧xtel → Set (ℓ ⊔ ℓ′)}
          → ∀ {pi} {x y : ⟦ D ⟧Data ℓ′ X pi} → NoConf x y → x ≡ y
  noConf₂ {x = kx , x} {ky , y} nc with kx Fin.≟ ky
  ... | yes refl = cong (kx ,_) (noConfCon (lookupCon D kx) nc)
  ... | no kx≢ky = ⊥-elim (Lift.lower nc)

-}


module Tactic.Nat.Subtract.By where

open import Prelude hiding (abs)
open import Builtin.Reflection
open import Tactic.Reflection.Quote
open import Tactic.Reflection.DeBruijn
open import Tactic.Reflection.Substitute
open import Tactic.Reflection
open import Control.Monad.State

open import Tactic.Nat.Reflect
open import Tactic.Nat.NF
open import Tactic.Nat.Exp
open import Tactic.Nat.Auto
open import Tactic.Nat.Auto.Lemmas
open import Tactic.Nat.Simpl.Lemmas
open import Tactic.Nat.Simpl
open import Tactic.Nat.Refute
open import Tactic.Nat.Reflect

open import Tactic.Nat.Subtract.Exp
open import Tactic.Nat.Subtract.Reflect
open import Tactic.Nat.Subtract.Lemmas
open import Tactic.Nat.Less.Lemmas

private
  NFGoal : (R₁ R₂ : Nat → Nat → Set) (a b c d : SubNF) → Env Var → Set
  NFGoal _R₁_ _R₂_ a b c d ρ = ⟦ a ⟧ns (atomEnvS ρ) R₁ ⟦ b ⟧ns (atomEnvS ρ) → ⟦ c ⟧ns (atomEnvS ρ) R₂ ⟦ d ⟧ns (atomEnvS ρ)

  follows-diff-prf : {a b c d : Nat} → a ≤ b → b < c → c ≤ d → d ≡ suc (d - suc a) + a
  follows-diff-prf {a} (diff! i) (diff! j) (diff! k) =
    sym $ (λ z → suc z + a) $≡ lem-sub-zero (k + suc (j + (i + a))) (suc a) (i + j + k) auto ʳ⟨≡⟩
          auto

  decide-leq : ∀ u v ρ → Maybe (⟦ u ⟧ns (atomEnvS ρ) ≤ ⟦ v ⟧ns (atomEnvS ρ))
  decide-leq u v ρ with cancel u v | λ a b → cancel-sound-s′ a b u v (atomEnvS ρ)
  ... | [] , d | sound =
    let eval x = ⟦ x ⟧ns (atomEnvS ρ) in
    just (diff (eval d) $ sym (sound (suc (eval d)) 1 auto))
  ... | _  , _ | _     = nothing

  by-proof-less-nf : ∀ u u₁ v v₁ ρ → Maybe (NFGoal _<_ _<_ u u₁ v v₁ ρ)
  by-proof-less-nf u u₁ v v₁ ρ = do
    v≤u   ← decide-leq v  u  ρ
    u₁≤v₁ ← decide-leq u₁ v₁ ρ
    pure λ u<u₁ →
         diff (⟦ v₁ ⟧ns (atomEnvS ρ) - suc (⟦ v ⟧ns (atomEnvS ρ)))
              (follows-diff-prf v≤u u<u₁ u₁≤v₁)

  by-proof-less : ∀ a a₁ b b₁ ρ → Maybe (SubExpLess a a₁ ρ → SubExpLess b b₁ ρ)
  by-proof-less a a₁ b b₁ ρ with cancel (normSub a) (normSub a₁)
                               | cancel (normSub b) (normSub b₁)
                               | complicateSubLess a a₁ ρ
                               | simplifySubLess b b₁ ρ
  ... | u , u₁ | v , v₁ | compl | simpl = do
    prf ← by-proof-less-nf u u₁ v v₁ ρ
    pure (simpl ∘ prf ∘ compl)

  lem-plus-zero-r : (a b : Nat) → a + b ≡ 0 → b ≡ 0
  lem-plus-zero-r  zero   b eq = eq
  lem-plus-zero-r (suc a) b ()

  lem-leq-zero : {a b : Nat} → a ≤ b → b ≡ 0 → a ≡ 0
  lem-leq-zero (diff k eq) refl = lem-plus-zero-r k _ (follows-from (sym eq))

  ⟨+⟩-sound-ns : ∀ {Atom} {{_ : Ord Atom}} u v (ρ : Env Atom) → ⟦ u +nf v ⟧ns ρ ≡ ⟦ u ⟧ns ρ + ⟦ v ⟧ns ρ
  ⟨+⟩-sound-ns u v ρ =
    ns-sound (u +nf v) ρ ⟨≡⟩
    ⟨+⟩-sound u v ρ ⟨≡⟩ʳ
    _+_ $≡ ns-sound u ρ *≡ ns-sound v ρ

  by-proof-eq-nf : Nat → ∀ u u₁ v v₁ ρ → Maybe (NFGoal _≡_ _≡_ u u₁ v v₁ ρ)

  by-proof-eq-sub : Nat → ∀ u u₁ v v₁ v₂ ρ → Maybe (NFGoal _≡_ _≡_ u u₁ [ 1 , [ v ⟨-⟩ v₁ ] ] v₂ ρ)
  by-proof-eq-sub n u u₁ v v₁ v₂ ρ = do
    let eval  x = ⟦ x ⟧ns (atomEnvS ρ)
        evals x = ⟦ x ⟧sns ρ
    prf ← by-proof-eq-nf n u u₁ v (v₁ +nf v₂) ρ
    pure (λ u=u₁ →
      sym $ lem-sub-zero (evals v) (evals v₁) (eval v₂) $ sym $
        lem-eval-sns-ns v ρ ⟨≡⟩
        prf u=u₁ ⟨≡⟩
        ⟨+⟩-sound-ns v₁ v₂ (atomEnvS ρ) ⟨≡⟩ʳ
        (_+ eval v₂) $≡ (lem-eval-sns-ns v₁ ρ))

  by-proof-eq-sub₂ : Nat → ∀ u u₁ v v₁ v₂ v₃ ρ → Maybe (NFGoal _≡_ _≡_ u u₁ [ 1 , [ v ⟨-⟩ v₁ ] ] [ 1 , [ v₂ ⟨-⟩ v₃ ] ] ρ)
  by-proof-eq-sub₂ n u u₁ v v₁ v₂ v₃ ρ = do
    let eval  x = ⟦ x ⟧ns (atomEnvS ρ)
        evals x = ⟦ x ⟧sns ρ
    prf ← by-proof-eq-nf n u u₁ (v₃ +nf v) (v₂ +nf v₁) ρ
    pure λ u=u₁ →
      lem-sub (evals v₂) (evals v₃) (evals v) (evals v₁) $
        _+_ $≡ lem-eval-sns-ns v₃ ρ *≡ lem-eval-sns-ns v ρ ⟨≡⟩
        ⟨+⟩-sound-ns v₃ v (atomEnvS ρ) ʳ⟨≡⟩
        prf u=u₁ ⟨≡⟩ ⟨+⟩-sound-ns v₂ v₁ (atomEnvS ρ) ⟨≡⟩ʳ
        _+_ $≡ lem-eval-sns-ns v₂ ρ *≡ lem-eval-sns-ns v₁ ρ

  -- More advanced tactics for equalities
  --   a + b ≡ 0 → a ≡ 0
  by-proof-eq-adv : Nat → ∀ u u₁ v v₁ ρ → Maybe (NFGoal _≡_ _≡_ u u₁ v v₁ ρ)
  by-proof-eq-adv _ u  [] v  [] ρ = do leq ← decide-leq v  u  ρ; pure (lem-leq-zero leq)
  by-proof-eq-adv _ [] u₁ v  [] ρ = do leq ← decide-leq v  u₁ ρ; pure (lem-leq-zero leq ∘ sym)
  by-proof-eq-adv _ u  [] [] v₁ ρ = do leq ← decide-leq v₁ u  ρ; pure (sym ∘ lem-leq-zero leq)
  by-proof-eq-adv _ [] u₁ [] v₁ ρ = do leq ← decide-leq v₁ u₁ ρ; pure (sym ∘ lem-leq-zero leq ∘ sym)
  by-proof-eq-adv (suc n) u  u₁ [ 1 , [ v ⟨-⟩ v₁ ] ] [ 1 , [ v₂ ⟨-⟩ v₃ ] ] ρ = by-proof-eq-sub₂ n u u₁ v v₁ v₂ v₃ ρ
  by-proof-eq-adv n u  u₁ [ 1 , [ v ⟨-⟩ v₁ ] ] v₂ ρ = by-proof-eq-sub n u u₁ v v₁ v₂ ρ
  by-proof-eq-adv (suc n) u u₁ v₂ [ 1 , [ v ⟨-⟩ v₁ ] ] ρ = do
    prf ← by-proof-eq-sub n u u₁ v v₁ v₂ ρ
    pure (sym ∘ prf)
  by-proof-eq-adv _ u  u₁ v  v₁ ρ = nothing

  by-proof-eq-nf n u u₁  v  v₁ ρ with u == v | u₁ == v₁
  by-proof-eq-nf n u u₁ .u .u₁ ρ | yes refl | yes refl = just id
  ... | _ | _ with u == v₁ | u₁ == v -- try sym
  by-proof-eq-nf n u u₁ .u₁ .u ρ | _ | _ | yes refl | yes refl = just sym
  ... | _ | _ = by-proof-eq-adv n u u₁ v v₁ ρ -- try advanced stuff

  by-proof-eq : ∀ a a₁ b b₁ ρ → Maybe (SubExpEq a a₁ ρ → SubExpEq b b₁ ρ)
  by-proof-eq a a₁ b b₁ ρ with cancel (normSub a) (normSub a₁)
                             | cancel (normSub b) (normSub b₁)
                             | complicateSubEq a a₁ ρ
                             | simplifySubEq b b₁ ρ
  ... | u , u₁ |  v ,  v₁ | compl | simpl = do
    prf ← by-proof-eq-nf 10 u u₁ v v₁ ρ
    pure (simpl ∘ prf ∘ compl)

  not-less-zero′ : {n : Nat} → n < 0 → ⊥
  not-less-zero′ (diff _ ())

  not-less-zero : {A : Set} {n : Nat} → n < 0 → A
  not-less-zero n<0 = ⊥-elim (erase-⊥ (not-less-zero′ n<0))

  less-one-is-zero : {n : Nat} → n < 1 → n ≡ 0
  less-one-is-zero {zero} _ = refl
  less-one-is-zero {suc n} (diff k eq) = refute eq

  by-proof-less-eq-nf : ∀ u u₁ v v₁ ρ → Maybe (NFGoal _<_ _≡_ u u₁ v v₁ ρ)
  by-proof-less-eq-nf u [] v v₁ ρ = just not-less-zero  -- could've used refute, but we'll take it
  by-proof-less-eq-nf u [ 1 , [] ] v v₁ ρ = do
    prf ← by-proof-eq-nf 10 u [] v v₁ ρ
    pure (prf ∘ less-one-is-zero)
  by-proof-less-eq-nf u u₁ v v₁ ρ = nothing

  by-proof-less-eq : ∀ a a₁ b b₁ ρ → Maybe (SubExpLess a a₁ ρ → SubExpEq b b₁ ρ)
  by-proof-less-eq a a₁ b b₁ ρ with cancel (normSub a) (normSub a₁)
                                  | cancel (normSub b) (normSub b₁)
                                  | complicateSubLess a a₁ ρ
                                  | simplifySubEq b b₁ ρ
  ... | u , u₁ | v , v₁ | compl | simpl = do
    prf ← by-proof-less-eq-nf u u₁ v v₁ ρ
    pure (simpl ∘ prf ∘ compl)

  by-proof : ∀ hyp goal ρ → Maybe (⟦ hyp ⟧eqn ρ → ⟦ goal ⟧eqn ρ)
  by-proof (a :≡ a₁) (b :≡ b₁) ρ = by-proof-eq a a₁ b b₁ ρ
  by-proof (a :< a₁) (b :≡ b₁) ρ = by-proof-less-eq a a₁ b b₁ ρ
  by-proof (a :< a₁) (b :< b₁) ρ = by-proof-less a a₁ b b₁ ρ
  by-proof (a :≡ a₁) (b :< b₁) ρ = do
    prf ← by-proof-less a (lit 1 ⟨+⟩ a₁) b b₁ ρ
    pure λ eq → prf (diff 0 (cong suc (sym eq)))

by-tactic : Term → Type → TC Term
by-tactic prf g = do
  ensureNoMetas prf
  h ← inferNormalisedType prf
  let t = pi (vArg h) (abs "_" (weaken 1 g))
  just (hyp ∷ goal ∷ [] , Γ) ← termToSubHyps t
    where _ → typeError $ strErr "Invalid goal:" ∷ termErr t ∷ []
  pure $
    applyTerm (safe
      (getProof (quote cantProve) t $
       def (quote by-proof)
           ( vArg (` hyp)
           ∷ vArg (` goal)
           ∷ vArg (quotedEnv Γ)
           ∷ [])) _) (vArg prf ∷ [])