-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

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

open import Data.Empty
open import Data.Unit
open import Data.Product
open import Data.Maybe
open import Data.Sum
open import Data.List using (_++_; []; _∷_; _∷ʳ_; length)
open import Data.List.Properties using (∷-injective)

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_; _⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; sym; subst; cong)

open import Function.Base using (case_of_)

open import Common

module Divergence {ℙ : Set} (message : Message ℙ)
  where

open import SessionType message
open import Session message
open import Trace message
open import HasTrace message
open import TraceSet message
open import Transitions message
open import Semantics message
open import Subtyping message

DivergeForward : SessionType -> SessionType -> Trace -> Set

record _↑_ (T : SessionType) (S : SessionType) : Set where
  coinductive
  field
    trace : Trace
    with-trace : T HasTrace trace
    without-trace : ¬ S HasTrace trace
    divergence : DivergeForward T S trace

DivergeForward T S φ =
  ∀{ψ x}
  (pre : ψ ⊑ φ)
  (tψx : T HasTrace (ψ ∷ʳ O x))
  (sψx : S HasTrace (ψ ∷ʳ O x)) -> after tψx ↑ after sψx

diverge-before-input : ∀{f g x} -> f x .force ↑ g x .force -> inp f ↑ inp g
_↑_.trace (diverge-before-input {_} {_} {x} div) = I x ∷ _↑_.trace div
_↑_.with-trace (diverge-before-input div) = inp-has-trace (_↑_.with-trace div)
_↑_.without-trace (diverge-before-input div) = inp-has-no-trace (_↑_.without-trace div)
_↑_.divergence (diverge-before-input div) none (_ , _ , step () _) _
_↑_.divergence (diverge-before-input div) (some le) (_ , tdef , step inp tr) (_ , sdef , step inp sr) =
  _↑_.divergence div le (_ , tdef , tr) (_ , sdef , sr)

DivergeBackward : ∀{T S φ} -> T HasTrace φ -> S HasTrace φ -> Set
DivergeBackward {_} {_} {φ} tφ sφ =
  ∀{ψ} (pre : ψ ⊑ φ) -> after (⊑-has-trace pre tφ) ↑ after (⊑-has-trace pre sφ)

⊑-diverge-backward :
  ∀{T S φ ψ}
  {tφ  : T HasTrace φ}
  {sφ  : S HasTrace φ}
  (pre : ψ ⊑ φ) ->
  DivergeBackward tφ sφ ->
  DivergeBackward (⊑-has-trace pre tφ) (⊑-has-trace pre sφ)
⊑-diverge-backward {_} {_} {_} {_} {tφ} {sφ} pre div pre'  rewrite ⊑-tran-has-trace pre' pre tφ | ⊑-tran-has-trace pre' pre sφ =
  div (⊑-tran pre' pre)

data DiscSet : SessionType -> SessionType -> Trace -> Set where
  inc : ∀{T S φ}
        (tφ : T HasTrace φ)
        (sφ : S HasTrace φ)
        (div←φ : DivergeBackward tφ sφ) -> DiscSet T S φ
  exc : ∀{T S φ ψ x}
        (eq : φ ≡ ψ ∷ʳ O x)
        (tψ : T HasTrace ψ)
        (sψ : S HasTrace ψ)
        (tφ : T HasTrace φ)
        (nsφ : ¬ S HasTrace φ)
        (div←ψ : DivergeBackward tψ sψ) -> DiscSet T S φ

⊑-proper : ∀{φ ψ α} -> φ ⊑ (ψ ∷ʳ α) -> φ ⊑ ψ ⊎ φ ≡ ψ ∷ʳ α
⊑-proper {[]} {[]} none = inj₁ none
⊑-proper {_ ∷ []} {[]} (some none) = inj₂ refl
⊑-proper {[]} {_ ∷ _} none = inj₁ none
⊑-proper {_} {_ ∷ _} (some pre) with ⊑-proper pre
... | inj₁ pre' = inj₁ (some pre')
... | inj₂ refl = inj₂ refl

disc-set->closed : (T S : SessionType) -> PrefixClosed (DiscSet T S)
disc-set->closed T S pre (inc tφ sφ div←φ) =
  inc (⊑-has-trace pre tφ) (⊑-has-trace pre sφ) (⊑-diverge-backward pre div←φ)
disc-set->closed T S pre (exc refl tψ sψ tφ nsφ div←ψ) with ⊑-proper pre
... | inj₁ pre' = inc (⊑-has-trace pre' tψ) (⊑-has-trace pre' sψ) (⊑-diverge-backward pre' div←ψ)
... | inj₂ refl = exc refl tψ sψ tφ nsφ div←ψ

input-lemma : ∀{φ x ψ χ y} -> φ ++ I x ∷ ψ ≡ χ ∷ʳ O y -> (φ ∷ʳ I x) ⊑ χ
input-lemma {[]} {_} {_} {I x ∷ χ} refl = some none
input-lemma {x ∷ φ} {_} {_} {[]} eq with ∷-injective eq
... | (_ , eq') = ⊥-elim (absurd-++-≡ eq')
input-lemma {x ∷ φ} {_} {_} {y ∷ χ} eq with ∷-injective eq
... | (refl , eq'') = some (input-lemma eq'')

disc-set-input : ∀{φ x ψ} {T S : SessionType} -> DiscSet T S (φ ++ I x ∷ ψ) ->
  T HasTrace (φ ∷ʳ I x) × S HasTrace (φ ∷ʳ I x)
disc-set-input {φ} {x} {ψ} (inc tφ sφ div←φ) with ⊑-precong-++ {φ} {I x ∷ []} {I x ∷ ψ} (some none)
... | pre = ⊑-has-trace pre tφ , ⊑-has-trace pre sφ
disc-set-input (exc eq tχ sχ _ _ _) with input-lemma eq
... | pre = ⊑-has-trace pre tχ , ⊑-has-trace pre sχ

disc-set-output : ∀{φ x ψ} {T S : SessionType} -> DiscSet T S (φ ++ O x ∷ ψ) -> T HasTrace (φ ∷ʳ O x)
disc-set-output {φ} {x} {ψ} (inc tφx sφx _) =
  let pre = ⊑-precong-++ {φ} {O x ∷ []} {O x ∷ ψ} (some none) in
  ⊑-has-trace pre tφx
disc-set-output {φ} {x} {ψ} (exc _ _ _ tφx _ _) =
  let pre = ⊑-precong-++ {φ} {O x ∷ []} {O x ∷ ψ} (some none) in
  ⊑-has-trace pre tφx

disc-set->coherent : (T S : SessionType) -> Coherent (DiscSet T S)
disc-set->coherent T S ti to =
  let (ti[] , _) = disc-set-input ti in
  let to[] = disc-set-output to in
  ⊥-elim (coherent (sem-sound T) ti[] to[])

disc-set->semantics : (T S : SessionType) -> Semantics (DiscSet T S)
closed (disc-set->semantics T S) = disc-set->closed T S
coherent (disc-set->semantics T S) = disc-set->coherent T S

disc-set-subset : ∀{T S} -> DiscSet T S ⊆ ⟦ T ⟧
disc-set-subset (inc tφ _ _) = tφ
disc-set-subset (exc _ _ _ tφ _ _) = tφ

disc-set-disjoint :
  ∀{T S φ} ->
  φ ∈ DiscSet T S ->
  ¬ S HasTrace φ ->
  ∃[ ψ ] ∃[ x ] (φ ≡ ψ ∷ʳ O x × S HasTrace ψ)
disc-set-disjoint (inc _ sφ _) nsφ = ⊥-elim (nsφ sφ)
disc-set-disjoint (exc eq _ sψ _ _ _) nsφ = _ , _ , eq , sψ

-- --| BEGIN MAXIMAL TRACES |--

diverge-forward-input :
  ∀{f g x φ} -> DivergeForward (inp f) (inp g) (I x ∷ φ)
             -> DivergeForward (f x .force) (g x .force) φ
diverge-forward-input div pre (_ , tdef , tr) (_ , sdef , sr) = div (some pre) (_ , tdef , step inp tr) (_ , sdef , step inp sr)

diverge-forward-input' :
  ∀{f g x φ} -> DivergeForward (f x .force) (g x .force) φ
             -> DivergeForward (inp f) (inp g) (I x ∷ φ)
diverge-forward-input' div none (_ , _ , step () _) (_ , _ , _)
diverge-forward-input' div (some le) (_ , tdef , step inp tr) (_ , sdef , step inp sr) = div le (_ , tdef , tr) (_ , sdef , sr)

diverge-forward-output :
  ∀{f g x φ} -> DivergeForward (out f) (out g) (O x ∷ φ)
             -> DivergeForward (f x .force) (g x .force) φ
diverge-forward-output div pre (_ , tdef , tr) (_ , sdef , sr) =
  div (some pre)
      (_ , tdef , step (out (transitions+defined->defined tr tdef)) tr)
      (_ , sdef , step (out (transitions+defined->defined sr sdef)) sr)

-- the next lemma says that if T ↑ S and φ is the trace that
-- discriminates between them, then we have divergence along any
-- common prefix of φ shared by both T and S

diverge-forward->backward :
  ∀{T S φ ψ}
  (tφ  : T HasTrace φ)
  (nsφ : ¬ S HasTrace φ)
  (div : DivergeForward T S φ)
  (pre : ψ ⊑ φ)
  (tψ  : T HasTrace ψ)
  (sψ  : S HasTrace ψ) ->
  DivergeBackward tψ sψ
