module LC.Parallel where

open import LC.Base
open import LC.Subst
open import LC.Reduction

open import Data.Nat
open import Relation.Binary.Construct.Closure.ReflexiveTransitive

-- parallel β-reduction
infix 3 _β⇒_
data _β⇒_ : Term → Term → Set where

  β-var : {n : ℕ} → var n β⇒ var n

  β-ƛ : ∀ {M M'} → (M⇒M' : M β⇒ M') → ƛ M β⇒ ƛ M'

  β-∙ : ∀ {M M' N N'} → (M⇒M' : M β⇒ M') → (N⇒N' : N β⇒ N') → M ∙ N β⇒ M' ∙ N'

  β-ƛ-∙ : ∀ {M M' N N'} → (M⇒M' : M β⇒ M') → (N⇒N' : N β⇒ N') → (ƛ M) ∙ N β⇒ M' [ N' ]

-- properties
β⇒identity : ∀ {M} → M β⇒ M
β⇒identity {var x} = β-var
β⇒identity {ƛ M}   = β-ƛ β⇒identity
β⇒identity {M ∙ N} = β-∙ β⇒identity β⇒identity

to-parallel : ∀ {M N} → M β→ N → M β⇒ N
to-parallel β-ƛ-∙       = β-ƛ-∙ β⇒identity β⇒identity
to-parallel (β-ƛ M→N)   = β-ƛ (to-parallel M→N)
to-parallel (β-∙-l M→N) = β-∙ (to-parallel M→N) β⇒identity
to-parallel (β-∙-r M→N) = β-∙ β⇒identity (to-parallel M→N)

from-parallel : ∀ {M N} → M β⇒ N → M β→* N
from-parallel β-var             = ε
from-parallel (β-ƛ M⇒N)         = cong-ƛ (from-parallel M⇒N)
from-parallel (β-∙ M⇒M' N⇒N')   = cong-∙ (from-parallel M⇒M') (from-parallel N⇒N')
from-parallel (β-ƛ-∙ M⇒M' N⇒N') = return β-ƛ-∙ ◅◅ cong-[] (from-parallel M⇒M') (from-parallel N⇒N')

open import Relation.Binary.PropositionalEquality hiding ([_]; preorder)

≡⇒β⇒ : ∀ {M N} → M ≡ N → M β⇒ N
≡⇒β⇒ refl = β⇒identity

