-- Andreas, 2015-03-17
-- Andreas, 2020-10-26 conform to Issue1428a

open import Agda.Builtin.Size

data ⊥ : Set where

data SizeLt (i : Size) : Set where
  wrap : Size< i → SizeLt i

-- This definition of size predecessor should be forbidden...
module _ (i : Size) where
  postulate
    pred : Size< i

-- ...otherwise the injectivity test loops here.
iter : ∀ i → SizeLt i → ⊥
iter i (wrap j) = iter j (wrap (pred j))

loop : Size → ⊥
loop i = iter i (wrap (pred i))

absurd : ⊥
absurd = FIXME loop ∞

-- Testcase temporarily mutilated, original error:
--
-- -Issue1428c.agda:...
-- -We don't like postulated sizes in parametrized modules.
--
-- +Issue1428c.agda:...
-- +Not in scope:
-- +  FIXME at Issue1428c.agda:...
-- +when scope checking FIXME


module par-swap.dpg-pot where

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List using ([] ; [_] ; _∷_ ; List ; _++_)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym)
open import Data.Maybe using ()
open import Data.List.Any using (here ; there)
open import Data.List.Any.Properties using ( ++-comm ; ++⁻ ; ++⁺ˡ ; ++⁺ʳ )
open import Data.Nat as Nat using (ℕ)

open import par-swap
open import par-swap.properties

open import Esterel.Lang.CanFunction
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction.Plug
open import Esterel.Environment as Env
open import Esterel.Context

open import utility

open import sn-calculus
open import context-properties -- get view, E-views
open import sn-calculus-props

open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)

canₛ-par :
  ∀ r₁ r₂ -> ∀ (θ : Env) (S : ℕ) →
   S ∈ Canₛ (r₂ ∥ r₁) θ →
   S ∈ Canₛ (r₁ ∥ r₂) θ
canₛ-par r₁ r₂ θ S S∈r₂∥r₁
 = ++-comm (proj₁ (Can r₂ θ)) (proj₁ (Can r₁ θ)) S∈r₂∥r₁

canₖ-par :
  ∀ r₁ r₂ -> ∀ (θ : Env) (k : Code) →
    k ∈ Canₖ (r₂ ∥ r₁) θ →
    k ∈ Canₖ (r₁ ∥ r₂) θ
canₖ-par
 = \ {r₁ r₂ θ S S∈r₂∥r₁ ->
      thing S
      (proj₁ (proj₂ (Can r₁ θ)))
      (proj₁ (proj₂ (Can r₂ θ)))
      S∈r₂∥r₁}  where

 simplify-foldr++-[] : ∀ (l2 : List Code) ->
   (Data.List.foldr{A = (List Code)}
     _++_
     []
     (Data.List.map (λ (k : Code) → []) l2)) ≡ []
 simplify-foldr++-[] [] = refl
 simplify-foldr++-[] (x ∷ l2) = simplify-foldr++-[] l2

 whatevs-left : ∀ S (whatevs : Code -> Code) l1 l2 ->
   Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map (λ k → Data.List.map (Code._⊔_ k) l2) l1))
   ->
   Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map (λ k → (whatevs k) ∷ Data.List.map (Code._⊔_ k) l2) l1))
 whatevs-left S whatevs [] l2 ()
 whatevs-left S whatevs (x ∷ l1) l2 blob
  with ++⁻ (Data.List.map (Code._⊔_ x) l2) blob
 ... | inj₁ y = there (++⁺ˡ y)
 ... | inj₂ y
  with whatevs-left S whatevs l1 l2 y
 ... | R = there (++⁺ʳ (Data.List.map (Code._⊔_ x) l2)  R)

 whatevs-right :
   ∀ S (whatevs : Code -> List Code) x l1 ->
   Data.List.Any.Any (_≡_ S) (Data.List.map (Code._⊔_ x) l1)
   ->
   Data.List.Any.Any (_≡_ S)
      (Data.List.foldr _++_ []
       (Data.List.map (λ k → (k Code.⊔ x) ∷ whatevs k)
        l1))
 whatevs-right S whatevs x [] blob = blob
 whatevs-right S whatevs x (x₁ ∷ l1) (here px)
  rewrite px = here (Code.⊔-comm x x₁)
 whatevs-right S whatevs x (x₁ ∷ l1) (there blob)
  = there (++⁺ʳ (whatevs x₁) (whatevs-right S whatevs x l1 blob))

 thing : ∀ S l1 l2 ->
    Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map
       (λ k → Data.List.map (Code._⊔_ k) l1)
       l2))
    ->
    Data.List.Any.Any (_≡_ S)
     (Data.List.foldr _++_ []
      (Data.List.map
       (λ k → Data.List.map (Code._⊔_ k) l2)
       l1))

 thing S l1 [] blob
   rewrite simplify-foldr++-[] l1
   = blob

 thing S l1 (x ∷ l2) blob
  with ++⁻ (Data.List.map (Code._⊔_ x) l1) blob
 thing S l1 (x ∷ l2) _ | inj₁ y =
   whatevs-right S (λ { k → Data.List.map (Code._⊔_ k) l2 }) x l1 y
 thing S l1 (x ∷ l2) _ | inj₂ y =
   whatevs-left S (\ { k ->  (k Code.⊔ x)}) l1 l2 (thing S l1 l2 y)

canₛₕ-par :
  ∀ r₁ r₂ -> ∀ (θ : Env) →
   Canₛₕ (r₂ ∥ r₁) θ ⊆¹ Canₛₕ (r₁ ∥ r₂) θ
canₛₕ-par r₁ r₂ θ S S∈r₂∥r₁
 = ++-comm (proj₂ (proj₂ (Can r₂ θ))) (proj₂ (proj₂ (Can r₁ θ))) S∈r₂∥r₁

canθₛ-C-par : ∀ sigs S'' -> ∀ {C p r₁ r₂} ->
    p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
    ∀ {θ} S' ->
     S' ∉ Canθₛ sigs S'' p θ ->
     S' ∉ Canθₛ sigs S'' (C ⟦ r₂ ∥ r₁ ⟧c) θ
canθₛ-C-par sigs S'' {C} {p} {r₁} {r₂} pC {θ} S' S'∉Canθₛ[p] S'∈Canθₛ[C⟦r₂∥r₁⟧c]
  with canθₛ-plug S'' sigs C (r₁ ∥ r₂) (r₂ ∥ r₁)
                 (canₛ-par r₁ r₂) (canₖ-par r₁ r₂) θ S'
... |  r₂r₁->r₁r₂ rewrite sym (unplugc pC) = S'∉Canθₛ[p] (r₂r₁->r₁r₂ S'∈Canθₛ[C⟦r₂∥r₁⟧c])

canθₛₕ-C-par : ∀ sigs S' -> ∀ {C p r₁ r₂} ->
    p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
    ∀ {θ} s' ->
     s' ∉ Canθₛₕ sigs S' p θ ->
     s' ∉ Canθₛₕ sigs S' (C ⟦ r₂ ∥ r₁ ⟧c) θ
canθₛₕ-C-par sigs S' {C} {p} {r₁} {r₂} pC {θ} s' s'∉Canθₛₕ[p] s'∈Canθₛₕ[C⟦r₂∥r₁⟧c]
  with canθₛₕ-plug S' sigs C (r₁ ∥ r₂) (r₂ ∥ r₁)
                  (canₛₕ-par r₁ r₂) (canₖ-par r₁ r₂) (canₛ-par r₁ r₂) θ s'
... | r₂r₁->r₁r₂ rewrite sym (unplugc pC) = s'∉Canθₛₕ[p] (r₂r₁->r₁r₂ s'∈Canθₛₕ[C⟦r₂∥r₁⟧c])

DPG-pot-view :
 ∀ {C r₁ r₂ p q θ θ' A A'} ->
  p ≐ C ⟦ r₁ ∥ r₂ ⟧c ->
  (psn⟶₁q : ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ' , A' ⟩· q) ->
  (p≡q : p ≡ q) ->
  (A≡A' : A ≡ A') ->
  ->pot-view psn⟶₁q p≡q A≡A' ->
  Σ[ dd′ ∈ Term × Term ]
  (ρ⟨ θ , A ⟩· C ⟦ r₂ ∥ r₁ ⟧c sn⟶ (proj₂ dd′))
  ×
  ((proj₂ dd′) sn⟶* (proj₁ dd′))
  ×
  ((ρ⟨ θ' , A' ⟩· q) ∥R* (proj₁ dd′))