_↑_.trace (diverge-forward->backward tφ nsφ div pre tψ sψ none) = _
_↑_.with-trace (diverge-forward->backward tφ nsφ div pre tψ sψ none) = tφ
_↑_.without-trace (diverge-forward->backward tφ nsφ div pre tψ sψ none) = nsφ
_↑_.divergence (diverge-forward->backward tφ nsφ div pre tψ sψ none) = div
diverge-forward->backward (_ , tdef , step inp tr) nsφ div (some pre) (_ , tdef' , step (inp {f}) tr') (_ , sdef , step (inp {g}) sr) (some pre') =
  diverge-forward->backward (_ , tdef , tr) (contraposition inp-has-trace nsφ) (diverge-forward-input {f} {g} div) pre (_ , tdef' , tr') (_ , sdef , sr) pre'
diverge-forward->backward (_ , tdef , step (out _) tr) nsφ div (some pre) (_ , tdef' , step (out {f} _) tr') (_ , sdef , step (out {g} _) sr) (some pre') =
  diverge-forward->backward (_ , tdef , tr) (contraposition out-has-trace nsφ) (diverge-forward-output {f} {g} div) pre (_ , tdef' , tr') (_ , sdef , sr) pre'

prefix-last-element : ∀{φ φ' ψ ψ' x y} -> φ ⊑ ψ -> φ ≡ φ' ++ O x ∷ [] -> ψ ≡ ψ' ∷ʳ O y -> ψ ≡ φ ⊎ φ ⊑ ψ'
prefix-last-element none e1 e2 = inj₂ none
prefix-last-element {φ' = []} {ψ' = []} (some pre) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (_ , e1') | (_ , e2') rewrite e1' | e2' = inj₁ refl
prefix-last-element {φ' = []} {ψ' = x ∷ ψ'} (some _) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (eq1 , e1') | (eq2 , e2') rewrite eq1 | eq2 | e1' | e2' = inj₂ (some none)
prefix-last-element {φ' = x ∷ φ'} {ψ' = []} (some pre) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (eq1 , e1') | (eq2 , e2') rewrite e1' | e2' = ⊥-elim (absurd-++-⊑ pre)
prefix-last-element {φ' = x ∷ φ'} {ψ' = x₁ ∷ ψ'} (some pre) e1 e2 with ∷-injective e1 | ∷-injective e2
... | (eq1 , e1') | (eq2 , e2') rewrite eq1 | eq2 with prefix-last-element pre e1' e2'
... | inj₁ eq rewrite eq = inj₁ refl
... | inj₂ pre' = inj₂ (some pre')

disc-set-maximal-1 :
  ∀{T S φ} ->
  φ ∈ DiscSet T S ->
  ¬ S HasTrace φ ->
  φ ∈ Maximal (DiscSet T S)
disc-set-maximal-1 dsφ nsφ with disc-set-disjoint dsφ nsφ
... | _ , _ , refl , sψ =
  maximal dsφ λ le ds' ->
  let _ , _ , eq , sψ' = disc-set-disjoint ds' (contraposition (⊑-has-trace le) nsφ) in
  case prefix-last-element le refl eq of λ
  { (inj₁ refl) → refl
  ; (inj₂ le') → ⊥-elim (contraposition (⊑-has-trace le') nsφ sψ') }

has-trace-after : ∀{T φ ψ} (tφ : T HasTrace φ) -> after tφ HasTrace ψ -> T HasTrace (φ ++ ψ)
has-trace-after (_ , _ , refl) tφψ = tφψ
has-trace-after (_ , tdef , step inp tr) tφψ = inp-has-trace (has-trace-after (_ , tdef , tr) tφψ)
has-trace-after (_ , tdef , step (out _) tr) tφψ = out-has-trace (has-trace-after (_ , tdef , tr) tφψ)

has-no-trace-after : ∀{T φ ψ} (tφ : T HasTrace φ) -> ¬ after tφ HasTrace ψ -> ¬ T HasTrace (φ ++ ψ)
has-no-trace-after (_ , _ , refl) tφ/nψ = tφ/nψ
has-no-trace-after (_ , tdef , step inp tr) tφ/nψ = inp-has-no-trace (has-no-trace-after (_ , tdef , tr) tφ/nψ)
has-no-trace-after (_ , tdef , step (out _) tr) tφ/nψ = out-has-no-trace (has-no-trace-after (_ , tdef , tr) tφ/nψ)

append-diverge-backward :
  ∀{T S φ ψ}
  (tφ : T HasTrace φ)
  (sφ : S HasTrace φ)
  (tφ/ψ : after tφ HasTrace ψ)
  (sφ/ψ : after sφ HasTrace ψ)
  (div←φ : DivergeBackward tφ sφ)
  (divφ←ψ : DivergeBackward tφ/ψ sφ/ψ) ->
  DivergeBackward (has-trace-after tφ tφ/ψ) (has-trace-after sφ sφ/ψ)
append-diverge-backward (_ , tdef , refl) (_ , sdef , refl) tφ/ψ sφ/ψ div←φ divφ←ψ pre = divφ←ψ pre
append-diverge-backward (_ , tdef , step t tr) (_ , sdef , step s sr) tφ/ψ sφ/ψ div←φ divφ←ψ none = div←φ none
append-diverge-backward (_ , tdef , step inp tr) (_ , sdef , step inp sr) tφ/ψ sφ/ψ div←φ divφ←ψ (some pre) =
  append-diverge-backward (_ , tdef , tr) (_ , sdef , sr) tφ/ψ sφ/ψ (λ pre -> div←φ (some pre)) divφ←ψ pre
append-diverge-backward (_ , tdef , step (out _) tr) (_ , sdef , step (out _) sr) tφ/ψ sφ/ψ div←φ divφ←ψ (some pre) =
  append-diverge-backward (_ , tdef , tr) (_ , sdef , sr) tφ/ψ sφ/ψ (λ pre -> div←φ (some pre)) divφ←ψ pre

append-snoc : ∀{φ ψ : Trace}{α : Action} -> φ ++ (ψ ∷ʳ α) ≡ (φ ++ ψ) ∷ʳ α
append-snoc {[]} = refl
append-snoc {β ∷ φ} = cong (β ∷_) (append-snoc {φ})

completion :
  ∀{φ T S} ->
  T <: S ->
  φ ∈ DiscSet T S ->
  (∃[ ψ ] (φ ⊏ ψ × ψ ∈ Maximal (DiscSet T S))) ⊎ (φ ∈ Maximal (DiscSet T S) × ¬ S HasTrace φ)
completion {φ} sub (inc tφ sφ div←φ) with div←φ (⊑-refl _)
... | div rewrite ⊑-has-trace-after tφ | ⊑-has-trace-after sφ =
  let χ = _↑_.trace div in
  let tφ/χ = _↑_.with-trace div in
  let sφ/nχ = _↑_.without-trace div in
  let divφ→χ = _↑_.divergence div in
  let subφ = sub-after tφ sφ sub in
  let ψ , x , ψ⊑χ , tφ/ψ , sφ/ψ , tφ/ψx , sφ/nψx = sub-excluded subφ tφ/χ sφ/nχ in
  let tφψ = has-trace-after tφ tφ/ψ in
  let sφψ = has-trace-after sφ sφ/ψ in
  let tφψx = has-trace-after tφ tφ/ψx in
  let sφnψx = has-no-trace-after sφ sφ/nψx in
  let divφ←ψ = diverge-forward->backward tφ/χ sφ/nχ divφ→χ ψ⊑χ tφ/ψ sφ/ψ in
  let div←ψ  = append-diverge-backward tφ sφ tφ/ψ sφ/ψ div←φ divφ←ψ in
  let ds = exc {_} {_} {φ ++ (ψ ∷ʳ O x)} {φ ++ ψ} {x} (append-snoc {φ} {ψ} {O x}) tφψ sφψ tφψx sφnψx div←ψ in
  inj₁ (φ ++ (ψ ∷ʳ O x) , ⊏-++ , disc-set-maximal-1 ds sφnψx)
completion sub ds@(exc _ _ _ _ nsφ _) =
  inj₂ (disc-set-maximal-1 ds nsφ , nsφ)

disc-set-maximal-2 :
  ∀{T S φ} ->
  T <: S ->
  φ ∈ Maximal (DiscSet T S) ->
  ¬ S HasTrace φ
disc-set-maximal-2 sub (maximal dφ F) sφ with completion sub dφ
... | inj₁ (ψ , φ⊏ψ , maximal dψ _) = ⊏->≢ φ⊏ψ (sym (F (⊏->⊑ φ⊏ψ) dψ))
... | inj₂ (_ , nsφ) = nsφ sφ

--| END MAXIMAL TRACES |--

-- Sia R il session type determinato da disc-set T S quando T ↑
-- S. L'obiettivo è dimostrare che R |- T e ¬ R |- S
--
-- R |- T
--
-- Ogni riduzione di (R # T) può essere completata a (R' # T') in
-- cui Win R' e Defined T'
--
-- Siccome le tracce di R sono incluse in quelle di T, basta
-- dimostrare che ogni traccia di R può essere completata, cioè che
-- ogni traccia di disc-set T S è prefisso di una traccia completa
-- di disc-set T S.
--
-- ∀ φ ∈ R => ∃ ψ : φ ++ ψ ∈ Maximal R
--
-- ¬ R |- S
--
-- Dimostrare che ogni traccia completa di R non è una traccia di S.
--
-- Maximal R ∩ ⟦ S ⟧ ≡ ∅


{-# OPTIONS --allow-unsolved-metas #-}
module FindTermNode where

open import TermNode
open import OscarPrelude

record FindTermNode (A : Set) : Set
 where
  field
    findTermNode : A → TermNode → Maybe TermNode

open FindTermNode ⦃ … ⦄ public

open import TermCode
open import Term
open import Element

instance
  FindTermNodeTermCode : FindTermNode TermCode
  FindTermNode.findTermNode FindTermNodeTermCode termCode record { children = [] ; number = number₁ } = nothing
  FindTermNode.findTermNode FindTermNodeTermCode termCode 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } = ifYes fst₁ ≟ termCode then just snd₁ else findTermNode termCode record 𝔫 { children = children₁ }

  FindTermNodeTermCodes : FindTermNode (List TermCode)
  FindTermNode.findTermNode FindTermNodeTermCodes [] node = just node
  FindTermNode.findTermNode FindTermNodeTermCodes (x ∷ termCodes) node = join $ findTermNode termCodes <$> findTermNode x node

  FindTermNodeTerm : FindTermNode Term
  FindTermNode.findTermNode FindTermNodeTerm term node = findTermNode (encodeTerm term) node

-- This is starting to get difficult. We need Agda to know that the Term is encoded in the TermNode. Then we can drop the Maybe
getInterpretationOfTerm : Term → TermNode → Maybe Element
getInterpretationOfTerm τ node = ⟨_⟩ ∘ number <$> findTermNode (encodeTerm τ) node

open import Membership

FindTermNodeTermCode-ok : ∀ {𝔠 𝔫} → 𝔠 child∈ 𝔫 → IsJust (findTermNode 𝔠 𝔫)
FindTermNodeTermCode-ok {𝔠} {record { children = [] ; number = number₁ }} ()
--FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ = case (fst₁ ≟_) 𝔠 , graphAt {B = λ 𝑐 → Dec (fst₁ ≡ 𝑐)} (fst₁ ≟_) 𝔠 of λ { (yes x , snd₂) → {!!} ; (no x , snd₂) → {!!}} --λ { ((yes ===) , (inspect s1)) → {!!} ; ((no =n=) , inspect s2) → {!!} }
--FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ = case fst₁ ≟ 𝔠 of λ { (yes refl) → {!!} ; (no x) → {!!}}
FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ with fst₁ ≟ 𝔠
FindTermNodeTermCode-ok {𝔠} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} x₁ | yes eq2 = tt
FindTermNodeTermCode-ok {.fst₁} {record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} (zero) | no neq = ⊥-elim (neq refl)
FindTermNodeTermCode-ok {𝔠} {𝔫@record { children = (fst₁ , snd₁) ∷ children₁ ; number = number₁ }} (suc x₁) | no neq = FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} x₁

Justified : ∀ {a} {A : Set a} → (m : Maybe A) → IsJust m → ∃ λ x → m ≡ just x
Justified nothing ()
Justified (just x) x₁ = _ , refl

open import FunctionName
open import Vector

storeTerm-ok : ∀ τ 𝔫 𝔑 → IsJust (findTermNode τ (snd (runIdentity (runStateT (runStateT (storeTerm τ) 𝔑) 𝔫))))
storeTerm-ok (variable 𝑥) 𝔫 𝔑 with variable 𝑥 child∈? 𝔫
storeTerm-ok (variable 𝑥) 𝔫 𝔑 | no x with TermCode.variable 𝑥 ≟ variable 𝑥
storeTerm-ok (variable 𝑥) 𝔫 𝔑 | no x | yes _ = tt
storeTerm-ok (variable 𝑥) 𝔫 𝔑 | no x | no variable𝑥≢variable𝑥 = ⊥-elim (variable𝑥≢variable𝑥 refl)
--storeTerm-ok (variable 𝑥) 𝔫 𝔑 | yes vx∈𝔫 rewrite setGet-ok 𝔫 vx∈𝔫 = {!𝔫!}
storeTerm-ok (variable 𝑥) record { children = [] ; number = number₁ } 𝔑 | yes ()
--storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 rewrite setGet-ok 𝔫 vx∈𝔫 = {!!}
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 rewrite setGet-ok 𝔫 vx∈𝔫 with fst₁ ≟ variable 𝑥
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | yes eq = tt
--… | no neq = case vx∈𝔫 of λ { (here .(map fst children₁)) → ⊥-elim (neq refl)  ; (there .fst₁ asdf) → case graphAt FindTermNodeTermCode-ok asdf of λ { (ingraph sss) → {!!} } } -- storeTerm-ok x {!record 𝔫 { children = children₁ }!} 𝔑 -- x record 𝔫 { children = children₁ } 𝔑
--… | no neq = case vx∈𝔫 of λ { (here .(map fst children₁)) → ⊥-elim (neq refl)  ; (there .fst₁ asdf) → case inspect $ FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} asdf of λ { (.(FindTermNodeTermCode-ok asdf) , ingraph refl) → {!!}} } -- storeTerm-ok x {!record 𝔫 { children = children₁ }!} 𝔑 -- x record 𝔫 { children = children₁ } 𝔑
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq with vx∈𝔫
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq | zero = ⊥-elim (neq refl)
--storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq | there dfdsf fdsdfs with FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} fdsdfs | graphAt (FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }}) fdsdfs
--… | frfrrf | ingraph tttttt = transport _ (snd $ Justified (FindTermNode.findTermNode FindTermNodeTermCode (variable 𝑥) (record { children = children₁ ; number = number₁ })) (FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} fdsdfs)) _
storeTerm-ok x@(variable 𝑥) 𝔫@record { children = ((fst₁ , snd₁) ∷ children₁) ; number = number₁ } 𝔑 | yes vx∈𝔫 | no neq | suc fdsdfs rewrite (snd $ Justified (FindTermNode.findTermNode FindTermNodeTermCode (variable 𝑥) (record { children = children₁ ; number = number₁ })) (FindTermNodeTermCode-ok {𝔫 = record 𝔫 { children = children₁ }} fdsdfs)) = tt
storeTerm-ok (function 𝑥 𝑎) 𝔫 𝔑 with (function 𝑥 (arity 𝑎)) child∈? 𝔫
storeTerm-ok (function 𝑥 ⟨ ⟨ [] ⟩ ⟩) 𝔫 𝔑 | no x with Eq._==_ EqFunctionName ⟨ name 𝑥 ⟩ ⟨ name 𝑥 ⟩
storeTerm-ok (function 𝑥 ⟨ ⟨ [] ⟩ ⟩) 𝔫 𝔑 | no x | (yes refl) = tt
… | no neq = ⊥-elim (neq refl)
--storeTerm-ok τ₀@(function 𝑓 ⟨ τ₁ ∷ τ₂s ⟩) 𝔫 𝔑 | no 𝔠₁∉𝔫 = {!τ₁!}
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₁∉𝔫 with variable 𝑥 child∈? 𝔫
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) with 𝑓₀ ≟ 𝑓₀
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | yes refl with TermCode.variable 𝑥 ≟ variable 𝑥
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | yes refl | yes eq = tt
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | yes refl | no neq = ⊥-elim (neq refl)
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥 ∷ []        ⟩ ⟩) 𝔫 𝔑        | no 𝔠₀∉𝔫 | (yes 𝔠₁∈𝔫) | no neq = ⊥-elim (neq refl)
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) with 𝑓₀ ≟ 𝑓₀
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | yes refl with TermCode.variable 𝑥₁ ≟ variable 𝑥₁
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | yes refl | yes 𝔠₁≡𝔠₁ = tt
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | yes refl | no 𝔠₁≢𝔠₁ = ⊥-elim (𝔠₁≢𝔠₁ refl)
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ []       ⟩ ⟩) 𝔫 𝔑       | no 𝔠₀∉𝔫 | (no 𝔠₁∉𝔫) | no 𝑓₀≢𝑓₀ = ⊥-elim (𝑓₀≢𝑓₀ refl) -- rewrite setGet-ok 𝔫 𝔠₁∈𝔫
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ τ₂ ∷ τ₃s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₀∉𝔫 with variable 𝑥₁ child∈? 𝔫
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ τ₂ ∷ τ₃s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₀∉𝔫 | yes 𝔠₁∈𝔫 = {!!}
storeTerm-ok (function 𝑓₀ ⟨ ⟨ variable 𝑥₁ ∷ τ₂ ∷ τ₃s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₀∉𝔫 | no 𝔠₁∉𝔫 = {!!}
storeTerm-ok τ₀@(function 𝑓₀ ⟨ ⟨ function 𝑓₁ τ₁s ∷ τ₂s ⟩ ⟩) 𝔫 𝔑 | no 𝔠₁∉𝔫 = {!!}
storeTerm-ok (function 𝑥 x₁) 𝔫 𝔑 | yes x = {!!}

mutual

  storeTermVerifiably' : (τ : Term) → StateT Nat (StateT (Σ TermNode λ n → IsJust (findTermNode τ n)) Identity) ⊤
  storeTermVerifiably' (variable x) = {!!}
  storeTermVerifiably' (function x x₁) = {!!}

  storeTermVerifiably : Term → StateT Nat (StateT TermNode Identity) ⊤
  storeTermVerifiably τ@(variable _) = storeTermCodes' (encodeTerm τ)
  storeTermVerifiably τ@(function _ τs) = storeTermCodes' (encodeTerm τ) ~| storeTermsVerifiably τs

  storeTermsVerifiably : Terms → StateT Nat (StateT TermNode Identity) ⊤
  storeTermsVerifiably ⟨ ⟨ [] ⟩ ⟩ = return tt
  storeTermsVerifiably ⟨ ⟨ τ ∷ τs ⟩ ⟩ = storeTermVerifiably τ ~| storeTermsVerifiably ⟨ ⟨ τs ⟩ ⟩ ~| return tt


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Conversion {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.RedSteps
open import Definition.Typed.Properties
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance

open import Tools.Embedding
open import Tools.Product
import Tools.PropositionalEquality as PE

-- Conversion of syntactic reduction closures.
convRed:*: : ∀ {t u A B Γ} → Γ ⊢ t :⇒*: u ∷ A → Γ ⊢ A ≡ B → Γ ⊢ t :⇒*: u ∷ B
convRed:*: [ ⊢t , ⊢u , d ] A≡B = [ conv ⊢t  A≡B , conv ⊢u  A≡B , conv* d  A≡B ]

mutual
  -- Helper function for conversion of terms converting from left to right.
  convTermT₁ : ∀ {l l′ Γ A B t} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
             → ShapeView Γ l l′ A B [A] [B]
             → Γ ⊩⟨ l ⟩  A ≡ B / [A]
             → Γ ⊩⟨ l ⟩  t ∷ A / [A]
             → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
  convTermT₁ (ℕᵥ D D′) A≡B (ιx (ℕₜ n d n≡n prop)) = ιx (ℕₜ n d n≡n prop)
  convTermT₁ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
             (ιx (neₜ k d (neNfₜ neK₂ ⊢k k≡k))) =
    let K≡K₁ = PE.subst (λ x → _ ⊢ _ ≡ x)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (≅-eq (~-to-≅ K≡M))
    in ιx (neₜ k (convRed:*: d K≡K₁)
            (neNfₜ neK₂ (conv ⊢k K≡K₁) (~-conv k≡k K≡K₁)))
  convTermT₁ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
             (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
             (Πₜ f d funcF f≡f [f] [f]₁) =
    let ΠF₁G₁≡ΠF′G′   = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        F₁≡F′ , G₁≡G′ = Π-PE-injectivity ΠF₁G₁≡ΠF′G′
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x) (PE.sym ΠF₁G₁≡ΠF′G′)
                             (≅-eq A≡B)
    in  Πₜ f (convRed:*: d ΠFG≡ΠF₁G₁) funcF (≅-conv f≡f ΠFG≡ΠF₁G₁)
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                           ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                  [a]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                  [b]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [b]
                  [a≡b]₁ = convEqTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a≡b]
                  [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                    (PE.sym G₁≡G′))
                                           ([G] [ρ] ⊢Δ [a]₁)
                                           ([G≡G′] [ρ] ⊢Δ [a]₁)
              in  convEqTerm₁ ([G] [ρ] ⊢Δ [a]₁) ([G]₁ [ρ] ⊢Δ [a]) [G≡G₁]
                              ([f] [ρ] ⊢Δ [a]₁ [b]₁ [a≡b]₁))
          (λ {ρ} [ρ] ⊢Δ [a] →
             let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                          ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                 [a]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                 [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                   (PE.sym G₁≡G′))
                                          ([G] [ρ] ⊢Δ [a]₁)
                                          ([G≡G′] [ρ] ⊢Δ [a]₁)
             in  convTerm₁ ([G] [ρ] ⊢Δ [a]₁) ([G]₁ [ρ] ⊢Δ [a]) [G≡G₁] ([f]₁ [ρ] ⊢Δ [a]₁))
  convTermT₁ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t = t
  convTermT₁ (emb⁰¹ PE.refl x) (ιx A≡B) (ιx t) = convTermT₁ x A≡B t
  convTermT₁ (emb¹⁰ PE.refl x) A≡B t = ιx (convTermT₁ x A≡B t)

  -- Helper function for conversion of terms converting from right to left.
  convTermT₂ : ∀ {l l′ Γ A B t} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
           → ShapeView Γ l l′ A B [A] [B]
           → Γ ⊩⟨ l ⟩  A ≡ B / [A]
           → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
           → Γ ⊩⟨ l ⟩  t ∷ A / [A]
  convTermT₂ (ℕᵥ D D′) A≡B (ιx (ℕₜ n d n≡n prop)) = ιx (ℕₜ n d n≡n prop)
  convTermT₂ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
             (ιx (neₜ k d (neNfₜ neK₂ ⊢k k≡k))) =
    let K₁≡K = PE.subst (λ x → _ ⊢ x ≡ _)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (sym (≅-eq (~-to-≅ K≡M)))
    in ιx (neₜ k (convRed:*: d K₁≡K)
            (neNfₜ neK₂ (conv ⊢k K₁≡K) (~-conv k≡k K₁≡K)))
  convTermT₂ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                         (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
             (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
             (Πₜ f d funcF f≡f [f] [f]₁) =
    let ΠF₁G₁≡ΠF′G′   = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        F₁≡F′ , G₁≡G′ = Π-PE-injectivity ΠF₁G₁≡ΠF′G′
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x)
                             (PE.sym ΠF₁G₁≡ΠF′G′) (≅-eq A≡B)
    in  Πₜ f (convRed:*: d (sym ΠFG≡ΠF₁G₁)) funcF (≅-conv f≡f (sym ΠFG≡ΠF₁G₁))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                           ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                  [a]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                  [b]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [b]
                  [a≡b]₁ = convEqTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a≡b]
                  [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                    (PE.sym G₁≡G′))
                                           ([G] [ρ] ⊢Δ [a])
                                           ([G≡G′] [ρ] ⊢Δ [a])
              in  convEqTerm₂ ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                              [G≡G₁] ([f] [ρ] ⊢Δ [a]₁ [b]₁ [a≡b]₁))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                           ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                  [a]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                  [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                    (PE.sym G₁≡G′))
                                           ([G] [ρ] ⊢Δ [a])
                                           ([G≡G′] [ρ] ⊢Δ [a])
              in  convTerm₂ ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                            [G≡G₁] ([f]₁ [ρ] ⊢Δ [a]₁))
  convTermT₂ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t = t
  convTermT₂ (emb⁰¹ PE.refl x) (ιx A≡B) t = ιx (convTermT₂ x A≡B t)
  convTermT₂ (emb¹⁰ PE.refl x) A≡B (ιx t) = convTermT₂ x A≡B t

  -- Conversion of terms converting from left to right.
  convTerm₁ : ∀ {Γ A B t l l′} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
            → Γ ⊩⟨ l ⟩  A ≡ B / [A]
            → Γ ⊩⟨ l ⟩  t ∷ A / [A]
            → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
  convTerm₁ [A] [B] A≡B t = convTermT₁ (goodCases [A] [B] A≡B) A≡B t

  -- Conversion of terms converting from right to left.
  convTerm₂ : ∀ {Γ A B t l l′} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
          → Γ ⊩⟨ l ⟩  A ≡ B / [A]
          → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
          → Γ ⊩⟨ l ⟩  t ∷ A / [A]
  convTerm₂ [A] [B] A≡B t = convTermT₂ (goodCases [A] [B] A≡B) A≡B t

  -- Conversion of terms converting from right to left
  -- with some propsitionally equal types.
  convTerm₂′ : ∀ {Γ A B B′ t l l′} → B PE.≡ B′
          → ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
          → Γ ⊩⟨ l ⟩  A ≡ B′ / [A]
          → Γ ⊩⟨ l′ ⟩ t ∷ B / [B]
          → Γ ⊩⟨ l ⟩  t ∷ A / [A]
  convTerm₂′ PE.refl [A] [B] A≡B t = convTerm₂ [A] [B] A≡B t

  -- Helper function for conversion of term equality converting from left to right.
  convEqTermT₁ : ∀ {l l′ Γ A B t u} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
               → ShapeView Γ l l′ A B [A] [B]
               → Γ ⊩⟨ l ⟩  A ≡ B / [A]
               → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
               → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
  convEqTermT₁ (ℕᵥ D D′) A≡B (ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)) = ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)
  convEqTermT₁ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
               (ιx (neₜ₌ k m d d′ (neNfₜ₌ neK₂ neM₁ k≡m))) =
    let K≡K₁ = PE.subst (λ x → _ ⊢ _ ≡ x)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (≅-eq (~-to-≅ K≡M))
    in ιx (neₜ₌ k m (convRed:*: d K≡K₁)
                 (convRed:*: d′ K≡K₁)
                 (neNfₜ₌ neK₂ neM₁ (~-conv k≡m K≡K₁)))
  convEqTermT₁ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                           (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
               (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
               (Πₜ₌ f g d d′ funcF funcG t≡u [t] [u] [t≡u]) =
    let [A] = Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext
        [B] = Πᵣ′ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁
        [A≡B] = Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]
        ΠF₁G₁≡ΠF′G′ = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x)
                             (PE.sym ΠF₁G₁≡ΠF′G′) (≅-eq A≡B)
    in  Πₜ₌ f g (convRed:*: d ΠFG≡ΠF₁G₁) (convRed:*: d′ ΠFG≡ΠF₁G₁)
            funcF funcG (≅-conv t≡u ΠFG≡ΠF₁G₁)
            (convTerm₁ [A] [B] [A≡B] [t]) (convTerm₁ [A] [B] [A≡B] [u])
            (λ {ρ} [ρ] ⊢Δ [a] →
               let F₁≡F′ , G₁≡G′ = Π-PE-injectivity (whrDet* (red D₁ , Πₙ) (D′ , Πₙ))
                   [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                            ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                   [a]₁ = convTerm₂ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                   [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                     (PE.sym G₁≡G′))
                                            ([G] [ρ] ⊢Δ [a]₁)
                                            ([G≡G′] [ρ] ⊢Δ [a]₁)
               in  convEqTerm₁ ([G] [ρ] ⊢Δ [a]₁) ([G]₁ [ρ] ⊢Δ [a])
                               [G≡G₁] ([t≡u] [ρ] ⊢Δ [a]₁))
  convEqTermT₁ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t≡u = t≡u
  convEqTermT₁ (emb⁰¹ PE.refl x) (ιx A≡B) (ιx t≡u) = convEqTermT₁ x A≡B t≡u
  convEqTermT₁ (emb¹⁰ PE.refl x) A≡B t≡u = ιx (convEqTermT₁ x A≡B t≡u)

  -- Helper function for conversion of term equality converting from right to left.
  convEqTermT₂ : ∀ {l l′ Γ A B t u} {[A] : Γ ⊩⟨ l ⟩ A} {[B] : Γ ⊩⟨ l′ ⟩ B}
             → ShapeView Γ l l′ A B [A] [B]
             → Γ ⊩⟨ l ⟩  A ≡ B / [A]
             → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
             → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
  convEqTermT₂ (ℕᵥ D D′) A≡B (ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)) = ιx (ℕₜ₌ k k′ d d′ k≡k′ prop)
  convEqTermT₂ (ne (ne K D neK K≡K) (ne K₁ D₁ neK₁ K≡K₁)) (ιx (ne₌ M D′ neM K≡M))
               (ιx (neₜ₌ k m d d′ (neNfₜ₌ neK₂ neM₁ k≡m))) =
    let K₁≡K = PE.subst (λ x → _ ⊢ x ≡ _)
                        (whrDet* (red D′ , ne neM) (red D₁ , ne neK₁))
                        (sym (≅-eq (~-to-≅ K≡M)))
    in ιx (neₜ₌ k m (convRed:*: d K₁≡K) (convRed:*: d′ K₁≡K)
                 (neNfₜ₌ neK₂ neM₁ (~-conv k≡m K₁≡K)))
  convEqTermT₂ {Γ = Γ} (Πᵥ (Πᵣ F G D ⊢F ⊢G A≡A [F] [G] G-ext)
                           (Πᵣ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁))
               (Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′])
               (Πₜ₌ f g d d′ funcF funcG t≡u [t] [u] [t≡u]) =
    let [A] = Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext
        [B] = Πᵣ′ F₁ G₁ D₁ ⊢F₁ ⊢G₁ A≡A₁ [F]₁ [G]₁ G-ext₁
        [A≡B] = Π₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]
        ΠF₁G₁≡ΠF′G′ = whrDet* (red D₁ , Πₙ) (D′ , Πₙ)
        ΠFG≡ΠF₁G₁ = PE.subst (λ x → Γ ⊢ Π F ▹ G ≡ x)
                             (PE.sym ΠF₁G₁≡ΠF′G′) (≅-eq A≡B)
    in  Πₜ₌ f g (convRed:*: d (sym ΠFG≡ΠF₁G₁)) (convRed:*: d′ (sym ΠFG≡ΠF₁G₁))
            funcF funcG (≅-conv t≡u (sym ΠFG≡ΠF₁G₁))
            (convTerm₂ [A] [B] [A≡B] [t]) (convTerm₂ [A] [B] [A≡B] [u])
            (λ {ρ} [ρ] ⊢Δ [a] →
               let F₁≡F′ , G₁≡G′ = Π-PE-injectivity (whrDet* (red D₁ , Πₙ) (D′ , Πₙ))
                   [F≡F₁] = irrelevanceEqR′ (PE.cong (wk ρ) (PE.sym F₁≡F′))
                                            ([F] [ρ] ⊢Δ) ([F≡F′] [ρ] ⊢Δ)
                   [a]₁ = convTerm₁ ([F] [ρ] ⊢Δ) ([F]₁ [ρ] ⊢Δ) [F≡F₁] [a]
                   [G≡G₁] = irrelevanceEqR′ (PE.cong (λ x → wk (lift ρ) x [ _ ])
                                                     (PE.sym G₁≡G′))
                                            ([G] [ρ] ⊢Δ [a])
                                            ([G≡G′] [ρ] ⊢Δ [a])
               in  convEqTerm₂ ([G] [ρ] ⊢Δ [a]) ([G]₁ [ρ] ⊢Δ [a]₁)
                               [G≡G₁] ([t≡u] [ρ] ⊢Δ [a]₁))
  convEqTermT₂ (Uᵥ .⁰ 0<1 ⊢Γ .⁰ 0<1 ⊢Γ₁) A≡B t≡u = t≡u
  convEqTermT₂ (emb⁰¹ PE.refl x) (ιx A≡B) t≡u = ιx (convEqTermT₂ x A≡B t≡u)
  convEqTermT₂ (emb¹⁰ PE.refl x) A≡B (ιx t≡u) = convEqTermT₂ x A≡B t≡u

  -- Conversion of term equality converting from left to right.
  convEqTerm₁ : ∀ {l l′ Γ A B t u} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
              → Γ ⊩⟨ l ⟩  A ≡ B / [A]
              → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
              → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
  convEqTerm₁ [A] [B] A≡B t≡u = convEqTermT₁ (goodCases [A] [B] A≡B) A≡B t≡u

  -- Conversion of term equality converting from right to left.
  convEqTerm₂ : ∀ {l l′ Γ A B t u} ([A] : Γ ⊩⟨ l ⟩ A) ([B] : Γ ⊩⟨ l′ ⟩ B)
            → Γ ⊩⟨ l ⟩  A ≡ B / [A]
            → Γ ⊩⟨ l′ ⟩ t ≡ u ∷ B / [B]
            → Γ ⊩⟨ l ⟩  t ≡ u ∷ A / [A]
  convEqTerm₂ [A] [B] A≡B t≡u = convEqTermT₂ (goodCases [A] [B] A≡B) A≡B t≡u


