------------------------------------------------------------------------
-- Some counterexamples
------------------------------------------------------------------------

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

module Bisimilarity.Up-to.Counterexamples where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude
open import Prelude.Size

open import Bijection equality-with-J using (_↔_)
open import Equality.Decision-procedures equality-with-J
open import Fin equality-with-J
open import Function-universe equality-with-J hiding (id; _∘_)
open import Surjection equality-with-J using (_↠_)

open import Indexed-container using (Container; ν; ⟦_⟧; force)
open import Labelled-transition-system
import Up-to

import Bisimilarity
import Bisimilarity.Classical
open import Bisimilarity.Comparison
import Bisimilarity.Equational-reasoning-instances
import Bisimilarity.Step
import Bisimilarity.Up-to
open import Equational-reasoning
open import Relation

private

  -- A combination of some parametrised modules.

  module Combination {ℓ} (lts : LTS ℓ) where

    open Bisimilarity lts public
    open Bisimilarity.Classical lts public using (Progression)
    open Bisimilarity.Up-to lts public
    open LTS lts public hiding (_[_]⟶_)

    private
      module S =
        Bisimilarity.Step lts (LTS._[_]⟶_ lts) (LTS._[_]⟶_ lts)

    open S public using (Step; Step↔StepC) hiding (module Step)

    module Step where
      open S public using (⟨_,_⟩)
      open S.Step public

-- There is a size-preserving relation transformer that is neither
-- monotone nor extensive.