DPG-pot-view pC (ris-present S∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (ris-absent S∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (remit S∈ ¬S≡a x) p≡q A≡A' ()
DPG-pot-view pC (rraise-shared e' x) p≡q A≡A' ()
DPG-pot-view pC (rset-shared-value-old e' s∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (rset-shared-value-new e' s∈ x x₁) p≡q A≡A' ()
DPG-pot-view pC (rraise-var e' x₁) p≡q A≡A' ()
DPG-pot-view pC (rset-var x∈ e' x₁) p≡q A≡A' ()
DPG-pot-view pC (rif-false x∈ x₁ x₂) p≡q A≡A' ()
DPG-pot-view pC (rif-true x∈ x₁ x₂) p≡q A≡A' ()
DPG-pot-view pC (rabsence{θ}{_}{S} S∈ x x₁) .refl .refl (vabsence .S .S∈ .x .x₁)
  = _ , rcontext [] dchole
         (rabsence{θ}{_}{S} S∈ x (canθₛ-C-par (sig θ) 0 pC (Signal.unwrap S) x₁)) ,
    rrefl ,
    Context1-∥R* (cenv _ _) (∥Rn (∥Rstep pC) ∥R0)
DPG-pot-view pC (rreadyness{θ}{_}{s} s∈ x x₁) .refl .refl (vreadyness .s .s∈ .x .x₁)
  = _ , rcontext [] dchole
         (rreadyness{s = s} s∈ x (canθₛₕ-C-par (sig θ) 0 pC (SharedVar.unwrap s) x₁)) ,
    rrefl ,
    Context1-∥R* (cenv _ _) (∥Rn (∥Rstep pC) ∥R0)
DPG-pot-view pC (rmerge x) p≡q A≡A' ()


-- Everything is strictly positive, but Agda doesn't see this.
{-# OPTIONS --no-positivity-check #-}

module Generic.Core where

open import Generic.Lib.Prelude public

infix  4 _≤ℓ_
infixr 5 _⇒_ _⊛_

_≤ℓ_ : Level -> Level -> Set
α ≤ℓ β = α ⊔ β ≡ β

mutual
  Binder : ∀ {ι} α β γ -> ArgInfo -> ι ⊔ lsuc (α ⊔ β) ≡ γ -> Set ι -> Set γ
  Binder α β γ i q I = Coerce q (∃ λ (A : Set α) -> < relevance i > A -> Desc I β)

  data Desc {ι} (I : Set ι) β : Set (ι ⊔ lsuc β) where
    var : I -> Desc I β
    π   : ∀ {α} i
        -> (q : α ≤ℓ β)
        -> Binder α β _ i (cong (λ αβ -> ι ⊔ lsuc αβ) q) I
        -> Desc I β
    _⊛_ : Desc I β -> Desc I β -> Desc I β

pattern DPi i A D = π i refl (coerce (A , D))

{-# DISPLAY π i refl (coerce (A , D)) = DPi i A D #-}

pattern explRelDPi A D = DPi explRelInfo A D
pattern explIrrDPi A D = DPi explIrrInfo A D
pattern implRelDPi A D = DPi implRelInfo A D
pattern implIrrDPi A D = DPi implIrrInfo A D
pattern instRelDPi A D = DPi instRelInfo A D
pattern instIrrDPi A D = DPi instIrrInfo A D

{-# DISPLAY DPi explRelInfo A D = explRelDPi A D #-}
{-# DISPLAY DPi explIrrInfo A D = explIrrDPi A D #-}
{-# DISPLAY DPi implRelInfo A D = implRelDPi A D #-}
{-# DISPLAY DPi implIrrInfo A D = implIrrDPi A D #-}
{-# DISPLAY DPi instRelInfo A D = instRelDPi A D #-}
{-# DISPLAY DPi instIrrInfo A D = instIrrDPi A D #-}

_⇒_ : ∀ {ι α β} {I : Set ι} {{q : α ≤ℓ β}} -> Set α -> Desc I β -> Desc I β
_⇒_ {{q}} A D = π (explRelInfo) q (qcoerce (A , λ _ -> D))

mutual
  ⟦_⟧ : ∀ {ι β} {I : Set ι} -> Desc I β -> (I -> Set β) -> Set β
  ⟦ var i   ⟧ B = B i
  ⟦ π i q C ⟧ B = ⟦ i / C ⟧ᵇ q B
  ⟦ D ⊛ E   ⟧ B = ⟦ D ⟧ B × ⟦ E ⟧ B

  ⟦_/_⟧ᵇ : ∀ {α ι β γ q} {I : Set ι} i
         -> Binder α β γ i q I -> α ≤ℓ β -> (I -> Set β) -> Set β
  ⟦ i / coerce (A , D) ⟧ᵇ q B = Coerce′ q $ Pi i A λ x -> ⟦ D x ⟧ B

mutual
  Extend : ∀ {ι β} {I : Set ι} -> Desc I β -> (I -> Set β) -> I -> Set β
  Extend (var i)   B j = Lift _ (i ≡ j)
  Extend (π i q C) B j = Extendᵇ i C q B j
  Extend (D ⊛ E)   B j = ⟦ D ⟧ B × Extend E B j

  Extendᵇ : ∀ {ι α β γ q} {I : Set ι} i
          -> Binder α β γ i q I -> α ≤ℓ β -> (I -> Set β) -> I -> Set β
  Extendᵇ i (coerce (A , D)) q B j = Coerce′ q $ ∃ λ x -> Extend (D x) B j

module _ {ι β} {I : Set ι} (D : Data (Desc I β)) where
  mutual
    data μ j : Set β where
      node : Node D j -> μ j

    Node : Data (Desc I β) -> I -> Set β
    Node D j = Any (λ C -> Extend C μ j) (consTypes D)

mutual
  Cons : ∀ {ι β} {I : Set ι} -> (I -> Set β) -> Desc I β -> Set β
  Cons B (var i)   = B i
  Cons B (π i q C) = Consᵇ B i C q
  Cons B (D ⊛ E)   = ⟦ D ⟧ B -> Cons B E

  Consᵇ : ∀ {ι α β γ q} {I : Set ι}
        -> (I -> Set β) -> ∀ i -> Binder α β γ i q I -> α ≤ℓ β -> Set β
  Consᵇ B i (coerce (A , D)) q = Coerce′ q $ Pi i A λ x -> Cons B (D x)

cons : ∀ {ι β} {I : Set ι} {D} -> (D₀ : Data (Desc I β)) -> D ∈ consTypes D₀ -> Cons (μ D₀) D
cons {D = D} D₀ p = go D λ e ->
  node (mapAny (consTypes D₀) (λ q -> subst (λ E -> Extend E _ _) q e) p) where
    mutual
      go : ∀ {ι β} {I : Set ι} {B : I -> Set β}
         -> (D : Desc I β) -> (∀ {j} -> Extend D B j -> B j) -> Cons B D
      go (var i)   k = k lrefl
      go (π a q C) k = goᵇ a C k
      go (D ⊛ E)   k = λ x -> go E (k ∘ _,_ x)

      goᵇ : ∀ {ι α β γ q q′} {I : Set ι} {B : I -> Set β} i
          -> (C : Binder α β γ i q′ I) -> (∀ {j} -> Extendᵇ i C q B j -> B j) -> Consᵇ B i C q
      goᵇ {q = q} i (coerce (A , D)) k =
        coerce′ q $ lamPi i λ x -> go (D x) (k ∘ coerce′ q ∘ _,_ x)

allCons : ∀ {ι β} {I : Set ι} -> (D : Data (Desc I β)) -> All (Cons (μ D)) (consTypes D)
allCons D = allIn _ (cons D)

node-inj : ∀ {i β} {I : Set i} {D : Data (Desc I β)} {j} {e₁ e₂ : Node D D j}
         -> node {D = D} e₁ ≡ node e₂ -> e₁ ≡ e₂
node-inj refl = refl

μ′ : ∀ {β} -> Data (Desc ⊤₀ β) -> Set β
μ′ D = μ D tt

pos : ∀ {β} -> Desc ⊤₀ β
pos = var tt

pattern #₀ p = node (inj₁ p)
pattern #₁ p = node (inj₂ (inj₁ p))
pattern #₂ p = node (inj₂ (inj₂ (inj₁ p)))
pattern #₃ p = node (inj₂ (inj₂ (inj₂ (inj₁ p))))
pattern #₄ p = node (inj₂ (inj₂ (inj₂ (inj₂ (inj₁ p)))))
pattern #₅ p = node (inj₂ (inj₂ (inj₂ (inj₂ (inj₂ (inj₁ p))))))

pattern !#₀ p = node p
pattern !#₁ p = node (inj₂ p)
pattern !#₂ p = node (inj₂ (inj₂ p))
pattern !#₃ p = node (inj₂ (inj₂ (inj₂ p)))
pattern !#₄ p = node (inj₂ (inj₂ (inj₂ (inj₂ p))))
pattern !#₅ p = node (inj₂ (inj₂ (inj₂ (inj₂ (inj₂ p)))))


open import MJ.Types
import MJ.Classtable.Core as Core

module MJ.Classtable.Code {c}(Ct : Core.Classtable c) where

open import Prelude
open import Data.Maybe as Maybe using (Maybe; just; nothing)
open import Data.Star as Star
open import Data.List
open import Data.List.Relation.Unary.All hiding (construct)
open import Data.List.Properties.Extra as List+
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary.Decidable
open import Data.String

import Data.Vec.Relation.Unary.All as Vec∀

open Core c
open Classtable Ct
open import MJ.Classtable.Membership Ct
open import MJ.LexicalScope c
open import MJ.Syntax Ct

data Body (I : Ctx) : Ty c → Set where
  body : ∀ {r}{O : Ctx} → Stmts I r O → Expr O r → Body I r

{-
A helper to generate the shape of the context for method bodies
-}
methodctx : Cid c → List (Ty c) → Ctx
methodctx cid as = (ref cid ∷ as)

{-
A helper to generate the shape of the context for constructors
-}
constrctx : Cid c → Ctx
constrctx cid = let cl = Σ cid in (ref cid ∷ Class.constr cl)

-- A method is either just a body, or a body prefixed by a super call.
data Method (cid : Cid c)(m : String) : Sig c → Set where
  super_⟨_⟩then_ : ∀ {as b} →
                let
                  pid = Class.parent (Σ cid)
                  Γ   = methodctx cid as
                in
                  -- must have a super to call, with the same signature
                  AccMember pid METHOD m (as , b) →
                  -- super call arguments
                  All (Expr Γ) as →
                  -- body
                  Body (Γ +local b) b → Method cid m (as , b)
  body        : ∀ {as b} → Body (methodctx cid as) b → Method cid m (as , b)

-- Constructors are similar
data Constructor (cid : Cid c) : Set where
  super_then_ : let
                  pid = Class.parent (Σ cid)
                  pclass = Σ pid
                  Γ   = constrctx cid
                in
                  -- super call arguments
                  All (Expr Γ) (Class.constr pclass) →
                  -- body
                  Body Γ void →
                  Constructor cid
  body        : Body (constrctx cid) void → Constructor cid

{-
A class implementation consists of a constructor and a body for every
METHOD declaration.
-}
record Implementation (cid : Cid c) : Set where
  constructor implementation
  open Class (Σ cid) public
  field
    construct : Constructor cid
    mbodies   : All (λ{ (name , sig) → Method cid name sig }) (decls METHOD)

-- Code is a lookup table for class implementations for every class identifier
Code = ∀ cid → Implementation cid

-- Mirroring `IsMember METHOD` we define the notion of an inherited method body.
InheritedMethod : ∀ (cid : Cid c)(m : String) → Sig c → Set
InheritedMethod cid m s = ∃ λ pid → Σ ⊢ cid <: pid × Method pid m s


------------------------------------------------------------------------
-- Compiler correctness
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --sized-types #-}

module Lambda.Delay-monad.Compiler-correctness where

import Equality.Propositional as E
open import Prelude
open import Prelude.Size

open import Maybe E.equality-with-J hiding (_>>=′_)
open import Monad E.equality-with-J
open import Vec.Function E.equality-with-J

open import Delay-monad.Bisimilarity
open import Delay-monad.Monad

open import Lambda.Compiler
open import Lambda.Delay-monad.Interpreter
open import Lambda.Delay-monad.Virtual-machine
open import Lambda.Syntax hiding ([_])
open import Lambda.Virtual-machine

private
  module C = Closure Code
  module T = Closure Tm

-- Bind preserves strong bisimilarity.

infixl 5 _>>=-congM_

_>>=-congM_ :
  ∀ {i ℓ} {A B : Type ℓ} {x y : M ∞ A} {f g : A → M ∞ B} →
  [ i ] run x ∼ run y →
  (∀ z → [ i ] run (f z) ∼ run (g z)) →
  [ i ] run (x >>= f) ∼ run (y >>= g)
p >>=-congM q = p >>=-cong [ (λ _ → run fail ∎) , q ]

-- Bind is associative.

associativityM :
  ∀ {ℓ} {A B C : Type ℓ} (x : M ∞ A) (f : A → M ∞ B) (g : B → M ∞ C) →
  run (x >>= (λ x → f x >>= g)) ∼ run (x >>= f >>= g)
associativityM x f g =
  run (x >>= λ x → f x >>= g)                                       ∼⟨⟩

  run x >>=′ maybe (λ x → run (f x >>= g)) (return nothing)         ∼⟨ (run x ∎) >>=-cong [ (λ _ → run fail ∎) , (λ x → run (f x >>= g) ∎) ] ⟩

  run x >>=′ (λ x → maybe (MaybeT.run ∘ f) (return nothing) x >>=′
                    maybe (MaybeT.run ∘ g) (return nothing))        ∼⟨ associativity′ (run x) _ _ ⟩

  run x >>=′ maybe (MaybeT.run ∘ f) (return nothing)
        >>=′ maybe (MaybeT.run ∘ g) (return nothing)                ∼⟨⟩

  run (x >>= f >>= g)                                               ∎

-- Compiler correctness.

mutual

  ⟦⟧-correct :
    ∀ {i n} t {ρ : T.Env n} {c s} {k : T.Value → M ∞ C.Value} →
    (∀ v → [ i ] run (exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩) ≈
                 run (k v)) →
    [ i ] run (exec ⟨ comp t c , s , comp-env ρ ⟩) ≈ run (⟦ t ⟧ ρ >>= k)

  ⟦⟧-correct (con i) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ con i ∷ c , s , comp-env ρ ⟩)                     ≳⟨⟩
    run (exec ⟨ c , val (comp-val (T.con i)) ∷ s , comp-env ρ ⟩)  ≈⟨ hyp (T.con i) ⟩∼
    run (k (T.con i))                                             ∼⟨⟩
    run (⟦ con i ⟧ ρ >>= k)                                       ∎

  ⟦⟧-correct (var x) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ var x ∷ c , s , comp-env ρ ⟩)                 ≳⟨⟩
    run (exec ⟨ c , val (comp-val (ρ x)) ∷ s , comp-env ρ ⟩)  ≈⟨ hyp (ρ x) ⟩∼
    run (k (ρ x))                                             ∼⟨⟩
    run (⟦ var x ⟧ ρ >>= k)                                   ∎

  ⟦⟧-correct (ƛ t) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ clo (comp t (ret ∷ [])) ∷ c , s , comp-env ρ ⟩)   ≳⟨⟩
    run (exec ⟨ c , val (comp-val (T.ƛ t ρ)) ∷ s , comp-env ρ ⟩)  ≈⟨ hyp (T.ƛ t ρ) ⟩∼
    run (k (T.ƛ t ρ))                                             ∼⟨⟩
    run (⟦ ƛ t ⟧ ρ >>= k)                                         ∎

  ⟦⟧-correct (t₁ · t₂) {ρ} {c} {s} {k} hyp =
    run (exec ⟨ comp t₁ (comp t₂ (app ∷ c)) , s , comp-env ρ ⟩)    ≈⟨ (⟦⟧-correct t₁ λ v₁ → ⟦⟧-correct t₂ λ v₂ → ∙-correct v₁ v₂ hyp) ⟩∼

    run (⟦ t₁ ⟧ ρ >>= λ v₁ → ⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂ >>= k)    ∼⟨ (run (⟦ t₁ ⟧ ρ) ∎) >>=-congM (λ _ → associativityM (⟦ t₂ ⟧ ρ) _ _) ⟩

    run (⟦ t₁ ⟧ ρ >>= λ v₁ → (⟦ t₂ ⟧ ρ >>= λ v₂ → v₁ ∙ v₂) >>= k)  ∼⟨ associativityM (⟦ t₁ ⟧ ρ) _ _ ⟩

    run (⟦ t₁ · t₂ ⟧ ρ >>= k)                                      ∎

  ∙-correct :
    ∀ {i n} v₁ v₂ {ρ : T.Env n} {c s} {k : T.Value → M ∞ C.Value} →
    (∀ v → [ i ] run (exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩) ≈
                 run (k v)) →
    [ i ] run (exec ⟨ app ∷ c
                    , val (comp-val v₂) ∷ val (comp-val v₁) ∷ s
                    , comp-env ρ
                    ⟩) ≈
          run (v₁ ∙ v₂ >>= k)
  ∙-correct (T.con i) v₂ {ρ} {c} {s} {k} hyp =
    run (exec ⟨ app ∷ c
              , val (comp-val v₂) ∷ val (C.con i) ∷ s
              , comp-env ρ
              ⟩)                                       ∼⟨⟩

    run fail                                           ∼⟨⟩

    run (T.con i ∙ v₂ >>= k)                           ∎

  ∙-correct (T.ƛ t₁ ρ₁) v₂ {ρ} {c} {s} {k} hyp =
    run (exec ⟨ app ∷ c
              , val (comp-val v₂) ∷ val (comp-val (T.ƛ t₁ ρ₁)) ∷ s
              , comp-env ρ
              ⟩)                                                    ≈⟨ later (λ { .force →

      run (exec ⟨ comp t₁ (ret ∷ [])
                , ret c (comp-env ρ) ∷ s
                , cons (comp-val v₂) (comp-env ρ₁)
             ⟩)                                                          ≡⟨ E.cong (λ ρ′ → run (exec ⟨ comp t₁ (ret ∷ []) ,
                                                                                ret c (comp-env ρ) ∷ s , ρ′ ⟩))
                                                                                (E.sym comp-cons) ⟩
      run (exec ⟨ comp t₁ (ret ∷ [])
                , ret c (comp-env ρ) ∷ s
                , comp-env (cons v₂ ρ₁)
                ⟩)                                                       ≈⟨ ⟦⟧-correct t₁ (λ v →

        run (exec ⟨ ret ∷ []
                  , val (comp-val v) ∷ ret c (comp-env ρ) ∷ s
                  , comp-env (cons v₂ ρ₁)
                  ⟩)                                                          ≳⟨⟩

        run (exec ⟨ c , val (comp-val v) ∷ s , comp-env ρ ⟩)                  ≈⟨ hyp v ⟩∎

        run (k v)                                                             ∎) ⟩∼

      run (⟦ t₁ ⟧ (cons v₂ ρ₁) >>= k)                                    ∎ }) ⟩∎

    run (T.ƛ t₁ ρ₁ ∙ v₂ >>= k)                                      ∎

-- Note that the equality that is used here is syntactic.

correct :
  ∀ t →
  exec ⟨ comp t [] , [] , nil ⟩ ≈M
  ⟦ t ⟧ nil >>= λ v → return (comp-val v)
correct t =
  run (exec ⟨ comp t [] , [] , nil ⟩)            ≡⟨ E.cong (λ ρ → run (exec ⟨ comp t [] , [] , ρ ⟩)) $ E.sym comp-nil ⟩
  run (exec ⟨ comp t [] , [] , comp-env nil ⟩)   ≈⟨ ⟦⟧-correct t (λ v → return (just (comp-val v)) ∎) ⟩
  run (⟦ t ⟧ nil >>= λ v → return (comp-val v))  ∎


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Tarski-style semantics with context pairs as concrete worlds, and glueing for α, ▻, and □.
-- Hilbert-style syntax.

module BasicIS4.Semantics.TarskiOvergluedDyadicHilbert where

open import BasicIS4.Syntax.Common public
open import Common.Semantics public

-- Intuitionistic Tarski models.

record Model : Set₁ where
  infix 3 _⊩ᵅ_ _[⊢]_
  field
    -- Forcing for atomic propositions; monotonic.
    _⊩ᵅ_    : Cx² Ty Ty → Atom → Set
    mono²⊩ᵅ : ∀ {P Π Π′} → Π ⊆² Π′ → Π ⊩ᵅ P → Π′ ⊩ᵅ P

    -- Hilbert-style syntax representation; monotonic.
    _[⊢]_    : Cx² Ty Ty → Ty → Set
    mono²[⊢] : ∀ {A Π Π′}    → Π ⊆² Π′ → Π [⊢] A → Π′ [⊢] A
    [var]     : ∀ {A Γ Δ}     → A ∈ Γ → Γ ⁏ Δ [⊢] A
    [app]     : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ▻ B → Γ ⁏ Δ [⊢] A → Γ ⁏ Δ [⊢] B
    [ci]      : ∀ {A Γ Δ}     → Γ ⁏ Δ [⊢] A ▻ A
    [ck]      : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ▻ B ▻ A
    [cs]      : ∀ {A B C Γ Δ} → Γ ⁏ Δ [⊢] (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
    [mvar]    : ∀ {A Γ Δ}     → A ∈ Δ → Γ ⁏ Δ [⊢] A
    [box]     : ∀ {A Γ Δ}     → ∅ ⁏ Δ [⊢] A → Γ ⁏ Δ [⊢] □ A
    [cdist]   : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] □ (A ▻ B) ▻ □ A ▻ □ B
    [cup]     : ∀ {A Γ Δ}     → Γ ⁏ Δ [⊢] □ A ▻ □ □ A
    [cdown]   : ∀ {A Γ Δ}     → Γ ⁏ Δ [⊢] □ A ▻ A
    [cpair]   : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ▻ B ▻ A ∧ B
    [cfst]    : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ∧ B ▻ A
    [csnd]    : ∀ {A B Γ Δ}   → Γ ⁏ Δ [⊢] A ∧ B ▻ B
    [unit]    : ∀ {Γ Δ}       → Γ ⁏ Δ [⊢] ⊤

    -- NOTE: [mlam] is necessary for [mmulticut], which is necessary for eval.
    [mlam] : ∀ {A B Γ Δ} → Γ ⁏ Δ , A [⊢] B → Γ ⁏ Δ [⊢] □ A ▻ B

  infix 3 _[⊢]⋆_
  _[⊢]⋆_ : Cx² Ty Ty → Cx Ty → Set
  Π [⊢]⋆ ∅     = 𝟙
  Π [⊢]⋆ Ξ , A = Π [⊢]⋆ Ξ × Π [⊢] A

open Model {{…}} public

-- Forcing in a particular model.

module _ {{_ : Model}} where
  infix 3 _⊩_
  _⊩_ : Cx² Ty Ty → Ty → Set
  Π ⊩ α P   = Glue (Π [⊢] α P) (Π ⊩ᵅ P)
  Π ⊩ A ▻ B = ∀ {Π′} → Π ⊆² Π′ → Glue (Π′ [⊢] A ▻ B) (Π′ ⊩ A → Π′ ⊩ B)
  Π ⊩ □ A   = ∀ {Π′} → Π ⊆² Π′ → Glue (Π′ [⊢] □ A) (Π′ ⊩ A)
  Π ⊩ A ∧ B = Π ⊩ A × Π ⊩ B
  Π ⊩ ⊤    = 𝟙

  infix 3 _⊩⋆_
  _⊩⋆_ : Cx² Ty Ty → Cx Ty → Set
  Π ⊩⋆ ∅     = 𝟙
  Π ⊩⋆ Ξ , A = Π ⊩⋆ Ξ × Π ⊩ A

-- Monotonicity with respect to context inclusion.

module _ {{_ : Model}} where
  mono²⊩ : ∀ {A Π Π′} → Π ⊆² Π′ → Π ⊩ A → Π′ ⊩ A
  mono²⊩ {α P}   ψ s = mono²[⊢] ψ (syn s) ⅋ mono²⊩ᵅ ψ (sem s)
  mono²⊩ {A ▻ B} ψ s = λ ψ′ → s (trans⊆² ψ ψ′)
  mono²⊩ {□ A}   ψ s = λ ψ′ → s (trans⊆² ψ ψ′)
  mono²⊩ {A ∧ B} ψ s = mono²⊩ {A} ψ (π₁ s) , mono²⊩ {B} ψ (π₂ s)
  mono²⊩ {⊤}    ψ s = ∙

  mono²⊩⋆ : ∀ {Ξ Π Π′} → Π ⊆² Π′ → Π ⊩⋆ Ξ → Π′ ⊩⋆ Ξ
  mono²⊩⋆ {∅}     ψ ∙        = ∙
  mono²⊩⋆ {Ξ , A} ψ (ts , t) = mono²⊩⋆ ψ ts , mono²⊩ {A} ψ t

-- Extraction of syntax representation in a particular model.

module _ {{_ : Model}} where
  reifyʳ : ∀ {A Π} → Π ⊩ A → Π [⊢] A
  reifyʳ {α P}   s = syn s
  reifyʳ {A ▻ B} s = syn (s refl⊆²)
  reifyʳ {□ A}   s = syn (s refl⊆²)
  reifyʳ {A ∧ B} s = [app] ([app] [cpair] (reifyʳ {A} (π₁ s))) (reifyʳ {B} (π₂ s))
  reifyʳ {⊤}    s = [unit]

  reifyʳ⋆ : ∀ {Ξ Π} → Π ⊩⋆ Ξ → Π [⊢]⋆ Ξ
  reifyʳ⋆ {∅}     ∙        = ∙
  reifyʳ⋆ {Ξ , A} (ts , t) = reifyʳ⋆ ts , reifyʳ t

-- Useful theorems in functional form.

module _ {{_ : Model}} where
  [mmulticut] : ∀ {Ξ A Γ Δ} → Γ ⁏ Δ [⊢]⋆ □⋆ Ξ → Γ ⁏ Ξ [⊢] A → Γ ⁏ Δ [⊢] A
  [mmulticut] {∅}     ∙        u = mono²[⊢] (refl⊆ , bot⊆) u
  [mmulticut] {Ξ , B} (ts , t) u = [app] ([mmulticut] ts ([mlam] u)) t

-- Additional useful equipment.

module _ {{_ : Model}} where
  _⟪$⟫_ : ∀ {A B Π} → Π ⊩ A ▻ B → Π ⊩ A → Π ⊩ B
  s ⟪$⟫ a = sem (s refl⊆²) a

  ⟪K⟫ : ∀ {A B Π} → Π ⊩ A → Π ⊩ B ▻ A
  ⟪K⟫ {A} a ψ = let a′ = mono²⊩ {A} ψ a
                in  [app] [ck] (reifyʳ a′) ⅋ K a′

  ⟪S⟫ : ∀ {A B C Π} → Π ⊩ A ▻ B ▻ C → Π ⊩ A ▻ B → Π ⊩ A → Π ⊩ C
  ⟪S⟫ s₁ s₂ a = (s₁ ⟪$⟫ a) ⟪$⟫ (s₂ ⟪$⟫ a)

  ⟪S⟫′ : ∀ {A B C Π} → Π ⊩ A ▻ B ▻ C → Π ⊩ (A ▻ B) ▻ A ▻ C
  ⟪S⟫′ {A} {B} {C} s₁ ψ = let s₁′ = mono²⊩ {A ▻ B ▻ C} ψ s₁
                              t   = syn (s₁′ refl⊆²)
                          in  [app] [cs] t ⅋ λ s₂ ψ′ →
                              let s₁″ = mono²⊩ {A ▻ B ▻ C} (trans⊆² ψ ψ′) s₁
                                  s₂′ = mono²⊩ {A ▻ B} ψ′ s₂
                                  t′  = syn (s₁″ refl⊆²)
                                  u   = syn (s₂′ refl⊆²)
                              in  [app] ([app] [cs] t′) u ⅋ ⟪S⟫ s₁″ s₂′

  _⟪D⟫_ : ∀ {A B Π} → Π ⊩ □ (A ▻ B) → Π ⊩ □ A → Π ⊩ □ B
  (s₁ ⟪D⟫ s₂) ψ = let t ⅋ s₁′ = s₁ ψ
                      u ⅋ a   = s₂ ψ
                  in  [app] ([app] [cdist] t) u ⅋ s₁′ ⟪$⟫ a

  _⟪D⟫′_ : ∀ {A B Π} → Π ⊩ □ (A ▻ B) → Π ⊩ □ A ▻ □ B
  _⟪D⟫′_ {A} {B} s₁ ψ = let s₁′ = mono²⊩ {□ (A ▻ B)} ψ s₁
                        in  [app] [cdist] (reifyʳ (λ {_} ψ′ → s₁′ ψ′)) ⅋ _⟪D⟫_ s₁′

  ⟪↑⟫ : ∀ {A Π} → Π ⊩ □ A → Π ⊩ □ □ A
  ⟪↑⟫ {A} s ψ = [app] [cup] (syn (s ψ)) ⅋ λ ψ′ → s (trans⊆² ψ ψ′)

  ⟪↓⟫ : ∀ {A Π} → Π ⊩ □ A → Π ⊩ A
  ⟪↓⟫ s = sem (s refl⊆²)

  _⟪,⟫′_ : ∀ {A B Π} → Π ⊩ A → Π ⊩ B ▻ A ∧ B
  _⟪,⟫′_ {A} a ψ = let a′ = mono²⊩ {A} ψ a
                   in  [app] [cpair] (reifyʳ a′) ⅋ _,_ a′

-- Forcing in a particular world of a particular model, for sequents.

module _ {{_ : Model}} where
  infix 3 _⊩_⇒_
  _⊩_⇒_ : Cx² Ty Ty → Cx² Ty Ty → Ty → Set
  Π ⊩ Γ ⁏ Δ ⇒ A = Π ⊩⋆ Γ → Π ⊩⋆ □⋆ Δ → Π ⊩ A

  infix 3 _⊩_⇒⋆_
  _⊩_⇒⋆_ : Cx² Ty Ty → Cx² Ty Ty → Cx Ty → Set
  Π ⊩ Γ ⁏ Δ ⇒⋆ Ξ = Π ⊩⋆ Γ → Π ⊩⋆ □⋆ Δ → Π ⊩⋆ Ξ

-- Entailment, or forcing in all worlds of all models, for sequents.

infix 3 _⊨_
_⊨_ : Cx² Ty Ty → Ty → Set₁
Π ⊨ A = ∀ {{_ : Model}} {w : Cx² Ty Ty} → w ⊩ Π ⇒ A

infix 3 _⊨⋆_
_⊨⋆_ : Cx² Ty Ty → Cx Ty → Set₁
Π ⊨⋆ Ξ = ∀ {{_ : Model}} {w : Cx² Ty Ty} → w ⊩ Π ⇒⋆ Ξ

-- Additional useful equipment, for sequents.

module _ {{_ : Model}} where
  lookup : ∀ {A Γ w} → A ∈ Γ → w ⊩⋆ Γ → w ⊩ A
  lookup top     (γ , a) = a
  lookup (pop i) (γ , b) = lookup i γ

  mlookup : ∀ {A Δ w} → A ∈ Δ → w ⊩⋆ □⋆ Δ → w ⊩ A
  mlookup top     (γ , s) = sem (s refl⊆²)
  mlookup (pop i) (γ , s) = mlookup i γ

  -- TODO: More equipment.


open import Prelude

module Implicits.Resolution.Termination.Lemmas.SizeMeasures
  where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Vec
open import Data.Fin.Substitution
open import Extensions.Vec
open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties
open import Relation.Binary using (module DecTotalOrder)
open DecTotalOrder decTotalOrder using () renaming (refl to ≤-refl)
open import Extensions.Nat
open import Implicits.Resolution.Termination.SizeMeasures

-- we can show that our size measure a ρ< b is well founded
-- by relating it to the well-foundedness proof of _<'_
open import Induction.WellFounded
ρ<-well-founded : Well-founded _ρ<_
ρ<-well-founded = sub.well-founded (image.well-founded <-well-founded)
    where
        open import Induction.Nat
        open import Data.Nat
        open import Data.Nat.Properties
        module sub = Inverse-image (λ{ (_ , a ) → || a ||})
        module image = Subrelation {A = ℕ} {_<_} {_<′_} ≤⇒≤′

open import Induction.WellFounded
hρ<-well-founded : Well-founded _hρ<_
hρ<-well-founded = sub.well-founded (image.well-founded <-well-founded)
  where
    open import Induction.Nat
    open import Data.Nat
    open import Data.Nat.Properties
    module sub = Inverse-image (λ{ (_ , a ) → h|| a ||})
    module image = Subrelation {A = ℕ} {_<_} {_<′_} ≤⇒≤′

m<-well-founded : Well-founded _m<_
m<-well-founded = sub.well-founded (image.well-founded <-well-founded)
    where
        module sub = Inverse-image (λ{ (_ , _ , a) → m|| a ||})
        module image = Subrelation {A = ℕ} {_<_} {_<′_} ≤⇒≤′

module TypeSubstSizeLemmas where
  open MetaTypeTypeSubst

  mutual
    ||a/Var|| : ∀ {m ν μ} (a : MetaType m ν) (s : Sub Fin ν μ) →
                m|| a /Var s || ≡ m|| a ||
    ||a/Var|| (a ⇒ b) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (∀' a) s = cong (λ u → 1 + u) (||a/Var|| a (s VarSubst.↑))
    ||a/Var|| (simpl (tvar x)) s = refl
    ||a/Var|| (simpl (mvar x)) s = refl
    ||a/Var|| (simpl (a →' b)) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (simpl (tc c)) s = refl

    ||weaken-a|| : ∀ {m ν} (a : MetaType m ν) → m|| weaken a || ≡ m|| a ||
    ||weaken-a|| {m} {ν} a = begin
      m|| weaken a ||
        ≡⟨ refl ⟩
      m|| a /Var VarSubst.wk ||
        ≡⟨ ||a/Var|| a VarSubst.wk ⟩
      m|| a || ∎

    ||s↑|| : ∀ {m ν μ} (s : Sub (MetaType m) ν μ) →
                       (∀ (x : Fin ν) → m|| lookup x s || ≡ 1) →
                       ∀ y → m|| lookup y (s ↑) || ≡ 1
    ||s↑|| s p zero = refl
    ||s↑|| s p (suc y) = begin
      m|| lookup y (map weaken s) ||
        ≡⟨ cong m||_|| (sym $ lookup⋆map s weaken y) ⟩
      m|| weaken (lookup y s) ||
        ≡⟨ ||weaken-a|| (lookup y s) ⟩
      m|| (lookup y s) ||
        ≡⟨ p y ⟩
      1 ∎

    ||a/s|| : ∀ {m ν μ} (a : MetaType m ν) (s : Sub (MetaType m) ν μ) →
             (∀ x → m|| lookup x s || ≡ 1) →
             m|| a / s || ≡ m|| a ||
    ||a/s|| (a ⇒ b) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (∀' a) s p = cong (λ u → 1 + u) (||a/s|| a (s ↑) (||s↑|| s p))
    ||a/s|| {m} {ν} (simpl (tvar x)) s p = begin
      m|| (simpl (tvar x)) / s ||
        ≡⟨ cong m||_|| (MetaTypeTypeLemmas.var-/ {x = x}) ⟩
      m|| lookup x s ||
        ≡⟨ p x ⟩
      1 ∎
    ||a/s|| (simpl (mvar x)) s p = refl
    ||a/s|| (simpl (a →' b)) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (simpl (tc c)) s p = refl

module MetaSubstSizeLemmas where
  open MetaTypeMetaSubst hiding (open-meta)

  mutual
    ||a/Var|| : ∀ {ν m n} (a : MetaType m ν) (s : Sub Fin m n) →
                m|| a /Var s || ≡ m|| a ||
    ||a/Var|| (a ⇒ b) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| {ν = ν} (∀' a) s =
      cong (λ u → 1 + u) (||a/Var|| a ((varLift MetaLift.↑tp) {ν = ν} s))
    ||a/Var|| (simpl (tvar x)) s = refl
    ||a/Var|| (simpl (mvar x)) s = refl
    ||a/Var|| (simpl (a →' b)) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (simpl (tc c)) s = refl

    ||weaken-a|| : ∀ {m ν} (a : MetaType m ν) → m|| weaken a || ≡ m|| a ||
    ||weaken-a|| {m} {ν} a = begin
      m|| weaken a ||
        ≡⟨ refl ⟩
      m|| a /Var VarSubst.wk ||
        ≡⟨ ||a/Var|| a VarSubst.wk ⟩
      m|| a || ∎

    ||s↑|| : ∀ {m ν μ} (s : Sub (MetaType m) ν μ) →
                       (∀ (x : Fin ν) → m|| lookup x s || ≡ 1) →
                       ∀ y → m|| lookup y (s ↑) || ≡ 1
    ||s↑|| s p zero = refl
    ||s↑|| s p (suc y) = begin
      m|| lookup y (map weaken s) ||
        ≡⟨ cong m||_|| (sym $ lookup⋆map s weaken y) ⟩
      m|| weaken (lookup y s) ||
        ≡⟨ ||weaken-a|| (lookup y s) ⟩
      m|| (lookup y s) ||
        ≡⟨ p y ⟩
      1 ∎

    ||a/s|| : ∀ {m ν n} (a : MetaType m ν) (s : Sub (flip MetaType ν) m n) →
             (∀ x → m|| lookup x s || ≡ 1) →
             m|| a / s || ≡ m|| a ||
    ||a/s|| (a ⇒ b) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (∀' a) s p = cong (λ u → 1 + u) (||a/s|| a (map MetaTypeTypeSubst.weaken s) lem)
      where
        lem : ∀ x → m|| lookup x (map MetaTypeTypeSubst.weaken s) || ≡ 1
        lem x = begin
          m|| lookup x (map MetaTypeTypeSubst.weaken s) ||
            ≡⟨ cong m||_|| (sym $ lookup⋆map s _ x) ⟩
          m|| MetaTypeTypeSubst.weaken (lookup x s) ||
            ≡⟨ TypeSubstSizeLemmas.||weaken-a|| (lookup x s) ⟩
          m|| lookup x s ||
            ≡⟨ p x ⟩
          1 ∎
    ||a/s|| {m} {ν} (simpl (mvar x)) s p = begin
      m|| (simpl (mvar x)) / s ||
        ≡⟨ cong m||_|| (MetaTypeTypeLemmas.var-/ {x = x}) ⟩
      m|| lookup x s ||
        ≡⟨ p x ⟩
      1 ∎
    ||a/s|| (simpl (tvar x)) s p = refl
    ||a/s|| (simpl (a →' b)) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (simpl (tc c)) s p = refl

    ||open-meta-a||≡a : ∀ {m ν} (a : MetaType m (suc ν)) → m|| open-meta a || ≡ m|| a ||
    ||open-meta-a||≡a {m} {ν} a = begin
      m|| open-meta a ||
        ≡⟨ TypeSubstSizeLemmas.||a/s|| (MMS.weaken a) (MTS.sub (simpl (mvar zero))) lem ⟩
      m|| (MMS.weaken a) ||
        ≡⟨ ||weaken-a|| a ⟩
      m|| a || ∎
        where
          module MMS = MetaTypeMetaSubst
          module MTS = MetaTypeTypeSubst
          lem : ∀ (x : Fin (suc ν)) → m|| lookup x (MetaTypeTypeSubst.sub (simpl (mvar zero))) || ≡ 1
          lem zero = refl
          lem (suc x) =
            cong m||_|| (MetaTypeTypeLemmas.lookup-sub-↑⋆ {t = (simpl (mvar zero))} zero x)

module SubstSizeLemmas where
  open TypeLemmas

  mutual
    ||a|| : ∀ {ν} (a : Type ν) → || a || ≥ 1
    ||a|| (simpl (tc x)) = s≤s z≤n
    ||a|| (simpl (tvar n)) = s≤s z≤n
    ||a|| (simpl (a →' b)) = s≤s z≤n
    ||a|| (a ⇒ b) = s≤s z≤n
    ||a|| (∀' a) = s≤s z≤n

    ||a/Var|| : ∀ {ν μ} (a : Type ν) (s : Sub Fin ν μ) → || a /Var s || ≡ || a ||
    ||a/Var|| (a ⇒ b) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (∀' a) s = cong (λ u → 1 + u) (||a/Var|| a (s VarSubst.↑))
    ||a/Var|| (simpl (tvar x)) s = refl
    ||a/Var|| (simpl (a →' b)) s = cong₂ (λ u v → 1 + u + v) (||a/Var|| a s) (||a/Var|| b s)
    ||a/Var|| (simpl (tc c)) s = refl

    ||weaken-a|| : ∀ {ν} (a : Type ν) → || weaken a || ≡ || a ||
    ||weaken-a|| {ν} a = begin
      || weaken a ||
        ≡⟨ refl ⟩
      || a /Var VarSubst.wk ||
        ≡⟨ ||a/Var|| a VarSubst.wk ⟩
      || a || ∎

    ||s↑|| : ∀ {ν μ} (s : Sub Type ν μ) →
                       (∀ (x : Fin ν) → || lookup x s || ≡ 1) →
                       ∀ y → || lookup y (s ↑) || ≡ 1
    ||s↑|| s p zero = refl
    ||s↑|| s p (suc y) = begin
      || lookup y (map weaken s) ||
        ≡⟨ cong ||_|| (sym $ lookup⋆map s weaken y) ⟩
      || weaken (lookup y s) ||
        ≡⟨ ||weaken-a|| (lookup y s) ⟩
      || (lookup y s) ||
        ≡⟨ p y ⟩
      1 ∎

    ||a/s|| : ∀ {ν μ} (a : Type ν) (s : Sub Type ν μ) →
             (∀ x → || lookup x s || ≡ 1) →
             || a / s || ≡ || a ||
    ||a/s|| (a ⇒ b) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (∀' a) s p = cong (λ u → 1 + u) (||a/s|| a (s ↑) (||s↑|| s p))
    ||a/s|| {m} {ν} (simpl (tvar x)) s p = begin
      || (simpl (tvar x)) / s ||
        ≡⟨ cong ||_|| (var-/ {x = x}) ⟩
      || lookup x s ||
        ≡⟨ p x ⟩
      1 ∎
    ||a/s|| (simpl (a →' b)) s p = cong₂ (λ u v → 1 + u + v) (||a/s|| a s p) (||a/s|| b s p)
    ||a/s|| (simpl (tc c)) s p = refl

    ||a/wk↑k|| : ∀ {ν} k (a : Type (k + ν)) → || a / wk ↑⋆ k || ≡ || a ||
    ||a/wk↑k|| k a = ||a/s|| a (wk ↑⋆ k) (λ x → cong ||_|| (lookup-wk-↑⋆ k x))

    ||a/s||' : ∀ {ν μ} (a : Type ν) (s : Sub Type ν μ) → || a || ≤ || a / s ||
    ||a/s||' (simpl (tc x)) s = s≤s z≤n
    ||a/s||' (simpl (tvar n)) s = ||a|| (lookup n s)
    ||a/s||' (simpl (a →' b)) s = s≤s (<-+ (||a/s||' a s) (||a/s||' b s))
    ||a/s||' (a ⇒ b) s = s≤s (<-+ (||a/s||' a s) (||a/s||' b s))
    ||a/s||' (∀' b) s = s≤s (||a/s||' b (s TypeSubst.↑))

    h||a/s|| : ∀ {ν μ} (a : Type ν) (s : Sub Type ν μ) → (, a) hρ≤ (, a / s)
    h||a/s|| (simpl (tc x)) s = s≤s z≤n
    h||a/s|| (simpl (tvar n)) s = ||a|| (proj₂ (lookup n s ◁))
    h||a/s|| (simpl (a →' b)) s = s≤s (<-+ (||a/s||' a s) (||a/s||' b s))
    h||a/s|| (a ⇒ b) s = h||a/s|| b s
    h||a/s|| (∀' b) s = h||a/s|| b (s TypeSubst.↑)

a-ρ<-∀a : ∀ {n} a → (suc n , a) ρ< (, ∀' a)
a-ρ<-∀a _ = ≤-refl

b-ρ<-a⇒b : ∀ {ν} (a b : Type ν) → (_ , b) ρ< (_ , a ⇒ b)
b-ρ<-a⇒b a b = s≤s (≤-steps || a || ≤-refl)

b-hρ≤-a⇒b : ∀ {ν} (a b : Type ν) → (_ , b) hρ≤ (_ , a ⇒ b)
b-hρ≤-a⇒b a b = subst (λ u → u ≤ h|| a ⇒ b ||) refl ≤-refl

a-m<-∀a : ∀ {m ν} a → (m , suc ν , a) m< (m , ν , ∀' a)
a-m<-∀a a = ≤-refl

b-m<-a⇒b : ∀ {m ν} a b → (m , ν , b) m< (m , ν , a ⇒ b)
b-m<-a⇒b a b = s≤s (≤-steps m|| a || ≤-refl)

open-meta-a-m<-∀'a : ∀ {m ν} a → (suc m , ν , open-meta a) m< (m , ν , ∀' a)
open-meta-a-m<-∀'a a = subst (λ x → x < m||  ∀' a ||)
  (sym $ MetaSubstSizeLemmas.||open-meta-a||≡a a) (a-m<-∀a a)


module Generic.Lib.Reflection.Core where

open import Agda.Builtin.Reflection using (withNormalisation; Relevance; Visibility; clause) public
open import Reflection
  renaming (visible to expl; hidden to impl; instance′ to inst;
    relevant to rel; irrelevant to irr; pi to absPi; lam to absLam; def to appDef)
  hiding (Arg-info; var; con; meta; visibility; relevance; _≟_; return; _>>=_; _>>_) public
open import Reflection.Argument.Information using (ArgInfo; visibility; relevance) public
import Reflection.Name
open Term    using () renaming (var to appVar; con to appCon; meta to appMeta) public
open Pattern using () renaming (var to patVar; con to patCon) public
open Literal using () renaming (meta to litMeta) public
open Sort public

open import Generic.Lib.Intro
open import Generic.Lib.Equality.Propositional
open import Generic.Lib.Decidable
open import Generic.Lib.Category
open import Generic.Lib.Data.Nat
open import Generic.Lib.Data.String
open import Generic.Lib.Data.Maybe
open import Generic.Lib.Data.Product
open import Generic.Lib.Data.List

open import Data.Vec using (toList)
open import Data.Vec.N-ary using (N-ary; curryⁿ)

infixr 5 _‵→_
infixl 3 _·_

listCurryⁿ : ∀ {α β} {A : Set α} {B : Set β} n -> (List A -> B) -> N-ary n A B
listCurryⁿ n f = curryⁿ {n = n} (f ∘ toList)

named : String -> String
named s = if s == "_" then "x" else s

record Reify {α} (A : Set α) : Set α where
  field reify : A -> Term

  macro
    reflect : A -> Term -> TC _
    reflect = unify ∘ reify
open Reify {{...}} public

pattern pureVar  n = appVar  n []
pattern pureCon  c = appCon  c []
pattern pureDef  f = appDef  f []
pattern pureMeta m = appMeta m []

{-# DISPLAY appVar  i [] = pureVar  i #-}
{-# DISPLAY appCon  c [] = pureCon  c #-}
{-# DISPLAY appDef  f [] = pureDef  f #-}
{-# DISPLAY appMeta m [] = pureMeta m #-}

pattern explInfo r = arg-info expl r
pattern implInfo r = arg-info impl r
pattern instInfo r = arg-info inst r

{-# DISPLAY arg-info expl r = explInfo r #-}
{-# DISPLAY arg-info impl r = implInfo r #-}
{-# DISPLAY arg-info inst r = instInfo r #-}

pattern explRelInfo = explInfo rel
pattern explIrrInfo = explInfo irr
pattern implRelInfo = implInfo rel
pattern implIrrInfo = implInfo irr
pattern instRelInfo = instInfo rel
pattern instIrrInfo = instInfo irr

{-# DISPLAY explInfo rel = explRelInfo #-}
{-# DISPLAY explInfo irr = explIrrInfo #-}
{-# DISPLAY implInfo rel = implRelInfo #-}
{-# DISPLAY implInfo irr = implIrrInfo #-}
{-# DISPLAY instInfo rel = instRelInfo #-}
{-# DISPLAY instInfo irr = instIrrInfo #-}

pattern explArg r x = arg (explInfo r) x
pattern implArg r x = arg (implInfo r) x
pattern instArg r x = arg (instInfo r) x

{-# DISPLAY arg (explInfo r) = explArg r #-}
{-# DISPLAY arg (implInfo r) = implArg r #-}
{-# DISPLAY arg (instInfo r) = instArg r #-}

pattern explRelArg x = explArg rel x
pattern implRelArg x = implArg rel x
pattern instRelArg x = instArg rel x

{-# DISPLAY explArg rel x = explRelArg x #-}
{-# DISPLAY implArg rel x = implRelArg x #-}
{-# DISPLAY instArg rel x = instRelArg x #-}

pattern pi s a b = absPi a (abs s b)

{-# DISPLAY absPi a (abs s b) = pi s a b #-}

pattern explPi r s a b = pi s (explArg r a) b
pattern implPi r s a b = pi s (implArg r a) b
pattern instPi r s a b = pi s (instArg r a) b

{-# DISPLAY pi (explArg r a) s b = explPi r s a b #-}
{-# DISPLAY pi (implArg r a) s b = implPi r s a b #-}
{-# DISPLAY pi (instArg r a) s b = instPi r s a b #-}

pattern explRelPi s a b = explPi rel a s b
pattern explIrrPi s a b = explPi irr a s b
pattern implRelPi s a b = implPi rel a s b
pattern implIrrPi s a b = implPi irr a s b
pattern instRelPi s a b = instPi rel a s b
pattern instIrrPi s a b = instPi irr a s b

{-# DISPLAY explPi rel a s b = explRelPi s a b #-}
{-# DISPLAY explPi irr a s b = explIrrPi s a b #-}
{-# DISPLAY implPi rel a s b = implRelPi s a b #-}
{-# DISPLAY implPi irr a s b = implIrrPi s a b #-}
{-# DISPLAY instPi rel a s b = instRelPi s a b #-}
{-# DISPLAY instPi irr a s b = instIrrPi s a b #-}

pattern lam v s t = absLam v (abs s t)

{-# DISPLAY absLam v (abs s t) = lam v s t #-}

pattern explLam s t = lam expl s t
pattern implLam s t = lam impl s t
pattern instLam s t = lam inst s t

{-# DISPLAY lam expl s t = explLam s t #-}
{-# DISPLAY lam impl s t = implLam s t #-}
{-# DISPLAY lam inst s t = instLam s t #-}

pattern _‵→_ a b = pi "_" (explRelArg a) b

-- No longer parses for whatever reason.
-- {-# DISPLAY pi "_" (explRelArg a) b = a ‵→ b #-}

mutual
  <_>_ : ∀ {α} -> Relevance -> Set α -> Set α
  <_>_ = flip RelValue

  data RelValue {α} (A : Set α) : Relevance -> Set α where
    relv :  A -> < rel > A
    irrv : .A -> < irr > A

elimRelValue : ∀ {r α π} {A : Set α}
             -> (P : ∀ {r} -> < r > A -> Set π)
             -> (∀  x -> P (relv x))
             -> (∀ .x -> P (irrv x))
             -> (x : < r > A)
             -> P x
elimRelValue P f g (relv x) = f x
elimRelValue P f g (irrv x) = g x

unrelv : ∀ {α} {A : Set α} -> < rel > A -> A
unrelv (relv x) = x

-- Is it possible to handle this in some other way that doesn't require a postulate?
-- See the `appRel` function below. Or is the postulate fine?
postulate
  .unirrv : ∀ {α} {A : Set α} -> < irr > A -> A

<_>_~>_ : ∀ {α β} -> Relevance -> Set α -> Set β -> Set (α ⊔ β)
< rel > A ~> B =  A -> B
< irr > A ~> B = .A -> B

lamRel : ∀ {r α β} {A : Set α} {B : Set β} -> (< r > A -> B) -> < r > A ~> B
lamRel {rel} f = λ x -> f (relv x)
lamRel {irr} f = λ x -> f (irrv x)

-- The laziness is intentional.
appRel : ∀ {r α β} {A : Set α} {B : Set β} -> (< r > A ~> B) -> < r > A -> B
appRel {rel} f rx = f (unrelv rx)
appRel {irr} f rx = f (unirrv rx)

Pi : ∀ {α β} i -> (A : Set α) -> (< relevance i > A -> Set β) -> Set (α ⊔ β)
Pi explRelInfo A B =   (x : A)  -> B (relv x)
Pi explIrrInfo A B = . (x : A)  -> B (irrv x)
Pi implRelInfo A B =   {x : A}  -> B (relv x)
Pi implIrrInfo A B = . {x : A}  -> B (irrv x)
Pi instRelInfo A B =  {{x : A}} -> B (relv x)
Pi instIrrInfo A B = .{{x : A}} -> B (irrv x)

lamPi : ∀ {α β} {A : Set α} i {B : < relevance i > A -> Set β} -> (∀ x -> B x) -> Pi i A B
lamPi explRelInfo f = λ x -> f (relv x)
lamPi explIrrInfo f = λ x -> f (irrv x)
lamPi implRelInfo f = f _
lamPi implIrrInfo f = f _
lamPi instRelInfo f = f _
lamPi instIrrInfo f = f _

appPi : ∀ {α β} {A : Set α} i {B : < relevance i > A -> Set β} -> Pi i A B -> ∀ x -> B x
appPi explRelInfo f (relv x) = f x
appPi explIrrInfo f (irrv x) = f x
appPi implRelInfo y (relv x) = y
appPi implIrrInfo y (irrv x) = y
appPi instRelInfo y (relv x) = y {{x}}
appPi instIrrInfo y (irrv x) = y {{x}}

RelEq : ∀ {α} -> Relevance -> Set α -> Set α
RelEq rel A = Eq A
RelEq irr A = ⊤

vis : {A : Set} -> (A -> List (Arg Term) -> Term) -> A -> List Term -> Term
vis k x = k x ∘ map explRelArg

vis# : ∀ {A : Set} n -> (A -> List (Arg Term) -> Term) -> A -> N-ary n Term Term
vis# n k = listCurryⁿ n ∘ vis k

isRelevant : Relevance -> Bool
isRelevant rel = true
isRelevant irr = false

argInfo : ∀ {α} {A : Set α} -> Arg A -> _
argInfo (arg i x) = i

argVal : ∀ {α} {A : Set α} -> Arg A -> A
argVal (arg i x) = x

unExpl : ∀ {α} {A : Set α} -> Arg A -> Maybe A
unExpl (explArg r x) = just x
unExpl  _            = nothing

absName : ∀ {α} {A : Set α} -> Abs A -> String
absName (abs s x) = s

absVal : ∀ {α} {A : Set α} -> Abs A -> A
absVal (abs s x) = x

patVars : List String -> List (Arg Pattern)
patVars = map (explRelArg ∘ patVar ∘ named)

record Data {α} (A : Set α) : Set α where
  no-eta-equality
  constructor packData
  field
    dataName  : Name
    parsTele  : Type
    indsTele  : Type
    consTypes : List A
    consNames : All (const Name) consTypes
open Data public

instance
  NameEq : Eq Name
  NameEq = viaBase Reflection.Name._≟_

  EqRelValue : ∀ {α r} {A : Set α} {{aEq : RelEq r A}} -> Eq (< r > A)
  EqRelValue {A = A} {{aEq}} = record
    { _≟_ = go
    } where
        relv-inj : {x y : A} -> relv x ≡ relv y -> x ≡ y
        relv-inj refl = refl

        go : ∀ {r} {{aEq : RelEq r A}} -> IsSet (< r > A)
        go (relv x) (relv y) = dcong relv relv-inj (x ≟ y)
        go (irrv x) (irrv y) = yes refl

  ArgFunctor : ∀ {α} -> RawFunctor {α} Arg
  ArgFunctor = record
    { _<$>_ = λ{ f (arg i x) -> arg i (f x) }
    }

  AbsFunctor : ∀ {α} -> RawFunctor {α} Abs
  AbsFunctor = record
    { _<$>_ = λ{ f (abs s x) -> abs s (f x) }
    }

  TCMonad : ∀ {α} -> RawMonad {α} TC
  TCMonad = record
    { return = Reflection.return
    ; _>>=_  = Reflection._>>=_
    }

  TCApplicative : ∀ {α} -> RawApplicative {α} TC
  TCApplicative = rawIApplicative

  TCFunctor : ∀ {α} -> RawFunctor {α} TC
  TCFunctor = rawFunctor

keep : (ℕ -> ℕ) -> ℕ -> ℕ
keep ι  0      = 0
keep ι (suc n) = suc (ι n)

{-# TERMINATING #-}
mutual
  ren : (ℕ -> ℕ) -> Term -> Term
  ren ι (appVar v xs)   = appVar (ι v) (rens ι xs)
  ren ι (appCon c xs)   = appCon c (rens ι xs)
  ren ι (appDef f xs)   = appDef f (rens ι xs)
  ren ι (lam v s t)     = lam v s (ren (keep ι) t)
  ren ι (pat-lam cs xs) = undefined where postulate undefined : _
  ren ι (pi s a b)      = pi s (ren ι <$> a) (ren (keep ι) b)
  ren ι (agda-sort s)   = agda-sort (renSort ι s)
  ren ι (lit l)         = lit l
  ren ι (appMeta x xs)  = appMeta x (rens ι xs)
  ren ι  unknown        = unknown

  rens : (ℕ -> ℕ) -> List (Arg Term) -> List (Arg Term)
  rens ι = map (fmap (ren ι))

  renSort : (ℕ -> ℕ) -> Sort -> Sort
  renSort ι (set t) = set (ren ι t)
  renSort ι (lit n) = lit n
  renSort ι unknown = unknown

shiftBy : ℕ -> Term -> Term
shiftBy = ren ∘ _+_

shift : Term -> Term
shift = shiftBy 1

unshiftBy : ℕ -> Term -> Term
unshiftBy n = ren (_∸ n)

isSomeName : Name -> Term -> Bool
isSomeName n (appDef m _) = n == m
isSomeName n (appCon m _) = n == m
isSomeName n  t           = false

{-# TERMINATING #-}
mutual
  mapName : (ℕ -> List (Arg Term) -> Term) -> Name -> Term -> Term
  mapName f n (appVar v xs)   = appVar v (mapNames f n xs)
  mapName f n (appCon m xs)   = (if n == m then f 0 else appCon m) (mapNames f n xs)
  mapName f n (appDef m xs)   = (if n == m then f 0 else appDef m) (mapNames f n xs)
  mapName f n (lam v s t)     = lam v s (mapName (f ∘ suc) n t)
  mapName f n (pat-lam cs xs) = undefined where postulate undefined : _
  mapName f n (pi s a b)      = pi s (mapName f n <$> a) (mapName (f ∘ suc) n b)
  mapName f n (agda-sort s)   = agda-sort (mapNameSort f n s)
  mapName f n (lit l)         = lit l
  mapName f n (appMeta x xs)  = appMeta x (mapNames f n xs)
  mapName f n  unknown        = unknown

  mapNames : (ℕ -> List (Arg Term) -> Term) -> Name -> List (Arg Term) -> List (Arg Term)
  mapNames f n = map (fmap (mapName f n))

  mapNameSort : (ℕ -> List (Arg Term) -> Term) -> Name -> Sort -> Sort
  mapNameSort f n (set t) = set (mapName f n t)
  mapNameSort f n (lit l) = lit l
  mapNameSort f n unknown = unknown

explsOnly : List (Arg Term) -> List Term
explsOnly = mapMaybe unExpl

initType : Type -> Type
initType (pi s a b) = pi s a (initType b)
initType  b         = unknown

lastType : Type -> Type
lastType (pi s a b) = lastType b
lastType  b         = b

-- These two should return just `Type` like everything else.
takePis : ℕ -> Type -> Maybe Type
takePis  0       a         = just unknown
takePis (suc n) (pi s a b) = pi s a <$> takePis n b
takePis  _       _         = nothing

dropPis : ℕ -> Type -> Maybe Type
dropPis  0       a         = just a
dropPis (suc n) (pi s a b) = dropPis n b
dropPis  _       _         = nothing

monoLastType : Type -> Type
monoLastType = go 0 where
  go : ℕ -> Type -> Type
  go n (pi s a b) = go (suc n) b
  go n  b         = unshiftBy n b

appendType : Type -> Type -> Type
appendType (pi s a b) c = pi s a (appendType b c)
appendType  b         c = c

explLamsBy : Type -> Term -> Term
explLamsBy (explPi r s a b) t = explLam s (explLamsBy b t)
explLamsBy (pi       s a b) t = explLamsBy b t
explLamsBy  b               t = t

implicitize : Type -> Type
implicitize (explPi r s a b) = implPi r s a (implicitize b)
implicitize (pi       s a b) = pi       s a (implicitize b)
implicitize  b               = b

leadImpls : Type -> List (Abs Term)
leadImpls (implPi r s a b) = abs s a ∷ leadImpls b
leadImpls  b               = []

pisToAbsArgTypes : Type -> List (Abs (Arg Type))
pisToAbsArgTypes (pi s a b) = abs s a ∷ pisToAbsArgTypes b
pisToAbsArgTypes  b         = []

explPisToAbsTypes : Type -> List (Abs Type)
explPisToAbsTypes (explPi r s a b) = abs s a ∷ explPisToAbsTypes b
explPisToAbsTypes (pi       s a b) = explPisToAbsTypes b
explPisToAbsTypes  b               = []

explPisToNames : Type -> List String
explPisToNames = map absName ∘ explPisToAbsTypes

countPis : Type -> ℕ
countPis = length ∘ pisToAbsArgTypes

countExplPis : Type -> ℕ
countExplPis = length ∘ explPisToAbsTypes

pisToAbsArgVars : ℕ -> Type -> List (Abs (Arg Term))
pisToAbsArgVars (suc n) (pi s (arg i a) b) = abs s (arg i (pureVar n)) ∷ pisToAbsArgVars n b
pisToAbsArgVars  n       b                 = []

pisToArgVars : ℕ -> Type -> List (Arg Term)
pisToArgVars = map absVal % ∘ pisToAbsArgVars

explPisToAbsVars : ℕ -> Type -> List (Abs Term)
explPisToAbsVars (suc n) (explPi r s a b) = abs s (pureVar n) ∷ explPisToAbsVars n b
explPisToAbsVars (suc n) (pi       s a b) = explPisToAbsVars n b
explPisToAbsVars  n       b               = []

throw : ∀ {α} {A : Set α} -> String -> TC A
throw s = typeError (strErr s ∷ [])

panic : ∀ {α} {A : Set α} -> String -> TC A
panic s = throw $ "panic: " ++ˢ s

-- I'll merge these later.
macro
  sate : Name -> Term -> TC _
  sate f ?r =
    getType f >>= λ a ->
    let res = λ app -> quoteTC (vis# (countExplPis a) app f) >>= unify ?r in
    getDefinition f >>= λ
      { (data-cons _) -> res appCon
      ;  _            -> res appDef
      }

  sateMacro : Name -> Term -> TC _
  sateMacro f ?r =
    getType f >>= λ a ->
    quoteTC (vis# (pred (countExplPis a)) appDef f) >>= unify ?r

_·_ : Term -> Term -> Term
_·_ = sate _$_

unshift′ : Term -> Term
unshift′ t = explLam "_" t · sate tt₀

-- A note for myself: `foldℕ (sate lsuc) (sate lzero) n` is not `reify n`:
-- it's damn `lsuc` -- not `suc`.
termLevelOf : Term -> Maybe Term
termLevelOf (agda-sort (set t)) = just t
termLevelOf (agda-sort (lit n)) = just (foldℕ (sate lsuc) (sate lzero) n)
termLevelOf (agda-sort unknown) = just unknown
termLevelOf _ = nothing

instance
  TermReify : Reify Term
  TermReify = record
    { reify = id
    }

  NameReify : Reify Name
  NameReify = record
    { reify = lit ∘′ name
    }

  VisibilityReify : Reify Visibility
  VisibilityReify = record
    { reify = λ
        { expl -> sate expl
        ; impl -> sate impl
        ; inst -> sate inst
        }
    }

  RelevanceReify : Reify Relevance
  RelevanceReify = record
    { reify = λ
        { rel -> sate rel
        ; irr -> sate irr
        }
    }

  ArgInfoReify : Reify ArgInfo
  ArgInfoReify = record
    { reify = λ{ (arg-info v r) -> sate arg-info (reify v) (reify r) }
    }

  ProdReify : ∀ {α β} {A : Set α} {B : A -> Set β}
                {{aReify : Reify A}} {{bReify : ∀ {x} -> Reify (B x)}} -> Reify (Σ A B)
  ProdReify = record
    { reify = uncurry λ x y -> sate _,_ (reify x) (reify y)
    }

  ℕReify : Reify ℕ
  ℕReify = record
    { reify = foldℕ (sate suc) (sate zero)
    }

  ListReify : ∀ {α} {A : Set α} {{aReify : Reify A}} -> Reify (List A)
  ListReify = record
    { reify = foldr (sate _∷_ ∘ reify) (sate [])
    }

  AllReify : ∀ {α β} {A : Set α} {B : A -> Set β} {xs} {{bReify : ∀ {x} -> Reify (B x)}}
           -> Reify (All B xs)
  AllReify {B = B} {{bReify}} = record
    { reify = go _
    } where
        go : ∀ xs -> All B xs -> Term
        go  []       tt      = sate tt₀
        go (x ∷ xs) (y , ys) = sate _,_ (reify {{bReify}} y) (go xs ys)

toTuple : List Term -> Term
toTuple = foldr₁ (sate _,_) (sate tt₀)

curryBy : Type -> Term -> Term
curryBy = go 0 where
  go : ℕ -> Type -> Term -> Term
  go n (pi s (arg (arg-info v r) a) b) t = lam v s $ go (suc n) b t
  go n  _                              t = shiftBy n t · toTuple (map pureVar (downFrom n))

explUncurryBy : Type -> Term -> Term
explUncurryBy a f = explLam "x" $ appDef (quote id) (explArg rel (shift f) ∷ go a (pureVar 0)) where
  go : Term -> Term -> List (Arg Term)
  go (explPi r s a b@(pi _ _ _)) p = explArg r (sate proj₁ p) ∷ go b (sate proj₂ p)
  go (pi       s a b@(pi _ _ _)) p = go b (sate proj₂ p)
  go (explPi r s a b)            x = explArg r x ∷ []
  go  _                          t = []

defineTerm : Name -> Term -> TC _
defineTerm n t =
  getType n >>= λ a ->
  defineFun n (clause (map (implRelArg ∘ patVar ∘ named ∘ absName) (leadImpls a)) t ∷ [])

-- Able to normalize a Setω.
normalize : Term -> TC Term
normalize (pi s (arg i a) b) =
  pi s ∘ arg i <$> normalize a <*> extendContext (arg i a) (normalize b)
normalize  t                 = normalise t

getNormType : Name -> TC Type
getNormType = getType >=> normalize

inferNormType : Term -> TC Type
inferNormType = inferType >=> normalize

getData : Name -> TC (Data Type)
getData d = getNormType d >>= λ ab -> getDefinition d >>= λ
  { (data-type p cs) ->
       mapM (λ c -> _,_ c ∘ dropPis p <$> getNormType c) cs >>= λ mans ->
         case takePis p ab ⊗ (dropPis p ab ⊗ (mapM (uncurry λ c ma -> flip _,_ c <$> ma) mans)) of λ
           {  nothing             -> panic "getData: data"
           ; (just (a , b , acs)) -> return ∘ uncurry (packData d a b) $ splitList acs
           }
  ; (record-type c _) -> getNormType c >>= dropPis (countPis ab) >>> λ
       {  nothing  -> panic "getData: record"
       ; (just a′) -> return $ packData d (initType ab) (lastType ab) (a′ ∷ []) (c , tt)
       }
  ;  _ -> throw "not a data"
  }

macro
  TypeOf : Term -> Term -> TC _
  TypeOf t ?r = inferNormType t >>= unify ?r

  runTC : ∀ {α} {A : Set α} -> TC A -> Term -> TC _
  runTC a ?r = bindTC a quoteTC >>= unify ?r


module Untyped.Abstract where

open import Function

open import Data.String
open import Data.Nat
open import Data.Unit
open import Data.Product
open import Data.List
open import Data.Sum as Sum
open import Data.Maybe
open import Strict

open import Debug.Trace
open import Category.Monad

open import Untyped.Monads

postulate fail : ∀ {a : Set} → a

willneverhappenipromise : ∀ {a : Set} → String → a
willneverhappenipromise m = trace m fail

module _ where

  Var  = ℕ
  Chan = ℕ

  mutual
    record Closure : Set where
      inductive
      constructor ⟨_⊢_⟩
      field
        env  : Env
        body : Exp

    data Val : Set where
      tt    : Val
      nat   : ℕ → Val
      chan  : Chan → Val
      ⟨_,_⟩ : Val → Val → Val -- pairs
      clos  : Closure → Val -- closures

    Env = List Val

    data Exp : Set where
      -- the functional core
      nat     : ℕ → Exp
      var     : Var → Exp
      ƛ       : Exp → Exp
      _·_     : Exp → Exp → Exp

      -- products
      pair    : Exp → Exp → Exp
      letp    : Exp → Exp → Exp

      -- communication
      close   : Exp → Exp
      receive : Exp → Exp
      send    : (ch : Exp) → (v : Exp) → Exp

      -- threading
      fork    : Exp → Exp

  extend  : Val → Env → Env
  extend = _∷_

  unsafeLookup : ∀ {a} → ℕ → List a → a
  unsafeLookup _ [] = willneverhappenipromise "lookup fail"
  unsafeLookup zero (x ∷ xs)    = x
  unsafeLookup (suc n) (x ∷ xs) = unsafeLookup n xs

  unsafeUpdate : ∀ {a} → ℕ → List a → a → List a
  unsafeUpdate n [] a = willneverhappenipromise "update fail"
  unsafeUpdate zero (x ∷ xs) a = a ∷ xs
  unsafeUpdate (suc n) (x ∷ xs) a = x ∷ unsafeUpdate n xs a

  -- Ideally this should be two different dispatch sets
  data Comm : Set where
    -- communication
    send  : Chan → Val → Comm
    recv  : Chan → Comm
    clos  : Chan → Comm

  data Threading : Set where
    -- threading
    fork  : Closure → Threading
    yield : Threading

  Cmd = Comm ⊎ Threading

  ⟦_⟧-comm : Comm → Set
  ⟦ clos x ⟧-comm = ⊤
  ⟦ send x x₁ ⟧-comm = ⊤
  ⟦ recv x ⟧-comm = Val

  ⟦_⟧-thr : Threading → Set
  ⟦ fork x ⟧-thr = Chan
  ⟦ yield ⟧-thr  = ⊤

  ⟦_⟧ : Cmd → Set
  ⟦ inj₁ x ⟧ = ⟦ x ⟧-comm
  ⟦ inj₂ y ⟧ = ⟦ y ⟧-thr

  data Thread : Set where
    thread : Free Cmd ⟦_⟧ Val → Thread

  ThreadPool = List Thread

  Links  = Chan → Chan

  data Blocked : Set where
    blocked : Blocked

  {- Free an expression from its earthly -}
  module _ {m}
    ⦃ m-monad : RawMonad m ⦄
    ⦃ m-read  : MonadReader m Env ⦄
    ⦃ m-res   : MonadResumption m Closure Chan ⦄
    ⦃ m-comm  : MonadComm m Chan Val ⦄
    where

    open M

    {-# NON_TERMINATING #-}
    eval : Exp → m Val
    eval (nat n) = do
      return (nat n)
    eval (var x) = do
      asks (unsafeLookup x)
    eval (ƛ e) = do
      asks (clos ∘ ⟨_⊢ e ⟩)
    eval (f · e) = do
      clos ⟨ env ⊢ body ⟩ ← eval f
        where _ → willneverhappenipromise "not a closure"
      v ← eval e
      local (λ _ → extend v env) (eval body)

    -- products
    eval (pair e₁ e₂) = do
      v₁ ← eval e₁
      v₂ ← eval e₂
      return ⟨ v₁ , v₂ ⟩

    eval (letp b e) = do
      ⟨ v₁ , v₂ ⟩ ← eval b
        where _ → willneverhappenipromise "not a pair"
      local (extend v₂ ∘ extend v₁) $ eval e

    -- communication
    eval (close e) = do
      chan c ← eval e
        where _ → willneverhappenipromise "not a channel to close"
      M.close c
      return tt
    eval (receive e) = do
      chan c ← eval e
        where _ → willneverhappenipromise "not a channel to receive on"
      M.recv c
    eval (send e₁ e₂) = do
      chan c ← eval e₁
        where _ → willneverhappenipromise "not a channel to send on"
      v ← eval e₂
      M.send c v
      return tt

    -- threading
    eval (fork e) = do
      clos cl ← eval e
        where _ → willneverhappenipromise "not a closure to fork"
      c ← M.fork cl
      return (chan c)

  {- Interpreting communication commands -}
  module _ {com}
    ⦃ com-comm  : MonadComm com Chan Val ⦄ where

    communicate : (cmd : Comm) → com ⟦ cmd ⟧-comm
    communicate (Comm.send c v) = M.send c v
    communicate (Comm.recv x)   = M.recv x
    communicate (clos x)        = M.close x

  {- Interpreting threading commands -}
  module _ {thr}
    ⦃ thr-res   : MonadResumption thr Closure Chan ⦄ where

    threading : (cmd : Threading) → thr ⟦ cmd ⟧-thr
    threading (Threading.fork cl) = M.fork cl
    threading Threading.yield     = M.yield

  module _ {cmd}
    ⦃ cmd-comm  : MonadComm cmd Chan Val ⦄
    ⦃ cmd-res   : MonadResumption cmd Closure Chan ⦄ where

    handle : (c : Cmd) → cmd ⟦ c ⟧
    handle = Sum.[ communicate , threading ]

  {- Round robin scheduling -}
  module _ {w : Set} {m}

    ⦃ monad : RawMonad m ⦄
    ⦃ read  : MonadState m (List w) ⦄

    (atomic : w → m ⊤) where

    open M

    {-# NON_TERMINATING #-}
    robin : m ⊤
    robin = do
      (h ∷ tl) ← get
        where [] → return tt
      put tl
      atomic h
      robin


open import Nat
open import Prelude
open import List

open import contexts
open import core

open import lemmas-env
open import lemmas-progress
open import decidability
open import results-checks

-- TODO we're forced to prove this weaker version, since the strong version is
--      unprovable. That said, this weak version is still disappointing, so we
--      should come up with some more thoerems to shore up its deficiencies -
--      in particular, we should do something to mitigate the fact that an e
--      may succeed for every even n and fail for every odd n
--      - also, that evaluation may return different results for different n
-- TODO complete, then delete
--      e => r → ∀{n} e [n]=> r
--        something similar for =>∅ ?
--      (Σ[r] (e => r) ∧ e => ∅) → ⊥
--      ∀{k} → Σ[r] (e [k]=> r) ∨ e [k]=> ∅
module progress where
  progress : ∀{Δ Σ' Γ E e τ n} →
               Δ , Σ' , Γ ⊢ E →
               Δ , Σ' , Γ ⊢ e :: τ →
               -- Either there's some properly-typed result that e will eval to ...
               Σ[ r ∈ result ] Σ[ k ∈ constraints ] (
                  (E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒ r ⊣ k) ∧
                  Δ , Σ' ⊢ r ·: τ)
               -- ... or evaluation will have a constraint failure
               ∨ E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒∅

  xc-progress : ∀{Δ Σ' r1 r2 τ n} →
                  Δ , Σ' ⊢ r1 ·: τ →
                  Δ , Σ' ⊢ r2 ·: τ →
                  Σ[ k ∈ constraints ] Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:= k
                  ∨ Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:=∅

  xb-progress : ∀{Δ Σ' r ex τ n} →
                  Δ , Σ' ⊢ r ·: τ →
                  Δ , Σ' ⊢ ex :· τ →
                  Σ[ k ∈ constraints ] (r ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:= k)
                  ∨ r ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:=∅

  rule-fails : {n↓ : Nat} {E : env} {r : result} {ex : ex} → Set
  rule-fails {n↓} {E} {r} {ex} =
              Σ[ c-j ∈ Nat ] Σ[ x-j ∈ Nat ] Σ[ e-j ∈ exp ] (
                 r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ 1+ n↓ ⟩ ⌋:=∅
                 ∨ Σ[ k1 ∈ constraints ] (
                      r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ 1+ n↓ ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒∅)
                 ∨ Σ[ k1 ∈ constraints ] Σ[ k2 ∈ constraints ] Σ[ r-j ∈ result ] (
                      r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ 1+ n↓ ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒ r-j ⊣ k2 ∧ r-j ⇐ ex ⌊ ⛽⟨ n↓ ⟩ ⌋:=∅))

  lemma-xb-progress-case : ∀{Δ Σ' E r rules ex τ n n↓} →
                             (n == 1+ n↓) →
                             (len : Nat) →
                             (unchecked : rule ctx) →
                             len == ∥ unchecked ∥ →
                             (failed : (rule-fails {n↓} {E} {r} {ex}) ctx) →
                             (∀{c rule} → (c , rule) ∈ unchecked → (c , rule) ∈ rules) →
                             (∀{c c-j x-j e-j p-j} →
                                (c , c-j , x-j , e-j , p-j) ∈ failed →
                                c == c-j ∧ (c , |C x-j => e-j) ∈ rules) →
                             (∀{c} → dom rules c → dom unchecked c ∨ dom failed c) →
                             Δ , Σ' ⊢ [ E ]case r of⦃· rules ·⦄ ·: τ →
                             Δ , Σ' ⊢ ex :· τ →
                             ex ≠ ¿¿ →
                             Σ[ k ∈ constraints ] ([ E ]case r of⦃· rules ·⦄ ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:= k)
                             ∨ [ E ]case r of⦃· rules ·⦄ ⇐ ex ⌊ ⛽⟨ n ⟩ ⌋:=∅

  progress {n = Z} Γ⊢E ta
    = Inl (_ , _ , ELimit , π2 (typ-inhabitance-pres Γ⊢E ta))
  progress {n = 1+ n} Γ⊢E ta'@(TAFix ta) = Inl (_ , _ , EFix , TAFix Γ⊢E ta')
  progress {n = 1+ n} Γ⊢E (TAVar x∈Γ)
    with env-all-Γ Γ⊢E x∈Γ
  ... | _ , x∈E , ta = Inl (_ , _ , EVar x∈E , ta)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg)
    with progress Γ⊢E ta-arg
  ... | Inr arg-fails = Inr (EFAppArg arg-fails)
  ... | Inl (rarg , _ , arg-evals , ta-rarg)
    with progress Γ⊢E ta-f
  ... | Inr f-fails = Inr (EFAppFun f-fails)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ([ E' ]fix f ⦇·λ x => ef ·⦈ , _ , f-evals , ta'@(TAFix Γ'⊢E' (TAFix ta-ef)))
    with progress {n = n} (EnvInd (EnvInd Γ'⊢E' ta') ta-rarg) ta-ef
  ... | Inr ef-fails = Inr (EFAppFixEval CF⛽ refl f-evals arg-evals ef-fails)
  ... | Inl (ref , _ , ef-evals , ta-ref) = Inl (_ , _ , EAppFix CF⛽ refl f-evals arg-evals ef-evals , ta-ref)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ([ E' ]??[ u ] , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ((rf-f ∘ rf-arg) , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl (fst _ , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl (snd _ , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ([ E' ]case rf of⦃· rules ·⦄ , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E (TAApp _ ta-f ta-arg) | Inl (rarg , _ , arg-evals , ta-rarg) | Inl ((C⁻[ _ ] _) , _ , f-evals , ta-rf)
    = Inl (_ , _ , EAppUnfinished f-evals (λ ()) arg-evals , TAApp ta-rf ta-rarg)
  progress {n = 1+ n} Γ⊢E TAUnit = Inl (_ , _ , EUnit , TAUnit)
  progress {n = 1+ n} Γ⊢E (TAPair _ ta1 ta2)
    with progress Γ⊢E ta1
  ... | Inr fails                    = Inr (EFPair1 fails)
  ... | Inl (_ , _ , evals1 , ta-r1)
    with progress Γ⊢E ta2
  ... | Inr fails                    = Inr (EFPair2 fails)
  ... | Inl (_ , _ , evals2 , ta-r2) = Inl (_ , _ , EPair evals1 evals2 , TAPair ta-r1 ta-r2)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta)
    with progress Γ⊢E ta
  ... | Inr fails = Inr (EFFst fails)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl (⟨ r1 , r2 ⟩ , _ , evals , TAPair ta-r1 ta-r2)
    = Inl (_ , _ , EFst evals , ta-r1)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , _ , evals , TAFix _ ())
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ((C⁻[ x ] q) , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ([ x ]??[ x₁ ] , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ((q ∘ q₁) , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl (fst q , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl (snd q , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TAFst ta) | Inl ([ x ]case q of⦃· x₁ ·⦄ , _ , evals , ta-r)
    = Inl (_ , _ , EFstUnfinished evals (λ ()) , TAFst ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta)
    with progress Γ⊢E ta
  ... | Inr fails = Inr (EFSnd fails)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl (⟨ r1 , r2 ⟩ , _ , evals , TAPair ta-r1 ta-r2)
    = Inl (_ , _ , ESnd evals , ta-r2)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , _ , evals , TAFix _ ())
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ((C⁻[ x ] q) , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ([ x ]??[ x₁ ] , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ((q ∘ q₁) , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl (fst q , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl (snd q , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {Δ} {Σ'} {E = E} {τ = τ} {1+ n} Γ⊢E (TASnd ta) | Inl ([ x ]case q of⦃· x₁ ·⦄ , _ , evals , ta-r)
    = Inl (_ , _ , ESndUnfinished evals (λ ()) , TASnd ta-r)
  progress {n = 1+ n} Γ⊢E (TACtor d∈Σ' c∈d ta)
    with progress Γ⊢E ta
  ... | Inr e-fails = Inr (EFCtor e-fails)
  ... | Inl (_ , _ , e-evals , ta-r) = Inl (_ , _ , ECtor e-evals , TACtor d∈Σ' c∈d ta-r)
  progress {Σ' = Σ'} {n = 1+ n} Γ⊢E (TACase d∈σ' e-ta cctx⊆rules h-rules)
    with progress Γ⊢E e-ta
  ... | Inr e-fails = Inr (EFMatchScrut e-fails)
  ... | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , _ , e-evals , TAFix _ ())
  ... | Inl ([ x ]??[ x₁ ] , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ((re ∘ re₁) , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl (fst _ , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl (snd _ , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ([ x ]case re of⦃· x₁ ·⦄ , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ((C⁻[ _ ] _) , _ , e-evals , ta-re)
          = Inl (_ , _ , EMatchUnfinished e-evals (λ ()) , TACase d∈σ' Γ⊢E ta-re cctx⊆rules (λ form →
                 let _ , _ , _ , c∈cctx , ec-ta = h-rules form in
                 _ , c∈cctx , ec-ta))
  ... | Inl ((C[ c ] re) , _ , e-evals , TACtor d∈'σ' c∈cctx' ta-re)
    rewrite ctxunicity d∈'σ' d∈σ'
    with π2 (cctx⊆rules (_ , c∈cctx'))
  ... | form
    with h-rules form
  ... | _ , _ , _ , c∈cctx , ec-ta
    rewrite ctxunicity c∈cctx c∈cctx'
    with progress {n = n} (EnvInd Γ⊢E ta-re) ec-ta
  ... | Inr ec-fails = Inr (EFMatchRule CF⛽ form e-evals ec-fails)
  ... | Inl (_ , _ , ec-evals , ta-rec) = Inl (_ , _ , EMatch CF⛽ form e-evals ec-evals , ta-rec)
  progress {n = 1+ n} Γ⊢E (TAHole u∈Δ) = Inl (_ , _ , EHole , TAHole u∈Δ Γ⊢E)
  progress {n = 1+ n} Γ⊢E (TAAsrt _ ta1 ta2)
    with progress Γ⊢E ta1
  ... | Inr e1-fails = Inr (EFAsrtL e1-fails)
  ... | Inl (r1 , _ , e1-evals , ta-r1)
    with progress Γ⊢E ta2
  ... | Inr e2-fails = Inr (EFAsrtR e2-fails)
  ... | Inl (r2 , _ , e2-evals , ta-r2)
    with xc-progress ta-r1 ta-r2
  ... | Inl (_ , c-succ) = Inl (_ , _ , EAsrt e1-evals e2-evals c-succ , TAUnit)
  ... | Inr c-fail       = Inr (EFAsrt e1-evals e2-evals c-fail)

  lemma-xc-no-coerce : ∀{Δ Σ' r1 r2 τ n} →
                         Δ , Σ' ⊢ r1 ·: τ →
                         Δ , Σ' ⊢ r2 ·: τ →
                         r1 ≠ r2 →
                         (∀{ex} → Coerce r1 := ex → ⊥) →
                         r1 ≠ ⟨⟩ →
                         (∀{r'1 r'2} → r1 ≠ ⟨ r'1 , r'2 ⟩) →
                         (∀{c r} → r1 ≠ (C[ c ] r)) →
                         Σ[ k ∈ constraints ] Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:= k
                         ∨ Constraints⦃ r1 , r2 ⦄⌊ ⛽⟨ n ⟩ ⌋:=∅
  lemma-xc-no-coerce ta1 (TAFix x x₁) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TAApp ta2 ta3) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 TAUnit r1≠r2 no-coerce not-unit not-pair not-ctor
    with xb-progress ta1 TAUnit
  ...  | Inl (_ , xb) = Inl (_ , (XCBackProp1 r1≠r2 (Inl not-pair) (Inl not-ctor) CoerceUnit xb))
  ...  | Inr xb-fails = Inr (XCFXB1 r1≠r2 (Inl not-pair) (Inl not-ctor) CoerceUnit xb-fails)
  lemma-xc-no-coerce ta1 ta2@(TAPair _ _) r1≠r2 no-coerce not-unit not-pair not-ctor
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ {c-r2 → nc (_ , c-r2)})
  ...  | Inl (_ , c-r2)
    with xb-progress ta1 (Coerce-preservation ta2 c-r2)
  ...  | Inr xb-fails   = Inr (XCFXB1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb))
  lemma-xc-no-coerce ta1 (TAFst ta2) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TASnd ta2) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 ta2@(TACtor _ _ _) r1≠r2 no-coerce not-unit not-pair not-ctor
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ {c-r2 → nc (_ , c-r2)})
  ...  | Inl (_ , c-r2)
    with xb-progress ta1 (Coerce-preservation ta2 c-r2)
  ...  | Inr xb-fails   = Inr (XCFXB1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp1 r1≠r2 (Inl not-pair) (Inl not-ctor) c-r2 xb))
  lemma-xc-no-coerce ta1 (TAUnwrapCtor x x₁ ta2) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TACase x x₁ ta2 x₂ x₃) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())
  lemma-xc-no-coerce ta1 (TAHole x x₁) r1≠r2 no-coerce not-unit not-pair not-ctor
    = Inr (XCFNoCoerce r1≠r2 (Inl not-pair) (Inl not-ctor) no-coerce λ ())

  xc-progress {r1 = r1} {r2} ta1 ta2
    with result-==-dec r1 r2
  ... | Inl refl = Inl (_ , XCExRefl)
  xc-progress {r1 = _} {_} ta1@(TAFix x x₁) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TAApp _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} TAUnit ta2 | Inr r1≠r2
    with xb-progress ta2 TAUnit
  ...  | Inl (_ , xb) = Inl (_ , (XCBackProp2 r1≠r2 (Inl (λ ())) (Inl (λ ())) CoerceUnit xb))
  ...  | Inr xb-fails = Inr (XCFXB2 r1≠r2 (Inl (λ ())) (Inl (λ ())) CoerceUnit xb-fails)
  xc-progress (TAPair ta1a ta1b) (TAPair ta2a ta2b) | Inr r1≠r2
    with xc-progress ta1a ta2a
  ...  | Inr xca-fails = Inr (XCFPair1 xca-fails)
  ...  | Inl (_ , xca)
    with xc-progress ta1b ta2b
  ...  | Inr xcb-fails = Inr (XCFPair2 xcb-fails)
  ...  | Inl (_ , xcb) = Inl (_ , XCPair r1≠r2 xca xcb)
  xc-progress ta1@(TAPair _ _) ta2@(TAApp _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TAFst _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TASnd _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TAUnwrapCtor _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TACase _ _ _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAPair _ _) ta2@(TAHole _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TAFst _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TASnd _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress (TACtor {c = c1} d∈σ1 c1∈cctx ta1) (TACtor {c = c2} d∈σ2 c2∈cctx ta2) | Inr r1≠r2
    with natEQ c1 c2
  ...  | Inr ne         = Inr (XCFCtorMM ne)
  ...  | Inl refl
    rewrite ctxunicity d∈σ1 d∈σ2 | ctxunicity c1∈cctx c2∈cctx
    with xc-progress ta1 ta2
  ...  | Inr xc-fails   = Inr (XCFCtor xc-fails)
  ...  | Inl (_ , xc)   = Inl (_ , XCCtor (λ where refl → r1≠r2 refl) xc)
  xc-progress ta1@(TACtor _ _ _) ta2@(TAApp _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TAFst _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TASnd _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TAUnwrapCtor _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TACase _ _ _ _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress ta1@(TACtor _ _ _) ta2@(TAHole _ _) | Inr r1≠r2
    with Coerce-dec
  ...  | Inr nc         = Inr (XCFNoCoerce r1≠r2 (Inr (λ ())) (Inr (λ ())) (λ {c-r1 → nc (_ , c-r1)}) λ ())
  ...  | Inl (_ , c-r1)
    with xb-progress ta2 (Coerce-preservation ta1 c-r1)
  ...  | Inr xb-fails   = Inr (XCFXB2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb-fails)
  ...  | Inl (_ , xb)   = Inl (_ , (XCBackProp2 r1≠r2 (Inr (λ ())) (Inr (λ ())) c-r1 xb))
  xc-progress {r1 = _} {_} ta1@(TAUnwrapCtor _ _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TACase _ _ _ _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()
  xc-progress {r1 = _} {_} ta1@(TAHole _ _) ta2 | Inr r1≠r2
    = lemma-xc-no-coerce ta1 ta2 r1≠r2 (λ ()) (λ ()) (λ ()) λ ()

  xb-progress {n = Z} _ _ = Inl (_ , XBLimit)
  xb-progress {ex = ex} {n = 1+ n} ta-r ta-ex
    with ex-¿¿-dec {ex}
  ... | Inl refl = Inl (_ , XBNone)
  xb-progress {n = 1+ n} ta-f@(TAFix Γ⊢E (TAFix ta-e)) (TAMap _ ta-v ta-ex) | Inr ne
    with progress {n = n} (EnvInd (EnvInd Γ⊢E ta-f) ta-v) ta-e
  ... | Inr fails    = Inr (XBFFixEval CF⛽ refl fails)
  ... | Inl (_ , _ , evals , ta)
    with xb-progress {n = n} ta ta-ex
  ... | Inr fails    = Inr (XBFFix CF⛽ refl evals fails)
  ... | Inl (_ , xb) = Inl (_ , XBFix CF⛽ refl evals xb)
  xb-progress (TAFix x (TAFix _)) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAApp {arg = v} ta-rf ta-rarg) ta-ex | Inr ne
    with value-dec {v}
  ... | Inr nv  = Inr (XBFAppNonVal ne nv)
  ... | Inl val
    with xb-progress ta-rf (TAMap val ta-rarg ta-ex)
  ... | Inr fails    = Inr (XBFApp ne val fails)
  ... | Inl (_ , xb) = Inl (_ , XBApp ne val xb)
  xb-progress TAUnit TAUnit | Inr ne = Inl (_ , XBUnit)
  xb-progress TAUnit TADC   | Inr ne = Inl (_ , XBNone)
  xb-progress (TAPair ta-r1 ta-r2) (TAPair ta-ex1 ta-ex2) | Inr ne
    with xb-progress ta-r1 ta-ex1
  ... | Inr fails     = Inr (XBFPair1 fails)
  ... | Inl (_ , xb1)
    with xb-progress ta-r2 ta-ex2
  ... | Inr fails     = Inr (XBFPair2 fails)
  ... | Inl (_ , xb2) = Inl (_ , XBPair xb1 xb2)
  xb-progress (TAPair ta-r1 ta-r2) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAFst ta-r) ta-ex | Inr ne
    with xb-progress ta-r (TAPair ta-ex TADC)
  ... | Inr fails    = Inr (XBFFst ne fails)
  ... | Inl (_ , xb) = Inl (_ , XBFst ne xb)
  xb-progress (TASnd ta-r) ta-ex | Inr ne
    with xb-progress ta-r (TAPair TADC ta-ex)
  ... | Inr fails    = Inr (XBFSnd ne fails)
  ... | Inl (_ , xb) = Inl (_ , XBSnd ne xb)
  xb-progress (TACtor {c = c1} h1a h1b ta-r) (TACtor {c = c2} h2a h2b ta-ex) | Inr ne
    with natEQ c1 c2
  ... | Inr ne'  = Inr (XBFCtorMM ne')
  ... | Inl refl
    rewrite ctxunicity h1a h2a | ctxunicity h1b h2b
    with xb-progress ta-r ta-ex
  ... | Inr fails    = Inr (XBFCtor fails)
  ... | Inl (_ , xb) = Inl (_ , XBCtor xb)
  xb-progress (TACtor x x₁ ta-r) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAUnwrapCtor h1 h2 ta-r) ta-ex | Inr ne
    with xb-progress ta-r (TACtor h1 h2 ta-ex)
  ... | Inr fails    = Inr (XBFUnwrapCtor ne fails)
  ... | Inl (_ , xb) = Inl (_ , XBUnwrapCtor ne xb)
  xb-progress {n = 1+ n} ta-C@(TACase {rules = rules} x x₁ ta-r x₂ x₃) ta-ex | Inr ne
    = lemma-xb-progress-case {n = 1+ n} {n} refl ∥ rules ∥ rules refl ∅ (λ y → y) (λ ()) Inl ta-C ta-ex ne
  xb-progress (TAHole x x₁) TAUnit | Inr ne
    = Inl (_ , XBHole ne λ ())
  xb-progress (TAHole x x₁) (TAPair ta-ex ta-ex₁) | Inr ne
    = Inl (_ , XBHole ne λ ())
  xb-progress (TAHole x x₁) (TACtor x₂ x₃ ta-ex) | Inr ne
    = Inl (_ , XBHole ne λ ())
  xb-progress (TAHole x x₁) TADC | Inr ne = Inl (_ , XBNone)
  xb-progress (TAHole x x₁) (TAMap x₂ x₃ ta-ex) | Inr ne
    = Inr XBFHole

  lemma-xb-progress-case {E = E} {r} {rules} {ex} {n = n} {n↓} refl Z [] len-unchecked failed unchecked-wf failed-wf exh ta-C ta-ex n¿¿
    = Inr (XBFMatch CF⛽ n¿¿ all-failed)
      where
        all-failed : ∀{c-j x-j : Nat} {e-j : exp} →
                       (c-j , |C x-j => e-j) ∈ rules →
                       r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ n ⟩ ⌋:=∅
                       ∨ Σ[ k1 ∈ constraints ] (
                             r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ n ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒∅)
                       ∨ Σ[ k1 ∈ constraints ] Σ[ k2 ∈ constraints ] Σ[ r-j ∈ result ] (
                             r ⇐ C[ c-j ] ¿¿ ⌊ ⛽⟨ n ⟩ ⌋:= k1 ∧ (E ,, (x-j , C⁻[ c-j ] r)) ⊢ e-j ⌊ ⛽⟨ n↓ ⟩ ⌋⇒ r-j ⊣ k2 ∧ r-j ⇐ ex ⌊ ⛽⟨ n↓ ⟩ ⌋:=∅)
        all-failed c-j∈rules
          with exh (_ , c-j∈rules)
        ... | Inl (_ , ())
        ... | Inr ((c-j , x-j , e-j , p-j) , c-j∈f)
          with failed-wf c-j∈f
        ... | refl , c-j∈'rules
          with ctxunicity c-j∈rules c-j∈'rules
        ... | refl = p-j
  lemma-xb-progress-case {n = 1+ n↓} {n↓} refl (1+ len) unchecked len-unchecked failed unchecked-wf failed-wf exh ta-C@(TACase {rules = rules} d∈σ' Γ⊢E ta-r _ ta-rules) ta-ex n¿¿
    with ctx-elim {Γ = unchecked}
  ... | Inl refl = abort (0≠1+n (! len-unchecked))
  ... | Inr (c , |C x-j => e-j , unchecked' , refl , c#unchecked')
    with unchecked-wf (x,a∈Γ,,x,a {Γ = unchecked'})
  ... | c∈rules
    with ta-rules c∈rules
  ... | _ , c∈cctx , ta-be
    with xb-progress ta-r (TACtor d∈σ' c∈cctx TADC)
  ... | Inr fails
          = lemma-xb-progress-case
              refl
              len
              unchecked'
              (1+inj (len-unchecked · ctx-decreasing c#unchecked'))
              (failed ,, (c , fail))
              unchecked-wf' failed-wf' exh' ta-C ta-ex n¿¿
            where
              fail = c , x-j , e-j , (Inl fails)
              unchecked-wf' : ∀{c' rule'} → (c' , rule') ∈ unchecked' → (c' , rule') ∈ rules
              unchecked-wf' {c' = c'} c'∈uc'
                with natEQ c c'
              ... | Inl refl = abort (c#unchecked' (_ , c'∈uc'))
              ... | Inr cne  = unchecked-wf (x∈Γ→x∈Γ+ (flip cne) c'∈uc')
              failed-wf' : ∀{c' c-j' x-j' e-j' p-j'} →
                             (c' , c-j' , x-j' , e-j' , p-j') ∈ (failed ,, (c , fail)) →
                             c' == c-j' ∧ ((c' , (|C x-j' => e-j')) ∈ rules)
              failed-wf' {c' = c'} {c-j'} c'∈f+
                with natEQ c c'
              ... | Inr cne  = failed-wf (x∈Γ+→x∈Γ (flip cne) c'∈f+)
              ... | Inl refl
                with ctxunicity c'∈f+ (x,a∈Γ,,x,a {Γ = failed})
              ... | refl = refl , c∈rules
              exh' : ∀{c'} → dom rules c' → dom unchecked' c' ∨ dom (failed ,, (c , fail)) c'
              exh' {c' = c'} c'∈rules
                with natEQ c c'
              ... | Inl refl = Inr (_ , x,a∈Γ,,x,a {Γ = failed})
              ... | Inr cne
                with exh c'∈rules
              ... | Inl (_ , c'∈uc) = Inl (_ , (x∈Γ+→x∈Γ (flip cne) c'∈uc))
              ... | Inr (_ , c'∈f)  = Inr (_ , x∈Γ→x∈Γ+ (flip cne) c'∈f)
  ... | Inl (_ , xb-r)
    with progress {n = n↓} (EnvInd Γ⊢E (TAUnwrapCtor d∈σ' c∈cctx ta-r)) ta-be
  ... | Inr fails
          = lemma-xb-progress-case
              refl
              len
              unchecked'
              (1+inj (len-unchecked · ctx-decreasing c#unchecked'))
              (failed ,, (c , fail))
              unchecked-wf' failed-wf' exh' ta-C ta-ex n¿¿
            where
              fail = c , x-j , e-j , (Inr (Inl (_ , xb-r , fails)))
              unchecked-wf' : ∀{c' rule'} → (c' , rule') ∈ unchecked' → (c' , rule') ∈ rules
              unchecked-wf' {c' = c'} c'∈uc'
                with natEQ c c'
              ... | Inl refl = abort (c#unchecked' (_ , c'∈uc'))
              ... | Inr cne  = unchecked-wf (x∈Γ→x∈Γ+ (flip cne) c'∈uc')
              failed-wf' : ∀{c' c-j' x-j' e-j' p-j'} →
                             (c' , c-j' , x-j' , e-j' , p-j') ∈ (failed ,, (c , fail)) →
                             c' == c-j' ∧ ((c' , (|C x-j' => e-j')) ∈ rules)
              failed-wf' {c' = c'} {c-j'} c'∈f+
                with natEQ c c'
              ... | Inr cne  = failed-wf (x∈Γ+→x∈Γ (flip cne) c'∈f+)
              ... | Inl refl
                with ctxunicity c'∈f+ (x,a∈Γ,,x,a {Γ = failed})
              ... | refl = refl , c∈rules
              exh' : ∀{c'} → dom rules c' → dom unchecked' c' ∨ dom (failed ,, (c , fail)) c'
              exh' {c' = c'} c'∈rules
                with natEQ c c'
              ... | Inl refl = Inr (_ , x,a∈Γ,,x,a {Γ = failed})
              ... | Inr cne
                with exh c'∈rules
              ... | Inl (_ , c'∈uc) = Inl (_ , (x∈Γ+→x∈Γ (flip cne) c'∈uc))
              ... | Inr (_ , c'∈f)  = Inr (_ , x∈Γ→x∈Γ+ (flip cne) c'∈f)
  ... | Inl (_ , _ , evals , ta-br)
    with xb-progress {n = n↓} ta-br ta-ex
  ... | Inr fails
          = lemma-xb-progress-case
              refl
              len
              unchecked'
              (1+inj (len-unchecked · ctx-decreasing c#unchecked'))
              (failed ,, (c , fail))
              unchecked-wf' failed-wf' exh' ta-C ta-ex n¿¿
            where
              fail = c , x-j , e-j , (Inr (Inr (_ , _ , _ , xb-r , evals , fails)))
              unchecked-wf' : ∀{c' rule'} → (c' , rule') ∈ unchecked' → (c' , rule') ∈ rules
              unchecked-wf' {c' = c'} c'∈uc'
                with natEQ c c'
              ... | Inl refl = abort (c#unchecked' (_ , c'∈uc'))
              ... | Inr cne  = unchecked-wf (x∈Γ→x∈Γ+ (flip cne) c'∈uc')
              failed-wf' : ∀{c' c-j' x-j' e-j' p-j'} →
                             (c' , c-j' , x-j' , e-j' , p-j') ∈ (failed ,, (c , fail)) →
                             c' == c-j' ∧ ((c' , (|C x-j' => e-j')) ∈ rules)
              failed-wf' {c' = c'} {c-j'} c'∈f+
                with natEQ c c'
              ... | Inr cne  = failed-wf (x∈Γ+→x∈Γ (flip cne) c'∈f+)
              ... | Inl refl
                with ctxunicity c'∈f+ (x,a∈Γ,,x,a {Γ = failed})
              ... | refl = refl , c∈rules
              exh' : ∀{c'} → dom rules c' → dom unchecked' c' ∨ dom (failed ,, (c , fail)) c'
              exh' {c' = c'} c'∈rules
                with natEQ c c'
              ... | Inl refl = Inr (_ , x,a∈Γ,,x,a {Γ = failed})
              ... | Inr cne
                with exh c'∈rules
              ... | Inl (_ , c'∈uc) = Inl (_ , (x∈Γ+→x∈Γ (flip cne) c'∈uc))
              ... | Inr (_ , c'∈f)  = Inr (_ , x∈Γ→x∈Γ+ (flip cne) c'∈f)
  ... | Inl (_ , xb)
          = Inl (_ , (XBMatch CF⛽ n¿¿ c∈rules xb-r evals xb))

{- TODO delete - this strong version is unprovable
module progress where
  progress : ∀{Δ Σ' Γ E e τ} →
               Δ , Σ' , Γ ⊢ E →
               Δ , Σ' , Γ ⊢ e :: τ →
               -- Either there's some properly-typed result that e will eval to
               -- for any beta reduction limit ...
               Σ[ r ∈ result ] (
                  Δ , Σ' ⊢ r ·: τ ∧
                  ∀{n} → Σ[ k ∈ constraints ] (E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒ r ⊣ k))
               ∨
               -- ... or evaluation will have a constraint failure for any
               -- beta reduction limit
               (∀{n} → E ⊢ e ⌊ ⛽⟨ n ⟩ ⌋⇒∅)
  progress Γ⊢E ta'@(TALam _ ta) = Inl (_ , TALam Γ⊢E ta' , (_ , EFun))
  progress Γ⊢E ta'@(TAFix _ _ ta) = Inl (_ , TAFix Γ⊢E ta' , (_ , EFix))
  progress Γ⊢E (TAVar x∈Γ)
    with env-all-Γ Γ⊢E x∈Γ
  ... | _ , x∈E , ta = Inl (_ , ta , (_ , EVar x∈E))
  progress Γ⊢E (TAApp _ ta-f ta-arg)
    with progress Γ⊢E ta-arg
  ... | Inr arg-fails = Inr (EFAppArg arg-fails)
  ... | Inl (_ , ta-rarg , arg-evals)
    with progress Γ⊢E ta-f
  ... | Inr f-fails = Inr (EFAppFun f-fails)
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl (([ E' ]λ x => ef) , TALam Γ'⊢E' (TALam x#Γ' ta-ef) , f-evals)
    with progress (EnvInd Γ'⊢E' ta-rarg) ta-ef
  ... | q = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ([ E' ]fix f ⦇·λ x => ef ·⦈ , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ([ x ]??[ x₁ ] , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ((rf ∘ rf₁) , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ((get[ x th-of x₁ ] rf) , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl ([ x ]case rf of⦃· x₁ ·⦄ , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TAApp _ ta-f ta-arg) | Inl (_ , ta-rarg , arg-evals) | Inl (PF x , ta-rf , f-evals) = {!!}
  progress Γ⊢E (TATpl ∥es∥==∥τs∥ _ tas) = {!!}
  progress {Δ} {Σ'} {E = E} {τ = τ} Γ⊢E (TAGet {i = i} {len} {e} len==∥τs∥ i<∥τs∥ ta)
    with progress Γ⊢E ta
  ... | Inr e-fails = Inr (EFGet e-fails)
  ... | Inl (⟨ rs ⟩ , TATpl ∥rs∥==∥τs∥ tas , e-evals)
          = let i<∥rs∥ = tr (λ y → i < y) (! ∥rs∥==∥τs∥) i<∥τs∥ in
            Inl (_ , tas i<∥rs∥ i<∥τs∥ , _ , EGet (len==∥τs∥ · ! ∥rs∥==∥τs∥) i<∥rs∥ (π2 e-evals))
  ... | Inl (([ x ]λ x₁ => x₂) , TALam _ () , e-evals)
  ... | Inl ([ x ]fix x₁ ⦇·λ x₂ => x₃ ·⦈ , TAFix _ () , e-evals)
  ... | Inl ([ x ]??[ x₁ ] , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl ((r ∘ r₁) , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl ((get[ x th-of x₁ ] r) , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl ([ x ]case r of⦃· x₁ ·⦄ , ta-r , e-evals)
          rewrite len==∥τs∥ = Inl (_ , TAGet i<∥τs∥ ta-r , _ , EGetUnfinished (π2 e-evals) λ ())
  ... | Inl (PF x , TAPF () , e-evals)
  progress Γ⊢E (TACtor d∈Σ' c∈d ta)
    with progress Γ⊢E ta
  ... | Inl (_ , ta-r , e-evals) = Inl (_ , TACtor d∈Σ' c∈d ta-r , _ , ECtor (π2 e-evals))
  ... | Inr e-fails = Inr (EFCtor e-fails)
  progress Γ⊢E (TACase x ta x₁ x₂) = {!!}
  progress Γ⊢E (TAHole u∈Δ) = Inl (_ , TAHole u∈Δ Γ⊢E , (_ , EHole))
  progress Γ⊢E (TAPF ta) = Inl (_ , TAPF ta , (_ , EPF))
  progress Γ⊢E (TAAsrt x ta ta₁) = {!!}
-}