------------------------------------------------------------------------
-- Simplification of parsers
------------------------------------------------------------------------

module TotalParserCombinators.Simplification where

open import Algebra
open import Codata.Musical.Notation
open import Data.List using (List; [])
import Data.List.Relation.Binary.BagAndSetEquality as BSEq
open import Data.Maybe using (Maybe); open Data.Maybe.Maybe
open import Data.Nat
open import Data.Product
open import Data.Vec.Recursive hiding ([])
open import Function
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl; [_])
open import Relation.Binary.HeterogeneousEquality
  using (refl) renaming (_≅_ to _≅H_)

private
  module BSMonoid {k} {A : Set} =
    CommutativeMonoid (BSEq.commutativeMonoid k A)

open import TotalParserCombinators.Congruence
  hiding (return; fail; token) renaming (_∣_ to _∣′_)
import TotalParserCombinators.Congruence.Sound as C
import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Laws
open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- Simplification of a single "layer"

-- The result type used for single-layer simplification.

record Simplify₁ {Tok R xs} (p : Parser Tok R xs) : Set₁ where
  constructor result
  field
    {bag}   : List R
    parser  : Parser Tok R bag
    correct : p ≅P parser

-- The function simplify₁ simplifies the first "layer" of a parser,
-- down to the first occurrences of ♯_. The following simplifications
-- are applied in a bottom-up manner (in relevant cases also for
-- delayed arguments):
--
-- f <$> fail                  → fail
-- f <$> return x              → return (f x)
-- fail         ∣ p            → p
-- p            ∣ fail         → p
-- token >>= p₁ ∣ token >>= p₂ → token >>= λ t →
--                                 ♯ (♭? (p₁ t) ∣ ♭? (p₂ t))
-- fail     ⊛ p                → fail
-- p        ⊛ fail             → fail
-- return f ⊛ return x         → return (f x)
-- fail     >>= p              → fail
-- return x >>= p              → p x
-- nonempty fail               → fail
-- nonempty (return x)         → fail
-- cast eq p                   → p
--
-- Some ♯_'s may be removed, but care is taken to ensure that
-- non-simplified parsers in the result are delayed.