∃size-preserving×¬[monotone⊎extensive] :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ∃ λ (F : Trans₂ (# 0) Proc) →
      Size-preserving F × ¬ (Monotone F ⊎ Extensive F)
∃size-preserving×¬[monotone⊎extensive] =
  one-loop , F , F-pres , [ ¬-F-mono , ¬-F-extensive ]
  where
  open Combination one-loop

  F : Trans₂ (# 0) Proc
  F R = ¬_ ∘ R

  ¬-F-mono : ¬ Monotone F
  ¬-F-mono =
    Monotone F                                                   ↝⟨ (λ mono → mono {_}) ⟩
    ((λ _ → ⊥) ⊆ (λ _ → ↑ _ ⊤) → F (λ _ → ⊥) ⊆ F (λ _ → ↑ _ ⊤))  ↔⟨⟩
    ((λ _ → ⊥) ⊆ (λ _ → ↑ _ ⊤) → (λ _ → ¬ ⊥) ⊆ (λ _ → ¬ ↑ _ ⊤))  ↝⟨ _$ _ ⟩
    (λ _ → ¬ ⊥) ⊆ (λ _ → ¬ ↑ _ ⊤)                                ↝⟨ (λ hyp → hyp {tt}) ⟩
    (¬ ⊥ → ¬ ↑ _ ⊤)                                              ↝⟨ _$ ⊥-elim ⟩
    ¬ ↑ _ ⊤                                                      ↝⟨ _$ _ ⟩□
    ⊥                                                            □

  ¬-F-extensive : ¬ Extensive F
  ¬-F-extensive =
    Extensive F        ↝⟨ (λ hyp → hyp _) ⟩
    (↑ _ ⊤ → ¬ ↑ _ ⊤)  ↝⟨ (_$ _) ∘ (_$ _) ⟩□
    ⊥                  □

  total : ∀ {i x y} → [ i ] x ∼ y
  total = reflexive

  F-pres : Size-preserving F
  F-pres _ _ = total

-- A slight strengthening of the previous result, with a somewhat more
-- complicated proof: There are (at least two) size-preserving
-- relation transformers that are neither monotone nor extensive.

∃-2-size-preserving×¬[monotone⊎extensive] :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ∃ λ (F : Trans₂ (# 0) Proc) →
  ∃ λ (G : Trans₂ (# 0) Proc) →
    Size-preserving F × ¬ (Monotone F ⊎ Extensive F) ×
    Size-preserving G × ¬ (Monotone G ⊎ Extensive G) ×
    F ≢ G
∃-2-size-preserving×¬[monotone⊎extensive] =
    lts
  , F ⊤ , F ⊥
  , F-pres , [ ¬-F-mono , ¬-F-extensive ]
  , F-pres , [ ¬-F-mono , ¬-F-extensive ]
  , F⊤≢F⊥
  where
  lts : LTS lzero
  lts = record
    { Proc      = Bool
    ; Label     = ⊥
    ; _[_]⟶_    = λ _ ()
    ; is-silent = λ ()
    }

  open Combination lts

  F : Type → Trans₂ (# 0) Bool
  F A R p@(true  , false) = R p × A
  F A R p@(false , true)  = R p
  F A R p                 = ¬ R p

  ¬-F-mono : ∀ {A} → ¬ Monotone (F A)
  ¬-F-mono {A} =
    Monotone (F A)                                                   ↝⟨ (λ mono → mono {_}) ⟩
    ((λ _ → ⊥) ⊆ (λ _ → ↑ _ ⊤) → F A (λ _ → ⊥) ⊆ F A (λ _ → ↑ _ ⊤))  ↝⟨ (λ hyp {p} → hyp _ {p}) ⟩
    F A (λ _ → ⊥) ⊆ F A (λ _ → ↑ _ ⊤)                                ↝⟨ (λ hyp → hyp {true , true}) ⟩
    (¬ ⊥ → ¬ ↑ _ ⊤)                                                  ↝⟨ _$ ⊥-elim ⟩
    ¬ ↑ _ ⊤                                                          ↝⟨ _$ _ ⟩□
    ⊥                                                                □

  ¬-F-extensive : ∀ {A} → ¬ Extensive (F A)
  ¬-F-extensive {A} =
    Extensive (F A)    ↝⟨ (λ hyp → hyp (λ _ → ↑ _ ⊤) {true , true}) ⟩
    (↑ _ ⊤ → ¬ ↑ _ ⊤)  ↝⟨ (_$ _) ∘ (_$ _) ⟩□
    ⊥                  □

  F-pres : ∀ {A} → Size-preserving (F A)
  F-pres R⊆∼i {true  , false} = R⊆∼i ∘ proj₁
  F-pres R⊆∼i {false , true}  = R⊆∼i
  F-pres _    {true  , true}  = λ _ → true ■
  F-pres _    {false , false} = λ _ → false ■

  F⊤≢F⊥ : F ⊤ ≢ F ⊥
  F⊤≢F⊥ =
    F ⊤ ≡ F ⊥                                                       ↝⟨ subst (λ F → F (λ _ → ⊤) (true , false)) ⟩
    (F ⊤  (λ _ → ⊤) (true , false) → F ⊥ (λ _ → ⊤) (true , false))  ↔⟨⟩
    (⊤ × ⊤ → ⊤ × ⊥)                                                 ↝⟨ proj₂ ∘ (_$ _) ⟩□
    ⊥                                                               □

-- There is a container C such that there are (at least two) relation
-- transformers satisfying λ F → ∀ {i} → F (ν C i) ⊆ ν C i that are
-- not up-to techniques with respect to C.

∃special-case-of-size-preserving×¬up-to :
  ∃ λ (I : Type) →
  ∃ λ (C : Container I I) →
  ∃ λ (F : Trans (# 0) I) →
  ∃ λ (G : Trans (# 0) I) →
    (∀ {i} → F (ν C i) ⊆ ν C i) × ¬ Up-to.Up-to-technique C F ×
    (∀ {i} → G (ν C i) ⊆ ν C i) × ¬ Up-to.Up-to-technique C G ×
    F ≢ G
∃special-case-of-size-preserving×¬up-to =
    (Proc × Proc)
  , StepC
  , G ⊤ , G ⊥
  , bisimilarity-pre-fixpoint
  , ¬-up-to
  , bisimilarity-pre-fixpoint
  , ¬-up-to
  , G⊤≢G⊥
  where

  data Proc : Type where
    p q r : Proc

  data _⟶_ : Proc → Proc → Type where
    p : p ⟶ p
    q : q ⟶ r

  lts = record
    { Proc      = Proc
    ; Label     = ⊤
    ; _[_]⟶_    = λ p _ q → p ⟶ q
    ; is-silent = λ _ → false
    }

  open Combination lts hiding (Proc)

  G : Type → Trans₂ (# 0) Proc
  G A R x = R (r , r) → ¬ R (p , r) → R x × A

  p≁r : ∀ {i} → ¬ Bisimilarity i (p , r)
  p≁r hyp with left-to-right hyp p
  ... | _ , () , _

  bisimilarity-pre-fixpoint :
    ∀ {A i} → G A (Bisimilarity i) ⊆ Bisimilarity i
  bisimilarity-pre-fixpoint hyp = proj₁ (hyp reflexive p≁r)

  data S : Rel₂ (# 0) Proc where
    pq : S (p , q)

  S⊆StepGS : ∀ {A} → S ⊆ Step (G A S)
  Step.left-to-right (S⊆StepGS pq) p = r , q , λ ()
  Step.right-to-left (S⊆StepGS pq) q = p , p , λ ()

  p≁q : ¬ Bisimilarity ∞ (p , q)
  p≁q hyp with left-to-right hyp p
  ... | r , q , p∼r = p≁r (force p∼r)

  ¬-up-to : ∀ {A} → ¬ Up-to-technique (G A)
  ¬-up-to {A} =
    Up-to-technique (G A)                         ↝⟨ (λ up-to → up-to) ⟩
    (S ⊆ ⟦ StepC ⟧ (G A S) → S ⊆ Bisimilarity ∞)  ↝⟨ (λ hyp below → hyp (Step↔StepC _ ∘ below)) ⟩
    (S ⊆ Step (G A S) → S ⊆ Bisimilarity ∞)       ↝⟨ _$ S⊆StepGS ⟩
    S ⊆ Bisimilarity ∞                            ↝⟨ _$ pq ⟩
    Bisimilarity ∞ (p , q)                        ↝⟨ p≁q ⟩□
    ⊥                                             □

  G⊤≢G⊥ : G ⊤ ≢ G ⊥
  G⊤≢G⊥ =
    G ⊤ ≡ G ⊥                                                    ↝⟨ subst (λ G → G (uncurry _≡_) (q , q)) ⟩
    (G ⊤ (uncurry _≡_) (q , q) → G ⊥ (uncurry _≡_) (q , q))      ↔⟨⟩
    ((r ≡ r → p ≢ r → q ≡ q × ⊤) → (r ≡ r → p ≢ r → q ≡ q × ⊥))  ↝⟨ _$ (λ _ _ → refl , _) ⟩
    (r ≡ r → p ≢ r → q ≡ q × ⊥)                                  ↝⟨ proj₂ ∘ (_$ λ ()) ∘ (_$ refl) ⟩□
    ⊥                                                            □

-- There is a container C such that there are (at least two) relation
-- transformers satisfying λ F → ∀ {i} → F (ν C i) ⊆ ν C i that are
-- not size-preserving with respect to C.

∃special-case-of-size-preserving×¬size-preserving :
  ∃ λ (I : Type) →
  ∃ λ (C : Container I I) →
  ∃ λ (F : Trans (# 0) I) →
  ∃ λ (G : Trans (# 0) I) →
    (∀ {i} → F (ν C i) ⊆ ν C i) × ¬ Up-to.Size-preserving C F ×
    (∀ {i} → G (ν C i) ⊆ ν C i) × ¬ Up-to.Size-preserving C G ×
    F ≢ G
∃special-case-of-size-preserving×¬size-preserving =
  Σ-map id (Σ-map id (Σ-map id (Σ-map id (Σ-map id
    (Σ-map (_∘ Up-to.size-preserving→up-to _) (Σ-map id
       (Σ-map (_∘ Up-to.size-preserving→up-to _) id)))))))
    ∃special-case-of-size-preserving×¬up-to

-- There is a monotone, extensive and size-preserving relation
-- transformer that is not compatible.

∃monotone×extensive×size-preserving×¬compatible :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ∃ λ (F : Trans₂ (# 0) Proc) →
    Monotone F × Extensive F × Size-preserving F × ¬ Compatible F
∃monotone×extensive×size-preserving×¬compatible =
    one-transition
  , F
  , mono
  , extensive
  , pres
  , ¬comp

  where

  -- An LTS with two distinct processes and one transition from one to
  -- the other.

  one-transition : LTS lzero
  one-transition = record
    { Proc      = Bool
    ; Label     = ⊤
    ; _[_]⟶_    = λ x _ y → T (x ∧ not y)
    ; is-silent = λ _ → false
    }

  open Combination one-transition

  -- A relation transformer.

  F : Trans₂ (# 0) Proc
  F R (true , true) = R (false , false) ⊎ R (true , true)
  F R               = R

  -- F is monotone.

  mono : Monotone F
  mono R⊆S {true  , true}  = ⊎-map R⊆S R⊆S
  mono R⊆S {true  , false} = R⊆S
  mono R⊆S {false , true}  = R⊆S
  mono R⊆S {false , false} = R⊆S

  -- F is extensive.

  extensive : Extensive F
  extensive R {true  , true}  = inj₂
  extensive R {true  , false} = id
  extensive R {false , true}  = id
  extensive R {false , false} = id

  -- Bisimilarity of size i is a pre-fixpoint of F.

  pre : ∀ {i} → F (Bisimilarity i) ⊆ Bisimilarity i
  pre {x = true  , true}  = λ _ → true ■
  pre {x = true  , false} = id
  pre {x = false , true}  = id
  pre {x = false , false} = id

  -- F is size-preserving.

  pres : Size-preserving F
  pres = _⇔_.from (monotone→⇔ mono) (λ {_ x} → pre {x = x})

  -- A relation.

  R : Rel₂ (# 0) Proc
  R _ = ⊥

  -- A lemma.

  StepRff : Step R (false , false)
  Step.left-to-right StepRff ()
  Step.right-to-left StepRff ()

  -- F is not compatible.

  ¬comp : ¬ Compatible F
  ¬comp =
    Compatible F                                                     ↝⟨ (λ comp {x} → comp {x = x}) ⟩

    F (⟦ StepC ⟧ R) ⊆ ⟦ StepC ⟧ (F R)                                ↝⟨ (λ le → le {true , true}) ⟩

    (F (⟦ StepC ⟧ R) (true , true) → ⟦ StepC ⟧ (F R) (true , true))  ↔⟨⟩

    (⟦ StepC ⟧ R (false , false) ⊎ ⟦ StepC ⟧ R (true , true) →
     ⟦ StepC ⟧ (F R) (true , true))                                  ↝⟨ _$ inj₁ (_⇔_.to (Step↔StepC _) StepRff) ⟩

    ⟦ StepC ⟧ (F R) (true , true)                                    ↝⟨ (λ step → StepC.left-to-right {p = true} {q = true} step {p′ = false} _ ) ⟩

    (∃ λ y → T (not y) × F R (false , y))                            ↔⟨⟩

    (∃ λ y → T (not y) × ⊥)                                          ↝⟨ proj₂ ∘ proj₂ ⟩□

    ⊥                                                                □

-- An LTS used in a couple of lemmas below, along with some
-- properties.

module PQR where

  -- An LTS with two sets of processes, three "to the left", and three
  -- "to the right".

  Side : Type
  Side = Bool

  pattern left  = true
  pattern right = false

  data Process : Type where
    p q r : Side → Process

  data Label : Type where
    pq pr : Label
    qq rr : Side → Label

  infix 4 _[_]⟶_

  data _[_]⟶_ : Process → Label → Process → Type where
    pq : ∀ {s} → p s [ pq ]⟶ q s
    pr : ∀ {s} → p s [ pr ]⟶ r s
    qq : ∀ {s} → q s [ qq s ]⟶ q s
    rr : ∀ {s} → r s [ rr s ]⟶ r s

  lts : LTS lzero
  lts = record
    { Proc      = Process
    ; Label     = Label
    ; _[_]⟶_    = _[_]⟶_
    ; is-silent = λ _ → false
    }

  open Combination lts public hiding (Label)

  -- Two relation transformers: F and G both add (at most) one pair to
  -- the underlying relation.

  data F (R : Rel₂ (# 0) Proc) : Rel₂ (# 0) Proc where
    qq  : F R (q left , q right)
    [_] : ∀ {x} → R x → F R x

  data G (R : Rel₂ (# 0) Proc) : Rel₂ (# 0) Proc where
    rr  : G R (r left , r right)
    [_] : ∀ {x} → R x → G R x

  -- A relation that adds one pair to reflexivity.

  data S : Rel₂ (# 0) Proc where
    pp   : S (p left , p right)
    refl : ∀ {x} → S (x , x)

  -- S progresses to F (G S).

  S-prog : Progression S (F (G S))
  S-prog pp   = Step.⟨ (λ where
                          pq → _ , pq , qq
                          pr → _ , pr , [ rr ])
                     , (λ where
                          pq → _ , pq , qq
                          pr → _ , pr , [ rr ])
                     ⟩
  S-prog refl = Step.⟨ (λ where
                          pq → _ , pq , [ [ refl ] ]
                          pr → _ , pr , [ [ refl ] ]
                          qq → _ , qq , [ [ refl ] ]
                          rr → _ , rr , [ [ refl ] ])
                     , (λ where
                          pq → _ , pq , [ [ refl ] ]
                          pr → _ , pr , [ [ refl ] ]
                          qq → _ , qq , [ [ refl ] ]
                          rr → _ , rr , [ [ refl ] ])
                     ⟩

  S-prog′ : S ⊆ ⟦ StepC ⟧ (F (G S))
  S-prog′ Sx = _⇔_.to (Step↔StepC _) (S-prog Sx)

  -- The two processes q left and q right are not bisimilar.

  q≁q : ¬ q left ∼ q right
  q≁q =
    q left ∼ q right                                ↝⟨ (λ rel → StepC.left-to-right rel qq) ⟩
    (∃ λ y → q right [ qq left ]⟶ y × q left ∼′ y)  ↝⟨ (λ { (_ , () , _) }) ⟩□
    ⊥                                               □

  -- The two processes r left and r right are not bisimilar.

  r≁r : ¬ r left ∼ r right
  r≁r =
    r left ∼ r right                                ↝⟨ (λ rel → StepC.left-to-right rel rr) ⟩
    (∃ λ y → r right [ rr left ]⟶ y × r left ∼′ y)  ↝⟨ (λ { (_ , () , _) }) ⟩□
    ⊥                                               □

  -- F ∘ G is not an up-to technique.

  ¬-F∘G-up-to : ¬ Up-to-technique (F ∘ G)
  ¬-F∘G-up-to =
    Up-to-technique (F ∘ G)                    ↝⟨ (λ up-to → up-to S-prog′) ⟩
    S ⊆ Bisimilarity ∞                         ↝⟨ (λ le → le pp) ⟩
    p left ∼ p right                           ↝⟨ (λ rel → StepC.left-to-right rel pq) ⟩
    (∃ λ y → p right [ pq ]⟶ y × q left ∼′ y)  ↝⟨ (λ { (.(q right) , pq , rel) → rel }) ⟩
    q left ∼′ q right                          ↝⟨ (λ rel → q≁q (force rel)) ⟩
    ⊥                                          □

  -- F is not equal to G.

  F≢G : F ≢ G
  F≢G =
    F ≡ G                                                              ↝⟨ subst (λ F → F (λ _ → ⊥) (q left , q right)) ⟩
    (F (λ _ → ⊥) (q left , q right) → G (λ _ → ⊥) (q left , q right))  ↝⟨ _$ qq ⟩
    G (λ _ → ⊥) (q left , q right)                                     ↝⟨ (λ { [ () ] }) ⟩□
    ⊥                                                                  □

  module F-lemmas where

    -- F is monotone.

    mono : Monotone F
    mono R⊆S qq      = qq
    mono R⊆S [ Rxy ] = [ R⊆S Rxy ]

    -- F is extensive.

    ext : Extensive F
    ext = λ _ → [_]

    -- F is not size-preserving.

    ¬-pres : ¬ Size-preserving F
    ¬-pres =
      Size-preserving F                    ↝⟨ (λ pres → _⇔_.to (monotone→⇔ mono) pres) ⟩
      F (Bisimilarity ∞) ⊆ Bisimilarity ∞  ↝⟨ _$ qq ⟩
      q left ∼ q right                     ↝⟨ q≁q ⟩□
      ⊥                                    □

    -- F is an up-to technique.

    module _ {R} (R-prog′ : R ⊆ ⟦ StepC ⟧ (F R)) where

      R-prog : Progression R (F R)
      R-prog Rx = _⇔_.from (Step↔StepC _) (R-prog′ Rx)

      ¬rr : ∀ {s} → ¬ R (r s , r (not s))
      ¬rr rel with Progression.left-to-right R-prog rel rr
      ¬rr {true}  _ | _ , () , _
      ¬rr {false} _ | _ , () , _

      ¬qq : ∀ {s} → ¬ R (q s , q (not s))
      ¬qq rel with Progression.left-to-right R-prog rel qq
      ¬qq {true}  _ | _ , () , _
      ¬qq {false} _ | _ , () , _

      ¬pp : ∀ {s} → ¬ R (p s , p (not s))
      ¬pp rel with Progression.left-to-right R-prog rel pr
      ... | .(r _) , pr , [ rel′ ] = ¬rr rel′

      ¬pq : ∀ {s₁ s₂} → ¬ R (p s₁ , q s₂)
      ¬pq rel with Progression.left-to-right R-prog rel pq
      ... | _ , () , _

      ¬qp : ∀ {s₁ s₂} → ¬ R (q s₁ , p s₂)
      ¬qp rel with Progression.right-to-left R-prog rel pq
      ... | _ , () , _

      ¬pr : ∀ {s₁ s₂} → ¬ R (p s₁ , r s₂)
      ¬pr rel with Progression.left-to-right R-prog rel pq
      ... | _ , () , _

      ¬rp : ∀ {s₁ s₂} → ¬ R (r s₁ , p s₂)
      ¬rp rel with Progression.right-to-left R-prog rel pq
      ... | _ , () , _

      ¬qr : ∀ {s₁ s₂} → ¬ R (q s₁ , r s₂)
      ¬qr rel with Progression.right-to-left R-prog rel rr
      ... | _ , () , _

      ¬rq : ∀ {s₁ s₂} → ¬ R (r s₁ , q s₂)
      ¬rq rel with Progression.left-to-right R-prog rel rr
      ... | _ , () , _

      up-to : R ⊆ Bisimilarity ∞
      up-to {p left  , p left}  rel = reflexive
      up-to {p left  , p right} rel = ⊥-elim (¬pp rel)
      up-to {p right , p left}  rel = ⊥-elim (¬pp rel)
      up-to {p right , p right} rel = reflexive
      up-to {p _     , q _}     rel = ⊥-elim (¬pq rel)
      up-to {p _     , r _}     rel = ⊥-elim (¬pr rel)
      up-to {q _     , p _}     rel = ⊥-elim (¬qp rel)
      up-to {q left  , q left}  rel = reflexive
      up-to {q left  , q right} rel = ⊥-elim (¬qq rel)
      up-to {q right , q left}  rel = ⊥-elim (¬qq rel)
      up-to {q right , q right} rel = reflexive
      up-to {q _     , r _}     rel = ⊥-elim (¬qr rel)
      up-to {r _     , p _}     rel = ⊥-elim (¬rp rel)
      up-to {r _     , q _}     rel = ⊥-elim (¬rq rel)
      up-to {r left  , r left}  rel = reflexive
      up-to {r left  , r right} rel = ⊥-elim (¬rr rel)
      up-to {r right , r left}  rel = ⊥-elim (¬rr rel)
      up-to {r right , r right} rel = reflexive

  module G-lemmas where

    -- G is monotone.

    mono : Monotone G
    mono R⊆S rr      = rr
    mono R⊆S [ Rxy ] = [ R⊆S Rxy ]

    -- G is extensive.

    ext : Extensive G
    ext = λ _ → [_]

    -- G is not size-preserving.

    ¬-pres : ¬ Size-preserving G
    ¬-pres =
      Size-preserving G                    ↝⟨ (λ pres → _⇔_.to (monotone→⇔ mono) pres) ⟩
      G (Bisimilarity ∞) ⊆ Bisimilarity ∞  ↝⟨ _$ rr ⟩
      r left ∼ r right                     ↝⟨ r≁r ⟩□
      ⊥                                    □

    -- G is an up-to technique.

    module _ {R} (R-prog′ : R ⊆ ⟦ StepC ⟧ (G R)) where

      R-prog : Progression R (G R)
      R-prog Rx = _⇔_.from (Step↔StepC _) (R-prog′ Rx)

      ¬rr : ∀ {s} → ¬ R (r s , r (not s))
      ¬rr rel with Progression.left-to-right R-prog rel rr
      ¬rr {true}  _ | _ , () , _
      ¬rr {false} _ | _ , () , _

      ¬qq : ∀ {s} → ¬ R (q s , q (not s))
      ¬qq rel with Progression.left-to-right R-prog rel qq
      ¬qq {true}  _ | _ , () , _
      ¬qq {false} _ | _ , () , _

      ¬pp : ∀ {s} → ¬ R (p s , p (not s))
      ¬pp rel with Progression.left-to-right R-prog rel pq
      ... | .(q _) , pq , [ rel′ ] = ¬qq rel′

      ¬pq : ∀ {s₁ s₂} → ¬ R (p s₁ , q s₂)
      ¬pq rel with Progression.left-to-right R-prog rel pq
      ... | _ , () , _

      ¬qp : ∀ {s₁ s₂} → ¬ R (q s₁ , p s₂)
      ¬qp rel with Progression.right-to-left R-prog rel pq
      ... | _ , () , _

      ¬pr : ∀ {s₁ s₂} → ¬ R (p s₁ , r s₂)
      ¬pr rel with Progression.left-to-right R-prog rel pq
      ... | _ , () , _

      ¬rp : ∀ {s₁ s₂} → ¬ R (r s₁ , p s₂)
      ¬rp rel with Progression.right-to-left R-prog rel pq
      ... | _ , () , _

      ¬qr : ∀ {s₁ s₂} → ¬ R (q s₁ , r s₂)
      ¬qr rel with Progression.right-to-left R-prog rel rr
      ... | _ , () , _

      ¬rq : ∀ {s₁ s₂} → ¬ R (r s₁ , q s₂)
      ¬rq rel with Progression.left-to-right R-prog rel rr
      ... | _ , () , _

      up-to : R ⊆ Bisimilarity ∞
      up-to {p left  , p left}  rel = reflexive
      up-to {p left  , p right} rel = ⊥-elim (¬pp rel)
      up-to {p right , p left}  rel = ⊥-elim (¬pp rel)
      up-to {p right , p right} rel = reflexive
      up-to {p _     , q _}     rel = ⊥-elim (¬pq rel)
      up-to {p _     , r _}     rel = ⊥-elim (¬pr rel)
      up-to {q _     , p _}     rel = ⊥-elim (¬qp rel)
      up-to {q left  , q left}  rel = reflexive
      up-to {q left  , q right} rel = ⊥-elim (¬qq rel)
      up-to {q right , q left}  rel = ⊥-elim (¬qq rel)
      up-to {q right , q right} rel = reflexive
      up-to {q _     , r _}     rel = ⊥-elim (¬qr rel)
      up-to {r _     , p _}     rel = ⊥-elim (¬rp rel)
      up-to {r _     , q _}     rel = ⊥-elim (¬rq rel)
      up-to {r left  , r left}  rel = reflexive
      up-to {r left  , r right} rel = ⊥-elim (¬rr rel)
      up-to {r right , r left}  rel = ⊥-elim (¬rr rel)
      up-to {r right , r right} rel = reflexive

-- There are monotone and extensive up-to techniques F and G such
-- that F ∘ G is not an up-to-technique.
--
-- Pous and Sangiorgi discuss another instance of this property in
-- Section 6.5.4 of "Enhancements of the bisimulation proof method".

∃[monotone×extensive×up-to]²×¬∘-up-to :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ∃ λ (F : Trans₂ (# 0) Proc) →
  ∃ λ (G : Trans₂ (# 0) Proc) →
    Monotone F × Extensive F × Up-to-technique F ×
    Monotone G × Extensive G × Up-to-technique G ×
    ¬ Up-to-technique (F ∘ G)
∃[monotone×extensive×up-to]²×¬∘-up-to =
    lts
  , F
  , G
  , F-lemmas.mono
  , F-lemmas.ext
  , F-lemmas.up-to
  , G-lemmas.mono
  , G-lemmas.ext
  , G-lemmas.up-to
  , ¬-F∘G-up-to
  where
  open PQR

-- It is not the case that every monotone and extensive up-to
-- technique is size-preserving.

¬monotone×extensive×up-to→size-preserving :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ¬ (∀ {F} → Monotone F → Extensive F → Up-to-technique F →
             Size-preserving F)
¬monotone×extensive×up-to→size-preserving =
    lts
  , λ up-to→pres →
      ¬-F∘G-up-to $
      size-preserving→up-to $
      ∘-closure (up-to→pres F-lemmas.mono F-lemmas.ext F-lemmas.up-to)
                (up-to→pres G-lemmas.mono G-lemmas.ext G-lemmas.up-to)
  where
  open PQR

-- Up-to-technique is not closed under composition, not even for
-- monotone and extensive relation transformers.

¬-∘-closure :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ¬ ({F G : Trans₂ (# 0) Proc} →
     Monotone F → Extensive F →
     Monotone G → Extensive G →
     Up-to-technique F →
     Up-to-technique G →
     Up-to-technique (F ∘ G))
¬-∘-closure =
    lts
  , λ ∘-closure →
        ¬-F∘G-up-to (∘-closure F-lemmas.mono F-lemmas.ext
                               G-lemmas.mono G-lemmas.ext
                               F-lemmas.up-to G-lemmas.up-to)
  where
  open PQR

-- There are (at least two) monotone and extensive up-to techniques
-- that are not size-preserving.

∃monotone×extensive×up-to×¬size-preserving :
  ∃ λ (lts : LTS lzero) →
  let open Combination lts in
  ∃ λ (F : Trans₂ (# 0) Proc) →
  ∃ λ (G : Trans₂ (# 0) Proc) →
    Monotone F × Extensive F × Up-to-technique F × ¬ Size-preserving F ×
    Monotone G × Extensive G × Up-to-technique G × ¬ Size-preserving G ×
    F ≢ G
∃monotone×extensive×up-to×¬size-preserving =
    lts
  , F , G
  , F-lemmas.mono
  , F-lemmas.ext
  , F-lemmas.up-to
  , F-lemmas.¬-pres
  , G-lemmas.mono
  , G-lemmas.ext
  , G-lemmas.up-to
  , G-lemmas.¬-pres
  , F≢G
  where
  open PQR


module OlderBasicILP.Indirect.Hilbert.Sequential where

open import OlderBasicILP.Indirect public

-- Derivations, as Hilbert-style combinator sequences.

mutual
  data Tm : Set where
    NIL   : Tm
    VAR   : ℕ → Tm → Tm
    MP    : ℕ → ℕ → Tm → Tm
    CI    : Tm → Tm
    CK    : Tm → Tm
    CS    : Tm → Tm
    NEC   : Tm → Tm → Tm
    CDIST : Tm → Tm
    CUP   : Tm → Tm
    CDOWN : Tm → Tm
    CPAIR : Tm → Tm
    CFST  : Tm → Tm
    CSND  : Tm → Tm
    UNIT  : Tm → Tm

  _⧻ᵀᵐ_ : Tm → Tm → Tm
  US ⧻ᵀᵐ NIL       = US
  US ⧻ᵀᵐ VAR I TS  = VAR I (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ MP I J TS = MP I J (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CI TS     = CI (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CK TS     = CK (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CS TS     = CS (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ NEC SS TS = NEC SS (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CDIST TS  = CDIST (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CUP TS    = CUP (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CDOWN TS  = CDOWN (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CPAIR TS  = CPAIR (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CFST TS   = CFST (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ CSND TS   = CSND (US ⧻ᵀᵐ TS)
  US ⧻ᵀᵐ UNIT TS   = UNIT (US ⧻ᵀᵐ TS)

  APP : Tm → Tm → Tm
  APP TS US = MP 0 0 (US ⧻ᵀᵐ TS)

  BOX : Tm → Tm
  BOX TS = NEC TS NIL

  infix 3 _⊢×_
  data _⊢×_ (Γ : Cx (Ty Tm)) : Cx (Ty Tm) → Set where
    nil   : Γ ⊢× ∅
    var   : ∀ {Ξ A}         → A ∈ Γ → Γ ⊢× Ξ → Γ ⊢× Ξ , A
    mp    : ∀ {Ξ A B}       → A ▻ B ∈ Ξ → A ∈ Ξ → Γ ⊢× Ξ → Γ ⊢× Ξ , B
    ci    : ∀ {Ξ A}         → Γ ⊢× Ξ → Γ ⊢× Ξ , A ▻ A
    ck    : ∀ {Ξ A B}       → Γ ⊢× Ξ → Γ ⊢× Ξ , A ▻ B ▻ A
    cs    : ∀ {Ξ A B C}     → Γ ⊢× Ξ → Γ ⊢× Ξ , (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
    nec   : ∀ {Ξ Ξ′ A}      → (ss : ∅ ⊢× Ξ′ , A) → Γ ⊢× Ξ → Γ ⊢× Ξ , [ ss ]× ⦂ A
    cdist : ∀ {Ξ A B TS US} → Γ ⊢× Ξ → Γ ⊢× Ξ , TS ⦂ (A ▻ B) ▻ US ⦂ A ▻ APP TS US ⦂ B
    cup   : ∀ {Ξ A TS}      → Γ ⊢× Ξ → Γ ⊢× Ξ , TS ⦂ A ▻ BOX TS ⦂ TS ⦂ A
    cdown : ∀ {Ξ A TS}      → Γ ⊢× Ξ → Γ ⊢× Ξ , TS ⦂ A ▻ A
    cpair : ∀ {Ξ A B}       → Γ ⊢× Ξ → Γ ⊢× Ξ , A ▻ B ▻ A ∧ B
    cfst  : ∀ {Ξ A B}       → Γ ⊢× Ξ → Γ ⊢× Ξ , A ∧ B ▻ A
    csnd  : ∀ {Ξ A B}       → Γ ⊢× Ξ → Γ ⊢× Ξ , A ∧ B ▻ B
    unit  : ∀ {Ξ}           → Γ ⊢× Ξ → Γ ⊢× Ξ , ⊤

  [_]× : ∀ {Ξ Γ} → Γ ⊢× Ξ → Tm
  [ nil ]×       = NIL
  [ var i ts ]×  = VAR [ i ]ⁱ [ ts ]×
  [ mp i j ts ]× = MP [ i ]ⁱ [ j ]ⁱ [ ts ]×
  [ ci ts ]×     = CI [ ts ]×
  [ ck ts ]×     = CK [ ts ]×
  [ cs ts ]×     = CS [ ts ]×
  [ nec ss ts ]× = NEC [ ss ]× [ ts ]×
  [ cdist ts ]×  = CDIST [ ts ]×
  [ cup ts ]×    = CUP [ ts ]×
  [ cdown ts ]×  = CDOWN [ ts ]×
  [ cpair ts ]×  = CPAIR [ ts ]×
  [ cfst ts ]×   = CFST [ ts ]×
  [ csnd ts ]×   = CSND [ ts ]×
  [ unit ts ]×   = UNIT [ ts ]×

infix 3 _⊢_
_⊢_ : Cx (Ty Tm) → Ty Tm → Set
Γ ⊢ A = ∃ (λ Ξ → Γ ⊢× Ξ , A)

[_] : ∀ {A Γ} → Γ ⊢ A → Tm
[ Ξ , ts ] = [ ts ]×

-- Monotonicity with respect to context inclusion.

mono⊢× : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢× Ξ → Γ′ ⊢× Ξ
mono⊢× η nil         = nil
mono⊢× η (var i ts)  = var (mono∈ η i) (mono⊢× η ts)
mono⊢× η (mp i j ts) = mp i j (mono⊢× η ts)
mono⊢× η (ci ts)     = ci (mono⊢× η ts)
mono⊢× η (ck ts)     = ck (mono⊢× η ts)
mono⊢× η (cs ts)     = cs (mono⊢× η ts)
mono⊢× η (nec ss ts) = nec ss (mono⊢× η ts)
mono⊢× η (cdist ts)  = cdist (mono⊢× η ts)
mono⊢× η (cup ts)    = cup (mono⊢× η ts)
mono⊢× η (cdown ts)  = cdown (mono⊢× η ts)
mono⊢× η (cpair ts)  = cpair (mono⊢× η ts)
mono⊢× η (cfst ts)   = cfst (mono⊢× η ts)
mono⊢× η (csnd ts)   = csnd (mono⊢× η ts)
mono⊢× η (unit ts)   = unit (mono⊢× η ts)

mono⊢ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢ A → Γ′ ⊢ A
mono⊢ η (Ξ , ts) = Ξ , mono⊢× η ts

-- Concatenation of derivations.

_⧻_ : ∀ {Γ Ξ Ξ′} → Γ ⊢× Ξ → Γ ⊢× Ξ′ → Γ ⊢× Ξ ⧺ Ξ′
us ⧻ nil       = us
us ⧻ var i ts  = var i (us ⧻ ts)
us ⧻ mp i j ts = mp (mono∈ weak⊆⧺₂ i) (mono∈ weak⊆⧺₂ j) (us ⧻ ts)
us ⧻ ci ts     = ci (us ⧻ ts)
us ⧻ ck ts     = ck (us ⧻ ts)
us ⧻ cs ts     = cs (us ⧻ ts)
us ⧻ nec ss ts = nec ss (us ⧻ ts)
us ⧻ cdist ts  = cdist (us ⧻ ts)
us ⧻ cup ts    = cup (us ⧻ ts)
us ⧻ cdown ts  = cdown (us ⧻ ts)
us ⧻ cpair ts  = cpair (us ⧻ ts)
us ⧻ cfst ts   = cfst (us ⧻ ts)
us ⧻ csnd ts   = csnd (us ⧻ ts)
us ⧻ unit ts   = unit (us ⧻ ts)

-- Modus ponens and necessitation in expanded form.

app : ∀ {A B Γ} → Γ ⊢ A ▻ B → Γ ⊢ A → Γ ⊢ B
app {A} {B} (Ξ , ts) (Ξ′ , us) = Ξ″ , vs
  where Ξ″ = (Ξ′ , A) ⧺ (Ξ , A ▻ B)
        vs = mp top (mono∈ (weak⊆⧺₁ (Ξ , A ▻ B)) top) (us ⧻ ts)

box : ∀ {A Γ} → (t : ∅ ⊢ A) → Γ ⊢ [ t ] ⦂ A
box (Ξ , ts) = ∅ , nec ts nil


-- Agda should warn if a coinductive record is declared but neither
-- --guardedness nor --sized-types is enabled.

record R : Set where
  coinductive
  field
    r : R


{-# OPTIONS --rewriting #-}

module Luau.ResolveOverloads where

open import FFI.Data.Either using (Left; Right)
open import Luau.Subtyping using (_<:_; _≮:_; Language; witness; scalar; unknown; never; function-ok)
open import Luau.Type using (Type ; _⇒_; _∩_; _∪_; unknown; never)
open import Luau.TypeSaturation using (saturate)
open import Luau.TypeNormalization using (normalize)
open import Properties.Contradiction using (CONTRADICTION)
open import Properties.DecSubtyping using (dec-subtyping; dec-subtypingⁿ; <:-impl-<:ᵒ)
open import Properties.Functions using (_∘_)
open import Properties.Subtyping using (<:-refl; <:-trans; <:-trans-≮:; ≮:-trans-<:; <:-∩-left; <:-∩-right; <:-∩-glb; <:-impl-¬≮:; <:-unknown; <:-function; function-≮:-never; <:-never; unknown-≮:-function; scalar-≮:-function; ≮:-∪-right; scalar-≮:-never; <:-∪-left; <:-∪-right)
open import Properties.TypeNormalization using (Normal; FunType; normal; _⇒_; _∩_; _∪_; never; unknown; <:-normalize; normalize-<:; fun-≮:-never; unknown-≮:-fun; scalar-≮:-fun)
open import Properties.TypeSaturation using (Overloads; Saturated; _⊆ᵒ_; _<:ᵒ_; normal-saturate; saturated; <:-saturate; saturate-<:; defn; here; left; right)

-- The domain of a normalized type
srcⁿ : Type → Type
srcⁿ (S ⇒ T) = S
srcⁿ (S ∩ T) = srcⁿ S ∪ srcⁿ T
srcⁿ never = unknown
srcⁿ T = never

-- To get the domain of a type, we normalize it first We need to do
-- this, since if we try to use it on non-normalized types, we get
--
-- src(number ∩ string) = src(number) ∪ src(string) = never ∪ never
-- src(never) = unknown
--
-- so src doesn't respect type equivalence.
src : Type → Type
src (S ⇒ T) = S
src T = srcⁿ(normalize T)

-- Calculate the result of applying a function type `F` to an argument type `V`.
-- We do this by finding an overload of `F` that has the most precise type,
-- that is an overload `(Sʳ ⇒ Tʳ)` where `V <: Sʳ` and moreover
-- for any other such overload `(S ⇒ T)` we have that `Tʳ <: T`.

-- For example if `F` is `(number -> number) & (nil -> nil) & (number? -> number?)`
-- then to resolve `F` with argument type `number`, we pick the `number -> number`
-- overload, but if the argument is `number?`, we pick `number? -> number?`./

-- Not all types have such a most precise overload, but saturated ones do.

data ResolvedTo F G V : Set where

  yes : ∀ Sʳ Tʳ →

    Overloads F (Sʳ ⇒ Tʳ) →
    (V <: Sʳ) →
    (∀ {S T} → Overloads G (S ⇒ T) → (V <: S) → (Tʳ <: T)) →
    --------------------------------------------
    ResolvedTo F G V

  no :

    (∀ {S T} → Overloads G (S ⇒ T) → (V ≮: S)) →
    --------------------------------------------
    ResolvedTo F G V

Resolved : Type → Type → Set
Resolved F V = ResolvedTo F F V

target : ∀ {F V} → Resolved F V → Type
target (yes _ T _ _ _) = T
target (no _) = unknown

-- We can resolve any saturated function type
resolveˢ : ∀ {F G V} → FunType G → Saturated F → Normal V → (G ⊆ᵒ F) → ResolvedTo F G V
resolveˢ (Sⁿ ⇒ Tⁿ) (defn sat-∩ sat-∪) Vⁿ G⊆F with dec-subtypingⁿ Vⁿ Sⁿ
resolveˢ (Sⁿ ⇒ Tⁿ) (defn sat-∩ sat-∪) Vⁿ G⊆F | Left V≮:S = no (λ { here → V≮:S })
resolveˢ (Sⁿ ⇒ Tⁿ) (defn sat-∩ sat-∪) Vⁿ G⊆F | Right V<:S = yes _ _ (G⊆F here) V<:S (λ { here _ → <:-refl })
resolveˢ (Gᶠ ∩ Hᶠ) (defn sat-∩ sat-∪) Vⁿ G⊆F with resolveˢ Gᶠ (defn sat-∩ sat-∪) Vⁿ (G⊆F ∘ left) | resolveˢ Hᶠ (defn sat-∩ sat-∪) Vⁿ (G⊆F ∘ right)
resolveˢ (Gᶠ ∩ Hᶠ) (defn sat-∩ sat-∪) Vⁿ G⊆F | yes S₁ T₁ o₁ V<:S₁ tgt₁ | yes S₂ T₂ o₂ V<:S₂ tgt₂ with sat-∩ o₁ o₂
resolveˢ (Gᶠ ∩ Hᶠ) (defn sat-∩ sat-∪) Vⁿ G⊆F | yes S₁ T₁ o₁ V<:S₁ tgt₁ | yes S₂ T₂ o₂ V<:S₂ tgt₂ | defn o p₁ p₂ =
  yes _ _ o (<:-trans (<:-∩-glb V<:S₁ V<:S₂) p₁) (λ { (left o) p → <:-trans p₂ (<:-trans <:-∩-left (tgt₁ o p)) ; (right o) p → <:-trans p₂ (<:-trans <:-∩-right (tgt₂ o p)) })
resolveˢ (Gᶠ ∩ Hᶠ) (defn sat-∩ sat-∪) Vⁿ G⊆F | yes S₁ T₁ o₁ V<:S₁ tgt₁ | no src₂ =
  yes _ _ o₁ V<:S₁ (λ { (left o) p → tgt₁ o p ; (right o) p → CONTRADICTION (<:-impl-¬≮: p (src₂ o)) })
resolveˢ (Gᶠ ∩ Hᶠ) (defn sat-∩ sat-∪) Vⁿ G⊆F | no src₁ | yes S₂ T₂ o₂ V<:S₂ tgt₂ =
  yes _ _ o₂ V<:S₂ (λ { (left o) p → CONTRADICTION (<:-impl-¬≮: p (src₁ o)) ; (right o) p → tgt₂ o p })
resolveˢ (Gᶠ ∩ Hᶠ) (defn sat-∩ sat-∪) Vⁿ G⊆F | no src₁ | no src₂ =
  no (λ { (left o) → src₁ o ; (right o) → src₂ o })

-- Which means we can resolve any normalized type, by saturating it first
resolveᶠ : ∀ {F V} → FunType F → Normal V → Type
resolveᶠ Fᶠ Vⁿ = target (resolveˢ (normal-saturate Fᶠ) (saturated Fᶠ) Vⁿ (λ o → o))

resolveⁿ : ∀ {F V} → Normal F → Normal V → Type
resolveⁿ (Sⁿ ⇒ Tⁿ) Vⁿ = resolveᶠ (Sⁿ ⇒ Tⁿ) Vⁿ
resolveⁿ (Fᶠ ∩ Gᶠ) Vⁿ = resolveᶠ (Fᶠ ∩ Gᶠ) Vⁿ
resolveⁿ (Sⁿ ∪ Tˢ) Vⁿ = unknown
resolveⁿ unknown Vⁿ = unknown
resolveⁿ never Vⁿ = never

-- Which means we can resolve any type, by normalizing it first
resolve : Type → Type → Type
resolve F V = resolveⁿ (normal F) (normal V)


open import Prelude hiding (Bool)

module Implicits.Oliveira.Improved.Deterministic (TC' : Set) (_tc≟'_ : (a b : TC') → Dec (a ≡ b)) where

{-
open import Data.Fin.Substitution
open import Implicits.Oliveira.Types
open import Implicits.Oliveira.Types.Unification
open import Implicits.Oliveira.Terms
open import Implicits.Oliveira.Contexts
open import Implicits.Oliveira.Substitutions
open import Implicits.Oliveira.Improved.Resolution
open import Extensions.ListFirst
-}

-- This is more troublesome than I expected; the tricky thing is the rule r-simp.
-- r-simp requires an instance of first, which has 2 constructors:
--    (a) here: which relies on a proof that r can yield "a" (K ⊢ r ↓ a)
--    (b) there: which relies on a proof that r can NOT yield "a" (¬ K ⊢ r ↓ a)

-- Proving (b) deterministic is nonsensical. Check for example the example below:
-- (we give two ways to derive (b) for a single K, r and a)
-- Because (b) appears in _⊢ᵣ_, this makes _⊢ᵣ_ non-deterministic, which in turn makes
-- the r-iabs case of (a) non-deterministic.
-- The thing is that all non-determinism is situated in the "unhappy-path": (b).
-- Because the exact instance for (b) does not influence rule instantiation,
-- we should be able to give a weaker,
-- but still powerful enough, version of "equivalence" on derivations.

private

  data TC : Set where
    tc-int : TC
    tc-bool : TC

  _tc≟_ : (a b : TC) → Dec (a ≡ b)
  tc-int tc≟ tc-int = yes refl
  tc-int tc≟ tc-bool = no (λ ())
  tc-bool tc≟ tc-int = no (λ ())
  tc-bool tc≟ tc-bool = yes refl

  open import Data.Fin.Substitution
  open import Implicits.Oliveira.Types
  open import Implicits.Oliveira.Types.Unification
  open import Implicits.Oliveira.Terms
  open import Implicits.Oliveira.Contexts
  open import Implicits.Oliveira.Substitutions
  open import Implicits.Oliveira.Improved.Resolution
  open import Extensions.ListFirst

  Bool : Type 0
  Bool = simpl $ tc tc-bool

  Int : ∀ {ν} → Type ν
  Int = simpl $ tc tc-int

module Example₁ where

  K : Ktx 0 1
  K = (Int ⇒ Bool) ∷K nil

  p₁ : ¬ (K ⊢ Int ⇒ Bool ↓ tc tc-int)
  p₁ (i-iabs (r-simp (here (i-iabs _ ()) .List.[])) _)
  p₁ (i-iabs (r-simp (there ._ _ ())) _)

  p₂ : ¬ (K ⊢ Int ⇒ Bool ↓ tc tc-int)
  p₂ (i-iabs x ())


data ⊥ : Set where

_ : @0 ⊥ → Set
_ = λ @0 { () }


module Esterel.Lang.CanFunction.Properties where

{-
Basic properties of the Can function and utilities used in the reasoning,
such as Can does not look at shared variables and sequential variables; Can can
only output free variables; Can will capture free emit S and s ⇐ e (and more).
-}
open import Esterel.Lang.CanFunction.Base hiding ([_↦_]) public

{-
The equivalent "goodness" of can w.r.t. the rmerge reduction. Specifically, here
are the main lemmas:

  can-irr : ∀ {BV} {FV} θ₁ θ₂ q →
    CorrectBinding q BV FV →
    (distinct' (proj₁ FV) (proj₁ (Dom θ₂))) →
    Can q θ₁ ≡ Can q (θ₁ ← θ₂)
  can-irr θ₁ θ₂ q cbq FV≠Domθ₂

  canθₛ-mergeˡ : ∀ {E θ' r p BV FV} sigs θ →
    CorrectBinding p BV FV →
    p ≐ E ⟦ ρ θ' · r ⟧e →
    ∀ S' →
      Signal.unwrap S' ∉ SigMap.keys (Env.sig θ') →
      Signal.unwrap S' ∈ Canθₛ (SigMap.union sigs (Env.sig θ')) 0 (E ⟦ r ⟧e) θ →
      Signal.unwrap S' ∈ Canθₛ sigs 0 p θ

  canθₛ-mergeʳ : ∀ sigs θ' r θ →
    distinct' (proj₁ (Dom θ)) (SigMap.keys sigs) →
    ∀ S' →
      Signal.unwrap S' ∈ Canθₛ (SigMap.union sigs (Env.sig θ')) 0 r θ →
      Signal.unwrap S' ∈ Canθₛ (Env.sig θ') 0 r θ

These lemma says that when updating or extending the environent,
if the program does not refer to the updated variables, then
the Can function will not change and the Canθ function will
have some sort of monotonicity.

-}
open import Esterel.Lang.CanFunction.MergePotentialRuleCan public
open import Esterel.Lang.CanFunction.MergePotentialRuleTheta public

{-
The subset "goodness" of can w.r.t. other ρθ-reductions. For each of the 7 non-merge
ρθ-reductions, there are two corresponding Can subset lemmas.
-}
open import Esterel.Lang.CanFunction.NonMergePotentialRules public

{-
The compatible closure context C⟦_⟧c respects the monotonicity of the potential
function. For example, Can is monotonic w.r.t. to _sn⟶₁_, hence also _sn⟶_ by the
lemmas in this file.
-}
open import Esterel.Lang.CanFunction.Plug public

open import utility

open import Esterel.Lang
  using (Term ; emit ; _⇐_)
open import Esterel.Context
  using (_≐_⟦_⟧e)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Lang.CanFunction
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)

open import Function
  using (_∘_)
open import Relation.Nullary
  using (¬_)


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

data ⊥ : Set where

postulate
  T : Set
  t0 : T
  t1 : T

postulate
  foo : ⊥ → t0 ≡ t1
  {-# REWRITE foo #-}

test : t0 ≡ t1
test = refl


-- Andreas, 2014-09-23
-- Syntax declaration for overloaded constructor.

-- {-# OPTIONS -v scope.operators:50 #-}

syntax c x = ⟦ x ⟧

data D1 : Set where
  c : D1

data D2 : Set where
  c : D1 → D2

test : D2
test = ⟦ c ⟧

-- Should work.


module Generic.Test.Data where

open import Generic.Test.Data.Fin     public
open import Generic.Test.Data.Lift    public
open import Generic.Test.Data.Product public
open import Generic.Test.Data.List    public
open import Generic.Test.Data.Maybe   public
open import Generic.Test.Data.Vec     public
open import Generic.Test.Data.W       public


------------------------------------------------------------------------
-- Simple kinding of Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Simple where

open import Data.Context.WellFormed
open import Data.Fin using (Fin; zero; suc)
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.List as List using ([]; _∷_; _∷ʳ_; map)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Product as Prod using (∃; _,_; _×_)
open import Data.Vec as Vec using ([]; _∷_)
import Data.Vec.Properties as VecProps
open import Function using (_∘_)
import Level
open import Relation.Binary.PropositionalEquality as PropEq using (refl; _≡_)
open import Relation.Nullary.Negation

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization

------------------------------------------------------------------------
-- Simple kinding derivations.
--
-- TODO: explain the point of this and how "simple" kinding differs
-- from "canonical" kinding.

module Kinding where
  open SimpleCtx
  open Syntax

  infix 4 _⊢Var_∈_ _⊢_kds _⊢Nf_∈_ _⊢Ne_∈_ _⊢_∋∙_∈_ _⊢_wfs

  -- Simple kinding of variables.
  data _⊢Var_∈_ {n} (Γ : Ctx n) : Fin n → SKind → Set where
    ∈-var : ∀ {k} x → lookup Γ x ≡ kd k → Γ ⊢Var x ∈ k

  mutual

    -- Simplified well-formedness of kinds: a variant of
    -- well-formedness for η-long β-normal kinds based on simple
    -- kinding.
    data _⊢_kds {n} (Γ : Ctx n) : Kind Elim n → Set where
      kds-⋯ : ∀ {a b} → Γ ⊢Nf a ∈ ★ → Γ ⊢Nf b ∈ ★           → Γ ⊢ a ⋯ b kds
      kds-Π : ∀ {j k} → Γ ⊢ j kds   → kd ⌊ j ⌋ ∷ Γ ⊢ k kds  → Γ ⊢ Π j k kds

    -- Simple kinding of η-long β-normal types.
    data _⊢Nf_∈_ {n} (Γ : Ctx n) : Elim n → SKind → Set where
      ∈-⊥-f : Γ ⊢Nf ⊥∙ ∈ ★
      ∈-⊤-f : Γ ⊢Nf ⊤∙ ∈ ★
      ∈-∀-f : ∀ {k a} → Γ ⊢ k kds → kd ⌊ k ⌋ ∷ Γ ⊢Nf a ∈ ★ →
              Γ ⊢Nf ∀∙ k a ∈ ★
      ∈-→-f : ∀ {a b} → Γ ⊢Nf a ∈ ★ → Γ ⊢Nf b ∈ ★ → Γ ⊢Nf a ⇒∙ b ∈ ★
      ∈-Π-i : ∀ {j a k} → Γ ⊢ j kds → kd ⌊ j ⌋ ∷ Γ ⊢Nf a ∈ k →
              Γ ⊢Nf Λ∙ j a ∈ ⌊ j ⌋ ⇒ k
      ∈-ne  : ∀ {a} → Γ ⊢Ne a ∈ ★ → Γ ⊢Nf a ∈ ★

    -- Simple kinding of neutral types.
    data _⊢Ne_∈_ {n} (Γ : Ctx n) : Elim n → SKind → Set where
      ∈-∙ : ∀ {x j k} {as : Spine n} → Γ ⊢Var x ∈ j →
            Γ ⊢ j ∋∙ as ∈ k → Γ ⊢Ne var x ∙ as ∈ k

    -- Simple spine kinding.
    data _⊢_∋∙_∈_ {n} (Γ : Ctx n) : SKind → Spine n → SKind → Set where
      ∈-[] : ∀ {k} → Γ ⊢ k ∋∙ [] ∈ k
      ∈-∷  : ∀ {a as j k l} → Γ ⊢Nf a ∈ j → Γ ⊢ k ∋∙ as ∈ l →
             Γ ⊢ j ⇒ k ∋∙ a ∷ as ∈ l

  open ContextConversions using (⌊_⌋Ctx)

  -- Simple well-formedness of ascriptions
  data _⊢_wfs {n} (Γ : Ctx n) : ElimAsc n → Set where
    wfs-kd : ∀ {a} → Γ ⊢ a kds   → Γ ⊢ kd a wfs
    wfs-tp : ∀ {a} → Γ ⊢Nf a ∈ ★ → Γ ⊢ tp a wfs

  -- Simply well-formed contexts and context extensions.
  module SimplyWfCtx = ContextFormation (λ Γ a → ⌊ Γ ⌋Ctx ⊢ a wfs)
  open SimplyWfCtx public using () renaming (_wf to _ctxs; _⊢_wfExt to _⊢_exts)

open Syntax
open SimpleCtx
open Kinding
open PropEq

-- An admissible kinding rule for spine concatenation.
∈-++ : ∀ {n} {Γ : Ctx n} {as bs j k l} →
       Γ ⊢ j ∋∙ as ∈ k → Γ ⊢ k ∋∙ bs ∈ l →
       Γ ⊢ j ∋∙ as List.++ bs ∈ l
∈-++ ∈-[]               k∋as∈l = k∋as∈l
∈-++ (∈-∷ b∈j₁ j₂∋as∈k) k∋as∈l = ∈-∷ b∈j₁ (∈-++ j₂∋as∈k k∋as∈l)

-- An admissible kinding rule for appending a normal form to a spine.
∈-∷ʳ : ∀ {n} {Γ : Ctx n} {as a j k l} →
       Γ ⊢ j ∋∙ as ∈ k ⇒ l → Γ ⊢Nf a ∈ k →
       Γ ⊢ j ∋∙ as ∷ʳ a ∈ l
∈-∷ʳ j∋as∈k⇒k a∈k = ∈-++ j∋as∈k⇒k (∈-∷ a∈k ∈-[])

-- An admissible kinding rule for post-application to neutral types.
Ne∈-Π-e : ∀ {n} {Γ : Ctx n} {a b j k} →
          Γ ⊢Ne a ∈ j ⇒ k → Γ ⊢Nf b ∈ j → Γ ⊢Ne a ⌜·⌝ b ∈ k
Ne∈-Π-e (∈-∙ x∈j j∋as∈k) b∈k = ∈-∙ x∈j (∈-∷ʳ j∋as∈k b∈k)

-- An inversion lemma for _⊢_wf.
wfs-kd-inv : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ kd k wfs → Γ ⊢ k kds
wfs-kd-inv (wfs-kd k-kds) = k-kds

-- An inversion lemma for type operators.
Nf∈-⇒-inv : ∀ {n} {Γ : Ctx n} {a k₁ k₂} → Γ ⊢Nf a ∈ k₁ ⇒ k₂ →
            ∃ λ j → ∃ λ b →
              Γ ⊢ j kds × kd k₁ ∷ Γ ⊢Nf b ∈ k₂ × ⌊ j ⌋ ≡ k₁ × a ≡ Λ∙ j b
Nf∈-⇒-inv (∈-Π-i j-kds b∈k₂) = _ , _ , j-kds , b∈k₂ , refl , refl

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

-- Well-kinded variable substitutions (renamings).
module KindedRenaming where

  open ⊤-WellFormed SimpleCtx.weakenOps

  typedVarSubst : TypedVarSubst SAsc Level.zero
  typedVarSubst = record
    { _⊢_wf              = _⊢_wf
    ; typeExtension      = SimpleCtx.weakenOps
    ; typeVarApplication = record { _/_ = λ k _ → k }
    ; /-wk               = refl
    ; id-vanishes        = λ _ → refl
    ; /-⊙                = λ _ → refl
    ; wf-wf            = λ _ → ctx-wf _
    }
  open TypedVarSubst typedVarSubst public
    hiding (∈-weaken)
    renaming (_⊢Var_∈_ to _⊢Var′_∈_; lookup to ∈-lookup)

  open Substitution hiding (subst; _/Var_) renaming (_Elim/Var_ to _/Var_)
  open RenamingCommutes using (Kind[∈⌊⌋]-/Var)
  open PropEq
  open ≡-Reasoning

  -- A helper.
  ∈-↑′ : ∀ {m n} {Δ : Ctx n} {Γ : Ctx m} {k ρ} →
         Δ ⊢/Var ρ ∈ Γ →
         kd ⌊ k Kind′/Var ρ ⌋ ∷ Δ ⊢/Var ρ VarSubst.↑ ∈ kd ⌊ k ⌋ ∷ Γ
  ∈-↑′ {Δ = Δ} {_} {k} ρ∈Γ =
    subst (λ j → kd j ∷ Δ ⊢/Var _ ∈ _) (sym (⌊⌋-Kind′/Var k)) (∈-↑ _ ρ∈Γ)

  -- Convert between well-kindedness judgments for variables.
  Var∈′-Var∈ : ∀ {n} {Γ : Ctx n} {x a k} → a ≡ kd k →
               Γ ⊢Var′ x ∈ a → Γ ⊢Var x ∈ k
  Var∈′-Var∈ Γ[x]≡kd-k (∈-var x Γ-ctx) = ∈-var x Γ[x]≡kd-k

  -- Renamings preserve synthesized kinds of variables.
  Var∈-/Var : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {x k ρ} →
              Γ ⊢Var x ∈ k → Δ ⊢/Var ρ ∈ Γ → Δ ⊢Var Vec.lookup ρ x ∈ k
  Var∈-/Var (∈-var x Γ[x]≡kd-k) ρ∈Γ = Var∈′-Var∈ Γ[x]≡kd-k (∈-lookup ρ∈Γ x)

  mutual

    -- Renamings preserve well-formedness of kinds.
    kds-/Var : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {k ρ} →
               Γ ⊢ k kds → Δ ⊢/Var ρ ∈ Γ → Δ ⊢ k Kind′/Var ρ kds
    kds-/Var (kds-⋯ a∈★ b∈★) ρ∈Γ = kds-⋯ (Nf∈-/Var a∈★ ρ∈Γ) (Nf∈-/Var b∈★ ρ∈Γ)
    kds-/Var (kds-Π j-kds  k-kds) ρ∈Γ =
      kds-Π (kds-/Var j-kds ρ∈Γ) (kds-/Var k-kds (∈-↑′ ρ∈Γ))

    -- Renamings preserve synthesized kinds of normal types.
    Nf∈-/Var : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a k ρ} →
               Γ ⊢Nf a ∈ k → Δ ⊢/Var ρ ∈ Γ → Δ ⊢Nf a /Var ρ ∈ k
    Nf∈-/Var ∈-⊥-f              ρ∈Γ = ∈-⊥-f
    Nf∈-/Var ∈-⊤-f              ρ∈Γ = ∈-⊤-f
    Nf∈-/Var (∈-∀-f k-kds a∈★)  ρ∈Γ =
      ∈-∀-f (kds-/Var k-kds ρ∈Γ) (Nf∈-/Var a∈★ (∈-↑′ ρ∈Γ))
    Nf∈-/Var (∈-→-f a∈★ b∈★)    ρ∈Γ =
      ∈-→-f (Nf∈-/Var a∈★ ρ∈Γ) (Nf∈-/Var b∈★ ρ∈Γ)
    Nf∈-/Var (∈-Π-i {j} {a} {k} j-kds a∈k) ρ∈Γ =
      subst (λ l → _ ⊢Nf Λ∙ j a /Var _ ∈ l ⇒ k) (⌊⌋-Kind′/Var j)
            (∈-Π-i (kds-/Var j-kds ρ∈Γ) (Nf∈-/Var a∈k (∈-↑′ ρ∈Γ)))
    Nf∈-/Var (∈-ne a∈★)         ρ∈Γ = ∈-ne (Ne∈-/Var a∈★ ρ∈Γ)

    -- Renamings preserve synthesized kinds of neutral types.
    Ne∈-/Var : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a k ρ} →
               Γ ⊢Ne a ∈ k → Δ ⊢/Var ρ ∈ Γ → Δ ⊢Ne a /Var ρ ∈ k
    Ne∈-/Var (∈-∙ x∈j k∈as∈l) ρ∈Γ =
      ∈-∙ (Var∈-/Var x∈j ρ∈Γ) (Sp∈-/Var k∈as∈l ρ∈Γ)

    Sp∈-/Var : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {as j k ρ} →
               Γ ⊢ j ∋∙ as ∈ k → Δ ⊢/Var ρ ∈ Γ → Δ ⊢ j ∋∙ as //Var ρ  ∈ k
    Sp∈-/Var ∈-[]                ρ∈Γ = ∈-[]
    Sp∈-/Var (∈-∷ a∈j k[a]∈as∈l) ρ∈Γ =
      ∈-∷ (Nf∈-/Var a∈j ρ∈Γ) (Sp∈-/Var k[a]∈as∈l ρ∈Γ)

  -- Renamings preserve well-formedness of ascriptions.
  wfs-/Var : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a ρ} →
             Γ ⊢ a wfs → Δ ⊢/Var ρ ∈ Γ → Δ ⊢ a ElimAsc/Var ρ wfs
  wfs-/Var (wfs-kd k-kds) ρ∈Γ = wfs-kd (kds-/Var k-kds ρ∈Γ)
  wfs-/Var (wfs-tp a∈★)   ρ∈Γ = wfs-tp (Nf∈-/Var a∈★ ρ∈Γ)

  -- Weakening preserves simple well-formedness of kinds.

  kds-weaken : ∀ {n} {Γ : Ctx n} {k a} →
               Γ ⊢ k kds → a ∷ Γ ⊢ weakenKind′ k kds
  kds-weaken k-kds = kds-/Var k-kds (∈-wk _)

  kds-weaken⋆ : ∀ {m n} (Δ : CtxExt m n) {Γ : Ctx m} {k} →
                Γ ⊢ k kds → Δ ++ Γ ⊢ weakenKind′⋆ n k kds
  kds-weaken⋆ []       k-kds = k-kds
  kds-weaken⋆ (_ ∷ Δ′) k-kds = kds-weaken (kds-weaken⋆ Δ′ k-kds)

  -- Weakening preserves kinding of normal forms.

  Nf∈-weaken : ∀ {n} {Γ : Ctx n} {a b k} →
               Γ ⊢Nf b ∈ k → (a ∷ Γ) ⊢Nf weakenElim b ∈ k
  Nf∈-weaken b∈k = Nf∈-/Var b∈k (∈-wk _)

  Nf∈-weaken⋆ : ∀ {m n} (Δ : CtxExt m n) {Γ : Ctx m} {a k} →
                Γ ⊢Nf a ∈ k → Δ ++ Γ ⊢Nf weakenElim⋆ n a ∈ k
  Nf∈-weaken⋆ []       a∈k = a∈k
  Nf∈-weaken⋆ (_ ∷ Δ′) a∈k = Nf∈-weaken (Nf∈-weaken⋆ Δ′ a∈k)

  -- Weakening preserves kinding of neutral forms.
  Ne∈-weaken : ∀ {n} {Γ : Ctx n} {a b k} →
               Γ ⊢Ne b ∈ k → (a ∷ Γ) ⊢Ne weakenElim b ∈ k
  Ne∈-weaken b∈k = Ne∈-/Var b∈k (∈-wk _)

  -- Weakening preserves spine kinding.
  Sp∈-weaken : ∀ {n} {Γ : Ctx n} {a bs j k} →
               Γ ⊢ j ∋∙ bs ∈ k → (a ∷ Γ) ⊢ j ∋∙ weakenSpine bs ∈ k
  Sp∈-weaken j∋bs∈k = Sp∈-/Var j∋bs∈k (∈-wk _)

  -- Weakening preserves simple well-formedness of ascriptions.
  wfs-weaken : ∀ {n} {Γ : Ctx n} {a b} →
               Γ ⊢ b wfs → a ∷ Γ ⊢ weakenElimAsc b wfs
  wfs-weaken b-wfs = wfs-/Var b-wfs (∈-wk _)

-- Operations on simply well-formed contexts that require weakening of
-- well-formedness judgments.
module WfsCtxOps where
  open SimplyWfCtx
  open ContextConversions using (⌊_⌋Ctx)
  open KindedRenaming using (wfs-weaken)

  wfsWeakenOps : WellFormedWeakenOps ElimCtx.weakenOps
  wfsWeakenOps = record { wf-weaken = λ _ → wfs-weaken }

  private module W = WellFormedWeakenOps wfsWeakenOps
  open W public hiding (wf-weaken)

  -- Lookup the kind of a type variable in a well-formed context.
  lookup-kd : ∀ {m} {Γ : ElimCtx.Ctx m} {a} x →
              Γ ctxs → ElimCtx.lookup Γ x ≡ kd a → ⌊ Γ ⌋Ctx ⊢ a kds
  lookup-kd x Γ-ctxs Γ[x]≡kd-a =
    wfs-kd-inv (subst (_ ⊢_wfs) Γ[x]≡kd-a (W.lookup Γ-ctxs x))

module KindedHereditarySubstitution where
  open Data.Fin         using (zero; raise; lift)
  open Substitution     hiding (subst; sub; _↑; _↑⋆_)
  open KindedRenaming   using (_⊢/Var_∈_; Nf∈-/Var; Nf∈-weaken⋆; ∈-wk)
  open RenamingCommutes using (wk-/⟨⟩-↑⋆; /Var-wk-↑⋆-hsub-vanishes)
  open PropEq
  open ≡-Reasoning
  private module V = VarSubst

  infix 4 _⊢/⟨_⟩_∈_ _⊢?⟨_⟩_∈_

  -- Simply well-kinded hereditary substitions and lookup results.

  data _⊢/⟨_⟩_∈_ : ∀ {m n} → Ctx n → SKind → SVSub m n → Ctx m → Set where
    ∈-hsub : ∀ {n} {Γ : Ctx n} {k a} →
             Γ ⊢Nf a ∈ k → Γ ⊢/⟨ k ⟩ sub a ∈ kd k ∷ Γ
    ∈-H↑   : ∀ {m n Δ k Γ} {σ : SVSub m n} {a} →
             Δ ⊢/⟨ k ⟩ σ ∈ Γ → a ∷ Δ ⊢/⟨ k ⟩ σ ↑ ∈ a ∷ Γ

  data _⊢?⟨_⟩_∈_ {n} (Γ : Ctx n) (k : SKind) : SVRes n → SAsc n → Set where
    ∈-hit  : ∀ {a}   → Γ ⊢Nf a ∈ k    → Γ ⊢?⟨ k ⟩ hit a ∈ kd k
    ∈-miss : ∀ y {a} → lookup Γ y ≡ a → Γ ⊢?⟨ k ⟩ miss y ∈ a

  -- A variant of `∈-H↑' that applies `σ' in the target context

  ∈-H↑′ : ∀ {m n Δ k Γ} {σ : SVSub m n} {j} →
          Δ ⊢/⟨ k ⟩ σ ∈ Γ →
          kd ⌊ j Kind/⟨ k ⟩ σ ⌋ ∷ Δ ⊢/⟨ k ⟩ σ ↑ ∈ kd ⌊ j ⌋ ∷ Γ
  ∈-H↑′ σ∈Γ =
    subst (λ k → kd k ∷ _ ⊢/⟨ _ ⟩ _ ↑ ∈ kd _ ∷ _)
          (sym (⌊⌋-Kind/⟨⟩ _)) (∈-H↑ σ∈Γ)

  -- Lift a kinded hereditary substitution over multiple additional
  -- variables.

  ∈-H↑⋆ : ∀ {m n i} (E : CtxExt m i) {Δ k Γ} {σ : SVSub m n} →
          Δ ⊢/⟨ k ⟩ σ ∈ Γ → re-idx E ++ Δ ⊢/⟨ k ⟩ σ ↑⋆ i ∈ E ++ Γ
  ∈-H↑⋆ []      σ∈Γ = σ∈Γ
  ∈-H↑⋆ (a ∷ E) σ∈Γ = ∈-H↑ (∈-H↑⋆ E σ∈Γ)

  -- Renamings preserve well-kinded SV results.

  ?∈-/Var : ∀ {m n Γ k Δ r a} {ρ : Sub Fin m n} →
            Γ ⊢?⟨ k ⟩ r ∈ a → Δ ⊢/Var ρ ∈ Γ → Δ ⊢?⟨ k ⟩ r ?/Var ρ ∈ a
  ?∈-/Var                 (∈-hit a∈k)     ρ∈Γ = ∈-hit (Nf∈-/Var a∈k ρ∈Γ)
  ?∈-/Var {Γ = Γ} {k} {Δ} (∈-miss y refl) ρ∈Γ = helper refl (TV.lookup ρ∈Γ y)
    where
      module TV = TypedVarSubst KindedRenaming.typedVarSubst

      helper : ∀ {x a} → a ≡ lookup Γ y → Δ TV.⊢Var x ∈ a →
               Δ ⊢?⟨ k ⟩ miss x ∈ lookup Γ y
      helper Δ[x]≡Γ[y] (TV.∈-var x _) = ∈-miss x Δ[x]≡Γ[y]

  ?∈-weaken : ∀ {n} {Γ : Ctx n} {k r a b} →
              Γ ⊢?⟨ k ⟩ r ∈ a → (b ∷ Γ) ⊢?⟨ k ⟩ weakenSVRes r ∈ a
  ?∈-weaken r∈a = ?∈-/Var r∈a (∈-wk _)

  -- Look up a variable in a well-kinded hereditary substitution.

  lookup-/⟨⟩∈ : ∀ {m n Δ k Γ} {σ : SVSub m n} →
                Δ ⊢/⟨ k ⟩ σ ∈ Γ → (x : Fin m) →
                Δ ⊢?⟨ k ⟩ lookupSV σ x ∈ lookup Γ x
  lookup-/⟨⟩∈                (∈-hsub a∈k) zero    = ∈-hit a∈k
  lookup-/⟨⟩∈ {Γ = kd k ∷ Γ} (∈-hsub a∈k) (suc x) =
    ∈-miss x (cong (λ Γ → Vec.lookup Γ x) (sym (VecProps.map-id (toVec Γ))))
  lookup-/⟨⟩∈ (∈-H↑                     σ∈Γ) zero    = ∈-miss zero refl
  lookup-/⟨⟩∈ (∈-H↑ {Δ = Δ} {_} {Γ} {σ} σ∈Γ) (suc x) =
    ?∈-weaken (subst (λ as → Δ ⊢?⟨ _ ⟩ lookupSV σ x ∈ Vec.lookup as x)
                     (sym (VecProps.map-id (toVec Γ))) (lookup-/⟨⟩∈ σ∈Γ x))

  -- Lookup a hit in a well-kinded hereditary substitution.
  --
  -- NOTE. Since `j ≡ k', we could have formulated this lemma
  -- differently.  In particular, given the premise `Γ ⊢Var x ∈ j', it
  -- would have been more intuitive for the kinding judgment in the
  -- conclusion to use the shape `j' rather than `k' (preserving the
  -- kind of the variable, as usual for substitution lemmas).
  -- However, it is important that the shape `k' of the normal type
  -- returned by this function is syntactically equal to the shape
  -- annotation of the hereditary substitution `Δ ⊢/⟨ k ⟩ σ ∈ Γ'
  -- because it serves as the termination measure for the (hereditary)
  -- substitution lemmas below.

  lookup-/⟨⟩∈-Hit : ∀ {m n Δ k} {σ : SVSub m n} {Γ x j a} →
                    Δ ⊢/⟨ k ⟩ σ ∈ Γ → Γ ⊢Var x ∈ j → Hit σ x a →
                    Δ ⊢Nf a ∈ k × j ≡ k
  lookup-/⟨⟩∈-Hit σ∈Γ (∈-var {j} x Γ[x]≡kd-j) hitP =
    let a∈k , Γ[x]≡kd-k = helper (lookup-Hit hitP) (lookup-/⟨⟩∈ σ∈Γ x)
    in  a∈k , kd-inj′ (trans (sym Γ[x]≡kd-j) Γ[x]≡kd-k)
    where
      helper : ∀ {n} {Δ : Ctx n} {r a b k} →
               r ≡ hit a → Δ ⊢?⟨ k ⟩ r ∈ b → Δ ⊢Nf a ∈ k × b ≡ kd k
      helper refl (∈-hit a∈k) = a∈k , refl

  lookup-/⟨⟩∈-Miss : ∀ {m n Δ k} {σ : SVSub m n} {Γ x y j} →
                     Δ ⊢/⟨ k ⟩ σ ∈ Γ → Γ ⊢Var x ∈ j → Miss σ x y →
                     lookup Δ y ≡ lookup Γ x
  lookup-/⟨⟩∈-Miss σ∈Γ (∈-var {j} x Γ[x]≡kd-j) missP =
    helper (lookup-Miss missP) (lookup-/⟨⟩∈ σ∈Γ x)
    where
      helper : ∀ {n} {Δ : Ctx n} {r y b k} →
               r ≡ miss y → Δ ⊢?⟨ k ⟩ r ∈ b → lookup Δ y ≡ b
      helper refl (∈-miss y Δ[y]≡b) = Δ[y]≡b

  open KindSimpLemmas simpLemmasKind′

  -- TODO: explain why this terminates.
  mutual

    -- Hereditary substitutions preserve simple well-formedness and
    -- kinding (of kinds, normal types and spines).

    kds-/⟨⟩ : ∀ {m n Γ k Δ} {σ : SVSub m n} {j} →
              Γ ⊢ j kds → Δ ⊢/⟨ k ⟩ σ ∈ Γ → Δ ⊢ j Kind/⟨ k ⟩ σ kds
    kds-/⟨⟩ (kds-⋯ a∈★ b∈★)     σ∈Γ = kds-⋯ (Nf∈-/⟨⟩ a∈★ σ∈Γ) (Nf∈-/⟨⟩ b∈★ σ∈Γ)
    kds-/⟨⟩ (kds-Π j-kds k-kds) σ∈Γ =
      kds-Π (kds-/⟨⟩ j-kds σ∈Γ) (kds-/⟨⟩ k-kds (∈-H↑′ σ∈Γ))

    Nf∈-/⟨⟩ : ∀ {m n Γ k Δ} {σ : SVSub m n} {a j} →
              Γ ⊢Nf a ∈ j → Δ ⊢/⟨ k ⟩ σ ∈ Γ → Δ ⊢Nf a /⟨ k ⟩ σ ∈ j
    Nf∈-/⟨⟩ ∈-⊥-f             σ∈Γ = ∈-⊥-f
    Nf∈-/⟨⟩ ∈-⊤-f             σ∈Γ = ∈-⊤-f
    Nf∈-/⟨⟩ (∈-∀-f k-kds a∈★) σ∈Γ =
      ∈-∀-f (kds-/⟨⟩ k-kds σ∈Γ) (Nf∈-/⟨⟩ a∈★ (∈-H↑′ σ∈Γ))
    Nf∈-/⟨⟩ (∈-→-f a∈★ b∈★)   σ∈Γ =
      ∈-→-f (Nf∈-/⟨⟩ a∈★ σ∈Γ) (Nf∈-/⟨⟩ b∈★ σ∈Γ)
    Nf∈-/⟨⟩ (∈-Π-i {j} {a} {k} j-kds a∈k) σ∈Γ =
      subst (λ l → _ ⊢Nf Λ∙ j a /⟨ _ ⟩ _ ∈ l ⇒ k) (⌊⌋-Kind/⟨⟩ j)
            (∈-Π-i (kds-/⟨⟩ j-kds σ∈Γ) (Nf∈-/⟨⟩ a∈k (∈-H↑′ σ∈Γ)))
    Nf∈-/⟨⟩ (∈-ne a∈★)        σ∈Γ = Ne∈-/⟨⟩ a∈★ σ∈Γ

    Sp∈-/⟨⟩ : ∀ {m n Γ k Δ} {σ : SVSub m n} {as j₁ j₂} →
              Γ ⊢ j₁ ∋∙ as ∈ j₂ → Δ ⊢/⟨ k ⟩ σ ∈ Γ → Δ ⊢ j₁ ∋∙ as //⟨ k ⟩ σ ∈ j₂
    Sp∈-/⟨⟩ ∈-[]                   σ∈Γ = ∈-[]
    Sp∈-/⟨⟩ (∈-∷ a∈j₁ j₂[a]∈as∈j₃) σ∈Γ =
      ∈-∷ (Nf∈-/⟨⟩ a∈j₁ σ∈Γ) (Sp∈-/⟨⟩ j₂[a]∈as∈j₃ σ∈Γ)

    -- Hereditary substitutions preserve the shapes of neutral types
    -- (but not neutrality itself).

    Ne∈-/⟨⟩ : ∀ {m n Γ k Δ} {σ : SVSub m n} {a} →
              Γ ⊢Ne a ∈ ★ → Δ ⊢/⟨ k ⟩ σ ∈ Γ → Δ ⊢Nf a /⟨ k ⟩ σ ∈ ★
    Ne∈-/⟨⟩ (∈-∙ (∈-var x Γ[x]≡kd-j) j∈as∈l) σ∈Γ =
      ?⟨⟩∈-?∙∙ (subst (_ ⊢?⟨ _ ⟩ _ ∈_) Γ[x]≡kd-j (lookup-/⟨⟩∈ σ∈Γ x))
               (Sp∈-/⟨⟩ j∈as∈l σ∈Γ)

    -- Applications in simple kinding are admissible.

    ?⟨⟩∈-?∙∙ : ∀ {n} {Γ : Ctx n} {r as k j} →
               Γ ⊢?⟨ k ⟩ r ∈ kd j → Γ ⊢ j ∋∙ as ∈ ★ → Γ ⊢Nf r ?∙∙⟨ k ⟩ as ∈ ★
    ?⟨⟩∈-?∙∙ (∈-hit a∈j)          j∋as∈★ = Nf∈-∙∙ a∈j j∋as∈★
    ?⟨⟩∈-?∙∙ (∈-miss y Γ[y]≡kd-j) j∋as∈★ = ∈-ne (∈-∙ (∈-var y Γ[y]≡kd-j) j∋as∈★)

    Nf∈-∙∙ : ∀ {n} {Γ : Ctx n} {a as j k} →
             Γ ⊢Nf a ∈ j → Γ ⊢ j ∋∙ as ∈ k → Γ ⊢Nf a ∙∙⟨ j ⟩ as ∈ k
    Nf∈-∙∙ a∈j   ∈-[]             = a∈j
    Nf∈-∙∙ a∈j⇒k (∈-∷ b∈j k∋as∈l) = Nf∈-∙∙ (Nf∈-Π-e a∈j⇒k b∈j) k∋as∈l

    Nf∈-Π-e : ∀ {n} {Γ : Ctx n} {a b j k} →
              Γ ⊢Nf a ∈ j ⇒ k → Γ ⊢Nf b ∈ j → Γ ⊢Nf a ⌜·⌝⟨ j ⇒ k ⟩ b ∈ k
    Nf∈-Π-e (∈-Π-i j-kds a∈k) b∈⌊j⌋ = Nf∈-/⟨⟩ a∈k (∈-hsub b∈⌊j⌋)

  -- Concatenation of simply well-formed spines results in application.
  Nf∈-++-∙∙⟨⟩ : ∀ {n} {Γ : Ctx n} {a bs cs j k l} →
                Γ ⊢Nf a ∈ j → Γ ⊢ j ∋∙ bs ∈ k → Γ ⊢ k ∋∙ cs ∈ l →
                a ∙∙⟨ j ⟩ (bs List.++ cs) ≡ a ∙∙⟨ j ⟩ bs ∙∙⟨ k ⟩ cs
  Nf∈-++-∙∙⟨⟩ a∈j     ∈-[]                  k∋cs∈l = refl
  Nf∈-++-∙∙⟨⟩ a∈j₁⇒j₂ (∈-∷ b∈j₁ j₂[b]∋bs∈k) k∋cs∈l =
    Nf∈-++-∙∙⟨⟩ (Nf∈-Π-e a∈j₁⇒j₂ b∈j₁) j₂[b]∋bs∈k k∋cs∈l

  -- Another admissible kinding rule for applications.
  Nf∈-Π-e′ : ∀ {n} {Γ : Ctx n} {a b j k} →
             Γ ⊢Nf a ∈ j ⇒ k → Γ ⊢Nf b ∈ j → Γ ⊢Nf a ↓⌜·⌝ b ∈ k
  Nf∈-Π-e′ (∈-Π-i j-kds a∈k) b∈⌊j⌋ = Nf∈-/⟨⟩ a∈k (∈-hsub b∈⌊j⌋)

  mutual

    -- Simply well-kinded hereditary substitutions in simply
    -- well-formed kinds and simply well-kinded types commute.
    --
    -- NOTE: this is a variant of the `sub-commutes' lemma from
    -- Data.Fin.Substitution.Lemmas adapted to hereditary
    -- substitutions.

    kds-[]-/⟨⟩-↑⋆ : ∀ {i m n} (E : CtxExt (suc m) i) {Γ Δ}
                    {j b k l} {σ : SVSub m n} →
                    E ++ kd k ∷ Γ ⊢ j kds → Γ ⊢Nf b ∈ k → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                    j Kind/⟨ k ⟩ (sub b ↑⋆ i) Kind/⟨ l ⟩ σ ↑⋆ i ≡
                      j Kind/⟨ l ⟩ (σ ↑) ↑⋆ i Kind/⟨ k ⟩ sub (b /⟨ l ⟩ σ) ↑⋆ i
    kds-[]-/⟨⟩-↑⋆ E (kds-⋯ a∈★ b∈★)     c∈k σ∈Γ =
      cong₂ _⋯_ (Nf∈-[]-/⟨⟩-↑⋆ E a∈★ c∈k σ∈Γ) (Nf∈-[]-/⟨⟩-↑⋆ E b∈★ c∈k σ∈Γ)
    kds-[]-/⟨⟩-↑⋆ E (kds-Π j-kds k-kds) b∈k σ∈Γ =
      cong₂ Π (kds-[]-/⟨⟩-↑⋆ E j-kds b∈k σ∈Γ)
              (kds-[]-/⟨⟩-↑⋆ (_ ∷ E) k-kds b∈k σ∈Γ)

    Nf∈-[]-/⟨⟩-↑⋆ : ∀ {i m n} (E : CtxExt (suc m) i) {Γ Δ}
                    {a b j k l} {σ : SVSub m n} →
                    E ++ kd k ∷ Γ ⊢Nf a ∈ j → Γ ⊢Nf b ∈ k → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                    a /⟨ k ⟩ (sub b ↑⋆ i) /⟨ l ⟩ σ ↑⋆ i ≡
                      a /⟨ l ⟩ (σ ↑) ↑⋆ i /⟨ k ⟩ sub (b /⟨ l ⟩ σ) ↑⋆ i
    Nf∈-[]-/⟨⟩-↑⋆ E ∈-⊥-f b∈k σ∈Γ = refl
    Nf∈-[]-/⟨⟩-↑⋆ E ∈-⊤-f b∈k σ∈Γ = refl
    Nf∈-[]-/⟨⟩-↑⋆ E (∈-∀-f k-kds a∈★) b∈k σ∈Γ =
      cong (_∙ []) (cong₂ Π (kds-[]-/⟨⟩-↑⋆ E k-kds b∈k σ∈Γ)
                            (Nf∈-[]-/⟨⟩-↑⋆ (_ ∷ E) a∈★ b∈k σ∈Γ))
    Nf∈-[]-/⟨⟩-↑⋆ E (∈-→-f a∈★ b∈★)   c∈k σ∈Γ =
      cong (_∙ []) (cong₂ _⇒_ (Nf∈-[]-/⟨⟩-↑⋆ E a∈★ c∈k σ∈Γ)
                              (Nf∈-[]-/⟨⟩-↑⋆ E b∈★ c∈k σ∈Γ))
    Nf∈-[]-/⟨⟩-↑⋆ E (∈-Π-i j-kds a∈l) b∈k σ∈Γ =
      cong (_∙ []) (cong₂ Λ (kds-[]-/⟨⟩-↑⋆ E j-kds b∈k σ∈Γ)
                            (Nf∈-[]-/⟨⟩-↑⋆ (_ ∷ E) a∈l b∈k σ∈Γ))
    Nf∈-[]-/⟨⟩-↑⋆ E (∈-ne a∈★)        b∈k σ∈Γ = Ne∈-[]-/⟨⟩-↑⋆ E a∈★ b∈k σ∈Γ

    Ne∈-[]-/⟨⟩-↑⋆ : ∀ {i m n} (E : CtxExt (suc m) i) {Γ Δ}
                    {a b j k l} {σ : SVSub m n} →
                    E ++ kd k ∷ Γ ⊢Ne a ∈ j → Γ ⊢Nf b ∈ k → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                    a /⟨ k ⟩ (sub b ↑⋆ i) /⟨ l ⟩ σ ↑⋆ i ≡
                      a /⟨ l ⟩ (σ ↑) ↑⋆ i /⟨ k ⟩ sub (b /⟨ l ⟩ σ) ↑⋆ i
    Ne∈-[]-/⟨⟩-↑⋆ {i} E {b = b} (∈-∙ (∈-var x _) j∋as∈l) b∈k σ∈Γ
      with hit? (sub b ↑⋆ i) x
    Ne∈-[]-/⟨⟩-↑⋆ {i} E {_} {_} {var x ∙ as} {b} {_} {k} {l} {σ}
                  (∈-∙ (∈-var x Γ[x]=kd-j) j∋as∈l) b∈k σ∈Γ
      | hit a hitP =
      let σ₁′ = sub b ↑⋆ i
          σ₂′ = sub (b /⟨ l ⟩ σ) ↑⋆ i
          as₁ = as //⟨ k ⟩ σ₁′
          as₂ = as //⟨ l ⟩ ((σ ↑) ↑⋆ i)
          [b/i]∈E++k∷Γ = ∈-H↑⋆ E (∈-hsub b∈k)
          _ , j≡k   = lookup-/⟨⟩∈-Hit [b/i]∈E++k∷Γ (∈-var x Γ[x]=kd-j) hitP
          k∋as∈l    = subst (_ ⊢_∋∙ as ∈ _) j≡k j∋as∈l
          σ↑⋆i∈E++Γ = ∈-H↑⋆ (re-idx E) σ∈Γ
      in begin
        lookupSV σ₁′ x ?∙∙⟨ k ⟩ as₁ /⟨ l ⟩ σ ↑⋆ i
      ≡⟨ cong (λ r → r ?∙∙⟨ k ⟩ as₁ /⟨ l ⟩ _)
              (trans (lookup-Hit hitP) (cong hit (Hit-sub-↑⋆₂ i hitP))) ⟩
        weakenElim⋆ i b ∙∙⟨ k ⟩ as₁ /⟨ l ⟩ σ ↑⋆ i
      ≡⟨ Nf∈-∙∙-/⟨⟩ (Nf∈-weaken⋆ (re-idx E) b∈k)
                    (Sp∈-/⟨⟩ k∋as∈l [b/i]∈E++k∷Γ) σ↑⋆i∈E++Γ ⟩
        (weakenElim⋆ i b /⟨ l ⟩ σ ↑⋆ i) ∙∙⟨ k ⟩ (as₁ //⟨ l ⟩ σ ↑⋆ i)
      ≡⟨ cong₂ (_∙∙⟨ k ⟩_) (sym (weaken⋆-/⟨⟩-↑⋆ i b))
               (Sp∈-[]-/⟨⟩-↑⋆ E j∋as∈l b∈k σ∈Γ) ⟩
        weakenElim⋆ i (b /⟨ l ⟩ σ) ∙∙⟨ k ⟩ (as₂ //⟨ k ⟩ σ₂′)
      ≡˘⟨ cong (_?∙∙⟨ k ⟩ (as₂ //⟨ k ⟩ σ₂′)) (lookup-Hit (Hit-sub-↑⋆ i)) ⟩
        lookupSV σ₂′ (raise i zero) ?∙∙⟨ k ⟩ (as₂ //⟨ k ⟩ σ₂′)
      ≡⟨⟩
        miss (raise i zero) ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ≡˘⟨ cong (λ r → r ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′)
               (lookup-Miss (Miss-↑⋆ i under)) ⟩
        lookupSV ((σ ↑) ↑⋆ i) (raise i zero) ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ≡˘⟨ cong (λ y → lookupSV ((σ ↑) ↑⋆ i) y ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′)
               (Hit-sub-↑⋆₁ i hitP) ⟩
        lookupSV ((σ ↑) ↑⋆ i) x ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ∎
    Ne∈-[]-/⟨⟩-↑⋆ {i} E {_} {_} {var x ∙ as} {b} {_} {k} {l} {σ}
                  (∈-∙ (∈-var x Γ[x]=kd-j) j∋as∈l) b∈k σ∈Γ
      | miss y missP-[a/i] with hit? (σ ↑⋆ i) y
    ... | hit a hitP =
      let σ₁′ = sub b ↑⋆ i
          σ₂′ = sub (b /⟨ l ⟩ σ) ↑⋆ i
          as₁ = as //⟨ k ⟩ σ₁′
          as₂ = as //⟨ l ⟩ ((σ ↑) ↑⋆ i)
          hitP-σ↑↑⋆ = Hit-↑-↑⋆ i hitP
          σ₂′∈E++Γ  = ∈-H↑⋆ (re-idx E) (∈-hsub (Nf∈-/⟨⟩ b∈k σ∈Γ))
          σ∈E++k∷Γ  = ∈-H↑⋆ E (∈-H↑ σ∈Γ)
          x≡i+1+y   = Miss-sub-↑⋆′ i y missP-[a/i]
          i+1+y∈j   = subst (_ ⊢Var_∈ _) x≡i+1+y (∈-var x Γ[x]=kd-j)
          a∈l , j≡l = lookup-/⟨⟩∈-Hit σ∈E++k∷Γ i+1+y∈j hitP-σ↑↑⋆
          l∋as₂∈l   = subst (_ ⊢_∋∙ as₂ ∈ _) j≡l (Sp∈-/⟨⟩ j∋as∈l σ∈E++k∷Γ)
      in begin
        lookupSV σ₁′ x ?∙∙⟨ k ⟩ as₁ /⟨ l ⟩ σ ↑⋆ i
      ≡⟨ cong (λ r → r ?∙∙⟨ k ⟩ as₁ /⟨ l ⟩ σ ↑⋆ i) (lookup-Miss missP-[a/i]) ⟩
        var y ∙ as₁ /⟨ l ⟩ σ ↑⋆ i
      ≡⟨⟩
        lookupSV (σ ↑⋆ i) y ?∙∙⟨ l ⟩ (as₁ //⟨ l ⟩ σ ↑⋆ i)
      ≡⟨ cong₂ (_?∙∙⟨ l ⟩_) (lookup-Hit hitP) (Sp∈-[]-/⟨⟩-↑⋆ E j∋as∈l b∈k σ∈Γ) ⟩
        a ∙∙⟨ l ⟩ (as₂ //⟨ k ⟩ σ₂′)
      ≡˘⟨ cong (_∙∙⟨ l ⟩ (as₂ //⟨ k ⟩ σ₂′)) (/Var-wk-↑⋆-hsub-vanishes i a) ⟩
        (a Elim/Var V.wk V.↑⋆ i /⟨ k ⟩ σ₂′) ∙∙⟨ l ⟩ (as₂ //⟨ k ⟩ σ₂′)
      ≡˘⟨ Nf∈-∙∙-/⟨⟩ a∈l l∋as₂∈l σ₂′∈E++Γ ⟩
        (a Elim/Var V.wk V.↑⋆ i) ∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ≡˘⟨ cong (λ r → r ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′) (lookup-Hit hitP-σ↑↑⋆) ⟩
        lookupSV ((σ ↑) ↑⋆ i) (lift i suc y) ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ≡˘⟨ cong (λ z → lookupSV ((σ ↑) ↑⋆ i) z ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′) x≡i+1+y ⟩
        lookupSV ((σ ↑) ↑⋆ i) x ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ∎
    ... | miss z missP =
      let σ₁′ = sub b ↑⋆ i
          σ₂′ = sub (b /⟨ l ⟩ σ) ↑⋆ i
          as₁ = as //⟨ k ⟩ σ₁′
          as₂ = as //⟨ l ⟩ ((σ ↑) ↑⋆ i)
          missP-σ↑↑⋆ = Miss-↑-↑⋆ i missP
          x≡i+1+y    = Miss-sub-↑⋆′ i y missP-[a/i]
      in begin
        lookupSV σ₁′ x ?∙∙⟨ k ⟩ as₁ /⟨ l ⟩ σ ↑⋆ i
      ≡⟨ cong (λ r → r ?∙∙⟨ k ⟩ as₁ /⟨ l ⟩ σ ↑⋆ i) (lookup-Miss missP-[a/i]) ⟩
        var y ∙ as₁ /⟨ l ⟩ σ ↑⋆ i
      ≡⟨⟩
        lookupSV (σ ↑⋆ i) y ?∙∙⟨ l ⟩ (as₁ //⟨ l ⟩ σ ↑⋆ i)
      ≡⟨ cong₂ (_?∙∙⟨ l ⟩_) (lookup-Miss missP)
               (Sp∈-[]-/⟨⟩-↑⋆ E j∋as∈l b∈k σ∈Γ) ⟩
        var z ∙ (as₂ //⟨ k ⟩ σ₂′)
      ≡˘⟨ cong (_?∙∙⟨ k ⟩ (as₂ //⟨ k ⟩ σ₂′)) (lookup-Miss (Miss-sub-↑⋆ i z)) ⟩
        lookupSV σ₂′ (lift i suc z) ?∙∙⟨ k ⟩ (as₂ //⟨ k ⟩ σ₂′)
      ≡⟨⟩
        var (lift i suc z) ∙ as₂ /⟨ k ⟩ σ₂′
      ≡˘⟨ cong (λ r → r ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′) (lookup-Miss missP-σ↑↑⋆) ⟩
        lookupSV ((σ ↑) ↑⋆ i) (lift i suc y) ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ≡˘⟨ cong (λ z → lookupSV ((σ ↑) ↑⋆ i) z ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′) x≡i+1+y ⟩
        lookupSV ((σ ↑) ↑⋆ i) x ?∙∙⟨ l ⟩ as₂ /⟨ k ⟩ σ₂′
      ∎

    Sp∈-[]-/⟨⟩-↑⋆ : ∀ {i m n} (E : CtxExt (suc m) i) {Γ Δ}
                    {as b j₁ j₂ k l} {σ : SVSub m n} →
                    E ++ kd k ∷ Γ ⊢ j₁ ∋∙ as ∈ j₂ →
                    Γ ⊢Nf b ∈ k → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                    as //⟨ k ⟩ (sub b ↑⋆ i) //⟨ l ⟩ σ ↑⋆ i ≡
                      as //⟨ l ⟩ (σ ↑) ↑⋆ i //⟨ k ⟩ sub (b /⟨ l ⟩ σ) ↑⋆ i
    Sp∈-[]-/⟨⟩-↑⋆ E ∈-[]                b∈k σ∈Γ = refl
    Sp∈-[]-/⟨⟩-↑⋆ E (∈-∷ a∈j₁ j₂∋as∈j₃) b∈k σ∈Γ =
      cong₂ _∷_ (Nf∈-[]-/⟨⟩-↑⋆ E a∈j₁ b∈k σ∈Γ) (Sp∈-[]-/⟨⟩-↑⋆ E j₂∋as∈j₃ b∈k σ∈Γ)

    -- Reducing applications commute with hereditary substitution.

    Nf∈-∙∙-/⟨⟩ : ∀ {l m n Γ Δ} {σ : SVSub m n} {a as j k} →
                 Γ ⊢Nf a ∈ j → Γ ⊢ j ∋∙ as ∈ k → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                 a ∙∙⟨ j ⟩ as /⟨ l ⟩ σ ≡ (a /⟨ l ⟩ σ) ∙∙⟨ j ⟩ (as //⟨ l ⟩ σ)
    Nf∈-∙∙-/⟨⟩ a∈j ∈-[] σ∈Γ = refl
    Nf∈-∙∙-/⟨⟩ {l} {σ = σ} {a} {b ∷ bs} {j ⇒ k} a∈j⇒k (∈-∷ b∈j k∋bs∈l) σ∈Γ =
      begin
        a ⌜·⌝⟨ j ⇒ k ⟩ b ∙∙⟨ k ⟩ bs /⟨ l ⟩ σ
      ≡⟨ Nf∈-∙∙-/⟨⟩ (Nf∈-Π-e a∈j⇒k b∈j) k∋bs∈l σ∈Γ ⟩
        (a ⌜·⌝⟨ j ⇒ k ⟩ b /⟨ l ⟩ σ) ∙∙⟨ _ ⟩ (bs //⟨ l ⟩ σ)
      ≡⟨ cong (_∙∙⟨ k ⟩ (bs //⟨ l ⟩ σ)) (Nf∈-Π-e-/⟨⟩ a∈j⇒k b∈j σ∈Γ) ⟩
        (a /⟨ l ⟩ σ) ⌜·⌝⟨ j ⇒ k ⟩ (b /⟨ l ⟩ σ) ∙∙⟨ k ⟩ (bs //⟨ l ⟩ σ)
      ∎

    Nf∈-Π-e-/⟨⟩ : ∀ {l m n Γ Δ} {σ : SVSub m n} {a b j k} →
                  Γ ⊢Nf a ∈ j ⇒ k → Γ ⊢Nf b ∈ j → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                  a ⌜·⌝⟨ j ⇒ k ⟩ b /⟨ l ⟩ σ ≡
                    (a /⟨ l ⟩ σ) ⌜·⌝⟨ j ⇒ k ⟩ (b /⟨ l ⟩ σ)
    Nf∈-Π-e-/⟨⟩ (∈-Π-i j-kds a∈k) b∈⌊j⌋ σ∈Γ = Nf∈-[]-/⟨⟩-↑⋆ [] a∈k b∈⌊j⌋ σ∈Γ

  -- Potentially reducing applications commute with hereditary
  -- substitution.

  Nf∈-Π-e-/⟨⟩′ : ∀ {l m n Γ Δ} {σ : SVSub m n} {a b j k} →
                Γ ⊢Nf a ∈ j ⇒ k → Γ ⊢Nf b ∈ j → Δ ⊢/⟨ l ⟩ σ ∈ Γ →
                a ↓⌜·⌝ b /⟨ l ⟩ σ ≡ (a /⟨ l ⟩ σ) ↓⌜·⌝ (b /⟨ l ⟩ σ)
  Nf∈-Π-e-/⟨⟩′ {l} {σ = σ} {_} {b} (∈-Π-i {j} {a} j-kds a∈k) b∈⌊j⌋ σ∈Γ =
    begin
      (a [ b ∈ ⌊ j ⌋ ]) /⟨ l ⟩ σ
    ≡⟨ Nf∈-[]-/⟨⟩-↑⋆ [] a∈k b∈⌊j⌋ σ∈Γ ⟩
      (a /⟨ l ⟩ σ ↑) [ b /⟨ l ⟩ σ ∈ ⌊ j ⌋ ]
    ≡⟨ cong ((a /⟨ l ⟩ σ ↑) [ b /⟨ l ⟩ σ ∈_]) (sym (⌊⌋-Kind/⟨⟩ j)) ⟩
      (a /⟨ l ⟩ σ ↑) [ b /⟨ l ⟩ σ ∈ ⌊ j Kind/⟨ l ⟩ σ ⌋ ]
    ∎