module Cong where

  open import LC.Subst.Term
  open import LC.Subst.Var

  β⇒cong-lift-ƛ : ∀ {n i M M' N N'} → M β⇒ M' → N β⇒ N' → (ƛ lift (suc n) i M) ∙ lift n i N β⇒ lift n i (M' [ N' ])
  β⇒cong-lift-ƛ β-var N→N' = {!   !}
  β⇒cong-lift-ƛ (β-ƛ M→M') N→N' = {!  !}
  β⇒cong-lift-ƛ (β-∙ M→M' M→M'') N→N' = {!   !}
  β⇒cong-lift-ƛ (β-ƛ-∙ M→M' M→M'') N→N' = {!    !}

  β⇒cong-lift : ∀ {n i M N} → M β⇒ N → lift n i M β⇒ lift n i N
  β⇒cong-lift β-var = β-var
  β⇒cong-lift (β-ƛ M→N) = β-ƛ (β⇒cong-lift M→N)
  β⇒cong-lift (β-∙ M→M' N→N') = β-∙ (β⇒cong-lift M→M') (β⇒cong-lift N→N')
  β⇒cong-lift (β-ƛ-∙ M→M' N→N') = β⇒cong-lift-ƛ M→M' N→N'

  β⇒cong-subst-var-match : ∀ {n i M N} → M β⇒ N → subst-var (match n i) M β⇒ subst-var (match n i) N
  β⇒cong-subst-var-match {n} {i} M→N with match n i
  ... | Under n<i = β-var
  ... | Exact n≡i = β⇒cong-lift M→N
  ... | Above v v≥i = β-var

  open import Relation.Binary.PropositionalEquality hiding ([_]; preorder)

  module Temp where

    lemma-1 : ∀ i m n o → (ƛ subst-var (match m (suc i)) (var n)) ∙ subst-var (match o i) (var n) ≡ (var m) [ var o ] [ var n / i ]
    lemma-1 i m n o with match m (suc i)
    ... | Under m<i+1 = {!   !}
    ... | Exact m≡i+1 = {!   !}
    ... | Above v v≥i+1 = {!   !}

    lemma-1-1 : ∀ i m n → subst-var (match m (suc i)) (var n) β⇒ {!   !}
    lemma-1-1 i m n = {!   !}

  β⇒cong-[]-ƛ-∙ : ∀ {i M M' N N' O O'} → M β⇒ M' → N β⇒ N' → O β⇒ O' → (ƛ M [ O / suc i ]) ∙ N [ O / i ] β⇒ (M' [ N' ]) [ O' / i ]
  β⇒cong-[]-ƛ-∙ {zero} (β-var {n}) (β-var {m}) (β-var {o}) = {!   !}
  β⇒cong-[]-ƛ-∙ {suc i} (β-var {n}) (β-var {m}) (β-var {o}) = {!   !}
  β⇒cong-[]-ƛ-∙ β-var β-var (β-ƛ O→O') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var β-var (β-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var β-var (β-ƛ-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ N→N') β-var = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ N→N') (β-ƛ O→O') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ N→N') (β-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ N→N') (β-ƛ-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-∙ N→N' N→N'') β-var = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-∙ N→N' N→N'') (β-ƛ O→O') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-∙ N→N' N→N'') (β-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-∙ N→N' N→N'') (β-ƛ-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ-∙ N→N' N→N'') β-var = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ-∙ N→N' N→N'') (β-ƛ O→O') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ-∙ N→N' N→N'') (β-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ β-var (β-ƛ-∙ N→N' N→N'') (β-ƛ-∙ O→O' O→O'') = {!   !}
  β⇒cong-[]-ƛ-∙ (β-ƛ M→M') N→N' O→O' = {!   !}
  β⇒cong-[]-ƛ-∙ (β-∙ M→M' M→M'') N→N' O→O' = {!   !}
  β⇒cong-[]-ƛ-∙ (β-ƛ-∙ M→M' M→M'') N→N' O→O' = {!   !}

  β⇒cong-[] : ∀ {i M M' N N'} → M β⇒ M' → N β⇒ N' → M [ N / i ] β⇒ M' [ N' / i ]
  β⇒cong-[] {i} (β-var {n}) N→N' = β⇒cong-subst-var-match {n} {i} N→N'
  β⇒cong-[] (β-ƛ M→M') N→N' = β-ƛ (β⇒cong-[] M→M' N→N')
  β⇒cong-[] (β-∙ M→M' M→M'') N→N' = β-∙ (β⇒cong-[] M→M' N→N') (β⇒cong-[] M→M'' N→N')
  β⇒cong-[] (β-ƛ-∙ M→M' M→M'') N→N' = {!   !}
    -- β⇒cong-[]-ƛ-∙ M→M' M→M'' N→N'
    -- β-∙ {!   !} {!   !}

    -- (ƛ M [ N₁ / suc i ]) ∙ N [ N₁ / i ] β⇒ M' [ N' ] [ N'' / i ]

    -- ((ƛ M) ∙ N) → M' [ N' ]
    -- ((ƛ M) ∙ N) [ N₁ / i ] β⇒ M' [ N' ] [ N'' / i ]
    --  M→M' N→N'  !} (β⇒cong-[] M→M'' N→N')

  -- β⇒cong-[] {i} {var x} {.(var x)} {var y} {.(var y)} β-var β-var with match x i
  -- ... | Under x<i = β-var
  -- ... | Exact x≡i = β-var
  -- ... | Above v v≥i = β-var
  -- β⇒cong-[] {i} {var x} {.(var x)} {ƛ N} {.(ƛ _)} β-var (β-ƛ N→N') with match x i
  -- ... | Under x<i = β-var
  -- ... | Exact x≡i = β-ƛ (β⇒cong-lift N→N')
  -- ... | Above v v≥i = β-var
  -- β⇒cong-[] {i} {var x} {.(var x)} {N ∙ O} {N'} β-var N→N' with match x i
  -- ... | Under x<i = β-var
  -- ... | Exact x≡i = {!   !}
  -- ... | Above v v≥i = β-var
  -- β⇒cong-[] {i} {ƛ M} {M'} {N} {N'} M→M' N→N' = {!   !}
  -- β⇒cong-[] {i} {M ∙ K} {M'} {N} {N'} M→M' N→N' = {!   !}

β⇒cong-[] : ∀ {M M' N N'} → M β⇒ M' → N β⇒ N' → M [ N ] β⇒ M' [ N' ]
β⇒cong-[] = Cong.β⇒cong-[]


module Luau.Syntax where

open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Bool using (Bool; true; false)
open import Agda.Builtin.Float using (Float)
open import Agda.Builtin.String using (String)
open import Luau.Var using (Var)
open import Luau.Addr using (Addr)
open import Luau.Type using (Type)
open import FFI.Data.Maybe using (Maybe; just; nothing)

infixr 5 _∙_

data Annotated : Set where
  maybe : Annotated
  yes : Annotated

data VarDec : Annotated → Set where
  var : Var → VarDec maybe
  var_∈_ : ∀ {a} → Var → Type → VarDec a

name : ∀ {a} → VarDec a → Var
name (var x) = x
name (var x ∈ T) = x

data FunDec : Annotated → Set where
  _⟨_⟩∈_ : ∀ {a} → Var → VarDec a → Type → FunDec a
  _⟨_⟩ : Var → VarDec maybe → FunDec maybe

fun : ∀ {a} → FunDec a → VarDec a
fun (f ⟨ x ⟩∈ T) = (var f ∈ T)
fun (f ⟨ x ⟩) = (var f)

arg : ∀ {a} → FunDec a → VarDec a
arg (f ⟨ x ⟩∈ T) = x
arg (f ⟨ x ⟩) = x

data BinaryOperator : Set where
  + : BinaryOperator
  - : BinaryOperator
  * : BinaryOperator
  / : BinaryOperator
  < : BinaryOperator
  > : BinaryOperator
  == : BinaryOperator
  ~= : BinaryOperator
  <= : BinaryOperator
  >= : BinaryOperator
  ·· : BinaryOperator

data Value : Set where
  nil : Value
  addr : Addr → Value
  number : Float → Value
  bool : Bool → Value
  string : String → Value

data Block (a : Annotated) : Set
data Stat (a : Annotated) : Set
data Expr (a : Annotated) : Set

data Block a where
  _∙_ : Stat a → Block a → Block a
  done : Block a

data Stat a where
  function_is_end : FunDec a → Block a → Stat a
  local_←_ : VarDec a → Expr a → Stat a
  return : Expr a → Stat a

data Expr a where
  var : Var → Expr a
  val : Value → Expr a
  _$_ : Expr a → Expr a → Expr a
  function_is_end : FunDec a → Block a → Expr a
  block_is_end : VarDec a → Block a → Expr a
  binexp : Expr a → BinaryOperator → Expr a → Expr a

isAnnotatedᴱ : ∀ {a} → Expr a → Maybe (Expr yes)
isAnnotatedᴮ : ∀ {a} → Block a → Maybe (Block yes)

isAnnotatedᴱ (var x) = just (var x)
isAnnotatedᴱ (val v) = just (val v)
isAnnotatedᴱ (M $ N) with isAnnotatedᴱ M | isAnnotatedᴱ N
isAnnotatedᴱ (M $ N) | just M′ | just N′ = just (M′ $ N′)
isAnnotatedᴱ (M $ N) | _ | _ = nothing
isAnnotatedᴱ (function f ⟨ var x ∈ T ⟩∈ U is B end) with isAnnotatedᴮ B
isAnnotatedᴱ (function f ⟨ var x ∈ T ⟩∈ U is B end) | just B′ = just (function f ⟨ var x ∈ T ⟩∈ U is B′ end)
isAnnotatedᴱ (function f ⟨ var x ∈ T ⟩∈ U is B end) | _ = nothing
isAnnotatedᴱ (function _ is B end) = nothing
isAnnotatedᴱ (block var b ∈ T is B end) with isAnnotatedᴮ B
isAnnotatedᴱ (block var b ∈ T is B end) | just B′ = just (block var b ∈ T is B′ end)
isAnnotatedᴱ (block var b ∈ T is B end) | _ = nothing
isAnnotatedᴱ (block _ is B end) = nothing
isAnnotatedᴱ (binexp M op N) with isAnnotatedᴱ M | isAnnotatedᴱ N
isAnnotatedᴱ (binexp M op N) | just M′ | just N′ = just (binexp M′ op N′)
isAnnotatedᴱ (binexp M op N) | _ | _ = nothing

isAnnotatedᴮ (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) with isAnnotatedᴮ B | isAnnotatedᴮ C
isAnnotatedᴮ (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) | just B′ | just C′ = just (function f ⟨ var x ∈ T ⟩∈ U is C′ end ∙ B′)
isAnnotatedᴮ (function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B) | _ | _ = nothing
isAnnotatedᴮ (function _ is C end ∙ B) = nothing
isAnnotatedᴮ (local var x ∈ T ← M ∙ B) with isAnnotatedᴱ M | isAnnotatedᴮ B
isAnnotatedᴮ (local var x ∈ T ← M ∙ B) | just M′ | just B′ = just (local var x ∈ T ← M′ ∙ B′)
isAnnotatedᴮ (local var x ∈ T ← M ∙ B) | _ | _ = nothing
isAnnotatedᴮ (local _ ← M ∙ B) = nothing
isAnnotatedᴮ (return M ∙ B) with isAnnotatedᴱ M | isAnnotatedᴮ B
isAnnotatedᴮ (return M ∙ B) | just M′ | just B′ = just (return M′ ∙ B′)
isAnnotatedᴮ (return M ∙ B) | _ | _ = nothing
isAnnotatedᴮ done = just done


module CantOpenConstructorsFromRecordModule where

module Datatypes where
  record Foo : Set where
    constructor foo

ok : Datatypes.Foo
ok = Datatypes.foo

open Datatypes.Foo

bad : Datatypes.Foo
bad = foo


module Prelude.IO where

open import Prelude.Function
open import Prelude.Functor
open import Prelude.Applicative
open import Prelude.Monad
open import Prelude.List
open import Prelude.String
open import Prelude.Char
open import Prelude.Unit
open import Prelude.Show
open import Prelude.Nat

open import Agda.Builtin.IO public

postulate
  ioReturn : ∀ {a} {A : Set a} → A → IO A
  ioBind   : ∀ {a b} {A : Set a} {B : Set b} → IO A → (A → IO B) → IO B

{-# COMPILE GHC ioReturn = (\ _ _ -> return)    #-}
{-# COMPILE GHC ioBind =   (\ _ _ _ _ -> (>>=)) #-}

{-# COMPILE UHC ioReturn = (\ _ _ x -> UHC.Agda.Builtins.primReturn x) #-}
{-# COMPILE UHC ioBind =   (\ _ _ _ _ x y -> UHC.Agda.Builtins.primBind x y) #-}

ioMap : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → IO A → IO B
ioMap f m = ioBind m λ x → ioReturn (f x)

instance
  FunctorIO : ∀ {a} → Functor {a} IO
  fmap {{FunctorIO}} = ioMap

  ApplicativeIO : ∀ {a} → Applicative {a} IO
  pure {{ApplicativeIO}} = ioReturn
  _<*>_ {{ApplicativeIO}} = monadAp ioBind

  MonadIO : ∀ {a} → Monad {a} IO
  _>>=_ {{MonadIO}} = ioBind

  FunctorIO′ : ∀ {a b} → Functor′ {a} {b} IO
  fmap′ {{FunctorIO′}} = ioMap

  ApplicativeIO′ : ∀ {a b} → Applicative′ {a} {b} IO
  _<*>′_ {{ApplicativeIO′}} = monadAp′ ioBind

  MonadIO′ : ∀ {a b} → Monad′ {a} {b} IO
  _>>=′_ {{MonadIO′}} = ioBind

--- Terminal IO ---

postulate
  getChar  : IO Char
  putChar  : Char → IO Unit
  putStr   : String → IO Unit
  putStrLn : String → IO Unit

{-# FOREIGN GHC import qualified Data.Text    as Text #-}
{-# FOREIGN GHC import qualified Data.Text.IO as Text #-}

{-# COMPILE GHC getChar =  getChar   #-}
{-# COMPILE GHC putChar =  putChar   #-}
{-# COMPILE GHC putStr =   Text.putStr   #-}
{-# COMPILE GHC putStrLn = Text.putStrLn #-}

{-# COMPILE UHC putStr =   (UHC.Agda.Builtins.primPutStr) #-}
{-# COMPILE UHC putStrLn = (UHC.Agda.Builtins.primPutStrLn) #-}

print : ∀ {a} {A : Set a} {{ShowA : Show A}} → A → IO Unit
print = putStrLn ∘ show

--- Command line arguments ---

{-# FOREIGN GHC import System.Environment (getArgs, getProgName) #-}

postulate
  getArgs : IO (List String)
  getProgName : IO String

{-# COMPILE GHC getArgs =     fmap (map Text.pack) getArgs #-}
{-# COMPILE GHC getProgName = fmap Text.pack getProgName   #-}

--- Misc ---

{-# FOREIGN GHC import System.Exit #-}

data ExitCode : Set where
  Success : ExitCode
  -- TODO we probably should also enforce an upper limit?
  Failure : (n : Nat) → {p : NonZero n} → ExitCode

private
  {-# FOREIGN GHC exitWith' x = exitWith (if x == 0 then ExitSuccess else ExitFailure $ fromInteger x) #-}

  postulate
    exitWith' : ∀ {a} {A : Set a} → Nat → IO A
  {-# COMPILE GHC exitWith' = \ _ _ -> exitWith' #-}

exitWith : ∀ {a} {A : Set a} → ExitCode → IO A
exitWith Success = exitWith' 0
exitWith (Failure i) = exitWith' i


-- Andreas, 2017-03-10, issue #2493, reported by nad
-- {-# OPTIONS -v tc.meta.assign:10 -v tc.size:90 -v tc:30 #-}

A : Set
A = {!!}

P : A → Set
P = {!λ _ → ?!}  -- give

-- Giving this made Agda loop as it solved ?0 := A.
-- Solution: don't assign metas during CheckInternal!


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

-- Approx. 15-20 min are required to typecheck this file (for Agda 2.6.1) on
-- my MacBook 13-inch 2017 with 3.5 GHz Core i7 CPU and 16 GB memory.
--
-- Since most of the time was spent for termination analysis, please
-- uncomment {-# TERMINATING #-} before evalR and eval to remove the
-- termination checks.

module Definitional where

open import Syntax

open import Data.Nat
open import Data.Fin using (Fin ; suc; zero)

open import Data.List using (length ; [] ; _∷_ )
open import Data.List.Properties using (length-++)
open import Data.Vec  using ([] ; _∷_)
open import Data.Vec.Relation.Unary.All using (All ; [] ; _∷_)
open import Data.Product

open import Relation.Binary.PropositionalEquality

open import Level renaming (zero to lzero ; suc to lsuc)
open ≡-Reasoning

open import Function using () renaming (case_of_ to CASE_OF_)

open import Value

open import Size
open import Codata.Thunk

module Interpreter where
  open import Codata.Delay renaming (length to dlength ; map to dmap )

  open import PInj
  open _⊢_⇔_

  -- A variant of the Delay monad in which the bind operator is
  -- frozen. While we cannot restrict levels in general, using Set is
  -- enough for enough for our purpose.

  data DELAY : (A : Set) -> (i : Size) -> Set₁ where
    Now   : ∀ {A i} -> A -> DELAY A i
    Later : ∀ {A i} -> Thunk (DELAY A) i -> DELAY A i
    Bind  : ∀ {A B i}
            -> (m : DELAY A i) -> (f : A -> DELAY B i) -> DELAY B i

  Never : ∀ {A i} -> DELAY A i
  Never = Later λ where .force -> Never

  Dmap : ∀ {A B i} -> (A -> B) -> DELAY A i -> DELAY B i
  Dmap f d = Bind d (λ x -> Now (f x))

  -- The function runD thaws the frozen operations.
  runD : ∀ {A : Set} {i : Size} -> DELAY A i -> Delay A i
  runD (Now x) = now x
  runD (Later x) = later λ where .force -> runD (force x)
  runD (Bind d f) = bind (runD d) (λ x -> runD (f x))

  -- The frozen version of _⊢_⇔_
  record _⊢F_⇔_ (i : Size) (A B : Set) : Set₁ where
    field
      Forward  : A -> DELAY B i
      Backward : B -> DELAY A i

  open _⊢F_⇔_

  forwardF  : ∀ {A B i} -> i ⊢F A ⇔ B -> A -> Delay B i
  forwardF h a = runD (Forward h a)

  backwardF : ∀ {A B i} -> i ⊢F A ⇔ B -> B -> Delay A i
  backwardF h b = runD (Backward h b)

  -- Similarly to runD, runD⇔ thawas the frozen operations in
  -- _⊢F_⇔_.
  runD⇔ : ∀ {A B i} -> i ⊢F A ⇔ B -> i ⊢ A ⇔ B
  forward  (runD⇔ f) = forwardF f
  backward (runD⇔ f) = backwardF f

  -- Environments handled by the forward and backward evaluations,
  -- which correponds to μ in the paper.
  data RValEnv : (Θ : TyEnv) (Ξ : MultEnv (length Θ)) -> Set where
    []   : RValEnv [] []
    skip : ∀ {Θ Ξ A} -> RValEnv Θ Ξ -> RValEnv (A ∷ Θ) (zero ∷ Ξ)
    _∷_  : ∀ {Θ Ξ A} -> Value [] ∅ A -> RValEnv Θ Ξ -> RValEnv (A ∷ Θ) (one ∷ Ξ)

  emptyRValEnv : ∀ {Θ} -> RValEnv Θ ∅
  emptyRValEnv {[]} = []
  emptyRValEnv {_ ∷ _} = skip emptyRValEnv

  splitRValEnv : ∀ {Θ Ξ₁ Ξ₂} -> RValEnv Θ (Ξ₁ +ₘ Ξ₂) -> RValEnv Θ Ξ₁ × RValEnv Θ Ξ₂
  splitRValEnv {[]} {[]} {[]} [] = [] , []
  splitRValEnv {_ ∷ Θ} {zero ∷ Ξ₁} {zero ∷ Ξ₂} (skip ρ)
    with splitRValEnv ρ
  ... | ρ₁ , ρ₂ = skip ρ₁ , skip ρ₂
  splitRValEnv {_ ∷ Θ} {zero ∷ Ξ₁} {one ∷ Ξ₂} (x ∷ ρ)
    with splitRValEnv ρ
  ... | ρ₁ , ρ₂ =  skip ρ₁ , x ∷ ρ₂
  splitRValEnv {_ ∷ Θ} {one ∷ Ξ₁} {zero ∷ Ξ₂} (x ∷ ρ)
    with splitRValEnv ρ
  ... | ρ₁ , ρ₂ = x ∷ ρ₁ , skip ρ₂

  -- An inverse of splitRValEnv.
  mergeRValEnv : ∀ {Θ Ξ₁ Ξ₂} -> all-no-omega (Ξ₁ +ₘ Ξ₂) -> RValEnv Θ Ξ₁ -> RValEnv Θ Ξ₂ -> RValEnv Θ (Ξ₁ +ₘ Ξ₂)
  mergeRValEnv {.[]} {.[]} {.[]} _ [] [] = []
  mergeRValEnv {.(_ ∷ _)} {.(zero ∷ _)} {.(zero ∷ _)} (_ ∷ ano) (skip ρ₁) (skip ρ₂) = skip (mergeRValEnv ano ρ₁ ρ₂)
  mergeRValEnv {.(_ ∷ _)} {.(zero ∷ _)} {.(one ∷ _)} (_ ∷ ano) (skip ρ₁) (x ∷ ρ₂) = x ∷ (mergeRValEnv ano ρ₁ ρ₂)
  mergeRValEnv {.(_ ∷ _)} {.(one ∷ _)} {.(zero ∷ _)} (_ ∷ ano) (x ∷ ρ₁) (skip ρ₂) = x ∷ mergeRValEnv ano ρ₁ ρ₂
  mergeRValEnv {.(_ ∷ _)} {.(one ∷ _)} {.(one ∷ _)} (() ∷ ano) (x ∷ ρ₁) (x₁ ∷ ρ₂)

  -- Construction of the empty value environment.
  from-all-zero : ∀ {Θ Ξ} -> all-zero Ξ -> RValEnv Θ Ξ
  from-all-zero {[]} {[]} [] = []
  from-all-zero {_ ∷ Θ} {.(zero ∷ _)} (refl ∷ az) = skip (from-all-zero az)

  -- Value environments conforms to an empty invertible environment must be empty.
  all-zero-canon : ∀ {Θ Ξ} -> (az : all-zero Ξ) -> (θ : RValEnv Θ Ξ) -> θ ≡ (from-all-zero az)
  all-zero-canon {[]} {[]} [] [] = refl
  all-zero-canon {_ ∷ Θ} {_ ∷ Ξ} (refl ∷ az) (skip θ) = cong skip (all-zero-canon az θ)

  -- Looking-up function for RValEnv
  lkup : ∀ {Θ A} {x : Θ ∋ A} {Ξ} -> varOk● Θ x Ξ -> RValEnv Θ Ξ -> Value [] ∅ A
  lkup (there ok) (skip ρ) = lkup ok ρ
  lkup (here ad) (x ∷ ρ) = x -- ad asserts ρ consists only of skip and []

  -- An inverse of lkup; the linearity matters here.
  unlkup : ∀ {Θ A} {x : Θ ∋ A} {Ξ} -> varOk● Θ x Ξ -> Value [] ∅ A -> RValEnv Θ Ξ
  unlkup (there ok) v = skip (unlkup ok v)
  unlkup (here ad) v = v ∷ from-all-zero ad

  -- Some utility functions.
  var●₀ : ∀ {A Θ} -> Residual (A ∷ Θ) (one ∷ ∅) (A ●)
  var●₀ = var● vz (here all-zero-∅)

  BindR : ∀ {i Θ Ξ A} {r : Set} -> DELAY (Value Θ Ξ (A ●)) i -> (Residual Θ Ξ (A ●) -> DELAY r i) -> DELAY r i
  BindR x f = Bind x λ { (red r) -> f r }

  -- For the do trick for the pattern matching
  -- See https://github.com/agda/agda/issues/2298
  _>>=_ : ∀ {a b : Level} {A : Set a} {B : A -> Set b} -> ∀ (x : A) -> (∀ x -> B x) -> B x
  x >>= f = f x

  -- Function application.
  apply :
    ∀ {Θ Ξ₁ Ξ₂ A m B} i ->
    all-no-omega (Ξ₁ +ₘ m ×ₘ Ξ₂) ->
    Value Θ Ξ₁ (A # m ~> B) -> Value Θ Ξ₂ A -> DELAY (Value Θ (Ξ₁ +ₘ m ×ₘ Ξ₂) B) i

  -- Forward, backward and unidirectional evalautions are given as
  -- mutually recursive functions. Notice that, the existence of these
  -- functions essentially proves the type safety (i.e., the
  -- preservation and progree prperty). Thus, in a sense, they are
  -- generalizations of Lemma 3.1 and Lemma 3.2 in the paper.

  -- Forward and backward evaluation.
  -- {-# TERMINATING #-}
  evalR :
    ∀ {Θ Ξ A} i ->
    all-no-omega Ξ -> Residual Θ Ξ (A ●) -> i ⊢F (RValEnv Θ Ξ) ⇔ Value [] ∅ A

  -- Unidirectional evaluation. Also, an important thing is that this function keeps
  -- the invariant all-no-omega (Ξₑ +ₘ Ξ) for recursive calls, which essentially supports
  -- the claim in Section 3.4: "This assumption is actually an invariant in our system ...".

  -- {-# TERMINATING #-}
  eval :
    ∀ {Θ Ξₑ Γ Δ Ξ A} i ->
    all-no-omega (Ξₑ +ₘ Ξ) -> ValEnv Γ Δ Θ Ξₑ -> Term Γ Δ Θ Ξ A -> DELAY (Value Θ (Ξₑ +ₘ Ξ) A) i

  apply {Θ} {Ξ₁} {Ξ₂} i ano (clo {Ξ' = Ξ'} {Ξₜ = Ξₜ} m refl θ t) v with all-no-omega-dist _ _ ano
  ... | ano-'t , ano-m2 = Later λ { .force {j} ->
        let T = eval j (subst all-no-omega lemma ano) (tup _ _ refl (value-to-multM ano-m2 v) θ) t
        in subst (λ x -> DELAY (Value Θ x _) j) (sym lemma) T
      }
    where
      lemma : Ξ' +ₘ Ξₜ +ₘ m ×ₘ Ξ₂ ≡ m ×ₘ Ξ₂ +ₘ Ξ' +ₘ Ξₜ
      lemma = trans (+ₘ-comm _ _)
                    (sym (+ₘ-assoc (m ×ₘ Ξ₂) Ξ' _))

  -- evalR is defined so that evalR ∞ ano r actually defines a
  -- bijection. See Invertiblity.agda for its proof.

  Forward  (evalR i ano unit●) _ = Now (unit refl)
  Backward (evalR i ano unit●) _ = Now emptyRValEnv

  Forward  (evalR i ano (letunit● r₁ r₂)) ρ = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    ρ₁ , ρ₂ <- splitRValEnv ρ
    Bind (Forward (evalR i ano₁ r₁) ρ₁) λ { (unit eq) -> Forward (evalR i ano₂ r₂) ρ₂ }
  Backward (evalR i ano (letunit● r₁ r₂)) v = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    Bind (Backward (evalR i ano₂ r₂) v) λ ρ₂ ->
     Bind (Backward (evalR i ano₁ r₁) (unit refl)) λ ρ₁ ->
      Now (mergeRValEnv ano ρ₁ ρ₂)

  Forward  (evalR i ano (pair● r₁ r₂)) ρ = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    ρ₁  , ρ₂  <- splitRValEnv ρ
    Bind (Forward (evalR i ano₁ r₁) ρ₁) λ v₁ ->
     Bind (Forward (evalR i ano₂ r₂) ρ₂) λ v₂ ->
      Now (pair refl v₁ v₂)

  Backward (evalR i ano (pair● {A = A} {B} r₁ r₂)) (pair {Ξ₁ = []} {[]} spΞ v₁ v₂) = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    Bind (Backward (evalR i ano₁ r₁) v₁) λ ρ₁ ->
     Bind (Backward (evalR i ano₂ r₂) v₂) λ ρ₂ ->
      Now (mergeRValEnv ano ρ₁ ρ₂)

  Forward (evalR i ano (letpair● r₁ r₂)) ρ = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    ρ₁  , ρ₂  <- splitRValEnv ρ
    Bind (Forward (evalR i ano₁ r₁) ρ₁) λ {
      (pair {Ξ₁ = []} {[]} spΞ v₁ v₂ ) ->
        Forward (evalR i (one ∷ one ∷ ano₂) r₂) (v₁ ∷ v₂ ∷ ρ₂)
     }

  Backward (evalR i ano (letpair● r₁ r₂)) v = do
    ano₁ , ano₂ <-  all-no-omega-dist _ _ ano
    Bind (Backward (evalR i (one ∷ one ∷ ano₂) r₂) v) λ { (v₁ ∷ v₂ ∷ ρ₂) ->
      Bind (Backward (evalR i ano₁ r₁) (pair refl v₁ v₂)) λ ρ₁ ->
       Now (mergeRValEnv ano ρ₁ ρ₂)
     }

  Forward (evalR i ano (inl● r)) ρ = Bind (Forward (evalR i ano r) ρ) λ x -> Now (inl x)
  Backward (evalR i ano (inl● r)) v =
    CASE v OF λ {
      (inl v₁) -> Backward (evalR i ano r) v₁ ;
      (inr v₂) -> Never
    }

  Forward  (evalR i ano (inr● r)) ρ = Bind (Forward (evalR i ano r) ρ) λ x -> Now (inr x)
  Backward (evalR i ano (inr● r)) v =
    CASE v OF λ {
      (inl v₁) -> Never ;
      (inr v₂) -> Backward (evalR i ano r) v₂
    }

  Forward  (evalR i ano (case● {Γ₁ = Γ₁} {Γ₂} r refl θ₁ t₁ θ₂ t₂ f)) ρ = do
    ano₀ , ano- <- all-no-omega-dist _ _ ano
    ρ₀  , ρ-  <- splitRValEnv ρ
    Bind (Forward (evalR i ano₀ r) ρ₀) λ {
          (inl v₁) ->
            Bind (eval i (one ∷ ano-) (weakenΘ-valEnv Γ₁ (compat-ext-here ext-id) θ₁) t₁) λ { (red r₁) ->
              Later λ { .force {j} ->
                Bind (Forward (evalR j (one ∷ ano-) r₁) (v₁ ∷ ρ-)) λ v ->
                 Bind (apply j [] f v) λ {
                   (inl _) -> Now v ;
                   (inr _) -> Never
                  }
              }
            }
           ;
          (inr v₂) ->
            Bind (eval i (one ∷ ano-) (weakenΘ-valEnv Γ₂ (compat-ext-here ext-id) θ₂) t₂) λ { (red r₂) ->
              Later λ { .force {j} ->
                Bind (Forward (evalR j (one ∷ ano-) r₂) (v₂ ∷ ρ-)) λ v ->
                  Bind (apply j [] f v) λ {
                    (inl _) -> Never ;
                    (inr _) -> Now v
                  }
               }
            }
        }

  Backward (evalR i ano (case● {Γ₁ = Γ₁} {Γ₂} r refl θ₁ t₁ θ₂ t₂ f)) v = do
    ano₀ , ano- <- all-no-omega-dist _ _ ano
    Bind (apply i [] f v) λ {
      (inl _) ->
         Bind (eval i (one ∷ ano-) (weakenΘ-valEnv Γ₁ (compat-ext-here ext-id) θ₁) t₁) λ { (red r₁) ->
           Later λ { .force {j} ->
               Bind (Backward (evalR j (one ∷ ano-) r₁) v) λ { (v₁ ∷ ρ-) ->
                 Bind (Backward (evalR j ano₀ r) (inl v₁)) λ ρ₀ ->
                     Now (mergeRValEnv ano ρ₀ ρ-)
               }
            }
         }
      ;
      (inr _) ->
          Bind (eval i (one ∷ ano-) (weakenΘ-valEnv Γ₂ (compat-ext-here ext-id) θ₂) t₂) λ { (red r₂) ->
            Later λ where .force {j} ->
                             Bind (Backward (evalR j (one ∷ ano-) r₂) v) λ { (v₂ ∷ ρ-) ->
                               Bind (Backward (evalR j ano₀ r) (inr v₂)) λ ρ₀ ->
                                 Now (mergeRValEnv ano ρ₀ ρ-)
                             }
          }
     }

  Forward  (evalR i ano (var● x ok)) ρ = Now (lkup ok ρ)
  Backward (evalR i ano (var● x ok)) v  = Now (unlkup ok v)

  Forward (evalR i ano (pin r f))  ρ = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    ρ₁  , ρ₂  <- splitRValEnv ρ
    Bind (Forward (evalR i ano₁ r) ρ₁) λ v₁ ->
      CASE f OF λ { (clo .omega refl θ t) →
        Later λ { .force {j} ->
           Bind (eval j ano₂ (tup ∅ _ (∅-lid _) (mult-omega (weakenΘ-value extendΘ v₁) refl) θ) t) λ {
            (red r₂) ->
              -- maybe another delaying would be needed here
              Bind (Forward (evalR j ano₂ r₂) ρ₂) λ v₂ ->
              Now (pair refl v₁ v₂)
           }
        }
      }

  Backward (evalR i ano (pin r (clo .omega refl θ t))) (pair {Ξ₁ = []} {[]} refl v₁ v₂) = do
    ano₁ , ano₂ <- all-no-omega-dist _ _ ano
    Later λ { .force {j} ->
      BindR (eval j ano₂ (tup ∅ _ (∅-lid _) (mult-omega (weakenΘ-value extendΘ v₁) refl) θ) t) λ r₂ ->
        Bind (Backward (evalR j ano₂ r₂) v₂) λ ρ₂ ->
        Bind (Backward (evalR j ano₁ r) v₁) λ ρ₁ ->
        Now (mergeRValEnv ano ρ₁ ρ₂)
     }

  -- The unidirectional evaluation, of which definition would be
  -- routine except for rather tedious manipulation of value
  -- environments.

  eval {Θ} _ ano θ (var x ok) = Now (subst (λ x -> Value Θ x _) (sym (∅-rid _)) (lookupVar θ ok))
  eval _ ano θ (abs m t) = Now (clo m refl θ t)

  eval {Θ} {Γ = Γ} i ano θ (app {Δ₁ = Δ₁} {Δ₂} {Ξ₁ = Ξ₁} {Ξ₂} {m = m} t₁ t₂)
      with separateEnv {Γ} Δ₁ (m ×ₘ Δ₂) θ
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂ with eval i (proj₁ lemma) θ₁ t₁ | proj₂ lemma | un×ₘ-valEnv Γ θ₂
    where
      lemma' : Ξₑ₁ +ₘ Ξₑ₂ +ₘ (Ξ₁ +ₘ m ×ₘ Ξ₂) ≡ (Ξₑ₁ +ₘ Ξ₁) +ₘ (Ξₑ₂ +ₘ m ×ₘ Ξ₂)
      lemma' = +ₘ-transpose Ξₑ₁ Ξₑ₂ Ξ₁ (m ×ₘ Ξ₂)

      lemma : all-no-omega (Ξₑ₁ +ₘ Ξ₁) × all-no-omega (Ξₑ₂ +ₘ m ×ₘ Ξ₂)
      lemma = all-no-omega-dist (Ξₑ₁ +ₘ Ξ₁) _ (subst all-no-omega lemma' ano)
  ... | T₁ | ano-e2m2 | Ξₑ₂' , θ₂' , refl with (subst all-no-omega (sym (×ₘ-dist m Ξₑ₂' _)) ano-e2m2)
  ... | ano-m[e2'2] with eval i (all-no-omega-dist-×ₘ m (Ξₑ₂' +ₘ Ξ₂) ano-m[e2'2]) θ₂' t₂
  ... | T₂ =
    Bind T₁ (λ { (clo {Ξ' = Ξ'} {Ξₜ = Ξₜ} m spΞ θf t) → Bind T₂ λ v₂ ->
      Later λ { .force ->
        let lemma : m ×ₘ (Ξₑ₂' +ₘ Ξ₂) +ₘ Ξ' +ₘ Ξₜ ≡ Ξₑ₁ +ₘ m ×ₘ Ξₑ₂' +ₘ (Ξ₁ +ₘ m ×ₘ Ξ₂)
            lemma =
              begin
                m ×ₘ (Ξₑ₂' +ₘ Ξ₂) +ₘ Ξ' +ₘ Ξₜ
              ≡⟨ +ₘ-assoc (m ×ₘ (Ξₑ₂' +ₘ Ξ₂)) Ξ' _ ⟩
                m ×ₘ (Ξₑ₂' +ₘ Ξ₂) +ₘ (Ξ' +ₘ Ξₜ)
              ≡⟨ cong (_ +ₘ_) spΞ ⟩
                m ×ₘ (Ξₑ₂' +ₘ Ξ₂) +ₘ (Ξₑ₁ +ₘ Ξ₁)
              ≡⟨ cong (_+ₘ _) (×ₘ-dist m Ξₑ₂' Ξ₂) ⟩
                m ×ₘ Ξₑ₂' +ₘ m ×ₘ Ξ₂ +ₘ (Ξₑ₁ +ₘ Ξ₁)
              ≡⟨ +ₘ-transpose (m ×ₘ Ξₑ₂') (m ×ₘ Ξ₂) Ξₑ₁ _ ⟩
                m ×ₘ Ξₑ₂' +ₘ Ξₑ₁ +ₘ (m ×ₘ Ξ₂ +ₘ Ξ₁)
              ≡⟨ cong₂ (_+ₘ_) (+ₘ-comm _ _) (+ₘ-comm _ _) ⟩
                Ξₑ₁ +ₘ m ×ₘ Ξₑ₂' +ₘ (Ξ₁ +ₘ m ×ₘ Ξ₂)
              ∎

            lemma-ano : all-no-omega (m ×ₘ (Ξₑ₂' +ₘ Ξ₂) +ₘ Ξ' +ₘ Ξₜ)
            lemma-ano = subst all-no-omega (sym lemma) ano

        in (Bind (eval _ lemma-ano (tup (m ×ₘ (Ξₑ₂' +ₘ Ξ₂)) Ξ' refl (value-to-multM ano-m[e2'2] v₂) θf) t) λ v ->  Now (subst (λ Ξ -> Value Θ Ξ _) lemma v)
       )}
    })

  eval {Γ = Γ} _ ano θ (unit ad) with discardable-has-no-resources {Γ} θ ad
  ... | refl = Now (substV (sym (∅-lid _)) (unit refl))

  eval {Θ} {Ξₑ} {Γ} i ano θ (letunit {Δ₀ = Δ₀} {Δ} {Ξ₀ = Ξ₀} {Ξ} m t₀ t)
    with separateEnv {Γ} (m ×ₘ Δ₀) Δ θ
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂
    with un×ₘ-valEnv Γ θ₁
  ... | Ξₑ₁' , θ₁' , refl
    with subst all-no-omega (+ₘ-transpose (m ×ₘ Ξₑ₁') Ξₑ₂ (m ×ₘ Ξ₀) _) ano
  ... | ano'
    with all-no-omega-dist (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀) _ ano'
  ... | ano-me1'm0 , ano-e2
    with eval i (all-no-omega-dist-×ₘ m (Ξₑ₁' +ₘ Ξ₀) (subst all-no-omega (sym (×ₘ-dist m Ξₑ₁' Ξ₀)) ano-me1'm0)) θ₁' t₀
  ... | T₀ = Bind T₀ λ { (unit emp-e1'0) →
      let lemma : Ξₑ₂ +ₘ Ξ ≡ (m ×ₘ Ξₑ₁' +ₘ Ξₑ₂) +ₘ ((m ×ₘ Ξ₀) +ₘ Ξ)
          lemma =
            begin
              Ξₑ₂ +ₘ Ξ
            ≡⟨ sym (∅-lid _) ⟩
              ∅ +ₘ (Ξₑ₂ +ₘ Ξ)
            ≡⟨ cong (_+ₘ (Ξₑ₂ +ₘ Ξ)) (sym (×ₘ∅ m)) ⟩
              m ×ₘ ∅ +ₘ (Ξₑ₂ +ₘ Ξ)
            ≡⟨ cong (λ h -> m ×ₘ h +ₘ (Ξₑ₂ +ₘ Ξ)) (emp-e1'0) ⟩
              m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ (Ξₑ₂ +ₘ Ξ)
            ≡⟨ cong (_+ₘ _) (×ₘ-dist m Ξₑ₁' Ξ₀) ⟩
              m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ)
            ≡⟨ +ₘ-transpose (m ×ₘ Ξₑ₁') (m ×ₘ Ξ₀) Ξₑ₂ Ξ ⟩
              (m ×ₘ Ξₑ₁' +ₘ Ξₑ₂) +ₘ ((m ×ₘ Ξ₀) +ₘ Ξ)
            ∎
      in Dmap (substV lemma) (eval i ano-e2 θ₂ t)
   }

  eval {Θ} {Ξₑ} {Γ} i ano θ (pair {Δ₁ = Δ₁} {Δ₂} {Ξ₁ = Ξ₁} {Ξ₂} t₁ t₂)
    with separateEnv {Γ} Δ₁ Δ₂ θ
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂
    with subst all-no-omega (+ₘ-transpose Ξₑ₁ Ξₑ₂ Ξ₁ _) ano
  ... | ano'
    with all-no-omega-dist (Ξₑ₁ +ₘ Ξ₁) _ ano'
  ... | ano-e11 , ano-e22
    with eval i ano-e11 θ₁ t₁ | eval i ano-e22 θ₂ t₂
  ... | T₁ | T₂ = Bind T₁ λ v₁ ->
                  Bind T₂ λ v₂ -> Now (pair (+ₘ-transpose Ξₑ₁ Ξ₁ Ξₑ₂ _) v₁ v₂)

  eval {Θ} {Ξₑ} {Γ} i ano θ (letpair {Δ₀ = Δ₀} {Δ} {Ξ₀ = Ξ₀} {Ξ} m t₀ t)
    with separateEnv {Γ} (m ×ₘ Δ₀) Δ θ
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂
    with un×ₘ-valEnv Γ θ₁
  ... | Ξₑ₁' , θ₁' , refl
    with subst all-no-omega (+ₘ-transpose (m ×ₘ Ξₑ₁') Ξₑ₂ (m ×ₘ Ξ₀) Ξ) ano
  ... | ano'
    with all-no-omega-dist (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀) _ ano'
  ... | ano-me1'm0 , ano-e2-
    with subst all-no-omega (sym (×ₘ-dist m Ξₑ₁' _)) ano-me1'm0
  ... | ano-m[e1'0]
    with all-no-omega-dist-×ₘ m _ ano-m[e1'0]
  ... | ano-e1'0
    with eval i ano-e1'0 θ₁' t₀
  ... | T₀  = Bind T₀ λ { (pair {Ξ₁ = Ξ₁} {Ξ₂} spΞ v₁ v₂) →
                   let ano-m[12] : all-no-omega (m ×ₘ (Ξ₁ +ₘ Ξ₂))
                       ano-m[12] = subst all-no-omega (cong (m ×ₘ_) (sym spΞ)) ano-m[e1'0]

                       ano-m1m2 : all-no-omega (m ×ₘ Ξ₁ +ₘ m ×ₘ Ξ₂)
                       ano-m1m2 = subst all-no-omega (×ₘ-dist m Ξ₁ Ξ₂) ano-m[12]

                       an : all-no-omega (m ×ₘ Ξ₁) × all-no-omega (m ×ₘ Ξ₂)
                       an = all-no-omega-dist (m ×ₘ Ξ₁) _ ano-m1m2

                       eq : m ×ₘ Ξ₁ +ₘ (m ×ₘ Ξ₂ +ₘ Ξₑ₂) ≡ m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ Ξₑ₂
                       eq = begin
                              m ×ₘ Ξ₁ +ₘ (m ×ₘ Ξ₂ +ₘ Ξₑ₂)
                            ≡⟨ sym (+ₘ-assoc (m ×ₘ Ξ₁) (m ×ₘ Ξ₂) _) ⟩
                              m ×ₘ Ξ₁ +ₘ m ×ₘ Ξ₂ +ₘ Ξₑ₂
                            ≡⟨ cong (_+ₘ Ξₑ₂) (sym (×ₘ-dist m Ξ₁ Ξ₂)) ⟩
                              m ×ₘ (Ξ₁ +ₘ Ξ₂) +ₘ Ξₑ₂
                            ≡⟨ cong (_+ₘ Ξₑ₂) (cong (m ×ₘ_) spΞ) ⟩
                              m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ Ξₑ₂
                            ≡⟨ cong (_+ₘ Ξₑ₂) (×ₘ-dist m _ _) ⟩
                              m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ Ξₑ₂
                            ∎

                       θ' : ValEnv (_ ∷ _ ∷ Γ) (M→M₀ m ∷ M→M₀ m ∷ Δ) Θ (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ Ξₑ₂)
                       θ' = tup (m ×ₘ Ξ₁) _ eq (value-to-multM (proj₁ an) v₁)
                                  (tup (m ×ₘ Ξ₂) Ξₑ₂ refl (value-to-multM (proj₂ an) v₂) θ₂)

                       eq' : m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ Ξₑ₂ +ₘ Ξ ≡ (m ×ₘ Ξₑ₁' +ₘ Ξₑ₂) +ₘ (m ×ₘ Ξ₀ +ₘ Ξ)
                       eq' = begin
                              m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ Ξₑ₂ +ₘ Ξ
                             ≡⟨ +ₘ-assoc (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀) Ξₑ₂ _ ⟩
                              m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ)
                             ≡⟨ +ₘ-transpose (m ×ₘ Ξₑ₁') (m ×ₘ Ξ₀) Ξₑ₂ _ ⟩
                              (m ×ₘ Ξₑ₁' +ₘ Ξₑ₂) +ₘ (m ×ₘ Ξ₀ +ₘ Ξ)
                             ∎
                           -- solve 4 (λ a b c d ->
                           --                 ((a ⊞ b) ⊞ c) ⊞ d ⊜
                           --                 (a ⊞ c) ⊞ (b ⊞ d)) refl (m ×ₘ Ξₑ₁') (m ×ₘ Ξ₀) Ξₑ₂ Ξ
                   in Dmap (substV eq') (eval i (subst all-no-omega (sym eq') ano) θ' t)
              }

  eval {Θ} {Ξₑ} {Γ} i ano θ (many m t) = do
    (Ξₑ' , θ' , refl) <- un×ₘ-valEnv Γ θ
    ano-m[e'-] <- subst all-no-omega (sym (×ₘ-dist m Ξₑ' _)) ano
    ano-e'- <- all-no-omega-dist-×ₘ m _ ano-m[e'-]
    Bind (eval i ano-e'- θ' t) λ v ->
      Now (many m (×ₘ-dist m Ξₑ' _) v)

  eval {Θ} {Ξₑ} {Γ} i ano θ (unmany {Δ₀ = Δ₀} {Δ} {Ξ₀ = Ξ₀} {Ξ} {m₀ = m₀} {A} m t₀ t) = do
    tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂  <- separateEnv {Γ} (m ×ₘ Δ₀) Δ θ
    Ξₑ₁' , θ₁' , refl <-  un×ₘ-valEnv Γ θ₁
    ano' <- subst all-no-omega (+ₘ-transpose (m ×ₘ Ξₑ₁') Ξₑ₂ (m ×ₘ Ξ₀) Ξ) ano
    ano-me1'm0 , ano-e2 <-  all-no-omega-dist (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀) _ ano'
    ano-m[e1'0] <- subst all-no-omega (sym (×ₘ-dist m Ξₑ₁' _)) ano-me1'm0
    ano-e1'0    <- all-no-omega-dist-×ₘ m _ ano-m[e1'0]
    Bind (eval i ano-e1'0 θ₁' t₀ ) λ where
      (many {Ξ₀ = Ξ''} .m₀ sp v₀) -> do
        let ano-mm₀[e1'0] : all-no-omega (m ×ₘ m₀ ×ₘ Ξ'')
            ano-mm₀[e1'0] = subst all-no-omega (cong (m ×ₘ_) (sym sp)) ano-m[e1'0]

            ano-mul[e1'0] : all-no-omega (mul m m₀ ×ₘ Ξ'')
            ano-mul[e1'0] = subst all-no-omega (sym (mul-×ₘ m m₀ Ξ'')) ano-mm₀[e1'0]

            eq : m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ) ≡ mul m m₀ ×ₘ Ξ'' +ₘ Ξₑ₂ +ₘ Ξ
            eq =
              begin
                m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ)
                ≡⟨ cong (_+ₘ _) (sym (×ₘ-dist m Ξₑ₁' _)) ⟩
                m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ (Ξₑ₂ +ₘ Ξ)
                ≡⟨ cong (λ e -> m ×ₘ e +ₘ _) (sym sp) ⟩
                m ×ₘ m₀ ×ₘ Ξ'' +ₘ (Ξₑ₂ +ₘ Ξ)
                ≡⟨ cong (_+ₘ _) (sym (mul-×ₘ m m₀ Ξ'')) ⟩
                mul m m₀ ×ₘ Ξ'' +ₘ (Ξₑ₂ +ₘ Ξ)
                ≡⟨ sym (+ₘ-assoc _ _ _) ⟩
                mul m m₀ ×ₘ Ξ'' +ₘ Ξₑ₂ +ₘ Ξ
              ∎

            ano'' : all-no-omega (mul m m₀ ×ₘ Ξ'' +ₘ Ξₑ₂ +ₘ Ξ)
            ano'' = subst all-no-omega eq ano'

            θ' : ValEnv (A ∷ Γ) (M→M₀ (mul m m₀) ∷ Δ) Θ (mul m m₀ ×ₘ Ξ'' +ₘ Ξₑ₂)
            θ' = tup _ Ξₑ₂ refl (value-to-multM ano-mul[e1'0] v₀) θ₂
        Bind (eval i ano'' θ' t) λ v -> Now (substV (trans (sym eq) (sym (+ₘ-transpose (m ×ₘ Ξₑ₁') Ξₑ₂ (m ×ₘ Ξ₀) Ξ))) v)

  eval i ano θ (inl t) = Dmap inl (eval i ano θ t)
  eval i ano θ (inr t) = Dmap inr (eval i ano θ t)
  eval {Θ} {Ξₑ = Ξₑ} {Γ} i ano θ (case {Δ₀ = Δ₀} {Δ} {Ξ₀ = Ξ₀} {Ξ} m t₀ t₁ t₂)
    with separateEnv {Γ} (m ×ₘ Δ₀) Δ θ
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂
    with un×ₘ-valEnv Γ θ₁
  ... | Ξₑ₁' , θ₁' , refl
    with subst all-no-omega (+ₘ-transpose (m ×ₘ Ξₑ₁') Ξₑ₂ (m ×ₘ Ξ₀) Ξ) ano
  ... | ano'
    with all-no-omega-dist (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀) _ ano'
  ... | ano-me1'm0 , ano-e2-
    with subst all-no-omega (sym (×ₘ-dist m Ξₑ₁' _)) ano-me1'm0
  ... | ano-m[e1'0]
    with all-no-omega-dist-×ₘ m _ ano-m[e1'0]
  ... | ano-e1'0
    with eval i ano-e1'0 θ₁' t₀
  ... | T₀ =  Bind T₀ λ {
                (inl v) →
                  let θ' : ValEnv (_ ∷ Γ) (M→M₀ m ∷ Δ) Θ (m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ Ξₑ₂)
                      θ' = tup (m ×ₘ (Ξₑ₁' +ₘ Ξ₀)) Ξₑ₂ refl (value-to-multM ano-m[e1'0] v) θ₂
                  in Dmap (substV lemma) (eval i (subst all-no-omega (sym lemma) ano) θ' t₁) ;
                (inr v) →
                  let θ' : ValEnv (_ ∷ Γ) (M→M₀ m ∷ Δ) Θ (m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ Ξₑ₂)
                      θ' = tup (m ×ₘ (Ξₑ₁' +ₘ Ξ₀)) Ξₑ₂ refl (value-to-multM ano-m[e1'0] v) θ₂
                  in Dmap (substV lemma) (eval i (subst all-no-omega (sym lemma) ano) θ' t₂)
              }
      where
        lemma : m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ Ξₑ₂ +ₘ Ξ ≡
                (m ×ₘ Ξₑ₁' +ₘ Ξₑ₂) +ₘ (m ×ₘ Ξ₀ +ₘ Ξ)
        lemma =
          begin
            m ×ₘ (Ξₑ₁' +ₘ Ξ₀) +ₘ Ξₑ₂ +ₘ Ξ
          ≡⟨ cong (λ x -> x +ₘ Ξₑ₂ +ₘ Ξ) (×ₘ-dist m Ξₑ₁' _) ⟩
            m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ Ξₑ₂ +ₘ Ξ
          ≡⟨ +ₘ-assoc (m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀) Ξₑ₂ _ ⟩
            m ×ₘ Ξₑ₁' +ₘ m ×ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ)
          ≡⟨ +ₘ-transpose _ _ _ _ ⟩
           (m ×ₘ Ξₑ₁' +ₘ Ξₑ₂) +ₘ (m ×ₘ Ξ₀ +ₘ Ξ)
          ∎

  eval i ano θ (roll t) = Dmap roll (eval i ano θ t)
  eval i ano θ (unroll t) =
   Bind (eval i ano θ t) λ { (roll v) → Later λ where .force -> Now v  }

  eval {Γ = Γ} i ano θ (unit● ad) with discardable-has-no-resources {Γ} θ ad
  ... | refl = Now (red (substR (sym (∅-lid _)) unit●))

  eval {Θ} {Ξₑ} {Γ} i ano θ (letunit● {Δ₀ = Δ₀} {Δ} {Ξ₀ = Ξ₀} {Ξ} t₀ t) = do
    tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂ <- separateEnv {Γ} Δ₀ Δ θ
    let lemma : Ξₑ₁ +ₘ Ξₑ₂ +ₘ (Ξ₀ +ₘ Ξ) ≡ Ξₑ₁ +ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ)
        lemma = +ₘ-transpose _ _ _ _
    let ano' = subst all-no-omega lemma ano
    ano-e10 , ano-e2- <- all-no-omega-dist (Ξₑ₁ +ₘ Ξ₀) _ ano'
    BindR (eval i ano-e10 θ₁ t₀) λ E₀ ->
     BindR (eval i ano-e2- θ₂ t) λ E ->
       Now (red (substR (sym lemma) (letunit● E₀ E)))

  eval {Θ} {Ξₑ} {Γ} i ano θ (pair● {Δ₁ = Δ₁} {Δ₂} {Ξ₁ = Ξ₁} {Ξ₂} t₁ t₂) = do
    tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂ <- separateEnv {Γ} Δ₁ Δ₂ θ
    let lemma : Ξₑ₁ +ₘ Ξₑ₂ +ₘ (Ξ₁ +ₘ Ξ₂) ≡ Ξₑ₁ +ₘ Ξ₁ +ₘ (Ξₑ₂ +ₘ Ξ₂)
        lemma = +ₘ-transpose _ _ _ _
    let ano' = subst all-no-omega lemma ano
    ano-e11 , ano-e22 <- all-no-omega-dist (Ξₑ₁ +ₘ Ξ₁) _ ano'
    BindR (eval i ano-e11 θ₁ t₁) λ E₁ ->
      BindR (eval i ano-e22 θ₂ t₂) λ E₂ ->
        Now (red (substR (sym lemma) (pair● E₁ E₂)))

  eval {Θ} {Ξₑ} {Γ} i ano θ (letpair● {Δ₀ = Δ₀} {Δ} {Ξ₀ = Ξ₀} {Ξ} t₀ t)
    with separateEnv {Γ} Δ₀ Δ θ
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂
    with subst all-no-omega (+ₘ-transpose Ξₑ₁ Ξₑ₂ Ξ₀ _) ano
  ... | ano'
    with all-no-omega-dist (Ξₑ₁ +ₘ Ξ₀) _ ano'
  ... | ano-e10 , ano-e2-
    with eval i ano-e10 θ₁ t₀ | eval i (one ∷ one ∷ ano-e2-) (weakenΘ-valEnv Γ (compat-ext-here (compat-ext-here ext-id)) θ₂) t
  ... | T₁ | T =
    Bind T₁ λ { (red E₁) ->
     Bind T  λ { (red E ) ->
       Now (red (substR (+ₘ-transpose Ξₑ₁ Ξ₀ _ _) (letpair● E₁ E)))
     }}

  eval i ano θ (inl● t) =
    BindR (eval i ano θ t) λ E -> Now (red (inl● E))

  eval i ano θ (inr● t) =
    BindR (eval i ano θ t) λ E -> Now (red (inr● E))

  eval {Θ} {Ξₑ} {Γ} i ano θ (case● {Δ₀ = Δ₀} {Δ} {Δ'} {Ξ₀ = Ξ₀} {Ξ} {Ξ'} t t₁ t₂ t₃)
    with separateEnv {Γ} (Δ₀ +ₘ Δ) _ θ
  ... | tup Ξₑ₁₂ Ξₑ₃ refl θ' θ₃
    with discardable-has-no-resources {Γ} θ₃ (omega×ₘ-discardable Δ')
  ... | refl
    with un×ₘ-valEnv Γ θ₃
  ... | Ξₑ₃' , θ₃' , eq
    with omega×ₘ∅-inv Ξₑ₃' eq
  ... | refl
    with separateEnv {Γ} Δ₀ Δ θ'
  ... | tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂
    with subst all-no-omega lemma ano | lemma
    where
      open import Algebra.Solver.CommutativeMonoid (+ₘ-commutativeMonoid (length Θ))
                  renaming (_⊕_ to _⊞_)

      lemma : Ξₑ₁ +ₘ Ξₑ₂ +ₘ ∅ +ₘ (Ξ₀ +ₘ Ξ +ₘ omega ×ₘ Ξ')
              ≡ (Ξₑ₁ +ₘ Ξ₀) +ₘ (Ξₑ₂ +ₘ Ξ) +ₘ omega ×ₘ Ξ'
      lemma = solve 5 (\a b c d e -> ((a ⊞ b) ⊞ id) ⊞ ((c ⊞ d) ⊞ e)
                                     ⊜ ((a ⊞ c) ⊞ (b ⊞ d)) ⊞ e) refl Ξₑ₁ Ξₑ₂ Ξ₀ Ξ (omega ×ₘ Ξ')
  ... | ano' | lemma
    with all-no-omega-dist ((Ξₑ₁ +ₘ Ξ₀) +ₘ (Ξₑ₂ +ₘ Ξ)) _ ano'
  ... | ano'' , ano₃
    with all-no-omega-dist (Ξₑ₁ +ₘ Ξ₀) _ ano''
  ... | ano-e10 , ano-e2-
    with all-no-omega-omega×ₘ Ξ' ano₃
  ... | refl
    with eval i ano-e10 θ₁ t | eval i (subst all-no-omega (sym (∅-lid _)) all-no-omega-∅) θ₃' t₃
  ... | T | T₃ =
        Bind T λ { (red r) ->
        Bind T₃ λ { f ->
          Now (red (substR (trans lemma' (sym lemma))
            let f' = weakenΘ-value smashΘ (subst (λ x -> Value Θ x _) (∅-lid ∅) f)
            in (case● r refl θ₂ t₁ θ₂ t₂ f')))
        }
        }
      where
        lemma' : Ξₑ₁ +ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ)
                 ≡ Ξₑ₁ +ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ) +ₘ omega ×ₘ ∅
        lemma' =
          sym (trans (cong (λ x -> Ξₑ₁ +ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ) +ₘ x)
                           (×ₘ∅ omega))
                     (∅-rid (Ξₑ₁ +ₘ Ξ₀ +ₘ (Ξₑ₂ +ₘ Ξ) )))

  eval {Θ} {Ξₑ} {Γ} i ano θ (var● x ad ok)
    with discardable-has-no-resources {Γ} θ ad
  ... | refl = Now (red (substR (sym (∅-lid _)) (var● x ok)))

  eval {Θ} {Ξₑ} {Γ} i ano θ (pin {Δ₁ = Δ₁} {Δ₂} {Ξ₁ = Ξ₁} {Ξ₂} t₁ t₂) = do
    tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂  <- separateEnv {Γ} Δ₁ Δ₂ θ
    let ano' = subst all-no-omega (+ₘ-transpose Ξₑ₁ Ξₑ₂ Ξ₁ _) ano
    ano-e11 , ano-e22 <- all-no-omega-dist (Ξₑ₁ +ₘ Ξ₁) _ ano'
    BindR (eval i ano-e11 θ₁ t₁) λ r ->
      Bind (eval i ano-e22 θ₂ t₂) λ v ->
        Now (red (substR (+ₘ-transpose _ _ _ _) (pin r v)))

  eval {Γ = Γ} i ano θ (unlift e) = do
    Ξ' , θ' , refl <- un×ₘ-valEnv Γ θ
    ano₁ , ano₂  <- all-no-omega-dist _ _ ano
    refl <- all-no-omega-omega×ₘ _ ano₁
    refl <- all-no-omega-omega×ₘ _ ano₂
    Bind (eval i (subst all-no-omega (sym (∅-lid ∅)) all-no-omega-∅ ) θ' e) λ v ->
      BindR (apply i (one ∷ subst all-no-omega (sym lemma₁) all-no-omega-∅) (weakenΘ-value (compat-ext-here ext-id) v) (red var●₀)) λ r ->
        Now (substV (sym lemma₂) (inj refl (weakenΘ-residual (compat-skip smashΘ) (substR (cong (one ∷_) lemma₁) r) )))
    where
      open import Data.Vec.Properties using (map-id)
      lemma₁ : ∀ {n} -> ∅ +ₘ ∅ +ₘ Data.Vec.map (λ y -> y) ∅ ≡ ∅ {n}
      lemma₁ {n} rewrite map-id (∅ {n}) | ∅-rid {n} ∅ = ∅-lid ∅

      lemma₂ : ∀ {n} -> omega ×ₘ ∅ +ₘ omega ×ₘ ∅ ≡ ∅ {n}
      lemma₂ {n} rewrite ×ₘ∅ {n} omega | ∅-lid {n} ∅ = refl

  eval {Γ = Γ} i ano θ (fapp e₁ e₂) = do
    anoₑ , ano'  <- all-no-omega-dist _ _ ano
    ano₁ , ano'' <- all-no-omega-dist _ _ ano'
    refl <- all-no-omega-omega×ₘ _ ano''
    tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂  <- separateEnv {Γ} _ _ θ
    Ξₑ₂' , θ₂' , refl <- un×ₘ-valEnv Γ θ₂
    ano₁' , _ <- all-no-omega-dist _ _ (subst all-no-omega lemma' ano)
    Bind (eval i ano₁' θ₁ e₁) λ {
      (inj spΞ r) → do
        refl , refl <- ∅+ₘ∅-inv _ _ (sym spΞ)
        refl <- all-no-omega-omega×ₘ _ (subst all-no-omega (∅-lid _) anoₑ)
        Bind (eval i (subst all-no-omega (sym (∅-lid ∅)) all-no-omega-∅) θ₂' e₂) λ v -> Later λ { .force {j} ->
           Bind (Forward (evalR j (one ∷ all-no-omega-∅) r) (weakenΘ-value smashΘ (substV (∅-lid ∅) v) ∷ [])) λ v' ->
            Now (substV (sym lemma) (weakenΘ-value extendΘ v'))
         }
     }
    where
      lemma' : ∀ {n} {Ξₑ₁ Ξ₁ X Y : MultEnv n} -> Ξₑ₁ +ₘ X +ₘ (Ξ₁ +ₘ Y) ≡ Ξₑ₁ +ₘ Ξ₁ +ₘ (X +ₘ Y)
      lemma' {n} {A} {B} {C} {D} = +ₘ-transpose A C B D

      lemma : ∀ {n} -> ∅ +ₘ omega ×ₘ ∅ +ₘ (∅ +ₘ omega ×ₘ ∅) ≡ ∅ {n}
      lemma {n} rewrite ×ₘ∅ {n} omega | ∅-lid {n} ∅ = ∅-lid ∅

  eval {Γ = Γ} i ano θ (bapp e₁ e₂) = do
    anoₑ , ano'  <- all-no-omega-dist _ _ ano
    ano₁ , ano'' <- all-no-omega-dist _ _ ano'
    refl <- all-no-omega-omega×ₘ _ ano''
    tup Ξₑ₁ Ξₑ₂ refl θ₁ θ₂  <- separateEnv {Γ} _ _ θ
    Ξₑ₂' , θ₂' , refl <- un×ₘ-valEnv Γ θ₂
    ano₁' , _ <- all-no-omega-dist _ _ (subst all-no-omega lemma' ano)
    Bind (eval i ano₁' θ₁ e₁) λ {
      (inj spΞ r) → do
        refl , refl <- ∅+ₘ∅-inv _ _ (sym spΞ)
        refl <- all-no-omega-omega×ₘ _ (subst all-no-omega (∅-lid _) anoₑ)
        Bind (eval i (subst all-no-omega (sym (∅-lid ∅)) all-no-omega-∅) θ₂' e₂) λ v -> Later λ { .force {j} ->
          Bind (Backward (evalR j (one ∷ all-no-omega-∅) r) (weakenΘ-value smashΘ (substV (∅-lid ∅) v))) λ { (v' ∷ []) ->
             Now (substV (sym lemma) (weakenΘ-value extendΘ v'))
           }
         }
     }
    where
      lemma' : ∀ {n} {Ξₑ₁ Ξ₁ X Y : MultEnv n} -> Ξₑ₁ +ₘ X +ₘ (Ξ₁ +ₘ Y) ≡ Ξₑ₁ +ₘ Ξ₁ +ₘ (X +ₘ Y)
      lemma' {n} {A} {B} {C} {D} = +ₘ-transpose A C B D

      lemma : ∀ {n} -> ∅ +ₘ omega ×ₘ ∅ +ₘ (∅ +ₘ omega ×ₘ ∅) ≡ ∅ {n}
      lemma {n} rewrite ×ₘ∅ {n} omega | ∅-lid {n} ∅ = ∅-lid ∅

open Interpreter public


module Issue1436-1 where

module A where

  infixl 20 _↑_
  infixl  1 _↓_

  data D : Set where
    ●       : D
    _↓_ _↑_ : D → D → D

module B where

  infix -1000000 _↓_

  data D : Set where
    _↓_ : D → D → D

open A
open B

-- The expression below is not parsed. If the number 20 above is
-- replaced by 19, then it is parsed…

rejected = ● ↑ ● ↓ ● ↑ ● ↓ ● ↑ ●


------------------------------------------------------------------------
-- Reduced canonical kinding for the undecidability proof
------------------------------------------------------------------------

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

module FOmegaInt.Kinding.Canonical.Reduced 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 using ([]; _∷_; _++_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product using (∃; _,_; _×_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Vec as Vec using ([]; _∷_)
open import Data.Vec.Properties as VecProps using (map-∘; map-cong)
open import Function using (_∘_)
open import Level using () renaming (zero to lzero)
open import Relation.Binary.PropositionalEquality

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.HereditarySubstitution using (Kind/⟨★⟩-/)
import FOmegaInt.Kinding.Canonical as CanonicalKinding

module C where
  open CanonicalKinding public
  open Kinding          public

------------------------------------------------------------------------
-- Reduced canonical kinding derivations.

module Kinding where
  open ElimCtx
  open Syntax
  open Substitution using (_Kind′[_])

  infix 4 _⊢_wf _ctx _⊢_kd
  infix 4 _⊢Nf_⇉_ _⊢Ne_⇉_ _⊢Var_⇉_ _⊢_⇉∙_⇉_ _⊢Nf_⇇_
  infix 4 _⊢_<∷_ _⊢_∼_
  infix 4 _⊢_⇉∙_∼_⇉_

  mutual

    -- Formation of kinds, bindings, and contexts.
    --
    -- NOTE. The rule kd-Π only supports first-order operators.

    data _⊢_kd {n} (Γ : Ctx n) : Kind Elim n → Set where
      kd-⋯ : ∀ {a b}   → Γ ⊢Nf a ⇉ a ⋯ a → Γ ⊢Nf b ⇉ b ⋯ b → Γ ⊢ a ⋯ b kd
      kd-Π : ∀ {a b k} → Γ ⊢Nf a ⇉ a ⋯ a → Γ ⊢Nf b ⇉ b ⋯ b →
             kd (a ⋯ b) ∷ Γ ⊢ k kd → Γ ⊢ Π (a ⋯ b) k kd

    data _⊢_wf {n} (Γ : Ctx n) : ElimAsc n → Set where
      wf-kd : ∀ {a} → Γ ⊢ a kd        → Γ ⊢ kd a wf
      wf-tp : ∀ {a} → Γ ⊢Nf a ⇉ a ⋯ a → Γ ⊢ tp a wf

    _ctx : ∀ {n} → Ctx n → Set
    Γ ctx = ContextFormation._wf _⊢_wf Γ

    -- Kind synthesis for variables, neutrals and βη-normal types.

    data _⊢Var_⇉_ {n} (Γ : Ctx n) : Fin n → Kind Elim n → Set where
      ⇉-var : ∀ {k} x → Γ ctx → lookup Γ x ≡ kd k → Γ ⊢Var x ⇉ k

    data _⊢Ne_⇉_ {n} (Γ : Ctx n) : Elim n → Kind Elim n → Set where
      ⇉-∙ : ∀ {x j k} {as : Spine n} → Γ ⊢Var x ⇉ j →
            Γ ⊢ j ⇉∙ as ⇉ k → Γ ⊢Ne var x ∙ as ⇉ k

    data _⊢Nf_⇉_ {n} (Γ : Ctx n) : Elim n → Kind Elim n → Set where
      ⇉-⊥-f : Γ ctx → Γ ⊢Nf ⊥∙ ⇉ ⊥∙ ⋯ ⊥∙
      ⇉-⊤-f : Γ ctx → Γ ⊢Nf ⊤∙ ⇉ ⊤∙ ⋯ ⊤∙
      ⇉-s-i : ∀ {a b c} → Γ ⊢Ne a ⇉ b ⋯ c → Γ ⊢Nf a ⇉ a ⋯ a

    -- Kind checking for η-long β-normal types.

    data _⊢Nf_⇇_ {n} (Γ : Ctx n) : Elim n → Kind Elim n → Set where
      ⇇-⇑  : ∀ {a j k} → Γ ⊢Nf a ⇉ j → Γ ⊢ j <∷ k → Γ ⊢Nf a ⇇ k

    -- Kind synthesis for spines.
    --
    -- Note the use of ordinary (instead of hereditary) substitution.

    data _⊢_⇉∙_⇉_ {n} (Γ : Ctx n)
      : Kind Elim n → Spine n → Kind Elim n → Set where
      ⇉-[] : ∀ {k} → Γ ⊢ k ⇉∙ [] ⇉ k
      ⇉-∷  : ∀ {a as b c j k} → Γ ⊢Nf a ⇇ b ⋯ c →
             Γ ⊢ j Kind′[ ⌞ a ⌟ ] ⇉∙ as ⇉ k → Γ ⊢ Π (b ⋯ c) j ⇉∙ a ∷ as ⇉ k

    -- Reduced canonical subkinding derivations.
    --
    -- NOTE. The rule <∷-Π only supports first-order operators.

    data _⊢_<∷_ {n} (Γ : Ctx n) : Kind Elim n → Kind Elim n → Set where
      <∷-⋯ : ∀ {a₁ a₂ b₁ b₂} →
             Γ ⊢ a₂ ∼ a₁ → Γ ⊢ b₁ ∼ b₂ → Γ ⊢ a₁ ⋯ b₁ <∷ a₂ ⋯ b₂
      <∷-Π : ∀ {a₁ a₂ b₁ b₂ k₁ k₂} → Γ ⊢ a₁ ∼ a₂ → Γ ⊢ b₂ ∼ b₁ →
             kd (a₂ ⋯ b₂) ∷ Γ ⊢ k₁ <∷ k₂ →
             Γ ⊢ Π (a₁ ⋯ b₁) k₁ <∷ Π (a₂ ⋯ b₂) k₂

    -- Canonical relatedness of proper types and spines.

    data _⊢_∼_ {n} (Γ : Ctx n) : Elim n → Elim n → Set where
      ∼-trans : ∀ {a b c} → Γ ⊢ a ∼ b → Γ ⊢ b ∼ c → Γ ⊢ a ∼ c
      ∼-⊥     : ∀ {a} → Γ ⊢Nf a ⇉ a ⋯ a → Γ ⊢ ⊥∙ ∼ a
      ∼-⊤     : ∀ {a} → Γ ⊢Nf a ⇉ a ⋯ a → Γ ⊢ a ∼ ⊤∙
      ∼-∙     : ∀ {x as₁ as₂ k b c} →
                Γ ⊢Var x ⇉ k → Γ ⊢ k ⇉∙ as₁ ∼ as₂ ⇉ b ⋯ c →
                Γ ⊢ var x ∙ as₁ ∼ var x ∙ as₂
      ∼-⟨|    : ∀ {a b c} → Γ ⊢Ne a ⇉ b ⋯ c → Γ ⊢ b ∼ a
      ∼-|⟩    : ∀ {a b c} → Γ ⊢Ne a ⇉ b ⋯ c → Γ ⊢ a ∼ c

    data _⊢_⇉∙_∼_⇉_ {n} (Γ : Ctx n)
      : Kind Elim n → Spine n → Spine n → Kind Elim n → Set where
      ∼-[] : ∀ {k} → Γ ⊢ k ⇉∙ [] ∼ [] ⇉ k
      ∼-∷  : ∀ {a as b bs c d j k} → Γ ⊢ c ∼ a → Γ ⊢ a ∼ d →
             Γ ⊢ a ∼ b → Γ ⊢ j Kind′[ ⌞ a ⌟ ] ⇉∙ as ∼ bs ⇉ k →
             Γ ⊢ Π (c ⋯ d) j ⇉∙ a ∷ as ∼ b ∷ bs ⇉ k

  -- Well-formed context extensions.
  open ContextFormation _⊢_wf public hiding (_wf; _⊢_wfExt)

  -- A wrapper for the kind checking judgment that also supports
  -- arbitrary variable bindings.

  infix 4 _⊢NfOrVar_∈_

  data _⊢NfOrVar_∈_ {n} (Γ : Ctx n) : Term n → ElimAsc n → Set where
    ∈-nf  : ∀ {a b c d e} → Γ ⊢Nf a ⇇ c ⋯ d → ⌞ a ⌟ ≡ b → kd (c ⋯ d) ≡ e →
            Γ ⊢NfOrVar b ∈ e
    ∈-var : ∀ x {a b} → Γ ctx → var x ≡ a → lookup Γ x ≡ b →
            Γ ⊢NfOrVar a ∈ b

------------------------------------------------------------------------
-- Simple properties of canonical kindings

open Syntax
open ElimCtx hiding (_++_)
open Kinding

-- An inversion lemma for interval subkinding.

<∷-⋯-inv : ∀ {n} {Γ : Ctx n} {k a₂ b₂} → Γ ⊢ k <∷ a₂ ⋯ b₂ →
           ∃ λ a₁ → ∃ λ b₁ → Γ ⊢ a₂ ∼ a₁ × Γ ⊢ b₁ ∼ b₂ × k ≡ a₁ ⋯ b₁
<∷-⋯-inv (<∷-⋯ a₂∼a₁ b₁∼b₂) = _ , _ , a₂∼a₁ , b₁∼b₂ , refl

-- An inversion lemma for _⊢_wf.

wf-kd-inv : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ kd k wf → Γ ⊢ k kd
wf-kd-inv (wf-kd k-kd) = k-kd

-- The synthesized kind of a normal proper type is exactly the singleton
-- containing that type.

Nf⇉-≡ : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Nf a ⇉ k → k ≡ a ⋯ a
Nf⇉-≡ (⇉-⊥-f Γ-ctx)       = refl
Nf⇉-≡ (⇉-⊤-f Γ-ctx)       = refl
Nf⇉-≡ (⇉-s-i a∈b⋯c)       = refl

-- Derived singleton introduction rules where the premises are
-- well-kinded normal forms rather than neutrals.

Nf⇉-s-i : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Nf a ⇉ k → Γ ⊢Nf a ⇉ a ⋯ a
Nf⇉-s-i a⇉b⋯c with Nf⇉-≡ a⇉b⋯c
Nf⇉-s-i a⇉a⋯a | refl = a⇉a⋯a

Nf⇇-s-i : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Nf a ⇇ b ⋯ c → Γ ⊢Nf a ⇉ a ⋯ a
Nf⇇-s-i (⇇-⇑ a⇉b₁⋯c₁ (<∷-⋯ b₂∼b₁ c₁∼c₂)) = Nf⇉-s-i a⇉b₁⋯c₁

-- The synthesized kinds of neutrals kind-check.

Nf⇇-ne : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Ne a ⇉ b ⋯ c → Γ ⊢Nf a ⇇ b ⋯ c
Nf⇇-ne (⇉-∙ x∈k k⇉as⇉b⋯c) =
  ⇇-⇑ (⇉-s-i (⇉-∙ x∈k k⇉as⇉b⋯c))
      (<∷-⋯ (∼-⟨| (⇉-∙ x∈k k⇉as⇉b⋯c)) (∼-|⟩ (⇉-∙ x∈k k⇉as⇉b⋯c)))

-- The contexts of (most of) the above judgments are well-formed.
--
-- NOTE. The exceptions are again the spine judgments.  See the
-- comment on context validity in FOmegaInt.Kinding.Canonical for why
-- this doesn't matter.

Var⇉-ctx : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Var a ⇉ k → Γ ctx
Var⇉-ctx (⇉-var x Γ-ctx _) = Γ-ctx

Ne⇉-ctx : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Ne a ⇉ k → Γ ctx
Ne⇉-ctx (⇉-∙ x∈j j⇉as⇉k) = Var⇉-ctx x∈j

Nf⇉-ctx : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Nf a ⇉ k → Γ ctx
Nf⇉-ctx (⇉-⊥-f Γ-ctx) = Γ-ctx
Nf⇉-ctx (⇉-⊤-f Γ-ctx) = Γ-ctx
Nf⇉-ctx (⇉-s-i a∈b⋯c) = Ne⇉-ctx a∈b⋯c

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

kd-ctx : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ctx
kd-ctx (kd-⋯ a⇉a⋯a b⇉b⋯b)      = Nf⇉-ctx a⇉a⋯a
kd-ctx (kd-Π a⇉a⋯a b⇉b⋯b k-kd) = Nf⇉-ctx a⇉a⋯a

∼-ctx : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a ∼ b → Γ ctx
∼-ctx (∼-trans a∼b b∼c)   = ∼-ctx a∼b
∼-ctx (∼-⊥ a⇉a⋯a)           = Nf⇉-ctx a⇉a⋯a
∼-ctx (∼-⊤ a⇉a⋯a)           = Nf⇉-ctx a⇉a⋯a
∼-ctx (∼-∙ x∈j as∼bs)       = Var⇉-ctx x∈j
∼-ctx (∼-⟨| a∈b⋯c)          = Ne⇉-ctx a∈b⋯c
∼-ctx (∼-|⟩ a∈b⋯c)          = Ne⇉-ctx a∈b⋯c

<∷-ctx : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ j <∷ k → Γ ctx
<∷-ctx (<∷-⋯ a₂∼a₁ b₁∼b₂)        = ∼-ctx a₂∼a₁
<∷-ctx (<∷-Π a₁∼a₂ b₂∼b₁ k₁<∷k₂) = ∼-ctx a₁∼a₂

wf-ctx : ∀ {n} {Γ : Ctx n} {a} → Γ ⊢ a wf → Γ ctx
wf-ctx (wf-kd k-kd)  = kd-ctx k-kd
wf-ctx (wf-tp a⇉a⋯a) = Nf⇉-ctx a⇉a⋯a

NfOrVar∈-ctx : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢NfOrVar a ∈ b → Γ ctx
NfOrVar∈-ctx (∈-nf a⇇c⋯d _ _)    = Nf⇇-ctx a⇇c⋯d
NfOrVar∈-ctx (∈-var x Γ-ctx _ _) = Γ-ctx

-- Reflexivity of the various relations.

mutual

  <∷-refl : ∀ {n} {Γ : Ctx n} {k} → Γ ⊢ k kd → Γ ⊢ k <∷ k
  <∷-refl (kd-⋯ a⇉a⋯a b⇉b⋯b)      = <∷-⋯ (∼-refl a⇉a⋯a) (∼-refl b⇉b⋯b)
  <∷-refl (kd-Π a⇉a⋯a b⇉b⋯b k-kd) =
    <∷-Π (∼-refl a⇉a⋯a) (∼-refl b⇉b⋯b) (<∷-refl k-kd)

  ∼-refl : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Nf a ⇉ b ⋯ c → Γ ⊢ a ∼ a
  ∼-refl (⇉-⊥-f Γ-ctx)            = ∼-⊥ (⇉-⊥-f Γ-ctx)
  ∼-refl (⇉-⊤-f Γ-ctx)            = ∼-⊤ (⇉-⊤-f Γ-ctx)
  ∼-refl (⇉-s-i (⇉-∙ x∈j j⇉as⇉k)) = ∼-∙ x∈j (∼Sp-refl j⇉as⇉k)

  ∼Sp-refl : ∀ {n} {Γ : Ctx n} {as j k} →
             Γ ⊢ j ⇉∙ as ⇉ k → Γ ⊢ j ⇉∙ as ∼ as ⇉ k
  ∼Sp-refl ⇉-[]                       = ∼-[]
  ∼Sp-refl (⇉-∷ (⇇-⇑ a⇉b₁⋯c₁ (<∷-⋯ b₂∼b₁ c₁∼c₂)) k[a]⇉as⇉l)
    with Nf⇉-≡ a⇉b₁⋯c₁
  ∼Sp-refl (⇉-∷ (⇇-⇑ a⇉a⋯a (<∷-⋯ b∼a a∼c)) k[a]⇉as⇉l) | refl =
    ∼-∷ b∼a a∼c (∼-refl a⇉a⋯a) (∼Sp-refl k[a]⇉as⇉l)

-- Admissible projection rules for canonically kinded proper types.

∼-⟨|-Nf⇉ : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Nf a ⇉ b ⋯ c → Γ ⊢ b ∼ a
∼-⟨|-Nf⇉ a⇉b⋯c with Nf⇉-≡ a⇉b⋯c
∼-⟨|-Nf⇉ a⇉a⋯a | refl = ∼-refl a⇉a⋯a

∼-⟨|-Nf⇇ : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Nf a ⇇ b ⋯ c → Γ ⊢ b ∼ a
∼-⟨|-Nf⇇ (⇇-⇑ a⇉b₁⋯c₁ (<∷-⋯ b₂∼b₁ c₁∼c₂)) =
  ∼-trans b₂∼b₁ (∼-⟨|-Nf⇉ a⇉b₁⋯c₁)

∼-|⟩-Nf⇉ : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Nf a ⇉ b ⋯ c → Γ ⊢ a ∼ c
∼-|⟩-Nf⇉ a⇉b⋯c with Nf⇉-≡ a⇉b⋯c
∼-|⟩-Nf⇉ a⇉a⋯a | refl = ∼-refl a⇉a⋯a

∼-|⟩-Nf⇇ : ∀ {n} {Γ : Ctx n} {a b c} → Γ ⊢Nf a ⇇ b ⋯ c → Γ ⊢ a ∼ c
∼-|⟩-Nf⇇ (⇇-⇑ a⇉b₁⋯c₁ (<∷-⋯ b₂∼b₁ c₁∼c₂)) =
  ∼-trans (∼-|⟩-Nf⇉ a⇉b₁⋯c₁) c₁∼c₂

-- Spines with interval-kinded heads are empty, and therefore have
-- interval-kinded tails.

Sp⇉-⋯ : ∀ {n} {Γ : Ctx n} {as b c k} →
        Γ ⊢ b ⋯ c ⇉∙ as ⇉ k → as ≡ [] × k ≡ b ⋯ c
Sp⇉-⋯ ⇉-[] = refl , refl

Sp∼-⋯ : ∀ {n} {Γ : Ctx n} {as bs c d k} →
        Γ ⊢ c ⋯ d ⇉∙ as ∼ bs ⇉ k → as ≡ [] × bs ≡ [] × k ≡ c ⋯ d
Sp∼-⋯ ∼-[] = refl , refl , refl

----------------------------------------------------------------------
-- Well-kinded/typed substitutions (i.e. substitution lemmas)

-- A shorthand for kindings and typings of Ts by kind or type
-- ascriptions.
ElimAscTyping : (ℕ → Set) → Set₁
ElimAscTyping T = Typing ElimAsc T ElimAsc Level.zero

-- Liftings from well-typed Ts to well-typed/kinded normal forms or
-- variables.
LiftTo-NfOrVar∈ : ∀ {T} → ElimAscTyping T → Set₁
LiftTo-NfOrVar∈ _⊢T_∈_ =
  LiftTyped Substitution.elimAscTermSubst _⊢_wf _⊢T_∈_ _⊢NfOrVar_∈_

-- A helper lemma about untyped T-substitutions in raw kinds.

record TypedSubstAppHelpers {T} (rawLift : Lift T Term) : Set where
  open Substitution using (_Kind′[_])
  module A = SubstApp rawLift
  module L = Lift     rawLift

  -- Substitutions in kinds and types commute.

  field Kind/-sub-↑ : ∀ {m n} k a (σ : Sub T m n) →
                      k Kind′[ ⌞ a ⌟ ] A.Kind′/ σ ≡
                        (k A.Kind′/ σ L.↑) Kind′[ ⌞ a A.Elim/ σ ⌟ ]

-- Application of generic well-typed T-substitutions to all the judgments.

module TypedSubstApp {T : ℕ → Set} (_⊢T_∈_ : ElimAscTyping T)
                     (liftTyped : LiftTo-NfOrVar∈ _⊢T_∈_)
                     (helpers : TypedSubstAppHelpers
                                  (LiftTyped.rawLift liftTyped))
                     where

  open LiftTyped liftTyped renaming (lookup to /∈-lookup) hiding (∈-var)
  open TypedSubstAppHelpers helpers

  -- Well-typed/kinded substitutions preserve all the judgments.

  mutual

    wf-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a σ} →
              Γ ⊢ a wf → Δ ⊢/ σ ∈ Γ → Δ ⊢ a A.ElimAsc/ σ wf
    wf-/ (wf-kd k-kd)  σ∈Γ = wf-kd (kd-/ k-kd σ∈Γ)
    wf-/ (wf-tp a⇉a⋯a) σ∈Γ = wf-tp (Nf⇉-/ a⇉a⋯a σ∈Γ)

    kd-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {k σ} →
              Γ ⊢ k kd → Δ ⊢/ σ ∈ Γ → Δ ⊢ k A.Kind′/ σ kd
    kd-/ (kd-⋯ a⇉a⋯a b⇉b⋯b) σ∈Γ =
      kd-⋯ (Nf⇉-/ a⇉a⋯a σ∈Γ) (Nf⇉-/ b⇉b⋯b σ∈Γ)
    kd-/ (kd-Π a⇉a⋯a b⇉b⋯b  k-kd) σ∈Γ =
      let a/σ⇉a/σ⋯a/σ = Nf⇉-/ a⇉a⋯a σ∈Γ
          b/σ⇉b/σ⋯b/σ = Nf⇉-/ b⇉b⋯b σ∈Γ
      in kd-Π a/σ⇉a/σ⋯a/σ b/σ⇉b/σ⋯b/σ
              (kd-/ k-kd (∈-↑ (wf-kd (kd-⋯ a/σ⇉a/σ⋯a/σ b/σ⇉b/σ⋯b/σ)) σ∈Γ))

    Ne⇉-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a k σ} →
               Γ ⊢Ne a ⇉ k → Δ ⊢/ σ ∈ Γ →
               Δ ⊢Nf a A.Elim/ σ ⇇ k A.Kind′/ σ ⊎
               Δ ⊢Ne a A.Elim/ σ ⇉ k A.Kind′/ σ
    Ne⇉-/ (⇉-∙ (⇉-var x Γ-ctx Γ[x]≡j) j⇉as⇉k) σ∈Γ with ∈-lift (/∈-lookup σ∈Γ x)
    ... | ∈-nf {a} a⇇c⋯d ⌞a⌟≡σ[x] c⋯d≡Γ[x]/σ =
      let c⋯d≡j/σ = kd-inj (trans c⋯d≡Γ[x]/σ (cong (A._ElimAsc/ _) Γ[x]≡j))
          c⋯d⇉as/σ⇉k/σ = subst (_ ⊢_⇉∙ _ ⇉ _) (sym c⋯d≡j/σ) (Sp⇉-/ j⇉as⇉k σ∈Γ)
          as≡[] , k/σ≡c⋯d = Sp⇉-⋯ c⋯d⇉as/σ⇉k/σ
          a≡⌜σ[x]⌝ = trans (sym (⌜⌝∘⌞⌟-id a)) (cong ⌜_⌝ ⌞a⌟≡σ[x])
          ⌜σ[x]⌝∙∙as≡a = trans (cong₂ _∙∙_ (sym a≡⌜σ[x]⌝) as≡[]) (∙∙-[] _)
      in inj₁ (subst₂ (_ ⊢Nf_⇇_) (sym ⌜σ[x]⌝∙∙as≡a) (sym k/σ≡c⋯d) a⇇c⋯d)
    ... | ∈-var y Δ-ctx y≡σ[x] Δ[y]≡Γ[x]/σ =
      let Δ[y]≡j/σ = trans Δ[y]≡Γ[x]/σ (cong (A._ElimAsc/ _) Γ[x]≡j)
      in inj₂ (subst (_ ⊢Ne_⇉ _) (cong (_∙∙ _) (cong ⌜_⌝ y≡σ[x]))
                     (⇉-∙ (⇉-var y Δ-ctx Δ[y]≡j/σ) (Sp⇉-/ j⇉as⇉k σ∈Γ)))

    Nf⇉-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a k σ} →
            Γ ⊢Nf a ⇉ k → Δ ⊢/ σ ∈ Γ → Δ ⊢Nf a A.Elim/ σ ⇉ k A.Kind′/ σ
    Nf⇉-/ (⇉-⊥-f Γ-ctx) σ∈Γ = ⇉-⊥-f (/∈-wf σ∈Γ)
    Nf⇉-/ (⇉-⊤-f Γ-ctx) σ∈Γ = ⇉-⊤-f (/∈-wf σ∈Γ)
    Nf⇉-/ (⇉-s-i a∈b⋯c) σ∈Γ with Ne⇉-/ a∈b⋯c σ∈Γ
    ... | inj₁ a/σ⇇b/σ⋯c/σ = Nf⇇-s-i a/σ⇇b/σ⋯c/σ
    ... | inj₂ a/σ⇉b/σ⋯c/σ = ⇉-s-i a/σ⇉b/σ⋯c/σ

    Nf⇇-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a k σ} →
               Γ ⊢Nf a ⇇ k → Δ ⊢/ σ ∈ Γ → Δ ⊢Nf a A.Elim/ σ ⇇ k A.Kind′/ σ
    Nf⇇-/ (⇇-⇑ a⇉j j<∷k) σ∈Γ = ⇇-⇑ (Nf⇉-/ a⇉j σ∈Γ) (<∷-/ j<∷k σ∈Γ)

    Sp⇉-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {as j k σ} →
               Γ ⊢ j ⇉∙ as ⇉ k → Δ ⊢/ σ ∈ Γ →
               Δ ⊢ j A.Kind′/ σ ⇉∙ as A.// σ ⇉ k A.Kind′/ σ
    Sp⇉-/ ⇉-[]                                σ∈Γ = ⇉-[]
    Sp⇉-/ (⇉-∷ {a} {j = j} a⇇b⋯c j[a]⇉as⇉k) σ∈Γ =
      ⇉-∷ (Nf⇇-/ a⇇b⋯c σ∈Γ)
          (subst (_ ⊢_⇉∙ _ ⇉ _) (Kind/-sub-↑ j a _)
                 (Sp⇉-/ j[a]⇉as⇉k σ∈Γ))

    <∷-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {j k σ} →
              Γ ⊢ j <∷ k → Δ ⊢/ σ ∈ Γ → Δ ⊢ j A.Kind′/ σ <∷ k A.Kind′/ σ
    <∷-/ (<∷-⋯ a₂∼a₁ b₁∼b₂) σ∈Γ =
      <∷-⋯ (∼-/ a₂∼a₁ σ∈Γ) (∼-/ b₁∼b₂ σ∈Γ)
    <∷-/ (<∷-Π a₁∼a₂ b₂∼b₁ k₁<∷k₂) σ∈Γ =
      <∷-Π (∼-/ a₁∼a₂ σ∈Γ) (∼-/ b₂∼b₁ σ∈Γ)
           (<∷-/ k₁<∷k₂ (∈-↑ (<∷-/-wf k₁<∷k₂ σ∈Γ) σ∈Γ))

    ∼-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a b σ} →
              Γ ⊢ a ∼ b → Δ ⊢/ σ ∈ Γ → Δ ⊢ a A.Elim/ σ ∼ b A.Elim/ σ
    ∼-/ (∼-trans a∼b b∼c) σ∈Γ =
      ∼-trans (∼-/ a∼b σ∈Γ) (∼-/ b∼c σ∈Γ)
    ∼-/ (∼-⊥ a⇉a⋯a) σ∈Γ = ∼-⊥ (Nf⇉-/ a⇉a⋯a σ∈Γ)
    ∼-/ (∼-⊤ a⇉a⋯a) σ∈Γ = ∼-⊤ (Nf⇉-/ a⇉a⋯a σ∈Γ)
    ∼-/ (∼-∙ (⇉-var x Γ-ctx Γ[x]≡j) j⇉as∼bs⇉k) σ∈Γ
      with ∈-lift (/∈-lookup σ∈Γ x)
    ... | ∈-nf {a} (⇇-⇑ a⇉c₁⋯d₁ (<∷-⋯ _ _)) ⌞a⌟≡σ[x] c⋯d≡Γ[x]/σ =
      let c⋯d≡j/σ = kd-inj (trans c⋯d≡Γ[x]/σ (cong (A._ElimAsc/ _) Γ[x]≡j))
          c⋯d⇉as/σ∼bs/σ⇉k/σ = subst (_ ⊢_⇉∙ _ ∼ _ ⇉ _) (sym c⋯d≡j/σ)
                                    (Sp∼-/ j⇉as∼bs⇉k σ∈Γ)
          as≡[] , bs≡[] , _ = Sp∼-⋯ c⋯d⇉as/σ∼bs/σ⇉k/σ
          a≡⌜σ[x]⌝ = trans (sym (⌜⌝∘⌞⌟-id a)) (cong ⌜_⌝ ⌞a⌟≡σ[x])
          ⌜σ[x]⌝∙∙as≡a = trans (cong₂ _∙∙_ (sym a≡⌜σ[x]⌝) as≡[]) (∙∙-[] _)
          ⌜σ[x]⌝∙∙bs≡a = trans (cong₂ _∙∙_ (sym a≡⌜σ[x]⌝) bs≡[]) (∙∙-[] _)
      in subst₂ (_ ⊢_∼_) (sym ⌜σ[x]⌝∙∙as≡a) (sym ⌜σ[x]⌝∙∙bs≡a)
                (∼-refl a⇉c₁⋯d₁)
    ... | ∈-var y Δ-ctx y≡σ[x] Δ[y]≡Γ[x]/σ =
      let Δ[y]≡j/σ = trans Δ[y]≡Γ[x]/σ (cong (A._ElimAsc/ _) Γ[x]≡j)
      in subst₂ (_ ⊢_∼_) (cong (_∙∙ _) (cong ⌜_⌝ y≡σ[x]))
                (cong (_∙∙ _) (cong ⌜_⌝ y≡σ[x]))
                (∼-∙ (⇉-var y Δ-ctx Δ[y]≡j/σ) (Sp∼-/ j⇉as∼bs⇉k σ∈Γ))
    ∼-/ (∼-⟨| a∈b⋯c) σ∈Γ with Ne⇉-/ a∈b⋯c σ∈Γ
    ... | inj₁ a⇇b⋯c = ∼-⟨|-Nf⇇ a⇇b⋯c
    ... | inj₂ a⇉b⋯c = ∼-⟨| a⇉b⋯c
    ∼-/ (∼-|⟩ a∈b⋯c) σ∈Γ with Ne⇉-/ a∈b⋯c σ∈Γ
    ... | inj₁ a⇇b⋯c = ∼-|⟩-Nf⇇ a⇇b⋯c
    ... | inj₂ a⇉b⋯c = ∼-|⟩ a⇉b⋯c

    Sp∼-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {as bs j k σ} →
                Γ ⊢ j ⇉∙ as ∼ bs ⇉ k → Δ ⊢/ σ ∈ Γ →
                Δ ⊢ j A.Kind′/ σ ⇉∙ as A.// σ ∼ bs A.// σ ⇉ k A.Kind′/ σ
    Sp∼-/ ∼-[] σ∈Γ = ∼-[]
    Sp∼-/ (∼-∷ {a} {j = j} c∼a a∼d a∼b as∼bs) σ∈Γ =
      ∼-∷ (∼-/ c∼a σ∈Γ) (∼-/ a∼d σ∈Γ) (∼-/ a∼b σ∈Γ)
          (subst (_ ⊢_⇉∙ _ ∼ _ ⇉ _) (Kind/-sub-↑ j a _)
                 (Sp∼-/ as∼bs σ∈Γ))

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

    Nf⇉-/-wf : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a j k σ} →
                  kd j ∷ Γ ⊢Nf a ⇉ k → Δ ⊢/ σ ∈ Γ →
                  Δ ⊢ kd (j A.Kind′/ σ) wf
    Nf⇉-/-wf (⇉-⊥-f (j-wf ∷ _)) σ∈Γ = wf-/ j-wf σ∈Γ
    Nf⇉-/-wf (⇉-⊤-f (j-wf ∷ _)) σ∈Γ = wf-/ j-wf σ∈Γ
    Nf⇉-/-wf (⇉-s-i a∈b⋯c)      σ∈Γ = Ne⇉-/-wf a∈b⋯c σ∈Γ

    Ne⇉-/-wf : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a j k σ} →
                  kd j ∷ Γ ⊢Ne a ⇉ k → Δ ⊢/ σ ∈ Γ →
                  Δ ⊢ kd (j A.Kind′/ σ) wf
    Ne⇉-/-wf (⇉-∙ x∈k _) σ∈Γ = Var⇉-/-wf x∈k σ∈Γ

    Var⇉-/-wf : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a j k σ} →
                   kd j ∷ Γ ⊢Var a ⇉ k → Δ ⊢/ σ ∈ Γ →
                   Δ ⊢ kd (j A.Kind′/ σ) wf
    Var⇉-/-wf (⇉-var x (j-wf ∷ _) _) σ∈Γ = wf-/ j-wf σ∈Γ

    <∷-/-wf : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {j k l σ} →
                 kd j ∷ Γ ⊢ k <∷ l → Δ ⊢/ σ ∈ Γ → Δ ⊢ kd (j A.Kind′/ σ) wf
    <∷-/-wf (<∷-⋯ a₂∼a₁ _)   σ∈Γ = ∼-/-wf a₂∼a₁ σ∈Γ
    <∷-/-wf (<∷-Π a₁∼a₂ _ _) σ∈Γ = ∼-/-wf a₁∼a₂ σ∈Γ

    ∼-/-wf : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a b j σ} →
                 kd j ∷ Γ ⊢ a ∼ b → Δ ⊢/ σ ∈ Γ →
                 Δ ⊢ kd (j A.Kind′/ σ) wf
    ∼-/-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 (∼-∙ x∈j _)      σ∈Γ = Var⇉-/-wf x∈j σ∈Γ
    ∼-/-wf (∼-⟨| a∈b⋯c)     σ∈Γ = Ne⇉-/-wf a∈b⋯c σ∈Γ
    ∼-/-wf (∼-|⟩ a∈b⋯c)     σ∈Γ = Ne⇉-/-wf a∈b⋯c σ∈Γ

  -- Renamings preserve wrapped variable typing

  NfOrVar∈-/ : ∀ {m n} {Γ : Ctx m} {Δ : Ctx n} {a b σ} →
               Γ ⊢NfOrVar a ∈ b → Δ ⊢/ σ ∈ Γ →
               Δ ⊢NfOrVar a A./ σ ∈ b A.ElimAsc/ σ
  NfOrVar∈-/ (∈-nf {a} a⇇c⋯d refl refl) σ∈Γ =
    ∈-nf (Nf⇇-/ a⇇c⋯d σ∈Γ) (A.⌞⌟-/ a) refl
  NfOrVar∈-/ (∈-var x _ refl refl)  σ∈Γ = ∈-lift (/∈-lookup σ∈Γ x)

-- Well-kinded renamings and type substitutions.

module KindedSubstitution where
  open Substitution           using (simple; termSubst)
  open SimpleExt    simple    using (extension)
  open TermSubst    termSubst using (varLift; termLift)
  open ≡-Reasoning

  private
    module S  = Substitution
    module KL = TermLikeLemmas S.termLikeLemmasKind′

  -- Helper lemmas about untyped renamings and substitutions in terms
  -- and kinds.

  varHelpers : TypedSubstAppHelpers varLift
  varHelpers = record
    { Kind/-sub-↑ = λ k a ρ → begin
          (k Kind′[ ⌞ a ⌟ ]) Kind′/Var ρ
        ≡⟨ KL./-sub-↑ k ⌞ a ⌟ ρ ⟩
          (k Kind′/Var ρ VarSubst.↑) Kind′[ ⌞ a ⌟ /Var ρ ]
        ≡⟨ cong ((k Kind′/Var ρ VarSubst.↑) Kind′[_]) (sym (⌞⌟-/Var a)) ⟩
          (k Kind′/Var ρ VarSubst.↑) Kind′[ ⌞ a Elim/Var ρ ⌟ ]
        ∎
    }
    where open S

  termHelpers : TypedSubstAppHelpers termLift
  termHelpers = record
    { Kind/-sub-↑ = λ k a σ → begin
          (k Kind′[ ⌞ a ⌟ ]) Kind′/ σ
        ≡⟨ KL.sub-commutes k ⟩
          (k Kind′/ σ ↑) Kind′[ ⌞ a ⌟ / σ ]
        ≡⟨ cong ((k Kind′/ σ ↑) Kind′[_]) (sym (⌞⌟-/ a)) ⟩
          (k Kind′/ σ ↑) Kind′[ ⌞ a Elim/ σ ⌟ ]
        ∎
    }
    where open S

  -- Kinded type substitutions.

  typedTermSubst : TypedTermSubst ElimAsc Term Level.zero TypedSubstAppHelpers
  typedTermSubst = record
    { _⊢_wf = _⊢_wf
    ; _⊢_∈_ = _⊢NfOrVar_∈_
    ; termLikeLemmas = S.termLikeLemmasElimAsc
    ; varHelpers     = varHelpers
    ; termHelpers    = termHelpers
    ; wf-wf    = wf-ctx
    ; ∈-wf     = NfOrVar∈-ctx
    ; ∈-var    = λ x Γ-ctx → ∈-var x Γ-ctx refl refl
    ; typedApp = TypedSubstApp.NfOrVar∈-/
    }
  open TypedTermSubst typedTermSubst public
    hiding (_⊢_wf; _⊢_∈_; varHelpers; termHelpers; ∈-var; ∈-/Var; ∈-/)
    renaming (lookup to /∈-lookup)
  open TypedSubstApp _⊢Var_∈_ varLiftTyped varHelpers public using ()
    renaming (wf-/ to wf-/Var; ∼-/ to ∼-/Var)
  open Substitution using (weakenElim; weakenElimAsc)

  -- Weakening preserves the various judgments.

  wf-weaken : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a wf → Γ ⊢ b wf →
              (a ∷ Γ) ⊢ weakenElimAsc b wf
  wf-weaken a-wf b-wf = wf-/Var b-wf (Var∈-wk a-wf)

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

  open TypedSubstApp _⊢NfOrVar_∈_ termLiftTyped termHelpers public
  open Substitution using (_Kind′/_; id; sub; _Kind′[_])

  -- Substitution of a single variable or normal form preserves the
  -- kinding judgments.

  kd-[] : ∀ {n} {Γ : Ctx n} {a b c k} →
          kd (b ⋯ c) ∷ Γ ⊢ k kd → Γ ⊢Nf a ⇇ b ⋯ c → Γ ⊢ k Kind′[ ⌞ a ⌟ ] kd
  kd-[] k-kd a⇇b⋯c = kd-/ k-kd (∈-sub (∈-nf a⇇b⋯c refl refl))

  <∷-[] : ∀ {n} {Γ : Ctx n} {j k a b c} →
          kd (b ⋯ c) ∷ Γ ⊢ j <∷ k → Γ ⊢Nf a ⇇ b ⋯ c →
          Γ ⊢ j Kind′[ ⌞ a ⌟ ] <∷ k Kind′[ ⌞ a ⌟ ]
  <∷-[] j<∷k a⇇b⋯c = <∷-/ j<∷k (∈-sub (∈-nf a⇇b⋯c refl refl))

  -- A typed substitution that narrows the kind of the first type
  -- variable.

  ∈-<∷-sub : ∀ {n} {Γ : Ctx n} {a₁ a₂ b₁ b₂} →
             Γ ⊢ (a₁ ⋯ b₁) kd → Γ ⊢ a₂ ∼ a₁ → Γ ⊢ b₁ ∼ b₂ →
             kd (a₁ ⋯ b₁) ∷ Γ ⊢/ id ∈ kd (a₂ ⋯ b₂) ∷ Γ
  ∈-<∷-sub a₁⋯b₁-kd a₁∼a₂ b₂∼b₁ =
    ∈-tsub (∈-nf (⇇-⇑ (⇉-s-i x∈a₁⋯a₂) (<∷-⋯ x∼a₂ b₂∼x)) refl refl)
    where
      a₁⋯b₁-wf = wf-kd a₁⋯b₁-kd
      Γ-ctx    = kd-ctx a₁⋯b₁-kd
      x∈a₁⋯a₂  = ⇉-∙ (⇉-var zero (a₁⋯b₁-wf ∷ Γ-ctx) refl) ⇉-[]
      x∼a₂     = ∼-trans (∼-weaken a₁⋯b₁-wf a₁∼a₂) (∼-⟨| x∈a₁⋯a₂)
      b₂∼x     = ∼-trans (∼-|⟩ x∈a₁⋯a₂) (∼-weaken a₁⋯b₁-wf b₂∼b₁)

  -- Narrowing the kind of the first type variable preserves
  -- subkinding

  ⇓-<∷ : ∀ {n} {Γ : Ctx n} {a₁ a₂ b₁ b₂ k₁ k₂} →
         Γ ⊢ (a₁ ⋯ b₁) kd → Γ ⊢ a₂ ∼ a₁ → Γ ⊢ b₁ ∼ b₂ →
         kd (a₂ ⋯ b₂) ∷ Γ ⊢ k₁ <∷ k₂ → kd (a₁ ⋯ b₁) ∷ Γ ⊢ k₁ <∷ k₂
  ⇓-<∷ a₁⋯b₁-kd a₂∼a₁ b₁∼b₂ k₁<∷k₂ =
    subst₂ (_ ⊢_<∷_) (KL.id-vanishes _) (KL.id-vanishes _)
           (<∷-/ k₁<∷k₂ (∈-<∷-sub a₁⋯b₁-kd a₂∼a₁ b₁∼b₂))

-- Operations on well-formed contexts that require weakening of
-- well-formedness judgments.

module WfCtxOps where
  wfWeakenOps : WellFormedWeakenOps weakenOps
  wfWeakenOps = record { wf-weaken = KindedSubstitution.wf-weaken }

  open WellFormedWeakenOps wfWeakenOps public renaming (lookup to lookup-wf)

  -- Lookup the kind of a type variable in a well-formed context.

  lookup-kd : ∀ {m} {Γ : Ctx m} {k} x →
              Γ ctx → ElimCtx.lookup Γ x ≡ kd k → Γ ⊢ k kd
  lookup-kd x Γ-ctx Γ[x]≡kd-k =
    wf-kd-inv (subst (_ ⊢_wf) Γ[x]≡kd-k (lookup-wf Γ-ctx x))

open KindedSubstitution
open WfCtxOps

-- A corollary of context narrowing: transitivity of subkinding is
-- admissible.

<∷-trans : ∀ {n} {Γ : Ctx n} {j k l} → Γ ⊢ j <∷ k → Γ ⊢ k <∷ l → Γ ⊢ j <∷ l
<∷-trans (<∷-⋯ a₂∼a₁ b₁∼b₂) (<∷-⋯ a₃∼a₂ b₂∼b₃) =
  <∷-⋯ (∼-trans a₃∼a₂ a₂∼a₁) (∼-trans b₁∼b₂ b₂∼b₃)
<∷-trans (<∷-Π a₁∼a₂ b₂∼b₁ k₁<∷k₂) (<∷-Π a₂∼a₃ b₃∼b₂ k₂<∷k₃) =
  let a₃⋯b₃-kd = wf-kd-inv (wf-∷₁ (<∷-ctx k₂<∷k₃))
  in <∷-Π (∼-trans a₁∼a₂ a₂∼a₃) (∼-trans b₃∼b₂ b₂∼b₁)
          (<∷-trans (⇓-<∷ a₃⋯b₃-kd a₂∼a₃ b₃∼b₂ k₁<∷k₂) k₂<∷k₃)

-- Another corollary: subsumption is admissible in kind checking.

Nf⇇-⇑ : ∀ {n} {Γ : Ctx n} {a j k} → Γ ⊢Nf a ⇇ j → Γ ⊢ j <∷ k → Γ ⊢Nf a ⇇ k
Nf⇇-⇑ (⇇-⇑ a⇇j₁ j₁<∷j₂) j₂<∷j₃ = ⇇-⇑ a⇇j₁ (<∷-trans j₁<∷j₂ j₂<∷j₃)

-- We can push kind formation proofs through spine kindings.

kd-Sp⇉ : ∀ {n} {Γ : Ctx n} {j as k} →
         Γ ⊢ j kd → Γ ⊢ j ⇉∙ as ⇉ k → Γ ⊢ k kd
kd-Sp⇉ j-kd ⇉-[] = j-kd
kd-Sp⇉ (kd-Π b⇉b⋯b c⇉c⋯c j-kd) (⇉-∷ a⇇b⋯c j[a]⇉as⇉k) =
  kd-Sp⇉ (kd-[] j-kd a⇇b⋯c) j[a]⇉as⇉k

-- Kind-validity of neutrals

Var⇉-valid : ∀ {n} {Γ : Ctx n} {x k} → Γ ⊢Var x ⇉ k → Γ ⊢ k kd
Var⇉-valid (⇉-var x Γ-ctx Γ[x]≡k) = lookup-kd x Γ-ctx Γ[x]≡k

Ne⇉-valid : ∀ {n} {Γ : Ctx n} {a k} → Γ ⊢Ne a ⇉ k → Γ ⊢ k kd
Ne⇉-valid (⇉-∙ x⇉j j⇉as⇉k) = kd-Sp⇉ (Var⇉-valid x⇉j) j⇉as⇉k

-- Left-hand validity of related types and spines

mutual

  ∼-valid₁ : ∀ {n} {Γ : Ctx n} {a b} → Γ ⊢ a ∼ b → Γ ⊢Nf a ⇉ a ⋯ a
  ∼-valid₁ (∼-trans a∼b _) = ∼-valid₁ a∼b
  ∼-valid₁ (∼-⊥ b⇉b⋯b) = ⇉-⊥-f (Nf⇉-ctx b⇉b⋯b)
  ∼-valid₁ (∼-⊤ a⇉a⋯a) = a⇉a⋯a
  ∼-valid₁ (∼-∙ x⇉j j⇉as⇉k) = ⇉-s-i (⇉-∙ x⇉j (∼Sp-valid₁ j⇉as⇉k))
  ∼-valid₁ (∼-⟨| a⇉b⋯c) with Ne⇉-valid a⇉b⋯c
  ... | kd-⋯ b⇉b⋯b _ = b⇉b⋯b
  ∼-valid₁ (∼-|⟩ a⇉b⋯c) = ⇉-s-i a⇉b⋯c

  ∼Sp-valid₁ : ∀ {n} {Γ : Ctx n} {j as bs k} →
               Γ ⊢ j ⇉∙ as ∼ bs ⇉ k → Γ ⊢ j ⇉∙ as ⇉ k
  ∼Sp-valid₁ ∼-[] = ⇉-[]
  ∼Sp-valid₁ (∼-∷ c∼a a∼d a∼b j[x]⇉as⇉k) =
    ⇉-∷ (⇇-⇑ (∼-valid₁ a∼b) (<∷-⋯ c∼a a∼d)) (∼Sp-valid₁ j[x]⇉as⇉k)

-- We can push subkinding proofs through spine kindings/relations.

<∷-Sp⇉ : ∀ {n} {Γ : Ctx n} {j₁ j₂ as k₂} →
         Γ ⊢ j₁ <∷ j₂ → Γ ⊢ j₂ ⇉∙ as ⇉ k₂ → ∃ λ k₁ →
         Γ ⊢ j₁ ⇉∙ as ⇉ k₁ × Γ ⊢ k₁ <∷ k₂
<∷-Sp⇉ j₁<∷j₂ ⇉-[] = _ , ⇉-[] , j₁<∷j₂
<∷-Sp⇉ (<∷-Π b₁∼b₂ c₂∼c₁ j₁<∷j₂) (⇉-∷ a⇇b₂⋯c₂ j₂[a]⇉as⇉k₂) =
  let k₁ , j₁[a]⇉as⇉k₁ , k₁<∷k₂ = <∷-Sp⇉ (<∷-[] j₁<∷j₂ a⇇b₂⋯c₂) j₂[a]⇉as⇉k₂
  in  k₁ , ⇉-∷ (Nf⇇-⇑ a⇇b₂⋯c₂ (<∷-⋯ b₁∼b₂ c₂∼c₁)) j₁[a]⇉as⇉k₁ , k₁<∷k₂

<∷-Sp∼ : ∀ {n} {Γ : Ctx n} {j₁ j₂ as bs k₂} →
         Γ ⊢ j₁ <∷ j₂ → Γ ⊢ j₂ ⇉∙ as ∼ bs ⇉ k₂ → ∃ λ k₁ →
         Γ ⊢ j₁ ⇉∙ as ∼ bs ⇉ k₁ × Γ ⊢ k₁ <∷ k₂
<∷-Sp∼ j₁<∷j₂ ∼-[] = _ , ∼-[] , j₁<∷j₂
<∷-Sp∼ (<∷-Π c₁∼c₂ d₂∼d₁ j₁<∷j₂)
       (∼-∷ c₂∼a a∼d₂ a∼b j₂[a]⇉as∼bs⇉k₂) =
  let a⇇c₂⋯d₂ = ⇇-⇑ (∼-valid₁ a∼b) (<∷-⋯ c₂∼a a∼d₂)
      k₁ , j₁[a]⇉as∼bs⇉k₁ , k₁<∷k₂ = <∷-Sp∼ (<∷-[] j₁<∷j₂ a⇇c₂⋯d₂)
                                            j₂[a]⇉as∼bs⇉k₂
  in  k₁ , ∼-∷ (∼-trans c₁∼c₂ c₂∼a) (∼-trans a∼d₂ d₂∼d₁) a∼b j₁[a]⇉as∼bs⇉k₁ ,
      k₁<∷k₂

------------------------------------------------------------------------
-- Squashing of terms

mutual

  squashElim : ∀ {n} → Elim n → Elim n
  squashElim (a ∙ as) = squashHead a ∙ squashSpine as

  squashHead : ∀ {n} → Head n → Head n
  squashHead (var x) = var x
  squashHead ⊥       = ⊥
  squashHead ⊤       = ⊤
  {-# CATCHALL #-}
  squashHead a       = ⊤   -- all other types are squashed into ⊤

  squashSpine : ∀ {n} → Spine n → Spine n
  squashSpine []       = []
  squashSpine (a ∷ as) = squashElim a ∷ squashSpine as

  squashKind : ∀ {n} → Kind Elim n → Kind Elim n
  squashKind (a ⋯ b) = squashElim a ⋯ squashElim b
  squashKind (Π j k) = Π (squashKind j) (squashKind k)

squashAsc : ∀ {n} → ElimAsc n → ElimAsc n
squashAsc (kd k) = kd (squashKind k)
squashAsc (tp a) = tp (squashElim a)

squashCtx : ∀ {n} → Ctx n → Ctx n
squashCtx []      = []
squashCtx (a ∷ Γ) = (squashAsc a) ∷ (squashCtx Γ)

squashTerm : ∀ {n} → Term n → Term n
squashTerm a = ⌞ squashElim ⌜ a ⌝ ⌟

squash-++ : ∀ {n} (as : Spine n) {bs} →
            squashSpine as ++ squashSpine bs ≡ squashSpine (as ++ bs)
squash-++ []       = refl
squash-++ (a ∷ as) = cong (_ ∷_) (squash-++ as)

squash-∙∙ : ∀ {n} (a : Elim n) {bs} →
            squashElim a ∙∙ squashSpine bs ≡ squashElim (a ∙∙ bs)
squash-∙∙ (a ∙ as) = cong (_ ∙_) (squash-++ as)

-- Squashing commutes with generic substitutions.

module SquashSubstAppLemmas {T : ℕ → Set} (l : Lift T Term)
       (squashSub : ∀ {m n} → Sub T m n → Sub T m n)
       (squash-↑  : ∀ {m n} (σ : Sub T m n) →
          Lift._↑ l (squashSub σ) ≡ squashSub (Lift._↑ l σ))
       (squash-lift-lookup : ∀ {m n} (σ : Sub T m n) x →
          ⌜ Lift.lift l (Vec.lookup (squashSub σ) x) ⌝ ≡
          squashElim ⌜ Lift.lift l (Vec.lookup σ x) ⌝)
       where

  open SubstApp l

  -- Squashing commutes with application of generic substitutions.

  mutual

    squashElim-/ : ∀ {m n} {σ : Sub T m n} a →
                   squashElim a Elim/ squashSub σ ≡ squashElim (a Elim/ σ)
    squashElim-/ (a ∙ as) =
      trans (cong₂ _∙∙_ (squashHead-/ a) (squashSpine-/ as)) (squash-∙∙ _)

    squashHead-/ : ∀ {m n} {σ : Sub T m n} a →
                   squashHead a Head/ squashSub σ ≡ squashElim (a Head/ σ)
    squashHead-/ (var x) = squash-lift-lookup _ x
    squashHead-/ ⊥       = refl
    squashHead-/ ⊤       = refl
    squashHead-/ (Π k a) = refl
    squashHead-/ (a ⇒ b) = refl
    squashHead-/ (Λ k a) = refl
    squashHead-/ (ƛ a b) = refl
    squashHead-/ (a ⊡ b) = refl

    squashSpine-/ : ∀ {m n} {σ : Sub T m n} as →
                    squashSpine as // squashSub σ ≡ squashSpine (as // σ)
    squashSpine-/ []       = refl
    squashSpine-/ (a ∷ as) =
      cong₂ _∷_ (squashElim-/ a) (squashSpine-/ as)

    squashKind-/ : ∀ {m n} {σ : Sub T m n} k →
                   squashKind k Kind′/ squashSub σ ≡ squashKind (k Kind′/ σ)
    squashKind-/ (a ⋯ b) = cong₂ _⋯_ (squashElim-/ a) (squashElim-/ b)
    squashKind-/ (Π j k) =
      cong₂ Π (squashKind-/ j)
            (trans (cong (_ Kind′/_) (squash-↑ _)) (squashKind-/ k))

  squashAsc-/ : ∀ {m n} {σ : Sub T m n} a →
                squashAsc a ElimAsc/ squashSub σ ≡ squashAsc (a ElimAsc/ σ)
  squashAsc-/ (kd k) = cong kd (squashKind-/ k)
  squashAsc-/ (tp a) = cong tp (squashElim-/ a)

  squashTerm-/ : ∀ {m n} {σ : Sub T m n} a →
                 squashTerm a / squashSub σ ≡ squashTerm (a / σ)
  squashTerm-/ {σ = σ} a = begin
    ⌞ squashElim ⌜ a ⌝ ⌟ / squashSub σ      ≡˘⟨ ⌞⌟-/ (squashElim ⌜ a ⌝) ⟩
    ⌞ squashElim ⌜ a ⌝ Elim/ squashSub σ ⌟  ≡⟨ cong ⌞_⌟ (squashElim-/ ⌜ a ⌝) ⟩
    ⌞ squashElim (⌜ a ⌝ Elim/ σ) ⌟   ≡˘⟨ cong (⌞_⌟ ∘ squashElim) (⌜⌝-/ a) ⟩
    ⌞ squashElim ⌜ a / σ ⌝ ⌟         ∎
    where open ≡-Reasoning

-- Squashing commutes with renamings and term substitutions.

module SquashSubstLemmas where
  open Substitution
    using (termSubst; _↑; id; sub; weaken; _Kind′/_; _Kind′[_])
  open TermSubst termSubst using (varLift; termLift)
  open ≡-Reasoning

  open SquashSubstAppLemmas varLift (λ x → x) (λ _ → refl) (λ _ _ → refl)
    public using () renaming
    ( squashAsc-/  to squashAsc-/Var
    ; squashTerm-/ to squashTerm-/Var
    )

  -- Squashing applied point-wise to term substitutions.

  squashSub : ∀ {m n} → Sub Term m n → Sub Term m n
  squashSub = Vec.map squashTerm

  -- Helper lemmas about squashed substitutions.

  squash-↑ : ∀ {m n} (σ : Sub Term m n) → (squashSub σ) ↑ ≡ squashSub (σ ↑)
  squash-↑ σ = cong (_ ∷_) (begin
    Vec.map weaken (Vec.map squashTerm σ)  ≡˘⟨ map-∘ weaken squashTerm σ ⟩
    Vec.map (weaken ∘ squashTerm) σ        ≡⟨ map-cong squashTerm-/Var σ ⟩
    Vec.map (squashTerm ∘ weaken) σ        ≡⟨ map-∘ squashTerm weaken σ  ⟩
    Vec.map squashTerm (Vec.map weaken σ)  ∎)

  squash-lookup : ∀ {m n} (σ : Sub Term m n) x →
    ⌜ Vec.lookup (squashSub σ) x ⌝ ≡ squashElim ⌜ Vec.lookup σ x ⌝
  squash-lookup σ x = begin
      ⌜ Vec.lookup (squashSub σ) x ⌝
    ≡⟨ cong ⌜_⌝ (VecProps.lookup-map x squashTerm σ) ⟩
      ⌜ squashTerm (Vec.lookup σ x) ⌝
    ≡⟨ ⌜⌝∘⌞⌟-id (squashElim ⌜ Vec.lookup σ x ⌝) ⟩
      squashElim ⌜ Vec.lookup σ x ⌝
    ∎
  open SquashSubstAppLemmas termLift squashSub squash-↑ squash-lookup public

  squash-id : ∀ {n} → squashSub (id {n}) ≡ id
  squash-id {zero}  = refl
  squash-id {suc n} = cong (var zero ∷_) (begin
    Vec.map squashTerm (Vec.map weaken id)  ≡˘⟨ map-∘ squashTerm weaken id ⟩
    Vec.map (squashTerm ∘ weaken) id        ≡˘⟨ map-cong squashTerm-/Var id ⟩
    Vec.map (weaken ∘ squashTerm) id        ≡⟨ map-∘ weaken squashTerm id ⟩
    Vec.map weaken (Vec.map squashTerm id)  ≡⟨ cong (Vec.map weaken) squash-id ⟩
    Vec.map weaken id                       ∎)

  squash-sub : ∀ {n} (a : Term n) → squashSub (sub a) ≡ sub (squashTerm a)
  squash-sub a = cong (squashTerm a ∷_) squash-id

  -- Squashing commutes with single-variable substitutions in kinds.

  squashKind-[] : ∀ {n} k (a : Elim n) →
                  squashKind (k Kind′[ ⌞ a ⌟ ]) ≡
                    squashKind k Kind′[ ⌞ squashElim a ⌟ ]
  squashKind-[] k a = begin
      squashKind (k Kind′[ ⌞ a ⌟ ])
    ≡˘⟨ squashKind-/ k ⟩
      squashKind k Kind′/ squashSub (sub ⌞ a ⌟)
    ≡⟨ cong (squashKind k Kind′/_) (squash-sub ⌞ a ⌟) ⟩
      squashKind k Kind′[ squashTerm ⌞ a ⌟ ]
    ≡⟨ cong ((squashKind k Kind′[_]) ∘ ⌞_⌟ ∘ squashElim) (⌜⌝∘⌞⌟-id a) ⟩
      squashKind k Kind′[ ⌞ squashElim a ⌟ ]
    ∎

open Substitution using (weakenElimAsc)
open SquashSubstLemmas

-- Context lookup and conversion to vector representation commute with
-- squashing

toVec-squashCtx : ∀ {n} (Γ : Ctx n) →
                  toVec (squashCtx Γ) ≡ Vec.map squashAsc (toVec Γ)
toVec-squashCtx []      = refl
toVec-squashCtx (a ∷ Γ) = cong₂ _∷_ (squashAsc-/Var a) (begin
    Vec.map weakenElimAsc (toVec (squashCtx Γ))
  ≡⟨ cong (Vec.map weakenElimAsc) (toVec-squashCtx Γ) ⟩
    Vec.map weakenElimAsc (Vec.map squashAsc (toVec Γ))
  ≡˘⟨ map-∘ weakenElimAsc squashAsc (toVec Γ) ⟩
    Vec.map (weakenElimAsc ∘ squashAsc) (toVec Γ)
  ≡⟨ map-cong squashAsc-/Var (toVec Γ) ⟩
    Vec.map (squashAsc ∘ weakenElimAsc) (toVec Γ)
  ≡⟨ map-∘ squashAsc weakenElimAsc (toVec Γ) ⟩
    Vec.map squashAsc (Vec.map weakenElimAsc (toVec Γ))
  ∎)
  where open ≡-Reasoning

lookup-squashCtx : ∀ {n} (Γ : Ctx n) x →
                   lookup (squashCtx Γ) x ≡ squashAsc (lookup Γ x)
lookup-squashCtx {n} Γ x = begin
    Vec.lookup (toVec (squashCtx Γ)) x
  ≡⟨ cong (λ Δ → Vec.lookup Δ x) (toVec-squashCtx Γ) ⟩
    Vec.lookup (Vec.map squashAsc (toVec Γ)) x
  ≡⟨ VecProps.lookup-map x squashAsc (toVec Γ) ⟩
    squashAsc (Vec.lookup (toVec Γ) x)
  ∎
  where open ≡-Reasoning

------------------------------------------------------------------------
-- Predicates characterizing first-order kinds, bindings and contexts.

data FOKind {n} : Kind Elim n → Set where
  fo-⋯ : ∀ {a b}   → FOKind (a ⋯ b)
  fo-Π : ∀ {a b k} → FOKind k → FOKind (Π (a ⋯ b) k)

data FOAsc {n} : ElimAsc n → Set where
  fo-kd : ∀ {k} → FOKind k → FOAsc (kd k)

open ContextFormation (λ {n} Γ → FOAsc {n}) public using () renaming
  ( _wf to FOCtx; [] to fo-[]; _∷_ to fo-∷
  ; WellFormedWeakenOps to FOWeakenOps)

<∷-FOKind₂ : ∀ {n} {Γ : Ctx n} {j k} → Γ ⊢ j <∷ k → FOKind k
<∷-FOKind₂ (<∷-⋯ _ _)      = fo-⋯
<∷-FOKind₂ (<∷-Π _ _ j<∷k) = fo-Π (<∷-FOKind₂ j<∷k)

module FOSubstAppLemmas {T : ℕ → Set} (l : Lift T Term) where
  open SubstApp l

  FOKind-/ : ∀ {m n k} {σ : Sub T m n} → FOKind k → FOKind (k Kind′/ σ)
  FOKind-/ fo-⋯        = fo-⋯
  FOKind-/ (fo-Π k-fo) = fo-Π (FOKind-/ k-fo)

  FOAsc-/ : ∀ {m n a} {σ : Sub T m n} → FOAsc a → FOAsc (a ElimAsc/ σ)
  FOAsc-/ (fo-kd k-fo) = fo-kd (FOKind-/ k-fo)

module FOSubstLemmas where
  open Substitution using (termSubst)
  open TermSubst termSubst using (varLift; termLift)

  open FOSubstAppLemmas varLift public using ()
    renaming (FOKind-/ to FOKind-/Var; FOAsc-/ to FOAsc-/Var)
  open FOSubstAppLemmas termLift public

  FOAsc-weaken : ∀ {n} {a : ElimAsc n} → FOAsc a → FOAsc (weakenElimAsc a)
  FOAsc-weaken a-fo = FOAsc-/Var a-fo

open FOSubstLemmas

foWeakenOps : FOWeakenOps weakenOps
foWeakenOps = record { wf-weaken = λ _ → FOAsc-weaken }
open FOWeakenOps foWeakenOps public using () renaming (lookup to lookup-FOAsc)

lookup-FOKind : ∀ {m} {Γ : Ctx m} {k} x →
                FOCtx Γ → ElimCtx.lookup Γ x ≡ kd k → FOKind k
lookup-FOKind x Γ-fo Γ[x]≡kd-a with subst FOAsc Γ[x]≡kd-a (lookup-FOAsc Γ-fo x)
... | fo-kd k-fo = k-fo

------------------------------------------------------------------------
-- Reduction of canonical judgments to their reduced forms

open Substitution hiding (subst)

mutual

  reduce-ctx : ∀ {n} {Γ : Ctx n} → FOCtx (squashCtx Γ) →
               Γ C.ctx → squashCtx Γ ctx
  reduce-ctx fo-[] C.[]                        = []
  reduce-ctx (fo-∷ a-fo Γ-fo) (a-wf C.∷ Γ-ctx) =
    reduce-wf Γ-fo a-fo a-wf ∷ reduce-ctx Γ-fo Γ-ctx

  reduce-wf : ∀ {n} {Γ : Ctx n} {a} →
              FOCtx (squashCtx Γ) → FOAsc (squashAsc a) →
              Γ C.⊢ a wf → squashCtx Γ ⊢ squashAsc a wf
  reduce-wf Γ-fo (fo-kd k-fo) (C.wf-kd k-kd)  =
    wf-kd (reduce-kd Γ-fo k-fo k-kd)
  reduce-wf Γ-fo _ (C.wf-tp a⇉a⋯a) = wf-tp (reduce-Nf⇉ Γ-fo a⇉a⋯a)

  reduce-kd : ∀ {n} {Γ : Ctx n} {k} →
              FOCtx (squashCtx Γ) → FOKind (squashKind k) →
              Γ C.⊢ k kd → squashCtx Γ ⊢ squashKind k kd
  reduce-kd Γ-fo _ (C.kd-⋯ a⇉a⋯a b⇉b⋯b) =
    kd-⋯ (reduce-Nf⇉ Γ-fo a⇉a⋯a) (reduce-Nf⇉ Γ-fo b⇉b⋯b)
  reduce-kd Γ-fo (fo-Π k-fo) (C.kd-Π (C.kd-⋯ a⇉a⋯a b⇉b⋯b) k-kd) =
    kd-Π (reduce-Nf⇉ Γ-fo a⇉a⋯a) (reduce-Nf⇉ Γ-fo b⇉b⋯b)
         (reduce-kd (fo-∷ (fo-kd fo-⋯) Γ-fo) k-fo k-kd)
  reduce-kd Γ-fo () (C.kd-Π (C.kd-Π _ _) k-kd)

  reduce-Var∈ : ∀ {n} {Γ : Ctx n} {x k} → FOCtx (squashCtx Γ) →
                Γ C.⊢Var x ∈ k → ∃ λ j →
                squashCtx Γ ⊢Var x ⇉ j × squashCtx Γ ⊢ j <∷ squashKind k
  reduce-Var∈ {_} {Γ} Γ-fo (C.⇉-var x Γ-ctx Γ[x]≡kd-j₁) =
    let Γ-ctx′      = reduce-ctx Γ-fo Γ-ctx
        Γ[x]≡kd-j₁′ = trans (lookup-squashCtx Γ x) (cong squashAsc Γ[x]≡kd-j₁)
    in _ , ⇉-var x Γ-ctx′ Γ[x]≡kd-j₁′ ,
       <∷-refl (lookup-kd x Γ-ctx′ Γ[x]≡kd-j₁′)
  reduce-Var∈ Γ-fo (C.⇇-⇑ x∈k₁ k₁<∷k₂ _) =
    let j , x∈j , j<∷k₁ = reduce-Var∈ Γ-fo x∈k₁
    in  j , x∈j , <∷-trans j<∷k₁ (reduce-<∷ Γ-fo (<∷-FOKind₂ j<∷k₁) k₁<∷k₂)

  reduce-Ne∈ : ∀ {n} {Γ : Ctx n} {a b c} → FOCtx (squashCtx Γ) →
               Γ C.⊢Ne a ∈ (b ⋯ c) →
               squashCtx Γ ⊢Nf squashElim a ⇇ squashKind (b ⋯ c)
  reduce-Ne∈ {_} {Γ} Γ-fo (C.∈-∙ {as = as} x∈j₂ j₂⇉as⇉b₂⋯c₂) =
    let j₁ , x⇉j₁ , j₁<∷j₂ = reduce-Var∈ Γ-fo x∈j₂
        j₂-fo              = <∷-FOKind₂ j₁<∷j₂
        j₂⇉as⇉b₂⋯c₂′       = reduce-Sp⇉ Γ-fo j₂-fo j₂⇉as⇉b₂⋯c₂
        k₁ , j₁⇉as⇉k₁ , k₁<∷b₂⋯c₂        = <∷-Sp⇉ j₁<∷j₂ j₂⇉as⇉b₂⋯c₂′
        _ , _ , b₂∼b₁ , c₁∼c₂ , k₁≡b₁⋯c₁ = <∷-⋯-inv k₁<∷b₂⋯c₂
        j₁⇉as⇉b₁⋯c₁ = subst (squashCtx Γ ⊢ j₁ ⇉∙ squashSpine as ⇉_)
                            k₁≡b₁⋯c₁ j₁⇉as⇉k₁
    in Nf⇇-⇑ (Nf⇇-ne (⇉-∙ x⇉j₁ j₁⇉as⇉b₁⋯c₁)) (<∷-⋯ b₂∼b₁ c₁∼c₂)

  reduce-Nf⇉ : ∀ {n} {Γ : Ctx n} {a b c} → FOCtx (squashCtx Γ) →
               Γ C.⊢Nf a ⇉ b ⋯ c →
               squashCtx Γ ⊢Nf squashElim a ⇉ squashElim b ⋯ squashElim c
  reduce-Nf⇉ Γ-fo (C.⇉-⊥-f Γ-ctx)   = ⇉-⊥-f (reduce-ctx Γ-fo Γ-ctx)
  reduce-Nf⇉ Γ-fo (C.⇉-⊤-f Γ-ctx)   = ⇉-⊤-f (reduce-ctx Γ-fo Γ-ctx)
  reduce-Nf⇉ Γ-fo (C.⇉-∀-f k-kd _)  =
    ⇉-⊤-f (reduce-kd-ctx Γ-fo k-kd)
  reduce-Nf⇉ Γ-fo (C.⇉-→-f a⇉a⋯a _) =
    ⇉-⊤-f (Nf⇉-ctx (reduce-Nf⇉ Γ-fo a⇉a⋯a))
  reduce-Nf⇉ Γ-fo (C.⇉-s-i (C.∈-∙ x∈j j⇉as⇉b⋯c))
    with reduce-Ne∈ Γ-fo (C.∈-∙ x∈j j⇉as⇉b⋯c)
  ... | ⇇-⇑ (⇉-s-i x∙as∈b′⋯c′) (<∷-⋯ _ _) = ⇉-s-i x∙as∈b′⋯c′

  reduce-Nf⇇ : ∀ {n} {Γ : Ctx n} {a b c} → FOCtx (squashCtx Γ) →
               Γ C.⊢Nf a ⇇ b ⋯ c →
               squashCtx Γ ⊢Nf squashElim a ⇇ squashElim b ⋯ squashElim c
  reduce-Nf⇇ Γ-fo (C.⇇-⇑ a⇉b₁⋯c₁ (C.<∷-⋯ b₂<:b₁ c₁<:c₂)) =
    ⇇-⇑ (reduce-Nf⇉ Γ-fo a⇉b₁⋯c₁)
        (<∷-⋯ (reduce-<: Γ-fo b₂<:b₁) (reduce-<: Γ-fo c₁<:c₂))

  reduce-Sp⇉ : ∀ {n} {Γ : Ctx n} {j as k} →
               FOCtx (squashCtx Γ) → FOKind (squashKind j) →
               Γ C.⊢ j ⇉∙ as ⇉ k →
               squashCtx Γ ⊢ squashKind j ⇉∙ squashSpine as ⇉ squashKind k
  reduce-Sp⇉ Γ-fo _ C.⇉-[]                  = ⇉-[]
  reduce-Sp⇉ Γ-fo (fo-Π k-fo)
             (C.⇉-∷ {a} {as} {b ⋯ c} {k} a⇇b⋯c _ k[a∈★]⇉as⇉l) =
    let k[a∈★]≡k[a] = trans (cong squashKind (Kind/⟨★⟩-/ k))
                            (squashKind-[] k a)
        k[a∈★]-fo   = subst FOKind (sym k[a∈★]≡k[a])
                            (FOKind-/ {σ = sub ⌞ squashElim a ⌟} k-fo)
    in ⇉-∷ (reduce-Nf⇇ Γ-fo a⇇b⋯c)
           (subst (_ ⊢_⇉∙ _ ⇉ _) k[a∈★]≡k[a]
                  (reduce-Sp⇉ Γ-fo k[a∈★]-fo k[a∈★]⇉as⇉l))

  reduce-<∷ : ∀ {n} {Γ : Ctx n} {j k} →
              FOCtx (squashCtx Γ) → FOKind (squashKind j) →
              Γ C.⊢ j <∷ k → squashCtx Γ ⊢ squashKind j <∷ squashKind k
  reduce-<∷ Γ-fo a₁⋯a₂-fo (C.<∷-⋯ a₂<:a₁ b₁<:b₂) =
    <∷-⋯ (reduce-<: Γ-fo a₂<:a₁) (reduce-<: Γ-fo b₁<:b₂)
  reduce-<∷ Γ-fo (fo-Π k₁-fo) (C.<∷-Π (C.<∷-⋯ a₁<:a₂ b₂<:b₁) k₁<∷k₂ bb) =
    <∷-Π (reduce-<: Γ-fo a₁<:a₂) (reduce-<: Γ-fo b₂<:b₁)
         (reduce-<∷ (fo-∷ (fo-kd fo-⋯) Γ-fo) k₁-fo k₁<∷k₂)

  reduce-<: : ∀ {n} {Γ : Ctx n} {a b} → FOCtx (squashCtx Γ) →
              Γ C.⊢ a <: b → squashCtx Γ ⊢ squashElim a ∼ squashElim b
  reduce-<: Γ-fo (C.<:-trans a<:b b<:c) =
    ∼-trans (reduce-<: Γ-fo a<:b) (reduce-<: Γ-fo b<:c)
  reduce-<: Γ-fo (C.<:-⊥ b⇉b⋯b) = ∼-⊥ (reduce-Nf⇉ Γ-fo b⇉b⋯b)
  reduce-<: Γ-fo (C.<:-⊤ a⇉a⋯a) = ∼-⊤ (reduce-Nf⇉ Γ-fo a⇉a⋯a)
  reduce-<: Γ-fo (C.<:-∀ _ _ ∀ka⇉⋯) =
    ∼-⊤ (⇉-⊤-f (Nf⇉-ctx (reduce-Nf⇉ Γ-fo ∀ka⇉⋯)))
  reduce-<: Γ-fo (C.<:-→ a₂<:a₁ _) =
    ∼-⊤ (⇉-⊤-f (∼-ctx (reduce-<: Γ-fo a₂<:a₁)))
  reduce-<: {_} {Γ} Γ-fo (C.<:-∙ {as₁ = as} {bs} x∈j₂ j₂⇉as∼bs⇉c₂⋯d₂) =
    let j₁ , x⇉j₁ , j₁<∷j₂ = reduce-Var∈ Γ-fo x∈j₂
        j₂-fo              = <∷-FOKind₂ j₁<∷j₂
        j₂⇉as∼bs⇉c₂⋯d₂′    = reduce-Sp≃ Γ-fo j₂-fo j₂⇉as∼bs⇉c₂⋯d₂
        k₁ , j₁⇉as∼bs⇉k₁ , k₁<∷c₂⋯d₂ = <∷-Sp∼ j₁<∷j₂ j₂⇉as∼bs⇉c₂⋯d₂′
        _ , _ , _ , _ , k₁≡c₁⋯d₁     = <∷-⋯-inv k₁<∷c₂⋯d₂
        j₁⇉as∼bs⇉c₁⋯d₁ = subst (squashCtx Γ ⊢ j₁ ⇉∙ squashSpine as ∼
                                                    squashSpine bs ⇉_)
                               k₁≡c₁⋯d₁ j₁⇉as∼bs⇉k₁
    in ∼-∙ x⇉j₁ j₁⇉as∼bs⇉c₁⋯d₁
  reduce-<: Γ-fo (C.<:-⟨| b∈a⋯c) with reduce-Ne∈ Γ-fo b∈a⋯c
  ... | b⇇a⋯c = ∼-⟨|-Nf⇇ b⇇a⋯c
  reduce-<: Γ-fo (C.<:-|⟩ a∈c⋯b) with reduce-Ne∈ Γ-fo a∈c⋯b
  ... | a⇇c⋯b = ∼-|⟩-Nf⇇ a⇇c⋯b

  reduce-Sp≃ : ∀ {n} {Γ : Ctx n} {j as bs k} →
               FOCtx (squashCtx Γ) → FOKind (squashKind j) →
               Γ C.⊢ j ⇉∙ as ≃ bs ⇉ k →
               squashCtx Γ ⊢ squashKind j ⇉∙ squashSpine as ∼
                                             squashSpine bs ⇉ squashKind k
  reduce-Sp≃ Γ-fo _ C.≃-[] = ∼-[]
  reduce-Sp≃ Γ-fo (fo-Π k-fo)
             (C.≃-∷ {j = c ⋯ d}
                    (C.<:-antisym _
                      (C.<:-⇇ (C.⇇-⇑ a⇉c₁⋯d₁ (C.<∷-⋯ _ _)) _ a<:b) _)
                    k[a∈★]⇉as≃bs⇉l)
             with C.Nf⇉-≡ a⇉c₁⋯d₁
  reduce-Sp≃ Γ-fo (fo-Π k-fo)
             (C.≃-∷ {a} {as} {b} {bs} {c ⋯ d} {k}
                    (C.<:-antisym _
                      (C.<:-⇇ (C.⇇-⇑ a⇉a⋯a (C.<∷-⋯ c<:a a<:d)) _ a<:b) _)
                    k[a∈★]⇉as≃bs⇉l)
             | refl , refl =
    let k[a∈★]≡k[a] = trans (cong squashKind (Kind/⟨★⟩-/ k))
                            (squashKind-[] k a)
        k[a∈★]-fo   = subst FOKind (sym k[a∈★]≡k[a])
                            (FOKind-/ {σ = sub ⌞ squashElim a ⌟} k-fo)
    in ∼-∷ (reduce-<: Γ-fo c<:a) (reduce-<: Γ-fo a<:d)
           (reduce-<: Γ-fo a<:b)
           (subst (_ ⊢_⇉∙ _ ∼ _ ⇉ _) k[a∈★]≡k[a]
                  (reduce-Sp≃ Γ-fo k[a∈★]-fo k[a∈★]⇉as≃bs⇉l))

  -- A helper to satisfy the termination checker.

  reduce-kd-ctx : ∀ {n} {Γ : Ctx n} {k} →
                  FOCtx (squashCtx Γ) → Γ C.⊢ k kd → squashCtx Γ ctx
  reduce-kd-ctx Γ-fo (C.kd-⋯ a⇉a⋯a _) = Nf⇉-ctx (reduce-Nf⇉ Γ-fo a⇉a⋯a)
  reduce-kd-ctx Γ-fo (C.kd-Π j-kd _)  = reduce-kd-ctx Γ-fo j-kd


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

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

open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Handle
open import LibraBFT.Impl.Handle.Properties
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Concrete.System
open        EpochConfig
open import LibraBFT.Yasm.Types
open import LibraBFT.Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms PeerCanSignForPK (λ {st} {part} {pk} → PeerCanSignForPK-stable {st} {part} {pk})

-- In this module, we define two "implementation obligations"
-- (ImplObligationᵢ for i ∈ {1 , 2}), which are predicates over
-- reachable states of a system defined by
-- 'LibraBFT.Concrete.System.Parameters'.  These two properties relate
-- votes sent by the same sender, ensuring that if they are for the
-- same epoch and round, then they vote for the same blockID; the
-- first relates a vote output by the handler to a vote sent
-- previously, and the second relates two votes both sent by the
-- handler.
--
-- We then prove that, if an implementation satisfies these two
-- semantic obligations, along with a structural one about messages
-- sent by honest peers in the implementation, then the implemenation
-- satisfies the LibraBFT.Abstract.Properties.VotesOnce invariant.

module LibraBFT.Concrete.Properties.VotesOnce where
 -- TODO-3: This may not be the best way to state the implementation obligation.  Why not reduce
 -- this as much as possible before giving the obligation to the implementation?  For example, this
 -- will still require the implementation to deal with hash collisons (v and v' could be different,
 -- but yield the same bytestring and therefore same signature).  Also, avoid the need for the
 -- implementation to reason about messages sent by step-cheat, or give it something to make this
 -- case easy to eliminate.

 ImplObligation₁ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₁ =
   ∀{pid pid' s' outs pk}{pre : SystemState}
   → ReachableSystemState pre
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → ∀{v m v' m'} → Meta-Honest-PK pk
   -- For signed every vote v of every outputted message
   → v  ⊂Msg m  → send m ∈ outs
   → (sig : WithVerSig pk v) → ¬ (∈GenInfo (ver-signature sig))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre)) → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v pid pk
   -- And if there exists another v' that has been sent before
   → v' ⊂Msg m' → (pid' , m') ∈ (msgPool pre)
   → (sig' : WithVerSig pk v') → ¬ (∈GenInfo (ver-signature sig'))
   -- If v and v' share the same epoch and round
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → v ^∙ vRound ≡ v' ^∙ vRound
   ----------------------------------------------------------
   -- Then an honest implemenation promises v and v' vote for the same blockId.
   → v ^∙ vProposedId ≡ v' ^∙ vProposedId

 ImplObligation₂ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₂ =
   ∀{pid s' outs pk}{pre : SystemState}
   → ReachableSystemState pre
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → ∀{v m v' m'}
   → Meta-Honest-PK pk
   -- For every vote v represented in a message output by the call
   → v  ⊂Msg m  → send m ∈ outs
   → (sig : WithVerSig pk v) → ¬ (∈GenInfo (ver-signature sig))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre)) → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v pid pk

   -- And if there exists another v' that is also new and valid
   → v' ⊂Msg m'  → send m' ∈ outs
   → (sig' : WithVerSig pk v') → ¬ (∈GenInfo (ver-signature sig'))
   → ¬ (MsgWithSig∈ pk (ver-signature sig') (msgPool pre)) → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v' pid pk

   -- If v and v' share the same epoch and round
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → v ^∙ vRound ≡ v' ^∙ vRound
   ----------------------------------------------------------
   -- Then, an honest implemenation promises v and v' vote for the same blockId.
   → v ^∙ vProposedId ≡ v' ^∙ vProposedId

 -- Next, we prove that, given the necessary obligations,
 module Proof
   (sps-corr : StepPeerState-AllValidParts)
   (Impl-VO1 : ImplObligation₁)
   (Impl-VO2 : ImplObligation₂)
   where

  -- Any reachable state satisfies the VO rule for any epoch in the system.
  module _ (st : SystemState)(r : ReachableSystemState st)(𝓔 : EpochConfig) where

   open Structural sps-corr
   -- Bring in IntSystemState
   open WithSPS sps-corr
   open PerState st r
   open PerEpoch 𝓔

   open import LibraBFT.Concrete.Obligations.VotesOnce 𝓔 (ConcreteVoteEvidence 𝓔) as VO

   -- The VO proof is done by induction on the execution trace leading to 'st'. In
   -- Agda, this is 'r : RechableSystemState st' above.

   private

    -- From this point onwards, it might be easier to read this proof starting at 'voo'
    -- at the end of the file. Next, we provide an overview the proof.
    --
    -- We wish to prove that, for any two votes v and v' cast by an honest α in the message
    -- pool of a state st, if v and v' have equal rounds and epochs, then they vote for the
    -- same block.
    --
    -- The base case and the case for a new epoch in the system are trivial. For the base case
    -- we get to a contradiction because it's not possible to have any message in the msgpool.
    --
    -- Regarding the PeerStep case. The induction hypothesis tells us that the property holds
    -- in the pre-state.  Next, we reason about the post-state.  We start by analyzing whether
    -- v and v' have been sent as outputs of the PeerStep under scrutiny or were already in
    -- the pool before.
    --
    -- There are four possibilities:
    --
    --   i) v and v' were aleady present in the msgPool before: use induction hypothesis.
    --  ii) v and v' are both in the output produced by the PeerStep under scrutiny.
    -- iii) v was present before, but v' is new.
    --  iv) v' was present before, but v is new.
    --
    -- In order to obtain this four possiblities we invoke newMsg⊎msgSent4 lemma, which
    -- receives proof that some vote is in a message that is in the msgPool of the post state
    -- and returns evidence that either the vote is new or that some message with the same
    -- signature was sent before.
    --
    -- Case (i) is trivial; cases (iii) and (iv) are symmetric and reduce to an implementation
    -- obligation (Impl-VO1) and case (ii) reduces to a different implementation obligation
    -- (Impl-VO2).

    VotesOnceProof :
       ∀ {v v' pk} {st : SystemState}
       → ReachableSystemState st
       → Meta-Honest-PK pk
       → (vv  : WithVerSig pk v)  → MsgWithSig∈ pk (ver-signature vv)  (msgPool st)
       → (vv' : WithVerSig pk v') → MsgWithSig∈ pk (ver-signature vv') (msgPool st)
       → v ^∙ vEpoch ≡ v' ^∙ vEpoch
       → v ^∙ vRound ≡ v' ^∙ vRound
       → v ^∙ vProposedId ≡ v' ^∙ vProposedId
    VotesOnceProof step-0 _ _ msv _ _ _ _ = ⊥-elim (¬Any[] (msg∈pool msv))
    VotesOnceProof {v} {v'} (step-s r theStep) pkH vv msv vv' msv' eid≡ r≡
       with msgSameSig msv | msgSameSig msv'
    ...| refl | refl
      with sameSig⇒sameVoteDataNoCol (msgSigned msv)  vv  (msgSameSig msv )
         | sameSig⇒sameVoteDataNoCol (msgSigned msv') vv' (msgSameSig msv')
    ...| refl | refl
       with ∈GenInfo? (₋vSignature (msgPart msv)) | ∈GenInfo? (₋vSignature (msgPart msv'))
    ...| yes init  | yes init' =  genVotesConsistent (msgPart msv) (msgPart msv') init init'
       -- A signature in GenInfo is for a vote with round 0, and a signature for which we have a
       -- MsgWithSig∈ that is not in GenInfo and is for an honest PK is for a round ≢ 0, so we can
       -- derive a contradiction using r≡.
    ...| yes init  | no  ¬init = ⊥-elim (¬genVotesRound≢0 (step-s r theStep) pkH msv' ¬init ((trans (sym r≡) (genVotesRound≡0 vv  init))))
    ...| no  ¬init | yes init  = ⊥-elim (¬genVotesRound≢0 (step-s r theStep) pkH msv  ¬init ((trans r≡       (genVotesRound≡0 vv' init))))
    ...| no  ¬init | no ¬init'
       with theStep
    ...| step-peer cheat@(step-cheat c)
       with ¬cheatForgeNew cheat refl unit pkH msv  ¬init
          | ¬cheatForgeNew cheat refl unit pkH msv' ¬init'
    ...| msb4 | m'sb4
       with  msgSameSig msb4 | msgSameSig m'sb4
    ...| refl | refl = VotesOnceProof r pkH vv msb4 vv' m'sb4 eid≡ r≡

    VotesOnceProof (step-s r theStep) pkH vv msv vv' msv' eid≡ r≡
       | refl | refl
       | refl | refl
       | no  ¬init | no ¬init'
       | step-peer (step-honest stPeer)
       with newMsg⊎msgSentB4 r stPeer pkH (msgSigned msv)  ¬init  (msg⊆ msv)  (msg∈pool msv)
          | newMsg⊎msgSentB4 r stPeer pkH (msgSigned msv') ¬init' (msg⊆ msv') (msg∈pool msv')
    ...| inj₂ msb4                   | inj₂ m'sb4
         = VotesOnceProof r pkH vv msb4 vv' m'sb4 eid≡ r≡
    ...| inj₁ (m∈outs , vspk , newV) | inj₁ (m'∈outs , v'spk , newV')
      = Impl-VO2 r stPeer pkH (msg⊆ msv) m∈outs (msgSigned msv) ¬init newV vspk
                 (msg⊆ msv') m'∈outs (msgSigned msv') ¬init' newV' v'spk eid≡ r≡
    ...| inj₁ (m∈outs , vspk , newV) | inj₂ m'sb4
       with sameSig⇒sameVoteData (msgSigned m'sb4) vv' (msgSameSig m'sb4)
    ...| inj₁ hb   = ⊥-elim (meta-sha256-cr hb)
    ...| inj₂ refl rewrite sym (msgSameSig msv')
      = Impl-VO1 r stPeer pkH (msg⊆ msv) m∈outs (msgSigned msv) ¬init newV vspk
                 (msg⊆ m'sb4) (msg∈pool m'sb4) (msgSigned m'sb4) (¬subst ¬init' (msgSameSig m'sb4)) eid≡ r≡

    VotesOnceProof (step-s r theStep) pkH vv msv vv' msv' eid≡ r≡
       | refl | refl
       | refl | refl
       | no  ¬init | no ¬init'
       | step-peer (step-honest stPeer)
       | inj₂ msb4                   | inj₁ (m'∈outs , v'spk , newV')
       with sameSig⇒sameVoteData (msgSigned msb4) vv (msgSameSig msb4)
    ...| inj₁ hb = ⊥-elim (meta-sha256-cr hb)
    ...| inj₂ refl
      = sym (Impl-VO1 r stPeer pkH (msg⊆ msv') m'∈outs (msgSigned msv') ¬init' newV' v'spk
                      (msg⊆ msb4) (msg∈pool msb4) (msgSigned msb4) (¬subst ¬init (msgSameSig msb4)) (sym eid≡) (sym r≡))

   voo : VO.Type IntSystemState
   voo hpk refl sv refl sv' round≡
      with vmsg≈v (vmFor sv) | vmsg≈v (vmFor sv')
   ...| refl | refl
       = let ver = vmsgSigned (vmFor sv)
             mswsv = mkMsgWithSig∈ (nm (vmFor sv)) (cv (vmFor sv)) (cv∈nm (vmFor sv))
                                    _ (nmSentByAuth sv) (vmsgSigned (vmFor sv)) refl
             ver' = vmsgSigned (vmFor sv')
             mswsv' = mkMsgWithSig∈ (nm (vmFor sv')) (cv (vmFor sv')) (cv∈nm (vmFor sv'))
                                     _ (nmSentByAuth sv') (vmsgSigned (vmFor sv')) refl
             epoch≡ = trans (vmsgEpoch (vmFor sv)) (sym (vmsgEpoch (vmFor sv')))
         in VotesOnceProof r hpk ver mswsv ver' mswsv' epoch≡ round≡


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat

{-# BUILTIN REWRITE _≡_ #-}

not : Bool → Bool
not true = false
not false = true

postulate rew : Nat ≡ Bool
{-# REWRITE rew #-}

0' : Bool
0' = 0

test : not 0' ≡ true
test = refl