mutual

  simplify₁ : ∀ {Tok R xs} (p : Parser Tok R xs) → Simplify₁ p

  -- • return:

  simplify₁ (return x) = result _ (return x ∎)

  -- • fail:

  simplify₁ fail       = result _ (fail ∎)

  -- • token:

  simplify₁ token      = result _ (token ∎)

  -- • _<$>_:

  simplify₁ (f <$> p) with simplify₁ p
  ... | result fail       p≅∅  = result _ (
                                 f <$> p     ≅⟨ (λ _ → refl) <$> p≅∅ ⟩
                                 f <$> fail  ≅⟨ <$>.zero ⟩
                                 fail        ∎)
  ... | result (return x) p≅ε  = result _ (
                                 f <$> p         ≅⟨ (λ x → refl {x = f x}) <$> p≅ε ⟩
                                 f <$> return x  ≅⟨ <$>.homomorphism f ⟩
                                 return (f x)    ∎)
  ... | result p′         p≅p′ = result _ (
                                 f <$> p   ≅⟨ (λ _ → refl) <$> p≅p′ ⟩
                                 f <$> p′  ∎)

  -- • _∣_:

  simplify₁ (p₁ ∣ p₂) with simplify₁ p₁ | simplify₁ p₂
  ... | result fail          p₁≅∅
      | result p₂′           p₂≅p₂′ = result _ (
                                      p₁   ∣ p₂   ≅⟨ p₁≅∅ ∣′ p₂≅p₂′ ⟩
                                      fail ∣ p₂′  ≅⟨ AdditiveMonoid.left-identity p₂′ ⟩
                                      p₂′         ∎)
  ... | result p₁′           p₁≅p₁′
      | result fail          p₂≅∅   = result _ (
                                      p₁  ∣ p₂    ≅⟨ p₁≅p₁′ ∣′ p₂≅∅ ⟩
                                      p₁′ ∣ fail  ≅⟨ AdditiveMonoid.right-identity p₁′ ⟩
                                      p₁′         ∎)
  ... | result (p₁₁ >>= p₁₂) p₁≅…
      | result (p₂₁ >>= p₂₂) p₂≅…   = let h = helper p₁₁ refl p₁₂ p₂₁ refl p₂₂ in
                                      result _ (
                                      p₁          ∣ p₂           ≅⟨ p₁≅… ∣′ p₂≅… ⟩
                                      p₁₁ >>= p₁₂ ∣ p₂₁ >>= p₂₂  ≅⟨ Simplify₁.correct h ⟩
                                      Simplify₁.parser h         ∎)
    where
    helper : ∀ {Tok R₁ R₂ R xs₁ xs₁′ xs₂ xs₂′ f₁ f₂}
             (p₁₁ : ∞⟨ f₁ ⟩Parser Tok R₁ xs₁′)
             (eq₁ : xs₁′ ≡ flatten xs₁)
             (p₁₂ : (x : R₁) → ∞⟨ xs₁ ⟩Parser Tok R (apply f₁ x))
             (p₂₁ : ∞⟨ f₂ ⟩Parser Tok R₂ xs₂′)
             (eq₂ : xs₂′ ≡ flatten xs₂)
             (p₂₂ : (x : R₂) → ∞⟨ xs₂ ⟩Parser Tok R (apply f₂ x)) →
             Simplify₁ (P.subst (∞⟨ f₁ ⟩Parser Tok R₁) eq₁ p₁₁ >>= p₁₂ ∣
                        P.subst (∞⟨ f₂ ⟩Parser Tok R₂) eq₂ p₂₁ >>= p₂₂)
    helper p₁₁ eq₁ p₁₂ p₂₁ eq₂ p₂₂
      with ♭? p₁₁ | P.inspect ♭? p₁₁ | ♭? p₂₁ | P.inspect ♭? p₂₁
    helper {Tok} {f₁ = f₁} {f₂} p₁₁ eq₁ p₁₂ p₂₁ eq₂ p₂₂
      | token | [ eq₁′ ] | token | [ eq₂′ ] = result _ (
      cast₁ p₁₁ >>= p₁₂ ∣ cast₂ p₂₁ >>= p₂₂          ≅⟨ [ forced? p₁₁ - ○ - forced?′ p₁₂ - ○ ] Subst.correct∞ eq₁ p₁₁ >>=
                                                                                (λ t → ♭? (p₁₂ t) ∎) ∣′
                                                        [ forced? p₂₁ - ○ - forced?′ p₂₂ - ○ ] Subst.correct∞ eq₂ p₂₁ >>=
                                                                                (λ t → ♭? (p₂₂ t) ∎) ⟩
      ♭? p₁₁ >>= (♭? ∘ p₁₂) ∣ ♭? p₂₁ >>= (♭? ∘ p₂₂)  ≅⟨ [ ○ - ○ - ○ - ○ ]
                                                          P.subst (λ p → p ≅P token) (P.sym eq₁′) (token ∎) >>= (λ t → ♭? (p₁₂ t) ∎) ∣′
                                                        [ ○ - ○ - ○ - ○ ]
                                                          P.subst (λ p → p ≅P token) (P.sym eq₂′) (token ∎) >>= (λ t → ♭? (p₂₂ t) ∎) ⟩
      token >>= (♭? ∘ p₁₂) ∣ token >>= (♭? ∘ p₂₂)    ≅⟨ sym $ Monad.left-distributive token (♭? ∘ p₁₂) (♭? ∘ p₂₂) ⟩
      token >>= (λ t → ♭? (p₁₂ t) ∣ ♭? (p₂₂ t))      ≅⟨ [ ○ - ○ - ○ - ◌ ] token ∎ >>= (λ t → ♭? (p₁₂ t) ∣ ♭? (p₂₂ t) ∎) ⟩
      token >>= (λ t → ♯ (♭? (p₁₂ t) ∣ ♭? (p₂₂ t)))  ∎)
      where
      cast₁ = P.subst (∞⟨ f₁ ⟩Parser Tok Tok) eq₁
      cast₂ = P.subst (∞⟨ f₂ ⟩Parser Tok Tok) eq₂
    helper _ _ _ _ _ _ | _ | _ | _ | _ = result _ (_ ∎)

  simplify₁ (p₁ ∣ p₂) | result p₁′ p₁≅p₁′ | result p₂′ p₂≅p₂′ =
    result _ (
    p₁  ∣ p₂   ≅⟨ p₁≅p₁′ ∣′ p₂≅p₂′ ⟩
    p₁′ ∣ p₂′  ∎)

  -- • _⊛_:

  simplify₁ (p₁ ⊛ p₂) =
    helper _ _ p₁ p₂ (simplify₁∞ p₁) (simplify₁∞ p₂) refl refl
    where
    -- token ⊛ token is never type correct, but Agda's case-splitting
    -- machinery cannot see this, so instead of a with clause the
    -- following ugly machinery is used.

    cast₁ : ∀ {Tok R R₁ R₁′ xs xs′} {ys : Maybe (List R)} →
            (R≡  : R₁ ≡ R₁′) → xs ≅H xs′ →
            ∞⟨ ys ⟩Parser Tok R₁′ (flatten xs′) →
            ∞⟨ ys ⟩Parser Tok R₁  (flatten xs)
    cast₁ refl refl p = p

    helper : ∀ {Tok R₁ R₁′ R₂} fs xs {xs′}
               (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs))
               (p₂ : ∞⟨ fs ⟩Parser Tok  R₁′      (flatten xs′)) →
             Simplify₁ (♭? p₁) → Simplify₁ (♭? p₂) →
             (R≡ : R₁ ≡ R₁′) (xs≅ : xs ≅H xs′) →
             Simplify₁ (p₁ ⊛ cast₁ R≡ xs≅ p₂)
    helper fs xs p₁ p₂ (result fail p₁≅∅) _ refl refl = result _ (
      p₁   ⊛ p₂     ≅⟨ [ xs - ○ - fs - ○ ] p₁≅∅ ⊛ (♭? p₂ ∎) ⟩
      fail ⊛ ♭? p₂  ≅⟨ ApplicativeFunctor.left-zero (♭? p₂) ⟩
      fail          ∎)
    helper fs xs p₁ p₂ _ (result fail p₂≅∅) refl refl = result _ (
      p₁    ⊛ p₂    ≅⟨ [ xs - ○ - fs - ○ ] ♭? p₁ ∎ ⊛ p₂≅∅ ⟩
      ♭? p₁ ⊛ fail  ≅⟨ ApplicativeFunctor.right-zero (♭? p₁) ⟩
      fail          ∎)
    helper fs xs p₁ p₂ (result (return f) p₁≅ε) (result (return x) p₂≅ε)
           refl refl = result _ (
      p₁       ⊛ p₂        ≅⟨ [ xs - ○ - fs - ○ ] p₁≅ε ⊛ p₂≅ε ⟩
      return f ⊛ return x  ≅⟨ ApplicativeFunctor.homomorphism f x ⟩
      return (f x)         ∎)
    helper fs xs p₁ p₂ p₁′ p₂′ R≡ xs≅ =
      helper′ fs xs p₁ p₂ p₁′ p₂′ R≡ xs≅
      where
      helper′ :
        ∀ {Tok R₁ R₁′ R₂} fs xs {xs′}
          (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs))
          (p₂ : ∞⟨ fs ⟩Parser Tok  R₁′      (flatten xs′)) →
        Simplify₁ (♭? p₁) → Simplify₁ (♭? p₂) →
        (R≡ : R₁ ≡ R₁′) (xs≅ : xs ≅H xs′) →
        Simplify₁ (p₁ ⊛ cast₁ R≡ xs≅ p₂)
      helper′ nothing nothing p₁ p₂ _ _ refl refl = result _ (
        p₁ ⊛ p₂  ∎)
      helper′ (just fs) nothing p₁ p₂ _ (result p₂′ p₂≅p₂′) refl refl
        with BSEq.empty-unique $ I.cong $ C.sound $ sym p₂≅p₂′
      helper′ (just fs) nothing p₁ p₂ _ (result p₂′ p₂≅p₂′) refl refl
        | refl = result _ (
                 p₁ ⊛ p₂   ≅⟨ [ ◌ - ◌ - ○ - ○ ] ♭ p₁ ∎ ⊛ p₂≅p₂′ ⟩
                 p₁ ⊛ p₂′  ∎)
      helper′ nothing (just xs) p₁ p₂ (result p₁′ p₁≅p₁′) _ refl refl
        with BSEq.empty-unique $ I.cong $ C.sound $ sym p₁≅p₁′
      helper′ nothing (just xs) p₁ p₂ (result p₁′ p₁≅p₁′) _ refl refl
        | refl = result _ (
                 p₁  ⊛ p₂  ≅⟨ [ ○ - ○ - ◌ - ◌ ] p₁≅p₁′ ⊛ (♭ p₂ ∎) ⟩
                 p₁′ ⊛ p₂  ∎)
      helper′ (just fs) (just xs)
              p₁ p₂ (result p₁′ p₁≅p₁′) (result p₂′ p₂≅p₂′) refl refl =
        result _ (
        p₁  ⊛ p₂   ≅⟨ [ ○ - ○ - ○ - ○ ] p₁≅p₁′ ⊛ p₂≅p₂′ ⟩
        p₁′ ⊛ p₂′  ∎)

  -- • _>>=_:

  simplify₁ (_>>=_ {xs = xs} {f = f} p₁ p₂) with simplify₁∞ p₁
  ... | result fail       p₁≅∅ = result _ (
                                 p₁   >>= p₂         ≅⟨ [ f - ○ - xs - ○ ] p₁≅∅ >>= (λ x → ♭? (p₂ x) ∎) ⟩
                                 fail >>= (♭? ∘ p₂)  ≅⟨ Monad.left-zero (♭? ∘ p₂) ⟩
                                 fail                ∎)
  ... | result (return x) p₁≅ε with simplify₁∞ (p₂ x)
  ...   | result p₂x′ p₂x≅p₂x′ = result _ (
                                 p₁       >>= p₂         ≅⟨ [ f - ○ - xs - ○ ] p₁≅ε >>= (λ x → ♭? (p₂ x) ∎) ⟩
                                 return x >>= (♭? ∘ p₂)  ≅⟨ Monad.left-identity x (♭? ∘ p₂) ⟩
                                 ♭? (p₂ x)               ≅⟨ p₂x≅p₂x′ ⟩
                                 p₂x′                    ∎)
  simplify₁ (p₁ >>= p₂) | result p₁′ p₁≅p₁′
    with forced? p₁ | forced?′ p₂
  ... | nothing | just xs = result _ (
                            p₁ >>= p₂                           ≅⟨ [ ◌ - ◌ - ○ - ○ ] ♭ p₁ ∎ >>= (λ x → simplify₁-[]-correct (p₂ x)) ⟩
                            p₁ >>= (λ x → simplify₁-[] (p₂ x))  ∎)
  ... | just f  | just xs = result _ (
                            p₁  >>= p₂                          ≅⟨ [ ○ - ○ - ○ - ○ ] p₁≅p₁′ >>=
                                                                                (λ x → Simplify₁.correct (simplify₁ (p₂ x))) ⟩
                            p₁′ >>= (λ x → Simplify₁.parser $
                                             simplify₁ (p₂ x))  ∎)
  ... | nothing | nothing = result _ (
                            p₁ >>= p₂ ∎)
  ... | just f  | nothing = result _ (
                            p₁          >>= p₂        ≅⟨ [ ○ - ○ - ◌ - ○ ] p₁≅p₁′ >>= (λ x → ♭ (p₂ x) ∎) ⟩
                            p₁′         >>= (♭ ∘ p₂)  ≅⟨ [ ○ - ○ - ○ - ◌ ] sym (Subst.correct lemma) >>= (λ x → ♭ (p₂ x) ∎) ⟩
                            cast-[] p₁′ >>= p₂        ∎)
    where
    lemma   = BSEq.empty-unique $ I.cong $ C.sound $ sym p₁≅p₁′
    cast-[] = P.subst (Parser _ _) lemma

  -- • nonempty:

  simplify₁ (nonempty p) with simplify₁ p
  ... | result fail       p≅∅  = result _ (
                                 nonempty p     ≅⟨ nonempty p≅∅ ⟩
                                 nonempty fail  ≅⟨ Nonempty.zero ⟩
                                 fail           ∎)
  ... | result (return x) p≅ε  = result _ (
                                 nonempty p           ≅⟨ nonempty p≅ε ⟩
                                 nonempty (return x)  ≅⟨ Nonempty.nonempty-return ⟩
                                 fail                 ∎)
  ... | result p′         p≅p′ = result _ (
                                 nonempty p   ≅⟨ nonempty p≅p′ ⟩
                                 nonempty p′  ∎)

  -- • cast:

  simplify₁ (cast xs₁≈xs₂ p) with simplify₁ p
  ... | result p′ p≅p′ = result _ (
                         cast xs₁≈xs₂ p  ≅⟨ Cast.correct ⟩
                         p               ≅⟨ p≅p′ ⟩
                         p′              ∎)

  private

    -- Note that if an argument parser is delayed, then simplification
    -- is not applied recursively (because this could lead to
    -- non-termination).

    simplify₁∞ : ∀ {Tok R R′ xs} {m : Maybe R′}
                 (p : ∞⟨ m ⟩Parser Tok R xs) → Simplify₁ (♭? p)
    simplify₁∞ {m = nothing} p = result _ (♭ p ∎)
    simplify₁∞ {m = just _}  p = simplify₁ p

    simplify₁-[] : ∀ {Tok R} → Parser Tok R [] → Parser Tok R []
    simplify₁-[] p = P.subst (Parser _ _) ([]-lemma p) $
                       Simplify₁.parser $ simplify₁ p

    simplify₁-[]-correct : ∀ {Tok R} (p : Parser Tok R []) →
                           p ≅P simplify₁-[] p
    simplify₁-[]-correct p =
      p                               ≅⟨ Simplify₁.correct (simplify₁ p) ⟩
      Simplify₁.parser (simplify₁ p)  ≅⟨ sym $ Subst.correct ([]-lemma p) ⟩
      simplify₁-[] p                  ∎

    []-lemma : ∀ {Tok R} (p : Parser Tok R []) →
               Simplify₁.bag (simplify₁ p) ≡ []
    []-lemma p = BSEq.empty-unique $ I.cong $ C.sound $
                   sym $ Simplify₁.correct $ simplify₁ p

------------------------------------------------------------------------
-- Deep simplification

-- The function simplify simplifies the first layer, then it traverses
-- the result and simplifies the following layers, and so on. The
-- extra traversals have been implemented to satisfy Agda's
-- termination checker; they could perhaps be avoided.
--
-- Note that simplifications in an upper layer do not get to take
-- advantage of simplifications performed in lower layers. Consider
-- ♯ p ⊛ token, for instance. If p can be simplified to fail, then one
-- might believe that ♯ p ⊛ token is simplified to fail as well.
-- However, this is only the case if p actually /computes/ to fail.
--
-- If simplification of the upper layer were dependent on complete
-- simplification of lower layers, then simplification could fail to
-- terminate. This does not mean that one cannot propagate /any/
-- information from lower layers to upper layers, though: one could
-- for instance perform partial simplification of lower layers, up to
-- a certain depth, before an upper layer is simplified.

mutual

  simplify : ∀ {Tok R xs} (p : Parser Tok R xs) →
             Parser Tok R (Simplify₁.bag $ simplify₁ p)
  simplify p = simplify↓ (Simplify₁.parser (simplify₁ p))

  private

    simplify↓ : ∀ {Tok R xs} → Parser Tok R xs → Parser Tok R xs
    simplify↓ (return x)       = return x
    simplify↓ fail             = fail
    simplify↓ token            = token
    simplify↓ (p₁ ∣ p₂)        = simplify↓ p₁ ∣ simplify↓ p₂
    simplify↓ (f <$> p)        = f <$> simplify↓ p
    simplify↓ (nonempty p)     = nonempty (simplify↓ p)
    simplify↓ (cast xs₁≈xs₂ p) = cast xs₁≈xs₂ (simplify↓ p)
    simplify↓ (p₁ ⊛ p₂)        with forced? p₁ | forced? p₂
    ... | just xs | just fs =   simplify↓      p₁  ⊛   simplify↓      p₂
    ... | just xs | nothing =   simplify↓      p₁  ⊛ ♯ simplify    (♭ p₂)
    ... | nothing | just fs = ♯ simplify    (♭ p₁) ⊛   simplify↓      p₂
    ... | nothing | nothing = ♯ simplify-[] (♭ p₁) ⊛ ♯ simplify-[] (♭ p₂)
    simplify↓ (p₁ >>= p₂)      with forced? p₁ | forced?′ p₂
    ... | just f  | just xs =   simplify↓      p₁  >>= λ x →   simplify↓      (p₂ x)
    ... | just f  | nothing =   simplify↓      p₁  >>= λ x → ♯ simplify    (♭ (p₂ x))
    ... | nothing | just xs = ♯ simplify    (♭ p₁) >>= λ x →   simplify↓      (p₂ x)
    ... | nothing | nothing = ♯ simplify-[] (♭ p₁) >>= λ x → ♯ simplify-[] (♭ (p₂ x))

    simplify-[] : ∀ {Tok R} → Parser Tok R [] → Parser Tok R []
    simplify-[] p = simplify↓ (simplify₁-[] p)

-- The simplifier is correct.

mutual

  correct : ∀ {Tok R xs} (p : Parser Tok R xs) → simplify p ≅P p
  correct p =
    simplify↓ (Simplify₁.parser $ simplify₁ p)  ≅⟨ correct↓ (Simplify₁.parser $ simplify₁ p) ⟩
    Simplify₁.parser (simplify₁ p)              ≅⟨ sym $ Simplify₁.correct $ simplify₁ p ⟩
    p                                           ∎

  private

    correct↓ : ∀ {Tok R xs} (p : Parser Tok R xs) → simplify↓ p ≅P p
    correct↓ (return x)       = return x ∎
    correct↓ fail             = fail ∎
    correct↓ token            = token ∎
    correct↓ (p₁ ∣ p₂)        = correct↓ p₁ ∣′ correct↓ p₂
    correct↓ (f <$> p)        = (λ _ → refl) <$> correct↓ p
    correct↓ (nonempty p)     = nonempty (correct↓ p)
    correct↓ (cast xs₁≈xs₂ p) = cast (correct↓ p)
    correct↓ (p₁ ⊛ p₂)        with forced? p₁ | forced? p₂
    ... | just xs | just fs = [ just (○ , ○) - just (○ , ○) ]   correct↓      p₁  ⊛   correct↓      p₂
    ... | just xs | nothing = [ just (○ , ○) - nothing      ]   correct↓      p₁  ⊛ ♯ correct    (♭ p₂)
    ... | nothing | just fs = [ nothing      - just (○ , ○) ] ♯ correct    (♭ p₁) ⊛   correct↓      p₂
    ... | nothing | nothing = [ nothing      - nothing      ] ♯ correct-[] (♭ p₁) ⊛ ♯ correct-[] (♭ p₂)
    correct↓ (p₁ >>= p₂)      with forced? p₁ | forced?′ p₂
    ... | just f  | just xs = [ just (○ , ○) - just (○ , ○) ]   correct↓      p₁  >>= λ x →   correct↓      (p₂ x)
    ... | just f  | nothing = [ just (○ , ○) - nothing      ]   correct↓      p₁  >>= λ x → ♯ correct    (♭ (p₂ x))
    ... | nothing | just xs = [ nothing      - just (○ , ○) ] ♯ correct    (♭ p₁) >>= λ x →   correct↓      (p₂ x)
    ... | nothing | nothing = [ nothing      - nothing      ] ♯ correct-[] (♭ p₁) >>= λ x → ♯ correct-[] (♭ (p₂ x))

    correct-[] : ∀ {Tok R} (p : Parser Tok R []) → simplify-[] p ≅P p
    correct-[] p =
      simplify-[] p   ≅⟨ correct↓ (simplify₁-[] p) ⟩
      simplify₁-[] p  ≅⟨ sym $ simplify₁-[]-correct p ⟩
      p               ∎


{-# OPTIONS --rewriting #-}

module Luau.TypeCheck where

open import Agda.Builtin.Equality using (_≡_)
open import FFI.Data.Maybe using (Maybe; just)
open import Luau.Syntax using (Expr; Stat; Block; BinaryOperator; yes; nil; addr; number; bool; string; val; var; var_∈_; _⟨_⟩∈_; function_is_end; _$_; block_is_end; binexp; local_←_; _∙_; done; return; name; +; -; *; /; <; >; ==; ~=; <=; >=; ··)
open import Luau.Var using (Var)
open import Luau.Addr using (Addr)
open import Luau.Heap using (Heap; Object; function_is_end) renaming (_[_] to _[_]ᴴ)
open import Luau.Type using (Type; nil; unknown; number; boolean; string; _⇒_; src; tgt)
open import Luau.VarCtxt using (VarCtxt; ∅; _⋒_; _↦_; _⊕_↦_; _⊝_) renaming (_[_] to _[_]ⱽ)
open import FFI.Data.Vector using (Vector)
open import FFI.Data.Maybe using (Maybe; just; nothing)
open import Properties.Product using (_×_; _,_)

orUnknown : Maybe Type → Type
orUnknown nothing = unknown
orUnknown (just T) = T

srcBinOp : BinaryOperator → Type
srcBinOp + = number
srcBinOp - = number
srcBinOp * = number
srcBinOp / = number
srcBinOp < = number
srcBinOp > = number
srcBinOp == = unknown
srcBinOp ~= = unknown
srcBinOp <= = number
srcBinOp >= = number
srcBinOp ·· = string

tgtBinOp : BinaryOperator → Type
tgtBinOp + = number
tgtBinOp - = number
tgtBinOp * = number
tgtBinOp / = number
tgtBinOp < = boolean
tgtBinOp > = boolean
tgtBinOp == = boolean
tgtBinOp ~= = boolean
tgtBinOp <= = boolean
tgtBinOp >= = boolean
tgtBinOp ·· = string

data _⊢ᴮ_∈_ : VarCtxt → Block yes → Type → Set
data _⊢ᴱ_∈_ : VarCtxt → Expr yes → Type → Set

data _⊢ᴮ_∈_ where

  done : ∀ {Γ} →

    ---------------
    Γ ⊢ᴮ done ∈ nil

  return : ∀ {M B T U Γ} →

    Γ ⊢ᴱ M ∈ T →
    Γ ⊢ᴮ B ∈ U →
    ---------------------
    Γ ⊢ᴮ return M ∙ B ∈ T

  local : ∀ {x M B T U V Γ} →

    Γ ⊢ᴱ M ∈ U →
    (Γ ⊕ x ↦ T) ⊢ᴮ B ∈ V →
    --------------------------------
    Γ ⊢ᴮ local var x ∈ T ← M ∙ B ∈ V

  function : ∀ {f x B C T U V W Γ} →

    (Γ ⊕ x ↦ T) ⊢ᴮ C ∈ V →
    (Γ ⊕ f ↦ (T ⇒ U)) ⊢ᴮ B ∈ W →
    -------------------------------------------------
    Γ ⊢ᴮ function f ⟨ var x ∈ T ⟩∈ U is C end ∙ B ∈ W

data _⊢ᴱ_∈_ where

  nil : ∀ {Γ} →

    --------------------
    Γ ⊢ᴱ (val nil) ∈ nil

  var : ∀ {x T Γ} →

    T ≡ orUnknown(Γ [ x ]ⱽ) →
    ----------------
    Γ ⊢ᴱ (var x) ∈ T

  addr : ∀ {a Γ} T →

    -----------------
    Γ ⊢ᴱ val(addr a) ∈ T

  number : ∀ {n Γ} →

    ---------------------------
    Γ ⊢ᴱ val(number n) ∈ number

  bool : ∀ {b Γ} →

    --------------------------
    Γ ⊢ᴱ val(bool b) ∈ boolean

  string : ∀ {x Γ} →

    ---------------------------
    Γ ⊢ᴱ val(string x) ∈ string

  app : ∀ {M N T U Γ} →

    Γ ⊢ᴱ M ∈ T →
    Γ ⊢ᴱ N ∈ U →
    ----------------------
    Γ ⊢ᴱ (M $ N) ∈ (tgt T)

  function : ∀ {f x B T U V Γ} →

    (Γ ⊕ x ↦ T) ⊢ᴮ B ∈ V →
    -----------------------------------------------------
    Γ ⊢ᴱ (function f ⟨ var x ∈ T ⟩∈ U is B end) ∈ (T ⇒ U)

  block : ∀ {b B T U Γ} →

    Γ ⊢ᴮ B ∈ U →
    ------------------------------------
    Γ ⊢ᴱ (block var b ∈ T is B end) ∈ T

  binexp : ∀ {op Γ M N T U} →

    Γ ⊢ᴱ M ∈ T →
    Γ ⊢ᴱ N ∈ U →
    ----------------------------------
    Γ ⊢ᴱ (binexp M op N) ∈ tgtBinOp op

data ⊢ᴼ_ : Maybe(Object yes) → Set where

  nothing :

    ---------
    ⊢ᴼ nothing

  function : ∀ {f x T U V B} →

    (x ↦ T) ⊢ᴮ B ∈ V →
    ----------------------------------------------
    ⊢ᴼ (just function f ⟨ var x ∈ T ⟩∈ U is B end)

⊢ᴴ_ : Heap yes → Set
⊢ᴴ H = ∀ a {O} → (H [ a ]ᴴ ≡ O) → (⊢ᴼ O)

_⊢ᴴᴱ_▷_∈_ : VarCtxt → Heap yes → Expr yes → Type → Set
(Γ ⊢ᴴᴱ H ▷ M ∈ T) = (⊢ᴴ H) × (Γ ⊢ᴱ M ∈ T)

_⊢ᴴᴮ_▷_∈_ : VarCtxt → Heap yes → Block yes → Type → Set
(Γ ⊢ᴴᴮ H ▷ B ∈ T) = (⊢ᴴ H) × (Γ ⊢ᴮ B ∈ T)


module LC.Parallel where

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

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

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

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

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

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

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

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

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

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

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

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

module Cong where

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

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

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

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

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

  module Temp where

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

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

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

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

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

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

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

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


module Luau.Syntax where

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

infixr 5 _∙_

data Annotated : Set where
  maybe : Annotated
  yes : Annotated

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

module Definitional where

open import Syntax

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

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

open import Relation.Binary.PropositionalEquality

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

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

open import Value

open import Size
open import Codata.Thunk

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

  open import PInj
  open _⊢_⇔_

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

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

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

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

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

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

  open _⊢F_⇔_

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

open Interpreter public