module Esterel.Lang.Binding where

open import utility
open import Data.List
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.Bool
  using (Bool ; true ; false ; if_then_else_)
open import Esterel.Lang
open import Esterel.Environment as Env
  using (Env ; VarList ; Dom ; Θ ; _←_)
open import Esterel.Context
  using (Context1 ; EvaluationContext1 ; _≐_⟦_⟧e ; _⟦_⟧e ; _≐_⟦_⟧c ; _⟦_⟧c)
open import Esterel.Context.Properties
  using (plug)
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ) renaming (_≟ₛₜ_ to _≟ₛₜₛ_ ; unwrap to Sunwrap)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ) renaming (_≟ₛₜ_ to _≟ₛₜₛₕ_ ; unwrap to sunwrap)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ) renaming (unwrap to vunwrap)
open import Data.Product
  using (_×_ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; ∃ ; Σ)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; _≟_ ; zero ; suc)
open import Relation.Nullary
  using (Dec ; yes ; no ; ¬_)

open import Function
  using (_∘_ ; id ; _∋_)
open import Relation.Binary
  using (Decidable)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; setoid)
open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Data.Bool
  using (not)
open import Data.List.Any as ListAny
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties using (∷↔)
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)

open ListSet Data.Nat._≟_
open _≐_⟦_⟧e
open _≐_⟦_⟧c
open Context1
open EvaluationContext1

base : VarList
base = [] ,′ [] ,′ []

+S : Signal -> VarList -> VarList
+S S' (S , s , v) =  ((Sunwrap S') ∷ S , s , v)

+s : SharedVar -> VarList ->  VarList
+s s' (S , s , v) =  (S , sunwrap s' ∷ s , v)

+x : SeqVar -> VarList -> VarList
+x x' (S , s , v) =  (S , s , vunwrap x' ∷ v)

Xs : VarList -> List ℕ
Xs (_ , _ , v) = v
Ss : VarList -> List ℕ
Ss (S , _ , _) = S
FVₑ : Expr -> VarList
FVₑ (plus []) = base
FVₑ (plus (num x ∷ x₁)) = FVₑ (plus x₁)
FVₑ (plus (seq-ref x ∷ x₁)) = +x x (FVₑ (plus x₁))
FVₑ (plus (shr-ref s ∷ x₁)) = +s s (FVₑ (plus x₁))

dist++ˡ : ∀{VL1 VL2 VL3} → (distinct VL1 (VL2 U̬ VL3)) → (distinct VL1 VL2)
dist++ˡ (a , b , c) =  (dist'++ˡ a) ,(dist'++ˡ b) ,(dist'++ˡ c)

dist++ʳ : ∀{VL1 VL2 VL3} → (distinct VL1 (VL2 U̬ VL3)) → (distinct VL1 VL3)
dist++ʳ{VL1}{VL2 = (v1 , v2 , v3)}{VL3 = (V1 , V2 , V3)} (a , b , c)
   =  (dist'++ʳ{V2 = v1}{V3 = V1} a)  , (dist'++ʳ{V2 = v2}{V3 = V2} b) , (dist'++ʳ{V2 = v3}{V3 = V3} c)

dist++b : ∀{VL1 VL2 VL3 VL4} → (distinct (VL1 U̬ VL2) (VL3 U̬ VL4)) → (distinct VL1 VL3)
dist++b (a , b , c) =  (dist'++b a) , (dist'++b b) , (dist'++b c)

dist:: : ∀{VL1 VL2 S} → (distinct VL1 (+S S VL2)) → (distinct VL1 VL2)
dist::{VL1}{(Ss , s , v)}{S} (a , b , c) = dist':: a  , b , c

{- This definition of CorrectBinding accumulates the bound
   and free variables to make it easier to work with.
   The definition of `CB` (below) matches the one in the paper. -}
data CorrectBinding : Term → (BV : VarList) → (FV : VarList) → Set where
  CBnothing : CorrectBinding nothin base base
  CBpause   : CorrectBinding pause base base
  CBsig     : ∀{p S BV FV} → CorrectBinding p BV FV
                         → CorrectBinding (signl S p) (+S S BV) (FV |̌ (+S S base))
  CBpresent : ∀{S p q BVp FVp BVq FVq}
               → (cbp : CorrectBinding p BVp FVp)
               → (cbq : CorrectBinding q BVq FVq)
               → CorrectBinding (present S ∣⇒ p ∣⇒ q) (BVp U̬ BVq) (+S S (FVp U̬ FVq))
  CBemit    : ∀{S} → CorrectBinding (emit S) base (+S S base)
  CBpar     : ∀{p q BVp FVp BVq FVq}
                → (cbp : CorrectBinding p BVp FVp)
                → (cbq : CorrectBinding q BVq FVq)
                → (BVp≠BVq : distinct BVp BVq)
                → (FVp≠BVq : distinct FVp BVq)
                → (BVp≠FVq : distinct BVp FVq)
                → (Xp≠Xq : distinct' (Xs FVp) (Xs FVq))
                → CorrectBinding (p ∥ q) (BVp U̬ BVq) (FVp U̬ FVq)
  CBloop    : ∀{p BV FV}
               → CorrectBinding p BV FV
               → (BV≠FV : distinct BV FV)
               → CorrectBinding (loop p) BV FV
  CBloopˢ   : ∀{p q BVp FVp BVq FVq}
               → CorrectBinding p BVp FVp
               → CorrectBinding q BVq FVq
               → (BVp≠FVq : distinct BVp FVq)
               → (BVq≠FVq : distinct BVq FVq)
               → CorrectBinding (loopˢ p q) (BVp U̬ BVq) (FVp U̬ FVq)
  CBseq     : ∀{p q BVp BVq FVp FVq}
                → (cbp : CorrectBinding p BVp FVp)
                → (cbq : CorrectBinding q BVq FVq)
                → (BVp≠FVq : distinct BVp FVq)
                → CorrectBinding (p >> q) (BVp U̬ BVq) (FVp U̬ FVq)
  CBsusp    : ∀{S p BV FV}
                → (cbp : CorrectBinding p BV FV)
                → ([S]≠BVp : distinct' [ (Sunwrap S) ] (Ss BV))
                → CorrectBinding (suspend p S) BV (+S S FV)
  CBexit    : ∀{n} → CorrectBinding (exit n) base base
  CBtrap    : ∀{p BV FV} → CorrectBinding p BV FV → CorrectBinding (trap p) BV FV
  CBshared  : ∀{s e p BV FV} → CorrectBinding p BV FV
                             → CorrectBinding (shared s ≔ e in: p)
                                              (+s s BV) ((FVₑ e) U̬ (FV |̌ (+s s base)))
  CBsset    : ∀{s e} → CorrectBinding (s ⇐ e) base (+s s (FVₑ e))
  CBvar     : ∀{x e p BV FV} → CorrectBinding p BV FV
                             → CorrectBinding (var x ≔ e in: p)
                                              (+x x BV) ((FVₑ e) U̬ (FV |̌ (+x x base)))
  CBvset    : ∀{x e} → CorrectBinding (x ≔ e) base (+x x (FVₑ e))
  CBif      : ∀{x p q BVp BVq FVp FVq}
              → (cbp : CorrectBinding p BVp FVp)
              → (cbq : CorrectBinding q BVq FVq)
              → CorrectBinding (if x ∣⇒ p ∣⇒ q) (BVp U̬ BVq) (+x x (FVp U̬ FVq))
  CBρ       : ∀{θ A p BV FV} → CorrectBinding p BV FV
                             → CorrectBinding (ρ⟨ θ , A ⟩· p) (((Dom θ) U̬ BV)) (FV |̌ (Dom θ))

binding-is-function : ∀{p BV₁ FV₁ BV₂ FV₂} →
  CorrectBinding p BV₁ FV₁ →
  CorrectBinding p BV₂ FV₂ →
  BV₁ ≡ BV₂ × FV₁ ≡ FV₂
binding-is-function CBnothing CBnothing = refl , refl
binding-is-function CBpause CBpause = refl , refl
binding-is-function (CBsig cb₁) (CBsig cb₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl
binding-is-function (CBpresent cbp₁ cbq₁) (CBpresent cbp₂ cbq₂)
  with binding-is-function cbp₁ cbp₂ | binding-is-function cbq₁ cbq₂
... | (refl , refl) | (refl , refl) = refl , refl
binding-is-function CBemit CBemit = refl , refl
binding-is-function (CBpar cbp₁ cbq₁ BVp≠BVq₁ FVp≠BVq₁ BVp≠FVq₁ Xp≠Xq₁)
                    (CBpar cbp₂ cbq₂ BVp≠BVq₂ FVp≠BVq₂ BVp≠FVq₂ Xp≠Xq₂)
  with binding-is-function cbp₁ cbp₂ | binding-is-function cbq₁ cbq₂
... | (refl , refl) | (refl , refl) = refl , refl
binding-is-function (CBloop cb₁ BV≠FV₁)
                    (CBloop cb₂ BV≠FVV₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl
binding-is-function (CBloopˢ cbp₁ cbq₁ BVp≠FVq₁ BVq≠FVq₁)
                    (CBloopˢ cbp₂ cbq₂ BVp≠FVq₂ BVq≠FVq₂)
  with binding-is-function cbp₁ cbp₂ | binding-is-function cbq₁ cbq₂
... | (refl , refl) | (refl , refl) = refl , refl
binding-is-function (CBseq cbp₁ cbq₁ BV≠FV₁) (CBseq cbp₂ cbq₂ BV≠FV₂)
  with binding-is-function cbp₁ cbp₂ | binding-is-function cbq₁ cbq₂
... | (refl , refl) | (refl , refl) = refl , refl
binding-is-function (CBsusp cb₁ S∉BV₁) (CBsusp cb₂ S∉BV₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl
binding-is-function CBexit CBexit = refl , refl
binding-is-function (CBtrap cb₁) (CBtrap cb₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl
binding-is-function (CBshared cb₁) (CBshared cb₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl
binding-is-function CBsset CBsset = refl , refl
binding-is-function (CBvar cb₁) (CBvar cb₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl
binding-is-function CBvset CBvset = refl , refl
binding-is-function (CBif cbp₁ cbq₁) (CBif cbp₂ cbq₂)
  with binding-is-function cbp₁ cbp₂ | binding-is-function cbq₁ cbq₂
... | (refl , refl) | (refl , refl) = refl , refl
binding-is-function (CBρ cb₁) (CBρ cb₂)
  with binding-is-function cb₁ cb₂
... | (refl , refl) = refl , refl

binding-dec : ∀ p → Dec (∃ \ BV -> ∃ \ FV -> CorrectBinding p BV FV)

binding-dec nothin = yes (base , base , CBnothing)

binding-dec pause = yes (base , base , CBpause)

binding-dec (signl S p) with binding-dec p
binding-dec (signl S p) | yes (BV , FV , CBp) =
  yes (+S S BV , (FV |̌ (+S S base)) , CBsig CBp)
binding-dec (signl S p) | no ¬p = no (\ { (BV , FV , CBsig proj₃) → ¬p (_ , _ , proj₃) })

binding-dec (present S ∣⇒ p ∣⇒ q) with binding-dec p
binding-dec (present S ∣⇒ p ∣⇒ q) | yes p₂ with binding-dec q
binding-dec (present S ∣⇒ p ∣⇒ q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) =
  yes (BVp U̬ BVq , +S S (FVp U̬ FVq) , CBpresent CBp CBq)
binding-dec (present S ∣⇒ p ∣⇒ p₁) | yes p₂ | (no ¬p) =
  no (\ { (BV , FV , CBpresent BD BD₁) → ¬p (_ , _ , BD₁) } )
binding-dec (present S ∣⇒ p ∣⇒ p₁) | no ¬p =
  no (\ { (BV , FV , CBpresent BD BD₁) → ¬p (_ , _ , BD) } )

binding-dec (emit S) = yes (base , (Sunwrap S ∷ [] , [] , []) , CBemit)

binding-dec (p ∥ q) with binding-dec p
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) with binding-dec q
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) with distinct-dec BVp BVq
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | yes BVp≠BVq  = no ¬CB
 where
   ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (p ∥ q) BV FV)
   ¬CB (BV₂ , FV₂ , CBpar CBp₂ CBq₂ BVp≠BVq' FVp≠BVq' BVp≠FVq' Xp≠Xq') with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
   ... | ((refl , refl) , (refl , refl)) = distinct-not-distinct-dec BVp≠BVq' BVp≠BVq
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | no ¬BVp≠BVq with distinct-dec FVp BVq
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (no ¬BVp≠BVq) | (yes FVp≠BVq) = no ¬CB
 where
   ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (p ∥ q) BV FV)
   ¬CB (BV₂ , FV₂ , CBpar CBp₂ CBq₂ BVp≠BVq' FVp≠BVq' BVp≠FVq' Xp≠Xq') with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
   ... | ((refl , refl) , (refl , refl)) = distinct-not-distinct-dec FVp≠BVq' FVp≠BVq
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (no ¬BVp≠BVq) | (no ¬FVp≠BVq) with distinct-dec BVp FVq
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (no ¬BVp≠BVq) | (no ¬FVp≠BVq) | (yes BVp≠FVq) = no ¬CB
 where
   ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (p ∥ q) BV FV)
   ¬CB (BV₂ , FV₂ , CBpar CBp₂ CBq₂ BVp≠BVq' FVp≠BVq' BVp≠FVq' Xp≠Xq') with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
   ... | ((refl , refl) , (refl , refl)) = distinct-not-distinct-dec BVp≠FVq' BVp≠FVq
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (no ¬BVp≠BVq) | (no ¬FVp≠BVq) | (no ¬BVp≠FVq) with distinct'-dec (Xs FVp) (Xs FVq)
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (no ¬BVp≠BVq) | (no ¬FVp≠BVq) | (no ¬BVp≠FVq) | (yes Xp≠Xq) = no ¬CB
 where
   ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (p ∥ q) BV FV)
   ¬CB (BV₂ , FV₂ , CBpar CBp₂ CBq₂ BVp≠BVq' FVp≠BVq' BVp≠FVq' Xp≠Xq') with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
   ... | ((refl , refl) , (refl , refl)) = Xp≠Xq' (proj₁ Xp≠Xq) (proj₁ (proj₂ Xp≠Xq)) (proj₂ (proj₂ Xp≠Xq))
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (no ¬BVp≠BVq) | (no ¬FVp≠BVq) | (no ¬BVp≠FVq) | (no ¬Xp≠Xq) =
  yes (BVp U̬ BVq , FVp U̬ FVq , CBpar CBp CBq (distinct-dec-is-distinct  ¬BVp≠BVq)
                                           (distinct-dec-is-distinct  ¬FVp≠BVq)
                                           (distinct-dec-is-distinct  ¬BVp≠FVq)
                                           (λ z z∈xs z∈ys → ¬Xp≠Xq (z , z∈xs , z∈ys)))
binding-dec (p ∥ q) | yes (BVp , FVp , CBp) | no ¬p =
  no (\ { (BV , FV , CBpar X X₁ BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) → ¬p (_ , _ , X₁ ) } )
binding-dec (p ∥ q) | no ¬p =
  no (\ { (BV , FV , CBpar X X₁ BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) → ¬p (_ , _ , X) } )

binding-dec (loop p) with binding-dec p
binding-dec (loop p) | yes (BV , FV , CB) with distinct-dec BV FV
binding-dec (loop p) | yes (BV , FV , CB) | yes dec = no ¬CB
  where
   ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (loop p) BV FV)
   ¬CB (BV₂ , FV₂ , CBloop CB₂  BV≠FV') with binding-is-function CB CB₂
   ... | (refl , refl) = distinct-not-distinct-dec BV≠FV' dec
binding-dec (loop p) | yes (BV , FV , CB) | no dec = yes (BV , (FV , (CBloop CB (distinct-dec-is-distinct dec))))
binding-dec (loop p) | no ¬p =
  no (\ { (BV , FV , CBloop CB BV≠FV) -> ¬p (_ , _ , CB) } )

binding-dec (loopˢ p q) with binding-dec p
binding-dec (loopˢ p q) | yes (BVp , FVq , CBp ) with binding-dec q
binding-dec (loopˢ p q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) with distinct-dec BVp FVq
binding-dec (loopˢ p q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | yes BVp≠FVq = no ¬CB
 where
  ¬CB :  ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (loopˢ p q) BV FV)
  ¬CB (BV₂ , FV₂ , CBloopˢ CBp₂ CBq₂ BVp≠FVq₂ BVq≠FVq₂) with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
  ... | ((refl , refl) , (refl , refl)) = distinct-not-distinct-dec BVp≠FVq₂ BVp≠FVq
binding-dec (loopˢ p q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | no ¬BVp≠FVq with distinct-dec BVq FVq
binding-dec (loopˢ p q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | no ¬BVp≠FVq | yes ¬BVq≠FVq = no ¬CB where
  ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (loopˢ p q) BV FV)
  ¬CB (BV₂ , FV₂ , CBloopˢ CBp₂ CBq₂ BVp≠FVq₂ BVq≠FVq₂)  with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
  ... | ((refl , refl) , (refl , refl)) = distinct-not-distinct-dec BVq≠FVq₂ ¬BVq≠FVq
binding-dec (loopˢ p q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | no BVp≠FVq | no BVq≠FVq =
   yes (BVp U̬ BVq , FVp U̬ FVq , CBloopˢ CBp CBq (distinct-dec-is-distinct BVp≠FVq) (distinct-dec-is-distinct BVq≠FVq))
binding-dec (loopˢ p q) | yes (BVp , FVq , CBp) | (no ¬CBq) =
  no (\ { (BV , FV , CBloopˢ CBp CBq BVp≠FVq BVq≠FVq) -> ¬CBq (_ , _ , CBq) } )
binding-dec (loopˢ p q) | no ¬CBp =
  no (\ { (BV , FV , CBloopˢ CBp CBq BVp≠FVq BVq≠FVq) -> ¬CBp (_ , _ , CBp) })

binding-dec (p >> q) with binding-dec p
binding-dec (p >> q) | yes (BVp , FVq , CBp ) with binding-dec q
binding-dec (p >> q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) with distinct-dec BVp FVq
binding-dec (p >> q) | yes (BVp , FVp , CBp) | (yes (BVq , FVq , CBq)) | (yes BVp≠FVq) = no ¬CB
 where
  ¬CB :  ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (p >> q) BV FV)
  ¬CB (BV₂ , FV₂ , CBseq CBp₂ CBq₂ BVp≠FVq') with (binding-is-function CBp CBp₂ , binding-is-function CBq CBq₂)
  ... | ((refl , refl) , (refl , refl)) = distinct-not-distinct-dec BVp≠FVq' BVp≠FVq
binding-dec (p >> q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) | no ¬BVp≠FVq =
  yes  (BVp U̬ BVq , FVp U̬ FVq , CBseq CBp CBq (distinct-dec-is-distinct ¬BVp≠FVq))
binding-dec (p >> q) | yes (BVp , FVq , CBp) | (no ¬CBq) =
  no (\ { (BV , FV , CBseq CBp CBq BVp≠FVq) -> ¬CBq (_ , _ , CBq) } )
binding-dec (p >> q) | no ¬CBp =
  no (\ { (BV , FV , CBseq CBp CBq BVp≠FVq) -> ¬CBp (_ , _ , CBp) })

binding-dec (suspend p S) with binding-dec p
binding-dec (suspend p S) | yes (BV , FV , CB) with distinct'-dec [ (Sunwrap S) ] (Ss BV)
binding-dec (suspend p S) | yes (BV₁ , FV₁ , CB₁) | yes ([S]≠BVp₁ , [S]≠BVp₂ , [S]≠BVp₃) = no ¬CB
 where
   ¬CB : ¬ (∃ \ BV -> ∃ \ FV -> CorrectBinding (suspend p S) BV FV)
   ¬CB (BV₂ , FV₂ , CBsusp CB₃ [S]≠BVp') with (binding-is-function CB₁ CB₃)
   ... | refl , refl = [S]≠BVp' [S]≠BVp₁ [S]≠BVp₂ [S]≠BVp₃
binding-dec (suspend p S) | yes (BV , FV , CB) | (no ¬[S]≠BVp) =
  yes (BV , +S S FV , CBsusp CB (λ z z∈xs z∈ys → ¬[S]≠BVp (z , z∈xs , z∈ys)))
binding-dec (suspend p S) | no ¬p =
  no (\ { (BV , FV , CBsusp CB [S]≠BVp) -> ¬p (_ , _ , CB)})

binding-dec (trap p) with binding-dec p
binding-dec (trap p) | yes (BV , FV , CB) = yes (BV , FV , CBtrap CB)
binding-dec (trap p) | no ¬p =
  no (\ { (BV , FV , CBtrap CB ) -> ¬p (BV , FV , CB) })

binding-dec (exit x) = yes (base , base , CBexit)

binding-dec (shared s ≔ e in: p) with binding-dec p
binding-dec (shared s ≔ e in: p) | yes (BV , FV , CB) =
  yes (+s s BV , (FVₑ e) U̬ (FV |̌ (+s s base)) , CBshared CB)
binding-dec (shared s ≔ e in: p) | no ¬p =
  no (\ { (BV , FV , CBshared CB) -> ¬p (_ , _ , CB) })

binding-dec (s ⇐ e) = yes (base , +s s (FVₑ e) , CBsset)

binding-dec (var x ≔ e in: p) with binding-dec p
binding-dec (var x ≔ e in: p) | yes (BV , FV , CB) =
  yes (+x x BV , (FVₑ e) U̬ (FV |̌ (+x x base)) , CBvar CB)
binding-dec (var x ≔ e in: p) | no ¬p =
  no (\ { (BV , FV , CBvar CB) -> ¬p (_ , _ , CB) } )

binding-dec (x ≔ e) = yes (base , (+x x (FVₑ e)) , CBvset)

binding-dec (if x ∣⇒ p ∣⇒ q) with binding-dec p
binding-dec (if x ∣⇒ p ∣⇒ q) | yes p₁ with binding-dec q
binding-dec (if x ∣⇒ p₁ ∣⇒ q) | yes (BVp , FVp , CBp) | yes (BVq , FVq , CBq) =
  yes (BVp U̬ BVq , +x x (FVp U̬ FVq) , CBif CBp CBq)
binding-dec (if x ∣⇒ p ∣⇒ q) | yes p₁ | (no ¬p) =
  no (\ { (BV , FV , CBif CBp CBq) -> ¬p (_ , _ , CBq) })
binding-dec (if x ∣⇒ p ∣⇒ q) | no ¬p =
  no (\ { (BV , FV , CBif CBp CBq) -> ¬p (_ , _ , CBp) })

binding-dec (ρ⟨ θ , A ⟩· p) with binding-dec p
binding-dec (ρ⟨ θ , A ⟩· p) | yes (BV , FV , BP) =
  yes (((Dom θ) U̬ BV)  , FV |̌ (Dom θ) , CBρ BP)
binding-dec (ρ⟨ θ , A ⟩· p) | no ¬p = no (\ { (BV , FV , CBρ p ) -> ¬p (_ , _ , p) } )

binding-extract : ∀{p BV FV p' E} →
  CorrectBinding p BV FV →
  p ≐ E ⟦ p' ⟧e →
  Σ (VarList × VarList) λ { (BV' , FV') → (BV' ⊆ BV × FV' ⊆ FV) × CorrectBinding p' BV' FV' }
binding-extract cb                      dehole =
  _ , (⊆-refl , ⊆-refl) , cb
binding-extract (CBpar cbp cbq _ _ _ _) (depar₁ p≐E⟦p'⟧)
  with binding-extract cbp p≐E⟦p'⟧
... | (BV' , FV') , (BV'⊆BV , FV'⊆FV) , cb* = _ , (∪ˡ BV'⊆BV , ∪ˡ FV'⊆FV) , cb*
binding-extract {_} (CBpar {BVp = BVp} {FVp = FVp} cbp cbq _ _ _ _) (depar₂ q≐E⟦q'⟧)
  with binding-extract cbq q≐E⟦q'⟧
... | (BV' , FV') , (BV'⊆BV , FV'⊆FV) , cb* = _ , (∪ʳ BVp BV'⊆BV , ∪ʳ FVp FV'⊆FV) , cb*
binding-extract (CBseq cbp cbq _)       (deseq p≐E⟦p'⟧)
  with binding-extract cbp p≐E⟦p'⟧
... | (BV' , FV') , (BV'⊆BV , FV'⊆FV) , cb* = _ , (∪ˡ BV'⊆BV , ∪ˡ FV'⊆FV) , cb*
binding-extract (CBloopˢ cbp cbq _ _)   (deloopˢ p≐E⟦p'⟧)
  with binding-extract cbp p≐E⟦p'⟧
... | (BV' , FV') , (BV'⊆BV , FV'⊆FV) , cb* = _ , (∪ˡ BV'⊆BV , ∪ˡ FV'⊆FV) , cb*
binding-extract (CBsusp {S = S} cb _)   (desuspend p≐E⟦p'⟧)
  with binding-extract cb  p≐E⟦p'⟧
... | (BV' , FV') , (BV'⊆BV , FV'⊆FV) , cb* = _ , (BV'⊆BV , ∪ʳ (+S S base) FV'⊆FV) , cb*
binding-extract (CBtrap cb)             (detrap p≐E⟦p'⟧)
  with binding-extract cb  p≐E⟦p'⟧
... | (BV' , FV') , (BV'⊆BV , FV'⊆FV) , cb* = _ , (BV'⊆BV , FV'⊆FV) , cb*

binding-subst : ∀{p BVp FVp q BVq FVq r BVr FVr E} →
  CorrectBinding p BVp FVp →
  p ≐ E ⟦ q ⟧e →
  CorrectBinding q BVq FVq →
  BVr ⊆ BVq →
  FVr ⊆ FVq →
  CorrectBinding r BVr FVr →
  Σ (VarList × VarList) λ { (BV' , FV') → (BV' ⊆ BVp × FV' ⊆ FVp) × CorrectBinding (E ⟦ r ⟧e) BV' FV' }
binding-subst (CBpar {BVq = BVq'} {FVq = FVq'} cbp' cbq' BVp'≠BVq' FVp'≠BVq' BVp'≠FVq' Xp'≠Xq')
              (depar₁ p'≐E⟦q⟧) cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-subst cbp' p'≐E⟦q⟧ cbq BVr⊆BVq FVr⊆FVq cbr
... | (BVp'' , FVp'') , (BVp''⊆BVp' , FVp''⊆FVp') , cbp'' =
  _ , (∪-respect-⊆-left BVp''⊆BVp' , ∪-respect-⊆-left FVp''⊆FVp') ,
  CBpar cbp'' cbq'
        (⊆-respect-distinct-left BVp''⊆BVp' BVp'≠BVq')
        (⊆-respect-distinct-left FVp''⊆FVp' FVp'≠BVq')
        (⊆-respect-distinct-left BVp''⊆BVp' BVp'≠FVq')
        (⊆¹-respect-distinct'-left (proj₂ (proj₂ FVp''⊆FVp')) Xp'≠Xq')
binding-subst (CBpar {BVp = BVp'} {FVp = FVp'} cbp' cbq' BVp'≠BVq' FVp'≠BVq' BVp'≠FVq' Xp'≠Xq')
              (depar₂ q'≐E⟦q⟧) cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-subst cbq' q'≐E⟦q⟧ cbq BVr⊆BVq FVr⊆FVq cbr
... | (BVq'' , FVq'') , (BVq''⊆BVq' , FVq''⊆FVq') , cbq'' =
  _ , (∪-respect-⊆-right BVp' BVq''⊆BVq' , ∪-respect-⊆-right FVp' FVq''⊆FVq') ,
  CBpar cbp' cbq''
        (⊆-respect-distinct-right BVq''⊆BVq' BVp'≠BVq')
        (⊆-respect-distinct-right BVq''⊆BVq' FVp'≠BVq')
        (⊆-respect-distinct-right FVq''⊆FVq' BVp'≠FVq')
        (⊆¹-respect-distinct'-right (proj₂ (proj₂ FVq''⊆FVq')) Xp'≠Xq')
binding-subst (CBseq {BVq = BVq'} {FVq = FVq'} cbp' cbq' BV≠FV)
              (deseq p'≐E⟦q⟧) cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-subst cbp' p'≐E⟦q⟧ cbq BVr⊆BVq FVr⊆FVq cbr
... | (BVp'' , FVp'') , (BVp''⊆BVp' , FVp''⊆FVp') , cbp'' =
  _ , (∪-respect-⊆-left BVp''⊆BVp' , ∪-respect-⊆-left FVp''⊆FVp') ,
  CBseq cbp'' cbq' (⊆-respect-distinct-left BVp''⊆BVp' BV≠FV)
binding-subst (CBloopˢ {BVq = BVq'} {FVq = FVq'} cbp' cbq' BVp≠FVq BVq≠FVq)
              (deloopˢ p'≐E⟦q⟧) cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-subst cbp' p'≐E⟦q⟧ cbq BVr⊆BVq FVr⊆FVq cbr
... | (BVp'' , FVp'') , (BVp''⊆BVp' , FVp''⊆FVp') , cbp'' =
  _ , (∪-respect-⊆-left BVp''⊆BVp' , ∪-respect-⊆-left FVp''⊆FVp') ,
  CBloopˢ cbp'' cbq' (⊆-respect-distinct-left BVp''⊆BVp' BVp≠FVq) BVq≠FVq
binding-subst (CBsusp {S} {FV = FVp'} cbp' S∉BVp') (desuspend p'≐E⟦q⟧) cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-subst cbp' p'≐E⟦q⟧ cbq BVr⊆BVq FVr⊆FVq cbr
... | (BVp'' , FVP'') , (BVp''⊆BVp' , FVp''⊆FVp') , cbp'' =
  _ , (BVp''⊆BVp' , (∪¹-respect-⊆¹-right [ Signal.unwrap S ] ,′ id ,′ id # FVp''⊆FVp')) ,
  CBsusp cbp'' (⊆¹-respect-distinct'-right (proj₁ BVp''⊆BVp') S∉BVp')
binding-subst (CBtrap cbp') (detrap p'≐E⟦q⟧) cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-subst cbp' p'≐E⟦q⟧ cbq BVr⊆BVq FVr⊆FVq cbr
... | (BVp'' , FVp'') , ⟨BVp''⊆BVp'⟩×⟨FVp''⊆FVp'⟩ , cbp'' =
  _ , ⟨BVp''⊆BVp'⟩×⟨FVp''⊆FVp'⟩ , CBtrap cbp''
binding-subst cbp dehole cbq BVr⊆BVq FVr⊆FVq cbr
  with binding-is-function cbp cbq
... | (refl , refl) = _ , (BVr⊆BVq , FVr⊆FVq) , cbr

binding-extractc' : ∀{p BV FV p' C} →
  CorrectBinding p BV FV →
  p ≐ C ⟦ p' ⟧c →
  Σ (VarList × VarList) λ { (BV' , FV') → CorrectBinding p' BV' FV' }
binding-extractc' cbp dchole =
  _ , cbp
binding-extractc' (CBsig cbp) (dcsignl p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBpresent cbp cbp₁) (dcpresent₁ p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBpresent cbp cbp₁) (dcpresent₂ p≐C⟦p'⟧) =
  binding-extractc' cbp₁ p≐C⟦p'⟧
binding-extractc' (CBpar cbp cbp₁ BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) (dcpar₁ p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBpar cbp cbp₁ BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) (dcpar₂ p≐C⟦p'⟧) =
  binding-extractc' cbp₁ p≐C⟦p'⟧
binding-extractc' (CBloop cbp BV≠FV) (dcloop p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBloopˢ CBp CBq BVp≠FVq BVq≠FVq) (dcloopˢ₁ p≐C⟦p'⟧) =
  binding-extractc' CBp p≐C⟦p'⟧
binding-extractc' (CBloopˢ CBp CBq BVp≠FVq BVq≠FVq) (dcloopˢ₂ q≐C⟦q'⟧) =
  binding-extractc' CBq q≐C⟦q'⟧
binding-extractc' (CBseq cbp cbp₁ BVp≠FVq) (dcseq₁ p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBseq cbp cbp₁ BVp≠FVq) (dcseq₂ p≐C⟦p'⟧) =
  binding-extractc' cbp₁ p≐C⟦p'⟧
binding-extractc' (CBsusp cbp [S]≠BVp) (dcsuspend p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBtrap cbp) (dctrap p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBshared cbp) (dcshared p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBvar cbp) (dcvar p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBif cbp cbp₁) (dcif₁ p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧
binding-extractc' (CBif cbp cbp₁) (dcif₂ p≐C⟦p'⟧) =
  binding-extractc' cbp₁ p≐C⟦p'⟧
binding-extractc' (CBρ cbp) (dcenv p≐C⟦p'⟧) =
  binding-extractc' cbp p≐C⟦p'⟧

binding-substc' : ∀{p BVp FVp q BVq FVq r BVr FVr C} →
  CorrectBinding p BVp FVp →
  p ≐ C ⟦ q ⟧c →
  CorrectBinding q BVq FVq →
  BVr ⊆ BVq →
  FVr ⊆ FVq →
  CorrectBinding r BVr FVr →
  Σ (VarList × VarList) λ { (BV' , FV') → (BV' ⊆ BVp × FV' ⊆ FVp) × CorrectBinding (C ⟦ r ⟧c) BV' FV' }
binding-substc' CBp dchole CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-is-function CBp CBq
... | refl , refl = _ , (BVr⊆BVq , FVr⊆FVq) , CBr

binding-substc' (CBpar  cbp cbp₁ BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq)
                (dcpar₁ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-left bvsub , ∪-respect-⊆-left fvsub) ,
  CBpar  cb1 cbp₁ (⊆-respect-distinct-left bvsub BVp≠BVq)
                  (⊆-respect-distinct-left fvsub FVp≠BVq)
                  (⊆-respect-distinct-left bvsub BVp≠FVq)
                  (⊆¹-respect-distinct'-left (thd fvsub) Xp≠Xq)

binding-substc' (CBpar{BVp = BVp}{FVp = FVp} cbp cbp₁ BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq)
                (dcpar₂ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp₁ dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub ,  fvsub) , cb1 =
  _ , (∪-respect-⊆-right BVp bvsub , ∪-respect-⊆-right FVp fvsub) ,
  CBpar cbp cb1 (⊆-respect-distinct-right bvsub BVp≠BVq)
                (⊆-respect-distinct-right bvsub FVp≠BVq)
                (⊆-respect-distinct-right fvsub BVp≠FVq)
                (⊆¹-respect-distinct'-right (thd fvsub) Xp≠Xq)

binding-substc' (CBseq cbp cbp₁ BVp≠FVq)
                (dcseq₁ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-left bvsub , ∪-respect-⊆-left fvsub) ,
  CBseq cb1 cbp₁ (⊆-respect-distinct-left bvsub BVp≠FVq)

binding-substc' (CBseq{BVp = BVp}{FVp = FVp} cbp cbp₁ BVp≠FVq)
                (dcseq₂ dc) CBq BVr⊆BVq FVr⊆FVq CBr
   with  binding-substc' cbp₁ dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
   _ , (∪-respect-⊆-right BVp bvsub , ∪-respect-⊆-right FVp fvsub) ,
   CBseq cbp cb1 (⊆-respect-distinct-right fvsub  BVp≠FVq)

binding-substc' (CBsusp{S = S} cbp [S]≠BVp)
                (dcsuspend dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
   _ ,  (bvsub , ((∷-respect-⊆¹ (Signal.unwrap S)) , id , id # fvsub)) ,
   CBsusp cb1 (⊆¹-respect-distinct'-right (fst bvsub) [S]≠BVp)

binding-substc' (CBtrap CBp) (dctrap dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' CBp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (bvsub , fvsub) , CBtrap cb1

binding-substc' (CBsig{S = S ₛ} cbp) (dcsignl dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (((∷-respect-⊆¹ S) , id , id # bvsub) ,
       ⊆-respect-|̌ (+S (S ₛ) base) fvsub),
  CBsig cb1

binding-substc' (CBpresent{S = S ₛ} cbp cbp₁)
                (dcpresent₁ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-left bvsub ,
       ((∷-respect-⊆¹ S) , id , id # (∪-respect-⊆-left fvsub))) ,
  CBpresent cb1 cbp₁

binding-substc' (CBpresent{S = S ₛ}{BVp = BVp}{FVp = FVp} cbp cbp₁)
                (dcpresent₂ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp₁ dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-right BVp bvsub ,
       ((∷-respect-⊆¹ S) , id , id # (∪-respect-⊆-right FVp fvsub))) ,
  CBpresent cbp cb1

binding-substc' (CBloop cbp BV≠FV)
                (dcloop dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-right base bvsub , fvsub) ,
  CBloop cb1 (⊆-respect-distinct-left bvsub
              (⊆-respect-distinct-right fvsub BV≠FV))

binding-substc' (CBloopˢ cbp cbp₁ BVp≠FVq BVq≠FVq)
                (dcloopˢ₁ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-left bvsub , ∪-respect-⊆-left fvsub) ,
  CBloopˢ cb1 cbp₁ (⊆-respect-distinct-left bvsub BVp≠FVq) BVq≠FVq

binding-substc' (CBloopˢ{BVp = BVp}{FVp = FVp} cbp cbp₁ BVp≠FVq BVq≠FVq)
                (dcloopˢ₂ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp₁ dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-right BVp bvsub , ∪-respect-⊆-right FVp fvsub) ,
  CBloopˢ cbp cb1 (⊆-respect-distinct-right fvsub  BVp≠FVq)
                  (⊆-respect-distinct-left bvsub
                   (⊆-respect-distinct-right fvsub BVq≠FVq))

binding-substc' (CBshared{s = s}{e = e} cbp)
                (dcshared dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
 _ , (((id , (∷-respect-⊆¹ (SharedVar.unwrap s)) , id # bvsub)) ,
      ∪-respect-⊆-right (FVₑ e) (⊆-respect-|̌ (+s s base) fvsub)) ,
 CBshared cb1

binding-substc' (CBvar{x = x}{e = e} cbp) (dcvar dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (((id , id , (∷-respect-⊆¹ (SeqVar.unwrap x)) # bvsub)) ,
        ∪-respect-⊆-right (FVₑ e) (⊆-respect-|̌ (+x x base) fvsub)) ,
  CBvar cb1

binding-substc' (CBif{x = x ᵥ} cbp cbp₁) (dcif₁ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-left bvsub , (id , id , (∷-respect-⊆¹ x) # (∪-respect-⊆-left fvsub))) ,
  CBif cb1 cbp₁

binding-substc' (CBif{x = x ᵥ}{BVp = BVp}{FVp = FVp} cbp cbp₁)
                (dcif₂ dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp₁ dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
  _ , (∪-respect-⊆-right BVp bvsub ,
       (id , id , (∷-respect-⊆¹ x) # (∪-respect-⊆-right FVp fvsub))) ,
  CBif cbp cb1

binding-substc' (CBρ{θ = θ} cbp) (dcenv dc) CBq BVr⊆BVq FVr⊆FVq CBr
  with binding-substc' cbp dc CBq BVr⊆BVq FVr⊆FVq CBr
... | _ , (bvsub , fvsub) , cb1 =
 _ , (∪-respect-⊆-right (Dom θ) bvsub , ⊆-respect-|̌ (Dom θ) fvsub) ,
 CBρ cb1

-- In the decomposition E ⟦ p ⟧e, the bound variables in p and the free
-- variables in E must be disjoint.
distinct-term-context-help : ∀ {BV FV BVp FVp BVnothin FVnothin} p E →
  CorrectBinding (E ⟦ p ⟧e) BV FV →
  CorrectBinding p BVp FVp →
  (BVp ⊆ BV) →
  CorrectBinding (E ⟦ nothin ⟧e) BVnothin FVnothin →
  distinct BVp FVnothin
distinct-term-context-help p [] cb cbp BVp⊆BV CBnothing =
  (λ _ _ ()) ,′ (λ _ _ ()) ,′ (λ _ _ ())
distinct-term-context-help p (epar₁ q ∷ E)
  (CBpar cbp' cbq' BVp'≠BVq' FVp'≠BVq' BVp'≠FVq' Xp'≠Xq') cbp BVp⊆BV
  (CBpar cbnothinp cbnothinq BVp≠BVq₁ FVp≠BVq₁ BVp≠FVq₁ Xp≠Xq₁)
  with binding-extract cbp' (((E ⟦ p ⟧e) ≐ E ⟦ p ⟧e) ∋ plug refl)
... | (BV' , FV') , (BV'⊆BVE⟦p⟧ , FV'⊆FVE⟦p⟧) , cbp*
  with binding-is-function cbp cbp* | binding-is-function cbq' cbnothinq
... | refl , refl | refl , refl =
  distinct-union-right
    (distinct-term-context-help p E cbp' cbp BV'⊆BVE⟦p⟧ cbnothinp)
    (⊆-respect-distinct-left BV'⊆BVE⟦p⟧ BVp'≠FVq')
distinct-term-context-help p (epar₂ p₁ ∷ E)
  (CBpar cbp' cbq' BVp'≠BVq' FVp'≠BVq' BVp'≠FVq' Xp'≠Xq') cbp BVp⊆BV
  (CBpar {FVq = FVnothinq} cbnothinp cbnothinq BVp≠BVq₁ FVp≠BVq₁ BVp≠FVq₁ Xp≠Xq₁)
  with binding-extract cbq' (((E ⟦ p ⟧e) ≐ E ⟦ p ⟧e) ∋ plug refl)
... | (BV' , FV') , (BV'⊆BVE⟦p⟧ , FV'⊆FVE⟦p⟧) , cbp*
  with binding-is-function cbp cbp* | binding-is-function cbp' cbnothinp
... | refl , refl | refl , refl =
  ⊆-respect-distinct-right
    (∪-comm-⊆-right FVnothinq ⊆-refl)
    (distinct-union-right
      (distinct-term-context-help p E cbq' cbp BV'⊆BVE⟦p⟧ cbnothinq)
      (⊆-respect-distinct-left BV'⊆BVE⟦p⟧ (distinct-sym FVp'≠BVq')))

distinct-term-context-help p (eseq q ∷ E)
  (CBseq {BVp = BVE⟦p⟧p} {FVp = FVE⟦p⟧p} cbp' cbq' BVp'≠FVq') cbp BVp⊆BV
  (CBseq {BVp = BVnothinp} {BVq = BVnothinq} {FVp = FVnothinp} {FVq = FVnothinq}
         cbnothinp cbnothinq BVp≠FVq)
  with binding-extract cbp' (((E ⟦ p ⟧e) ≐ E ⟦ p ⟧e) ∋ plug refl)
... | (BV' , FV') , (BV'⊆BVE⟦p⟧ , FV'⊆FVE⟦p⟧) , cbp*
  with binding-is-function cbp cbp* | binding-is-function cbq' cbnothinq
... | refl , refl | refl , refl =
  distinct-union-right
    (distinct-term-context-help p E cbp' cbp BV'⊆BVE⟦p⟧ cbnothinp)
    (⊆-respect-distinct-left
     BV'⊆BVE⟦p⟧
     (distinct-sym (dist++ˡ (distinct-sym (distinct-union-left BVp'≠FVq' BVp≠FVq)))))

distinct-term-context-help p (eloopˢ q ∷ E)
  (CBloopˢ {BVp = BVE⟦p⟧p} {FVp = FVE⟦p⟧p} cbp' cbq' BVp'≠FVq' BVq'≠FVq') cbp BVp⊆BV
  (CBloopˢ {BVp = BVnothinp} {FVp = FVnothinp} {BVq = BVnothinq} {FVq = FVnothinq}
           cbnothinp cbnothinq BVp≠FVq BVq≠FVq)
  with binding-extract cbp' (((E ⟦ p ⟧e) ≐ E ⟦ p ⟧e) ∋ plug refl)
... | (BV' , FV') , (BV'⊆BVE⟦p⟧ , FV'⊆FVE⟦p⟧) , cbp*
  with binding-is-function cbp cbp* | binding-is-function cbq' cbnothinq
... | refl , refl | refl , refl =
   distinct-union-right
    (distinct-term-context-help p E cbp' cbp BV'⊆BVE⟦p⟧ cbnothinp)
    (⊆-respect-distinct-left
     BV'⊆BVE⟦p⟧
     (distinct-sym (dist++ˡ (distinct-sym (distinct-union-left BVp'≠FVq' BVp≠FVq)))))

distinct-term-context-help {BVp = BVp} p (esuspend S ∷ E)
  (CBsusp cb [S]≠BVp) cbp BVp⊆BV
  (CBsusp {FV = FV} cbnothin [S]≠BVp₁) = BVp≠S∷FV ,′ id ,′ id # dist
  where dist = distinct-term-context-help p E cb cbp BVp⊆BV cbnothin
        BVp≠S∷FV : (typeof (proj₁ dist)) → ∀ S' → S' ∈ (proj₁ BVp) → S' ∈ (Signal.unwrap S ∷ proj₁ FV) → ⊥
        BVp≠S∷FV BVp≠FV S' S'∈BVp (here refl) = [S]≠BVp S' (here refl) (proj₁ BVp⊆BV S' S'∈BVp)
        BVp≠S∷FV BVp≠FV S' S'∈BVp (there S'∈FV) = BVp≠FV S' S'∈BVp S'∈FV
distinct-term-context-help p (etrap ∷ E)
  (CBtrap cb) cbp BVp⊆BV
  (CBtrap cbnothin) =
  distinct-term-context-help p E cb cbp BVp⊆BV cbnothin

BVars : ∀ (p : Term) -> VarList
BVars nothin = base
BVars pause = base
BVars (signl S p) = +S S (BVars p)
BVars (present S ∣⇒ p ∣⇒ q) = BVp U̬ BVq where
  BVp = BVars p
  BVq = BVars q
BVars (emit S) = base
BVars (p ∥ q) = BVp U̬ BVq where
  BVp = BVars p
  BVq = BVars q
BVars (loop p) = BV where
  BV = BVars p
BVars (loopˢ p q) = BVp U̬ BVq where
  BVp = BVars p
  BVq = BVars q
BVars (p >> q) = BVp U̬ BVq where
  BVp = BVars p
  BVq = BVars q
BVars (suspend p S) = BVars p
BVars (trap p) = BVars p
BVars (exit x) = base
BVars (shared s ≔ e in: p) = +s s (BVars p)
BVars (s ⇐ e) = base
BVars (var x ≔ e in: p) =  +x x (BVars p)
BVars (x ≔ e) = base
BVars (if x ∣⇒ p ∣⇒ q) =  BVp U̬ BVq where
  BVp = BVars p
  BVq = BVars q
BVars (ρ⟨ θ , A ⟩· p) = (Dom θ) U̬ BV where
  BV = BVars p

FVars : ∀ (p : Term) -> VarList
FVars nothin = base
FVars pause = base
FVars (signl S p) =  FV |̌ (+S S base) where
  FV = FVars p
FVars (present S ∣⇒ p ∣⇒ q) =  +S S (FVp U̬ FVq) where
  FVp = FVars p
  FVq = FVars q
FVars (emit S) =  +S S base
FVars (p ∥ q) = FVp U̬ FVq where
  FVp = FVars p
  FVq = FVars q
FVars (loop p) = FVars p
FVars (loopˢ p q) = FVp U̬ FVq where
  FVp = FVars p
  FVq = FVars q
FVars (p >> q) =  FVp U̬ FVq where
  FVp = FVars p
  FVq = FVars q
FVars (suspend p S) = +S S (FVars p)
FVars (trap p) = FVars p
FVars (exit x) = base
FVars (shared s ≔ e in: p) = (FVₑ e) U̬ (FV |̌ (+s s base)) where
  FV = FVars p
FVars (s ⇐ e) = +s s (FVₑ e) where
FVars (var x ≔ e in: p) = (FVₑ e) U̬ (FV |̌ (+x x base)) where
  FV = FVars p
FVars (x ≔ e) = +x x (FVₑ e)
FVars (if x ∣⇒ p ∣⇒ q) = +x x (FVp U̬ FVq) where
  FVp = FVars p
  FVq = FVars q
FVars (ρ⟨ θ , A ⟩· p) = FV |̌ (Dom θ) where
  FV = FVars p

CB : Term -> Set
CB p = CorrectBinding p (BVars p) (FVars p)

BVFVcorrect : ∀ p BV FV -> CorrectBinding p BV FV -> BVars p ≡ BV × FVars p ≡ FV
BVFVcorrect .nothin .([] , [] , []) .([] , [] , []) CBnothing = refl , refl
BVFVcorrect .pause .([] , [] , []) .([] , [] , []) CBpause = refl , refl
BVFVcorrect .(signl _ _) .(+S S BV) .(FV |̌ (+S S base))
            (CBsig{p}{S}{BV}{FV} CB) with BVFVcorrect p BV FV CB
... | refl , refl = refl , refl
BVFVcorrect .(present _ ∣⇒ _ ∣⇒ _) .(BVp U̬ BVq) .(+S S (FVp U̬ FVq))
            (CBpresent{S}{p}{q}{BVp}{FVp}{BVq}{FVq} CBp CBq) with
            BVFVcorrect p BVp FVp CBp | BVFVcorrect q BVq FVq CBq
... | refl , refl | refl , refl = refl , refl
BVFVcorrect .(emit _) _ _ CBemit = refl , refl
BVFVcorrect .(_ ∥ _) .(BVp U̬ BVq) .(FVp U̬ FVq)
            (CBpar{p}{q}{BVp}{FVp}{BVq}{FVq} CBp CBq BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) with
            BVFVcorrect p BVp FVp CBp | BVFVcorrect q BVq FVq CBq
... | refl , refl | refl , refl = refl , refl
BVFVcorrect .(loop _) .BV .FV
            (CBloop{p}{BV}{FV} CB BV≠FV) with
            BVFVcorrect p BV FV CB
... | refl , refl = refl , refl
BVFVcorrect .(loopˢ _ _) .(BVp U̬ BVq) .(FVp U̬ FVq)
            (CBloopˢ{p}{q}{BVp}{FVp}{BVq}{FVq} CBp CBq BVp≠FVq BVq≠FVq) with
            BVFVcorrect p BVp FVp CBp | BVFVcorrect q BVq FVq CBq
... | refl , refl | refl , refl = refl , refl
BVFVcorrect .(_ >> _) .(BVp U̬ BVq) .(FVp U̬ FVq)
            (CBseq{p}{q}{BVp}{BVq}{FVp}{FVq} CBp CBq BVp≠FVq) with
            BVFVcorrect p BVp FVp CBp | BVFVcorrect q BVq FVq CBq
... | refl , refl | refl , refl = refl , refl
BVFVcorrect .(suspend _ _) .BV .(+S S FV)
            (CBsusp{S}{p}{BV}{FV} CB [S]≠BVp) with
            BVFVcorrect p BV FV CB
... | refl , refl = refl , refl
BVFVcorrect .(trap _) .BV .FV (CBtrap{p}{BV}{FV} CB) with
             BVFVcorrect p BV FV CB
... | refl , refl = refl , refl
BVFVcorrect .(exit _) .([] , [] , []) .([] , [] , []) CBexit = refl , refl
BVFVcorrect .(shared _ ≔ _ in: _) .(+s s BV) .((FVₑ e) U̬ (FV |̌ (+s s base)))
            (CBshared{s}{e}{p}{BV}{FV} CB) with
            BVFVcorrect p BV FV CB
... | refl , refl = refl , refl
BVFVcorrect .(_ ⇐ _) .([] , [] , []) .(+s s (FVₑ e)) (CBsset{s}{e}) = refl , refl
BVFVcorrect .(var _ ≔ _ in: _) .(+x x BV) .((FVₑ e) U̬ (FV |̌ (+x x base)))
            (CBvar{x}{e}{p}{BV}{FV} CB) with
            BVFVcorrect p BV FV CB
... | refl , refl = refl , refl
BVFVcorrect .(_ ≔ _) .([] , [] , []) .(+x x (FVₑ e)) (CBvset{x}{e}) = refl , refl
BVFVcorrect .(if _ ∣⇒ _ ∣⇒ _) .(BVp U̬ BVq) .(+x x (FVp U̬ FVq))
            (CBif{x}{p}{q}{BVp}{BVq}{FVp}{FVq} CBp CBq) with
            BVFVcorrect p BVp FVp CBp | BVFVcorrect q BVq FVq CBq
... | refl , refl | refl , refl = refl , refl
BVFVcorrect .(ρ⟨ _ , _ ⟩· _) .(((Dom θ) U̬ BV)) .(FV |̌ (Dom θ))
            (CBρ{θ}{A}{p}{BV}{FV} CB) with BVFVcorrect p BV FV CB
... | refl , refl = refl , refl


module Aexamples where

open import Data.List hiding (reverse)
open import Data.List.All
open import Data.Nat

open import Typing
open import Syntax
open import Async

{-
Lithmus test for asynchronous operations
A thread send something to an asynchronous channel and receives it afterwards.
-}
aex1 : Expr [] TUnit
aex1 = letbind [] (anew [] (delay send!))
       (letpair (left []) (here [])
       (letbind (left (rght [])) (aclose (here []))
       (await (there UUnit (here [])))))

-- just replace synchronous operations by the asynchronous ones
asyncex1 : Expr [] TUnit
asyncex1 =
  letbind [] (anew [] (delay send!))
  (letpair (left []) (here [])
  (letbind (rght (left []))
           (fork (await (here [])))
  (aclose (there UUnit (here [])))))

-- sending and receiving
asyncex2 : Expr [] TUnit
asyncex2 =
  letbind [] (anew [] (delay (send TInt (delay send!))))
  (letpair (left []) (here [])
  (letbind (left (rght []))
           (fork (letbind (rght []) (nat [] 42)
                 (letbind (left (left [])) (asend (rght (left [])) (here []) (here []))
                 (letbind (left []) (aclose (here []))
                 (var (here []))))))
  (letbind (rght (left [])) (arecv (here []))
  (letpair (left (rght [])) (here [])
  (letbind (left (left (rght []))) (await (here (UInt ∷ [])))
  (var (here (UUnit ∷ []))))))))


module ParseTreeOperations where
open import ParseTree
open import Data.List.NonEmpty
open import Data.Bool
open import Data.List hiding ([_])
open import Data.Nat
open import Relation.Nullary
open import Data.String

-- go from ((f a) b) representation to f [a, b]
expressionToList : Expr -> List⁺ Expr
expressionToList (functionApp e e₁ {false}) = expressionToList e ⁺∷ʳ e₁
expressionToList x = [ x ]

typeToList : Expr -> List⁺ Expr
typeToList (functionApp e e₁ {true}) = e ∷⁺ typeToList e₁
typeToList x = [ x ]

-- go from f [a, b] representation to ((f a) b)
{-# TERMINATING #-}
listToExpression : List⁺ Expr -> Expr
listToExpression (head₁ ∷ []) = head₁
listToExpression (head₁ ∷ x ∷ tail₁) =
  listToExpression (functionApp head₁ x {false} ∷ tail₁)

{-# TERMINATING #-}
listToType : List⁺ Expr -> Expr
listToType (head₁ ∷ []) = head₁
listToType (head₁ ∷ y ∷ tail) =
  functionApp head₁ (listToType (y ∷ tail)) {true}

emptyRange : Range
emptyRange = range 0 0

newHole : Expr
newHole = hole {""} {emptyRange} {[]} {[]}

newUnderscore : Expr
newUnderscore = underscore {emptyRange} {[]} {[]}

sameId : Identifier -> Identifier -> Bool
sameId (identifier name isInRange scope declaration) (identifier name₁ isInRange₁ scope₁ declaration₁)
  with declaration Data.Nat.≟ declaration₁
sameId (identifier name isInRange scope declaration) (identifier name₁ isInRange₁ scope₁ declaration₁) | yes p = true
sameId (identifier name isInRange scope declaration) (identifier name₁ isInRange₁ scope₁ declaration₁) | no ¬p = false

sameName : Identifier -> Identifier -> Bool
sameName (identifier name isInRange scope declaration) (identifier name₁ isInRange₁ scope₁ declaration₁) = name₁ == name

_doesNotAppearInExp_ : Identifier -> Expr -> Bool
x doesNotAppearInExp numLit = true
identifier name₁ isInRange₁ scope₁ declaration₁ doesNotAppearInExp ident
    (identifier name isInRange scope declaration) with compare declaration₁ declaration
(identifier name₁ isInRange₁ scope₁ declaration₁) doesNotAppearInExp (ident (identifier name isInRange scope .declaration₁)) | equal .declaration₁ = false
... | _ = true
x doesNotAppearInExp hole = true
x doesNotAppearInExp namedArgument (typeSignature funcName funcType) = x doesNotAppearInExp funcType
x doesNotAppearInExp functionApp y y₁ =
     (x doesNotAppearInExp y) ∧
     (x doesNotAppearInExp y₁)
x doesNotAppearInExp implicit x1 = x doesNotAppearInExp x1
x doesNotAppearInExp underscore = true

isImplicit : Expr -> Bool
isImplicit (implicit e) = true
isImplicit (namedArgument arg {explicit}) = not explicit
isImplicit x = false


module MJ.Examples.Exceptions where

open import Prelude
open import Data.Star
import Data.Vec.All as Vec∀
open import Data.List
open import Data.List.Any
open import Data.List.Membership.Propositional
open import Data.List.All hiding (lookup)
open import Data.Product hiding (Σ)
open import Relation.Binary.PropositionalEquality

open import MJ.Examples.Integer

open import MJ.Types
open import MJ.Classtable
open import MJ.Classtable.Code Σ
open import MJ.Syntax Σ
open import MJ.Syntax.Program Σ
open import MJ.Semantics Σ Lib
open import MJ.Semantics.Values Σ

-- Integer class body

caught : Prog int
caught = Lib , let
    x = (here refl)
    y = (there (here refl))
    v = (there (there (here refl)))
  in body
    (
      loc int
      ◅ loc (ref INT)
      ◅ loc (ref INT)
      ◅ asgn v (num 0)
      ◅ asgn x (new INT (num 9 ∷ []))
      ◅ asgn y (new INT (num 18 ∷ []))
      ◅ (try (block (
          -- perform a side effect on the heap: writing 18 to x's int field
          run (call (var x) "set" {_}{void} (var y ∷ []))
          -- raise the exception
          ◅ raise
          ◅ ε
        )) catch (block (
          -- read the 18 from x's field
          asgn v (call (var x) "get" [])
          ◅ ε
        )))
      ◅ ε
    )
    (var v)

uncaught : Prog int
uncaught = Lib , let
    x = (here refl)
    y = (there (here refl))
    v = (there (there (here refl)))
  in body
    (
      loc int
      ◅ loc (ref INT)
      ◅ loc (ref INT)
      ◅ asgn v (num 0)
      ◅ asgn x (new INT (num 9 ∷ []))
      ◅ asgn y (new INT (num 18 ∷ []))
      ◅ asgn v (call (var x) "get" [])
      ◅ raise
      ◅ ε
    )
    (var v)

test : caught ⇓⟨ 100 ⟩ (λ v → v ≡ num 18)
test = refl

test₂ : uncaught ⇓⟨ 100 ⟩! (λ μ e → e ≡ other)
test₂ = refl


-- Note: out of order true and false. Confuses the
-- values if we mess up and compile it to a fresh
-- datatype instead of Haskell Bool.
data Two : Set where tt ff : Two

{-# BUILTIN BOOL Two #-}
{-# BUILTIN FALSE ff #-}
{-# BUILTIN TRUE  tt #-}

-- Note: out of order nil and cons. Causes segfault
-- if we mess up and compile it to a fresh datatype
-- instead of Haskell lists.
data List {a} (A : Set a) : Set a where
  _∷_ : A → List A → List A
  []  : List A

{-# BUILTIN LIST List #-}

postulate
  String : Set
  Char : Set

{-# BUILTIN STRING String #-}
{-# BUILTIN CHAR   Char #-}

primitive
  primStringToList   : String → List Char
  primStringFromList : List Char → String
  primStringEquality : String → String → Two

drop1 : {A : Set} → List A → List A
drop1 (x ∷ xs) = xs
drop1 [] = []

postulate
  drop1' : List Char → List Char
{-# COMPILE GHC drop1' = drop 1 #-}

onList : (List Char → List Char) → String → String
onList f s = primStringFromList (f (primStringToList s))

postulate
  _==_ : String → String → Two
{-# COMPILE GHC _==_ = (==) #-}

show : Two → String
show tt = onList drop1  "TRUE"
show ff = onList drop1' "FALSE"

record One : Set where
{-# COMPILE GHC One = data () (()) #-}

postulate IO : Set → Set
{-# BUILTIN IO IO #-}
{-# COMPILE GHC IO = type IO #-}

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

postulate putStrLn : String → IO One
{-# COMPILE GHC putStrLn = Data.Text.IO.putStrLn #-}

postulate _>>_ : IO One → IO One → IO One
{-# COMPILE GHC _>>_ = (>>) #-}

main : IO One
main = do
  putStrLn (show ("foo" == "bar"))
  putStrLn (show ("foo" == "foo"))


------------------------------------------------------------------------
-- The partiality monad's monad instance
------------------------------------------------------------------------

{-# OPTIONS --cubical --safe #-}

module Partiality-monad.Inductive.Monad where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
import Monad
open import Prelude hiding (⊥)

open import Bijection equality-with-J using (_↔_)
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
  as Trunc hiding (_>>=′_)
open import Nat equality-with-J as Nat
open import Univalence-axiom equality-with-J

open import Partiality-monad.Inductive
open import Partiality-monad.Inductive.Alternative-order
open import Partiality-monad.Inductive.Eliminators
open import Partiality-monad.Inductive.Monotone
open import Partiality-monad.Inductive.Omega-continuous

open [_⊥→_⊥]

------------------------------------------------------------------------
-- The monad instance

-- Functions of type A → B ⊥ can be lifted to /ω-continuous/ functions
-- from A ⊥ to B ⊥.

private

  =<<-args : ∀ {a b} {A : Type a} {B : Type b}
             (f : A → B ⊥) → Arguments-nd b b A
  =<<-args {B = B} f = record
    { P  = B ⊥
    ; Q  = _⊑_
    ; pe = never
    ; po = f
    ; pl = λ _ → ⨆
    ; pa = λ _ _ → antisymmetry
    ; ps = ⊥-is-set
    ; qr = λ _ → ⊑-refl
    ; qt = λ _ _ _ _ _ → ⊑-trans
    ; qe = λ _ → never⊑
    ; qu = λ _ → upper-bound
    ; ql = λ _ _ _ → least-upper-bound
    ; qp = λ _ _ → ⊑-propositional
    }

infix 50 _∗ _∗-inc_

_∗ : ∀ {a b} {A : Type a} {B : Type b} →
     (A → B ⊥) → [ A ⊥→ B ⊥]
f ∗ = record
  { monotone-function = record
    { function = ⊥-rec-nd (=<<-args f)
    ; monotone = ⊑-rec-nd (=<<-args f)
    }
  ; ω-continuous = λ s →
      ⊥-rec-nd (=<<-args f) (⨆ s)    ≡⟨ ⊥-rec-nd-⨆ (=<<-args f) s ⟩∎
      ⨆ (inc-rec-nd (=<<-args f) s)  ∎
  }

_∗-inc_ : ∀ {a b} {A : Type a} {B : Type b} →
          (A → B ⊥) → Increasing-sequence A → Increasing-sequence B
_∗-inc_ f = inc-rec-nd (=<<-args f)

-- A universe-polymorphic variant of bind.

infixl 5 _>>=′_

_>>=′_ : ∀ {a b} {A : Type a} {B : Type b} →
         A ⊥ → (A → B ⊥) → B ⊥
x >>=′ f = function (f ∗) x

-- Join.

join : ∀ {a} {A : Type a} → A ⊥ ⊥ → A ⊥
join x = x >>=′ id

-- "Computation" rules for bind.

never->>= : ∀ {a b} {A : Type a} {B : Type b} {f : A → B ⊥} →
            never >>=′ f ≡ never
never->>= = ⊥-rec-nd-never (=<<-args _)

now->>= : ∀ {a b} {A : Type a} {B : Type b} {f : A → B ⊥} {x} →
          now x >>=′ f ≡ f x
now->>= = ⊥-rec-nd-now (=<<-args _) _

⨆->>= : ∀ {a b} {A : Type a} {B : Type b} {f : A → B ⊥} {s} →
        ⨆ s >>=′ f ≡ ⨆ (f ∗-inc s)
⨆->>= = ⊥-rec-nd-⨆ (=<<-args _) _

-- Bind is monotone.

infixl 5 _>>=-mono_

_>>=-mono_ :
  ∀ {a b} {A : Type a} {B : Type b} {x y : A ⊥} {f g : A → B ⊥} →
  x ⊑ y → (∀ z → f z ⊑ g z) → x >>=′ f ⊑ y >>=′ g
_>>=-mono_ {x = x} {y} {f} {g} x⊑y f⊑g =
  x >>=′ f ⊑⟨ monotone (f ∗) x⊑y ⟩
  y >>=′ f ⊑⟨ ⊥-rec-⊥ (record
                { P  = λ y → y >>=′ f ⊑ y >>=′ g
                ; pe = never >>=′ f  ≡⟨ never->>= ⟩⊑
                       never         ⊑⟨ never⊑ _ ⟩■
                       never >>=′ g  ■
                ; po = λ x →
                         now x >>=′ f  ≡⟨ now->>= ⟩⊑
                         f x           ⊑⟨ f⊑g x ⟩
                         g x           ≡⟨ sym now->>= ⟩⊑
                         now x >>=′ g  ■
                ; pl = λ s ih →
                         ⨆ s >>=′ f     ≡⟨ ⨆->>= ⟩⊑
                         ⨆ (f ∗-inc s)  ⊑⟨ ⨆-mono ih ⟩
                         ⨆ (g ∗-inc s)  ≡⟨ sym ⨆->>= ⟩⊑
                         ⨆ s >>=′ g     ■
                ; pp = λ _ → ⊑-propositional
                })
                y ⟩
  y >>=′ g ■

-- Instances of the monad laws with extra universe polymorphism.

module Monad-laws where

  left-identity : ∀ {a b} {A : Type a} {B : Type b} x (f : A → B ⊥) →
                  now x >>=′ f ≡ f x
  left-identity _ _ = now->>=

  right-identity : ∀ {a} {A : Type a} (x : A ⊥) →
                   x >>=′ now ≡ x
  right-identity = ⊥-rec-⊥
    (record
       { pe = never >>=′ now  ≡⟨ never->>= ⟩∎
              never           ∎
       ; po = λ x →
                now x >>=′ now  ≡⟨ now->>= ⟩∎
                now x           ∎
       ; pl = λ s hyp →
                ⨆ s >>=′ now        ≡⟨ ⨆->>= ⟩
                ⨆ (now ∗-inc s)     ≡⟨ cong ⨆ (_↔_.to equality-characterisation-increasing λ n →

                  s [ n ] >>=′ now       ≡⟨ hyp n ⟩∎
                  s [ n ]                ∎) ⟩∎

                ⨆ s                 ∎
       ; pp = λ _ → ⊥-is-set
       })

  associativity : ∀ {a b c} {A : Type a} {B : Type b} {C : Type c} →
                  (x : A ⊥) (f : A → B ⊥) (g : B → C ⊥) →
                  x >>=′ (λ x → f x >>=′ g) ≡ x >>=′ f >>=′ g
  associativity x f g = ⊥-rec-⊥
    (record
       { pe = (never >>=′ λ x → f x >>=′ g)  ≡⟨ never->>= ⟩
              never                          ≡⟨ sym never->>= ⟩
              never >>=′ g                   ≡⟨ cong (_>>=′ g) $ sym never->>= ⟩∎
              never >>=′ f >>=′ g            ∎
       ; po = λ x →
                (now x >>=′ λ x → f x >>=′ g)  ≡⟨ now->>= ⟩
                f x >>=′ g                     ≡⟨ cong (_>>=′ g) $ sym now->>= ⟩∎
                now x >>=′ f >>=′ g            ∎
       ; pl = λ s hyp →
                (⨆ s >>=′ λ x → f x >>=′ g)        ≡⟨ ⨆->>= ⟩
                ⨆ ((λ x → f x >>=′ g) ∗-inc s)     ≡⟨ cong ⨆ (_↔_.to equality-characterisation-increasing λ n →

                  s [ n ] >>=′ (λ x → f x >>=′ g)       ≡⟨ hyp n ⟩∎
                  s [ n ] >>=′ f >>=′ g                 ∎) ⟩

                ⨆ (g ∗-inc (f ∗-inc s))            ≡⟨ sym ⨆->>= ⟩
                ⨆ (f ∗-inc s) >>=′ g               ≡⟨ cong (_>>=′ g) (sym ⨆->>=) ⟩∎
                ⨆ s >>=′ f >>=′ g                  ∎
       ; pp = λ _ → ⊥-is-set
       })
    x

open Monad equality-with-J hiding (map; map-id; map-∘)

instance

  -- The partiality monad's monad instance.

  partiality-raw-monad : ∀ {ℓ} → Raw-monad (_⊥ {a = ℓ})
  Raw-monad.return partiality-raw-monad = now
  Raw-monad._>>=_  partiality-raw-monad = _>>=′_

  partiality-monad : ∀ {ℓ} → Monad (_⊥ {a = ℓ})
  Monad.raw-monad      partiality-monad = partiality-raw-monad
  Monad.left-identity  partiality-monad = Monad-laws.left-identity
  Monad.right-identity partiality-monad = Monad-laws.right-identity
  Monad.associativity  partiality-monad = Monad-laws.associativity

------------------------------------------------------------------------
-- _⊥ is a functor

map : ∀ {a b} {A : Type a} {B : Type b} →
      (A → B) → [ A ⊥→ B ⊥]
map f = (return ∘ f) ∗

map-id : ∀ {a} {A : Type a} →
         map (id {A = A}) ≡ idω
map-id =
  return ∗  ≡⟨ _↔_.to equality-characterisation-continuous (λ x →

    x >>= return  ≡⟨ right-identity x ⟩∎
    x             ∎) ⟩∎

  idω       ∎

map-∘ : ∀ {a b c} {A : Type a} {B : Type b} {C : Type c}
        (f : B → C) (g : A → B) →
        map (f ∘ g) ≡ map f ∘ω map g
map-∘ f g =
  (now ∘ f ∘ g) ∗                ≡⟨ _↔_.to equality-characterisation-continuous (λ x →

    x >>=′ (now ∘ f ∘ g)                     ≡⟨ cong (x >>=′_) (⟨ext⟩ λ _ → sym now->>=) ⟩
    x >>=′ (λ x → now (g x) >>=′ (now ∘ f))  ≡⟨ Monad-laws.associativity x (now ∘ g) (now ∘ f) ⟩∎
    x >>=′ (now ∘ g) >>=′ (now ∘ f)          ∎) ⟩∎

  (now ∘ f) ∗ ∘ω (now ∘ g) ∗  ∎

------------------------------------------------------------------------
-- Some properties

-- A kind of inversion lemma for _⇓_.

>>=-⇓ :
  ∀ {a b} {A : Type a} {B : Type b}
    {x : A ⊥} {f : A → B ⊥} {y} →
  (x >>=′ f ⇓ y) ≃ ∥ ∃ (λ z → x ⇓ z × f z ⇓ y) ∥
>>=-⇓ {x = x} {f} {y} = ⊥-rec-⊥
  (record
     { P  = λ x → (x >>=′ f ⇓ y) ≃ ∥ ∃ (λ z → x ⇓ z × f z ⇓ y) ∥
     ; pe = never >>=′ f ⇓ y                   ↝⟨ ≡⇒↝ _ (cong (_⇓ y) never->>=) ⟩
            never ⇓ y                          ↝⟨ never⇓≃⊥ ⟩
            Prelude.⊥                          ↔⟨ inverse (not-inhabited⇒∥∥↔⊥ id) ⟩
            ∥ Prelude.⊥ ∥                      ↔⟨ ∥∥-cong (inverse ×-right-zero) ⟩
            ∥ ∃ (λ z → ⊥₀) ∥                   ↔⟨ ∥∥-cong (∃-cong (λ _ → inverse ×-left-zero)) ⟩
            ∥ ∃ (λ z → Prelude.⊥ × f z ⇓ y) ∥  ↝⟨ ∥∥-cong (∃-cong (λ _ → inverse never⇓≃⊥ ×-cong F.id)) ⟩□
            ∥ ∃ (λ z → never ⇓ z × f z ⇓ y) ∥  □
     ; po = λ x →
              now x >>=′ f ⇓ y                                   ↝⟨ ≡⇒↝ _ (cong (_⇓ y) now->>=) ⟩
              f x ⇓ y                                            ↔⟨ inverse (∥∥↔ ⊥-is-set) ⟩
              ∥ f x ⇓ y ∥                                        ↔⟨ ∥∥-cong (inverse $ drop-⊤-left-Σ $
                                                                      _⇔_.to contractible⇔↔⊤ (other-singleton-contractible _)) ⟩
              ∥ ∃ (λ (p : ∃ (λ z → x ≡ z)) → f (proj₁ p) ⇓ y) ∥  ↔⟨ ∥∥-cong (inverse Σ-assoc) ⟩
              ∥ ∃ (λ z → x ≡ z × f z ⇓ y) ∥                      ↔⟨ inverse $ Trunc.flatten′
                                                                      (λ F → ∃ (λ _ → F (_ ≡ _) × _))
                                                                      (λ f → Σ-map id (Σ-map f id))
                                                                      (λ { (x , y , z) → ∥∥-map ((x ,_) ∘ (_, z)) y }) ⟩
              ∥ ∃ (λ z → ∥ x ≡ z ∥ × f z ⇓ y) ∥                  ↝⟨ ∥∥-cong (∃-cong λ _ → inverse now≡now≃∥≡∥ ×-cong F.id) ⟩□
              ∥ ∃ (λ z → now x ⇓ z × f z ⇓ y) ∥                  □
     ; pl = λ s ih →
              ⨆ s >>=′ f ⇓ y                                     ↝⟨ ≡⇒↝ _ (cong (_⇓ y) ⨆->>=) ⟩
              ⨆ (f ∗-inc s) ⇓ y                                  ↝⟨ ⨆⇓≃∥∃⇓∥ ⟩
              ∥ (∃ λ n → s [ n ] >>=′ f ⇓ y) ∥                   ↝⟨ ∥∥-cong (∃-cong ih) ⟩
              ∥ (∃ λ n → ∥ ∃ (λ z → s [ n ] ⇓ z × f z ⇓ y) ∥) ∥  ↔⟨ Trunc.flatten′ (λ F → ∃ λ _ → F (∃ λ _ → _ × _))
                                                                                (λ f → Σ-map id f)
                                                                                (uncurry λ x → ∥∥-map (x ,_)) ⟩
              ∥ (∃ λ n → ∃ λ z → s [ n ] ⇓ z × f z ⇓ y) ∥        ↔⟨ ∥∥-cong ∃-comm ⟩
              ∥ (∃ λ z → ∃ λ n → s [ n ] ⇓ z × f z ⇓ y) ∥        ↔⟨ ∥∥-cong (∃-cong λ _ → Σ-assoc) ⟩
              ∥ (∃ λ z → (∃ λ n → s [ n ] ⇓ z) × f z ⇓ y) ∥      ↔⟨ inverse $ Trunc.flatten′
                                                                      (λ F → (∃ λ _ → F (∃ λ _ → _ ⇓ _) × _))
                                                                      (λ f → Σ-map id (Σ-map f id))
                                                                      (λ { (x , y , z) → ∥∥-map ((x ,_) ∘ (_, z)) y }) ⟩
              ∥ (∃ λ z → ∥ (∃ λ n → s [ n ] ⇓ z) ∥ × f z ⇓ y) ∥  ↝⟨ ∥∥-cong (∃-cong λ _ → inverse ⨆⇓≃∥∃⇓∥ ×-cong F.id) ⟩□
              ∥ ∃ (λ z → ⨆ s ⇓ z × f z ⇓ y) ∥                    □
     ; pp = λ _ → Eq.right-closure ext 0 truncation-is-proposition
     })
  x

-- □ is closed, in a certain sense, under bind.

□->>= :
  ∀ {a b p q}
    {A : Type a} {B : Type b} {P : A → Type p} {Q : B → Type q}
    {x : A ⊥} {f : A → B ⊥} →
  (∀ x → Is-proposition (Q x)) →
  □ P x → (∀ {x} → P x → □ Q (f x)) → □ Q (x >>=′ f)
□->>= {Q = Q} {x} {f} Q-prop □-x □-f y =
  x >>=′ f ⇓ y                   ↔⟨ >>=-⇓ ⟩
  ∥ (∃ λ z → x ⇓ z × f z ⇓ y) ∥  ↝⟨ Trunc.rec (Q-prop y) (λ { (z , x⇓z , fz⇓y) → □-f (□-x z x⇓z) y fz⇓y }) ⟩□
  Q y                            □

-- ◇ is closed, in a certain sense, under bind.

◇->>= :
  ∀ {a b p q}
    {A : Type a} {B : Type b} {P : A → Type p} {Q : B → Type q}
    {x : A ⊥} {f : A → B ⊥} →
  ◇ P x → (∀ {x} → P x → ◇ Q (f x)) → ◇ Q (x >>=′ f)
◇->>= {x = x} {f} ◇-x ◇-f = Trunc.rec
  truncation-is-proposition
  (λ { (y , x⇓y , Py) →
       ∥∥-map (λ { (z , fy⇓z , Qz) →
                     z
                   , (x >>=′ f      ≡⟨ cong (_>>=′ f) x⇓y ⟩
                      now y >>=′ f  ≡⟨ now->>= ⟩
                      f y           ≡⟨ fy⇓z ⟩∎
                      now z         ∎)
                   , Qz
                 })
              (◇-f Py)
     })
  ◇-x

-- Certain nested occurrences of ⨆ can be replaced by a single one.

⨆>>=⨆≡⨆>>= :
  ∀ {a b} {A : Type a} {B : Type b} →
  ∀ (s : Increasing-sequence A) (f : A → Increasing-sequence B)
    {inc₁ inc₂} →
  ⨆ ((λ n → s [ n ] >>=′ ⨆ ∘ f) , inc₁) ≡
  ⨆ ((λ n → s [ n ] >>=′ λ y → f y [ n ]) , inc₂)
⨆>>=⨆≡⨆>>= s f = antisymmetry
  (least-upper-bound _ _ λ n →
   _≃_.to ≼≃⊑ $ λ z →

     s [ n ] >>=′ ⨆ ∘ f ⇓ z                                   ↔⟨ >>=-⇓ ⟩
     ∥ (∃ λ y → s [ n ] ⇓ y × ⨆ (f y) ⇓ z) ∥                  ↔⟨ ∥∥-cong (∃-cong λ _ → F.id ×-cong ⨆⇓≃∥∃⇓∥) ⟩
     ∥ (∃ λ y → s [ n ] ⇓ y × ∥ (∃ λ m → f y [ m ] ⇓ z) ∥) ∥  ↔⟨ Trunc.flatten′
                                                                   (λ F → ∃ λ _ → _ × F (∃ λ _ → _ ⇓ _))
                                                                   (λ f → Σ-map id (Σ-map id f))
                                                                   (λ { (y , p , q) → ∥∥-map ((y ,_) ∘ (p ,_)) q }) ⟩
     ∥ (∃ λ y → s [ n ] ⇓ y × ∃ λ m → f y [ m ] ⇓ z) ∥        ↔⟨ ∥∥-cong (∃-cong λ _ → ∃-comm) ⟩
     ∥ (∃ λ y → ∃ λ m → s [ n ] ⇓ y × f y [ m ] ⇓ z) ∥        ↝⟨ ∥∥-map (Σ-map id lemma) ⟩
     ∥ (∃ λ y → ∃ λ m → s [ m ] ⇓ y × f y [ m ] ⇓ z) ∥        ↔⟨ ∥∥-cong ∃-comm ⟩
     ∥ (∃ λ m → ∃ λ y → s [ m ] ⇓ y × f y [ m ] ⇓ z) ∥        ↔⟨ inverse $ Trunc.flatten′
                                                                   (λ F → ∃ λ _ → F (∃ λ _ → _ × _))
                                                                   (λ f → Σ-map id f)
                                                                   (λ { (m , p) → ∥∥-map (m ,_) p }) ⟩
     ∥ (∃ λ m → ∥ (∃ λ y → s [ m ] ⇓ y × f y [ m ] ⇓ z) ∥) ∥  ↔⟨ ∥∥-cong (∃-cong λ _ → inverse $ >>=-⇓) ⟩
     ∥ (∃ λ m → (s [ m ] >>=′ λ y → f y [ m ]) ⇓ z) ∥         ↔⟨ inverse ⨆⇓≃∥∃⇓∥ ⟩□
     ⨆ ((λ m → s [ m ] >>=′ λ y → f y [ m ]) , _) ⇓ z         □)

  (⨆-mono λ n →

    (s [ n ] >>=′ λ y → f y [ n ])  ⊑⟨ ⊑-refl (s [ n ]) >>=-mono (λ y → upper-bound (f y) n) ⟩■
    (s [ n ] >>=′ ⨆ ∘ f)            ■)

  where
  lemma :
    ∀ {n y z} →
    (∃ λ m → s [ n ] ⇓ y × f y [ m ] ⇓ z) →
    (∃ λ m → s [ m ] ⇓ y × f y [ m ] ⇓ z)
  lemma {n} (m , p , q) with Nat.total m n
  ... | inj₁ m≤n = n
                 , p
                 , _≃_.from ≼≃⊑ (later-larger (f _) m≤n) _ q
  ... | inj₂ n≤m = m
                 , _≃_.from ≼≃⊑ (later-larger s n≤m) _ p
                 , q


open import Nat
open import Prelude
open import core

module lemmas-progress-checks where
  -- boxed values don't have an instruction transition
  boxedval-not-trans : ∀{d d'} → d boxedval → d →> d' → ⊥
  boxedval-not-trans (BVVal VConst) ()
  boxedval-not-trans (BVVal VLam) ()
  boxedval-not-trans (BVArrCast x bv) (ITCastID) = x refl
  boxedval-not-trans (BVHoleCast () bv) (ITCastID)
  boxedval-not-trans (BVHoleCast () bv) (ITCastSucceed x₁)
  boxedval-not-trans (BVHoleCast GHole bv) (ITGround (MGArr x)) = x refl
  boxedval-not-trans (BVHoleCast x a) (ITExpand ())
  boxedval-not-trans (BVHoleCast x x₁) (ITCastFail x₂ () x₄)

  -- indets don't have an instruction transition
  indet-not-trans : ∀{d d'} → d indet → d →> d' → ⊥
  indet-not-trans IEHole ()
  indet-not-trans (INEHole x) ()
  indet-not-trans (IAp x₁ () x₂) (ITLam)
  indet-not-trans (IAp x (ICastArr x₁ ind) x₂) (ITApCast ) = x _ _ _ _ _ refl
  indet-not-trans (ICastArr x ind) (ITCastID) = x refl
  indet-not-trans (ICastGroundHole () ind) (ITCastID)
  indet-not-trans (ICastGroundHole x ind) (ITCastSucceed ())
  indet-not-trans (ICastGroundHole GHole ind) (ITGround (MGArr x)) = x refl
  indet-not-trans (ICastHoleGround x ind ()) (ITCastID)
  indet-not-trans (ICastHoleGround x ind x₁) (ITCastSucceed x₂) = x _ _ refl
  indet-not-trans (ICastHoleGround x ind GHole) (ITExpand (MGArr x₂)) = x₂ refl
  indet-not-trans (ICastGroundHole x a) (ITExpand ())
  indet-not-trans (ICastHoleGround x a x₁) (ITGround ())
  indet-not-trans (ICastGroundHole x x₁) (ITCastFail x₂ () x₄)
  indet-not-trans (ICastHoleGround x x₁ x₂) (ITCastFail x₃ x₄ x₅) = x _ _ refl
  indet-not-trans (IFailedCast x x₁ x₂ x₃) ()

  -- finals don't have an instruction transition
  final-not-trans : ∀{d d'} → d final → d →> d' → ⊥
  final-not-trans (FBoxedVal x) = boxedval-not-trans x
  final-not-trans (FIndet x) = indet-not-trans x

  -- finals cast from a ground are still final
  final-gnd-cast : ∀{ d τ } → d final → τ ground → (d ⟨ τ ⇒ ⦇-⦈ ⟩) final
  final-gnd-cast (FBoxedVal x) gnd = FBoxedVal (BVHoleCast gnd x)
  final-gnd-cast (FIndet x) gnd = FIndet (ICastGroundHole gnd x)

  -- if an expression results from filling a hole in an evaluation context,
  -- the hole-filler must have been final
  final-sub-final : ∀{d ε x} → d final → d == ε ⟦ x ⟧ → x final
  final-sub-final x FHOuter = x
  final-sub-final (FBoxedVal (BVVal ())) (FHAp1 eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHAp2 eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHNEHole eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHCast eps)
  final-sub-final (FBoxedVal (BVVal ())) (FHFailedCast y)
  final-sub-final (FBoxedVal (BVArrCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps
  final-sub-final (FBoxedVal (BVHoleCast x₁ x₂)) (FHCast eps) = final-sub-final (FBoxedVal x₂) eps
  final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp1 eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (IAp x₁ x₂ x₃)) (FHAp2 eps) = final-sub-final x₃ eps
  final-sub-final (FIndet (INEHole x₁)) (FHNEHole eps) = final-sub-final x₁ eps
  final-sub-final (FIndet (ICastArr x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (ICastGroundHole x₁ x₂)) (FHCast eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (ICastHoleGround x₁ x₂ x₃)) (FHCast eps) = final-sub-final (FIndet x₂) eps
  final-sub-final (FIndet (IFailedCast x₁ x₂ x₃ x₄)) (FHFailedCast y) = final-sub-final x₁ y

  final-sub-not-trans : ∀{d d' d'' ε} →  d final → d == ε ⟦ d' ⟧ → d' →> d'' → ⊥
  final-sub-not-trans f sub step = final-not-trans (final-sub-final f sub) step


module sn-calculus-confluence.potrec where

open import utility
open import sn-calculus
open import context-properties
  using (->pot-view ; ->E-view)
open import sn-calculus-confluence.helper

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
open import Esterel.Lang.CanFunction.Properties
  using (canθₛ-subset ; canθₛₕ-subset ; canθₛ-membership ; canθₛₕ-membership
       ; canθₛ-mergeˡ ; canθₛₕ-mergeˡ
       ; canθ-is-present ; canθ-is-absent
       ; canθₛₕ-emit ; canθₛ-emit
       ; term-raise ; canₛ-raise ; canₛₕ-raise
       ; term-nothin ; canₛ-term-nothin ; canₛₕ-term-nothin
       ; canₛ-if-true ; canₛ-if-false ; canₛₕ-if-true ; canₛₕ-if-false
       ; canₛ-capture-emit-signal ; canₛₕ-capture-set-shared)

open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import Esterel.Variable.Signal as Signal
  using (Signal)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)

open import Data.Bool
  using (Bool ; true ; false ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; [] ; _∷_ ; [_])
open import Data.List.Any
  using (Any ; here ; there ; any)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; _≟_ ; zero ; suc ; _+_)
open import Data.Product
  using (Σ ; Σ-syntax ; _,_ ; proj₁ ; proj₂ ; _,′_ ; _×_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function
  using (_∘_ ; id ; _∋_)
open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; trans ; cong ; subst ; module ≡-Reasoning)

open ->pot-view
open ->E-view

open term-nothin
open term-raise
open ≡-Reasoning
  using (begin_ ; _∎ ; _≡⟨_⟩_ ; _≡⟨⟩_)

open import Data.OrderedListMap Signal Signal.unwrap Signal.Status as SigM
open import Data.OrderedListMap SharedVar SharedVar.unwrap (Σ SharedVar.Status (λ _ → ℕ)) as ShrM
open import Data.OrderedListMap SeqVar SeqVar.unwrap ℕ as SeqM

ρ-pot-conf-rec : ∀{p θ ql θl qr θr p≡ql E pin qin FV₀ BV₀ A Al Ar A≡Al}
                 → {ρθ·psn⟶₁ρθl·ql : (ρ⟨ θ , A ⟩· p) sn⟶₁ (ρ⟨ θl , Al ⟩· ql)}
                 → {ρθ·psn⟶₁ρθr·qr : (ρ⟨ θ , A ⟩· p) sn⟶₁ (ρ⟨ θr , Ar ⟩· qr)}
                 → {p≐E⟦pin⟧      : p ≐ E ⟦ pin ⟧e}
                 → {qr≐E⟦qin⟧     : qr ≐ E ⟦ qin ⟧e}
                 → CorrectBinding (ρ⟨ θ , A ⟩· p) FV₀ BV₀
                 → ->pot-view ρθ·psn⟶₁ρθl·ql p≡ql A≡Al
                 → ->E-view   ρθ·psn⟶₁ρθr·qr p≐E⟦pin⟧ qr≐E⟦qin⟧
                 →
                  (ρ⟨ θl , Al ⟩· ql sn⟶₁ ρ⟨ θr , Ar ⟩· qr) ⊎
                  (Σ[ s ∈ Term ]
                   Σ[ θo ∈ Env.Env ]
                   Σ[ Ao ∈ Ctrl ]
                      (ρ⟨ θl , Al ⟩· ql) sn⟶₁ (ρ⟨ θo , Ao ⟩· s)
                    × (ρ⟨ θr , Ar ⟩· qr) sn⟶₁ (ρ⟨ θo , Ao ⟩· s))

ρ-pot-conf-rec {p} {θ} {ql} {θl} {.(E ⟦ qin ⟧e)} {θr} {_} {E} {(ρ⟨ .θin , Ain ⟩· .qin)} {qin} {_} {_} {A} {.A} {_} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)} {.(rmerge {θ} {θin} p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vmerge {.θ} {θin} {.p} {.qin} {.E})
  with Env.Sig∈ S θin
... | yes S∈Domθin
  rewrite SigMap.update-union-union S Signal.absent (Env.sig θ) (Env.sig θin) S∈ S∈Domθin
  = inj₁ (ρ⟨ θl , A ⟩· ql sn⟶₁ ρ⟨ (θl ← θin) , A-max A Ain ⟩· E ⟦ qin  ⟧e ∋ rmerge {θl} {θin} p≐E⟦pin⟧)
... | no S∉Domθin
  with Env.sig-←-irr-get {θ} {θin} {S} S∈ S∉Domθin -- θr ≡ (θ ← θin)
... | S∈Domθ←θin , θS≡⟨θ←θin⟩S
  = inj₂
    (_ , _ , A-max A Ain ,
     subst (λ { θ* → ρ⟨ θl , A ⟩· ql sn⟶₁ ρ⟨ θ* , A-max A Ain ⟩· E ⟦ qin ⟧e})
       ((Env.set-sig {S} θ S∈ Signal.absent) ← θin ≡
        Env.set-sig {S} (θ ← θin) S∈Domθ←θin Signal.absent ∋
        cong (λ sig* → Θ sig* (Env.shr (θ ← θin)) (Env.var (θ ← θin)))
          (SigMap.put-union-comm S Signal.absent (Env.sig θ) (Env.sig θin) S∉Domθin))
       (ρ⟨ θl , A ⟩· ql sn⟶₁ ρ⟨ (θl ← θin) , A-max A Ain ⟩· E ⟦ qin ⟧e ∋
        rmerge {θl} {θin} p≐E⟦pin⟧) ,′
     (ρ⟨ (θ ← θin) , A-max A Ain ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ (Env.set-sig {S} (θ ← θin) S∈Domθ←θin Signal.absent) , A-max A Ain ⟩· E ⟦ qin ⟧e ∋
      (rabsence {θr} {_} {S} S∈Domθ←θin (trans (sym θS≡⟨θ←θin⟩S) θS≡unknown)
        (λ S∈can-E⟦qin⟧-θ←θin →
          S∉can-p-θ
            (canθₛ-mergeˡ (Env.sig θ) Env.[]env cbp p≐E⟦pin⟧
              S S∉Domθin S∈can-E⟦qin⟧-θ←θin)))))

ρ-pot-conf-rec {p} {θ} {ql} {θl} {.(E ⟦ qin ⟧e)} {θr} {_} {E} {(ρ⟨ .θin , Ain ⟩· qin)} {qin} {_} {_} {A} {Al} {Ar} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)} {.(rmerge p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vmerge {.θ} {θin} {.p} {.qin} {.E})
  with Env.Shr∈ s θin
... | yes s∈Domθin
  rewrite ShrMap.update-union-union s (SharedVar.ready , Env.shr-vals {s} θ s∈) (Env.shr θ) (Env.shr θin) s∈ s∈Domθin
  = inj₁ (rmerge {θl} {θin} p≐E⟦pin⟧)
... | no s∉Domθin
  with Env.shr-←-irr-get {θ} {θin} {s} s∈ s∉Domθin
... | s∈Domθ←θin , θs≡⟨θ←θin⟩s
  = inj₂
    (_ , _ , _ ,
     subst (λ { θ* → ρ⟨ θl , A ⟩· ql sn⟶₁ ρ⟨ θ* , A-max A Ain ⟩· E ⟦ qin ⟧e })
       (cong (λ shr* → Θ (Env.sig (θ ← θin)) shr* (Env.var (θ ← θin)))
         (trans
           (cong (λ shrval* →
                   ShrMap.union
                     (ShrMap.update (Env.shr θ) s (SharedVar.ready , proj₂ shrval*))
                     (Env.shr θin))
             (ShrMap.U-∉-irr-get-help-m {_} {Env.shr θ} {Env.shr θin} {s}
                                        s∈ s∉Domθin s∈Domθ←θin ))
           (ShrMap.put-union-comm s (SharedVar.ready , Env.shr-vals {s} (θ ← θin) s∈Domθ←θin)
                                  (Env.shr θ) (Env.shr θin) s∉Domθin)))
       (rmerge {θl} {θin} p≐E⟦pin⟧) ,′
     rreadyness {θr} {_} {s} s∈Domθ←θin
       (Data.Sum.map (trans (sym θs≡⟨θ←θin⟩s)) (trans (sym θs≡⟨θ←θin⟩s))
                     θs≡old⊎θs≡new)
       (λ s∈can-E⟦qin⟧-θ←θin →
         s∉can-p-θ
           (canθₛₕ-mergeˡ (Env.sig θ) Env.[]env cbp p≐E⟦pin⟧
             s s∉Domθin s∈can-E⟦qin⟧-θ←θin)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(present _ ∣⇒ qin ∣⇒ _)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(ris-present {θ} {S'} S'∈ θS'≡present p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vis-present {.θ} {S'} {S∈ = S'∈} {θS'≡present} {.p≐E⟦pin⟧})
  with S' Signal.≟ S
... | yes refl =
  ((Signal.unknown ≡ Signal.present → _) ∋ λ ())
  (trans (trans (sym θS≡unknown) (Env.sig-stats-∈-irr {S} {θ} S∈ S'∈)) θS'≡present)
... | no S'≠S =
  inj₂
  (_ , _ , _ ,
   ris-present {θl} {S'}
     (Env.sig-set-mono' {S'} {S} {θ} {_} {S∈} S'∈)
     (Env.sig-putputget {S'} {S} {θ} S'≠S S'∈ S∈ _ θS'≡present)
     p≐E⟦pin⟧ ,′
   rabsence {θ} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦qin⟧-θ →
      S∉can-p-θ
       (subst (Signal.unwrap S ∈_)
         (cong proj₁ (sym (canθ-is-present (Env.sig θ) S'∈ Env.[]env p≐E⟦pin⟧ θS'≡present)) )
         S∈can-E⟦qin⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(present _ ∣⇒ _ ∣⇒ qin)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(ris-absent {θ} {S'} S'∈ θS'≡absent p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vis-absent {.θ} {S'} {S∈ = S'∈} {θS'≡absent} {.p≐E⟦pin⟧})
  with S' Signal.≟ S
... | yes refl =
  ((Signal.unknown ≡ Signal.absent → _) ∋ λ ())
  (trans (trans (sym θS≡unknown) (Env.sig-stats-∈-irr {S} {θ} S∈ S'∈)) θS'≡absent)
... | no S'≠S =
  inj₂
  (_ , _ , _ ,
   ris-absent {θl} {S'}
     (Env.sig-set-mono' {S'} {S} {θ} {_} {S∈} S'∈)
     (Env.sig-putputget {S'} {S} {θ} S'≠S S'∈ S∈ _ θS'≡absent)
     p≐E⟦pin⟧ ,′
   rabsence {θ} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦qin⟧-θ →
      S∉can-p-θ
       (subst (Signal.unwrap S ∈_)
         (cong proj₁ (sym (canθ-is-absent (Env.sig θ) S'∈ Env.[]env p≐E⟦pin⟧ θS'≡absent)))
         S∈can-E⟦qin⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(present _ ∣⇒ qin ∣⇒ _)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(ris-present {θ} {S'} S'∈ θS'≡present p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vis-present {.θ} {S'} {S∈ = S'∈} {θS'≡present} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   ris-present {θl} {S'} S'∈ θS'≡present p≐E⟦pin⟧ ,′
   rreadyness {θ} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦qin⟧-θ →
       s∉can-p-θ
         (subst (SharedVar.unwrap s ∈_)
           (cong (proj₂ ∘ proj₂)
             (sym (canθ-is-present (Env.sig θ) S'∈ Env.[]env p≐E⟦pin⟧ θS'≡present)))
           s∈can-E⟦qin⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(present _ ∣⇒ _ ∣⇒ qin)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(ris-absent {θ} {S'} S'∈ θS'≡absent p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vis-absent {.θ} {S'} {S∈ = S'∈} {θS'≡absent} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   ris-absent {θl} {S'} S'∈ θS'≡absent p≐E⟦pin⟧ ,′
   rreadyness {θ} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦qin⟧-θ →
       s∉can-p-θ
         (subst (SharedVar.unwrap s ∈_)
           (cong (proj₂ ∘ proj₂)
             (sym (canθ-is-absent (Env.sig θ) S'∈ Env.[]env p≐E⟦pin⟧ θS'≡absent)))
           s∈can-E⟦qin⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr} {_} {E}
               {.(emit S')} {.nothin} {_} {_} {_} {_} {_} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(remit {θ} {p} {S'} S'∈ θS'≢absent p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vemit {.θ} {.p} {S'} {.E} {S'∈} {θS'≢absent} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   remit {θl} {_} {S'} S'∈ θS'≢absent p≐E⟦pin⟧ ,′
   rreadyness {θr} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦nothin⟧-θr →
       s∉can-p-θ
         (canθₛₕ-emit θ S'∈ Env.[]env p≐E⟦pin⟧
           θS'≢absent
           (canθₛ-membership (Env.sig θ) 0 p Env.[]env S'
             (λ θ* → canₛ-capture-emit-signal θ* p≐E⟦pin⟧))
           s s∈can-E⟦nothin⟧-θr)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr} {_} {E}
               {.(emit S')} {.nothin} {_} {_} {A} {Al} {Ar} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(remit {θ} {p} {S'} S'∈ θS'≢absent p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧}
               (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vemit {.θ} {.p} {S'} {.E} {S'∈} {θS'≢absent} {.p≐E⟦pin⟧})
  with S' Signal.≟ S
... | yes refl =
  ⊥-elim
    (S∉can-p-θ
      (canθₛ-membership (Env.sig θ) 0 p Env.[]env S'
        (λ θ* → canₛ-capture-emit-signal θ* p≐E⟦pin⟧)))
... | no S'≢S =
  inj₂
  (_ , _ , _ ,
   remit {θl} {_} {S'}
     (SigMap.insert-mono {_} {S'} {Env.sig θ} {S} {Signal.absent} S'∈)
     (θS'≢absent ∘
      trans
        (sym (SigMap.putputget {_} {Env.sig θ} {S'} {S}
               {_} {Signal.absent} S'≢S S'∈ S'∈Domθl refl)))
     p≐E⟦pin⟧ ,′
   subst (λ sig* → ρ⟨ θr , Ar ⟩· E ⟦ nothin ⟧e sn⟶₁ ρ⟨ (Θ sig* (Env.shr θ) (Env.var θ)) , Ar ⟩· E ⟦ nothin ⟧e)
     (SigMap.put-comm {_} {Env.sig θ} {_} {_} {Signal.present} {Signal.absent} S'≢S)
     (rabsence {θr} {_} {S}
       S∈Domθr
       (SigMap.putputget {_} {Env.sig θ} {S} {S'} {_} {Signal.present}
        (S'≢S ∘ sym) S∈ S∈Domθr θS≡unknown)
       (λ S''∈can-E⟦nothin⟧-θr →
         S∉can-p-θ
           (canθₛ-emit θ S'∈ Env.[]env p≐E⟦pin⟧
             θS'≢absent
             (canθₛ-membership (Env.sig θ) 0 p Env.[]env S'
               (λ θ* → canₛ-capture-emit-signal θ* p≐E⟦pin⟧))
             S S''∈can-E⟦nothin⟧-θr))))
  where S∈Domθr = SigMap.insert-mono {_} {S} {Env.sig θ} {S'} {Signal.present} S∈
        S'∈Domθl = SigMap.insert-mono {_} {S'} {Env.sig θ} {S} {Signal.absent} S'∈

ρ-pot-conf-rec {p} {θ} {.p} {θl}
               {.(E ⟦ ρ⟨ (Θ SigMap.empty ShrMap.[ s' ↦ (SharedVar.old , δ e') ] VarMap.empty) , WAIT ⟩· p' ⟧e)}
               {.θ} {_} {E}
               {.(shared s' ≔ e in: p')}
               {.(ρ⟨ (Θ SigMap.empty ShrMap.[ s' ↦ (SharedVar.old , δ e') ] VarMap.empty) , WAIT ⟩· p')}
               {_} {_} {A} {Al} {Ar} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rraise-shared e' p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vraise-shared {.θ} {.p} {s'} {e} {p'} {.E} {e'} {.p≐E⟦pin⟧})
  with ready-maint/irr S S∈ Signal.absent e'
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
           (ρ⟨ θl , Al ⟩· p) sn⟶₁
           (ρ⟨ θl , Al ⟩· E ⟦ ρ⟨ ([s,δe]-env s' δe*) , WAIT ⟩· p' ⟧e))
     (sym δe'≡δe'')
     (rraise-shared e'' p≐E⟦pin⟧) ,′
   rabsence {θ} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦ρΘp'⟧-θ →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ ρ⟨ ([s,δe]-env s' (δ e')) , WAIT ⟩· p' ⟧e) p Env.[]env
           (λ θ* S* → canₛ-raise θ* (tshared (δ e') s' e p') p≐E⟦pin⟧ S*)
           S S∈can-E⟦ρΘp'⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl}
               {.(E ⟦ ρ⟨ (Θ SigMap.empty ShrMap.[ s' ↦ (SharedVar.old , δ e') ] VarMap.empty) , WAIT ⟩· p' ⟧e)}
               {.θ} {_} {E}
               {.(shared s' ≔ e in: p')}
               {.(ρ⟨ (Θ SigMap.empty ShrMap.[ s' ↦ (SharedVar.old , δ e') ] VarMap.empty) , WAIT ⟩· p')}
               {_} {_} {A} {Al} {Ar} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rraise-shared e' p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vraise-shared {.θ} {.p} {s'} {e} {p'} {.E} {e'} {.p≐E⟦pin⟧})
  with ready-irr-on-irr-s/ready {θ} {e} s (Env.shr-vals {s} θ s∈) s∈ (θs≢ready θs≡old⊎θs≡new)
         e'
  where θs≢ready : typeof θs≡old⊎θs≡new → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready)
        θs≢ready (inj₁ θs≡old) θs≡ready with trans (sym θs≡old) θs≡ready
        ... | ()
        θs≢ready (inj₂ θs≡new) θs≡ready with trans (sym θs≡new) θs≡ready
        ... | ()
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
           (ρ⟨ θl , Al ⟩· p) sn⟶₁
           (ρ⟨ θl , Al ⟩· E ⟦ ρ⟨ ([s,δe]-env s' δe*) , WAIT ⟩· p' ⟧e))
     (sym δe'≡δe'')
     (rraise-shared e'' p≐E⟦pin⟧) ,′
   rreadyness {θ} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦ρΘp'⟧-θ →
       s∉can-p-θ
         (canθₛₕ-subset (Env.sig θ) 0
           (E ⟦ ρ⟨ ([s,δe]-env s' (δ e')) , WAIT ⟩· p' ⟧e) p Env.[]env
           (λ θ* S* → canₛ-raise θ* (tshared (δ e') s' e p') p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-raise θ* (tshared (δ e') s' e p') p≐E⟦pin⟧ s*)
           s s∈can-E⟦ρΘp'⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr} {_} {E}
               {.(s' ⇐ e)} {.nothin} {_} {_} {GO} {GO} {GO} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rset-shared-value-old {θ} {p} {s'} e' s'∈ θs'≡old p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vset-shared-value-old {.θ} {.p} {s'} {e} {.E} {e'} {s'∈} {θs'≡old})
  with ready-maint/irr S S∈ Signal.absent e'
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
            ρ⟨ θl , GO ⟩· p sn⟶₁
            ρ⟨ (θl-set-shr δe*) , GO ⟩· E ⟦ nothin ⟧e)
     (sym δe'≡δe'')
     (rset-shared-value-old {θl} {_} {s'} e'' s'∈ θs'≡old p≐E⟦pin⟧) ,′
   rabsence {θr} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦nothin⟧-θr →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ nothin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-shr s' e) p≐E⟦pin⟧ S*)
           S S∈can-E⟦nothin⟧-θr)))
  where
    θl-set-shr : ℕ → Env
    θl-set-shr n = Env.set-shr {s'} θl s'∈ SharedVar.new n

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr} {_} {E}
               {.(s' ⇐ e)} {.nothin} {_} {_} {GO} {GO} {GO} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rset-shared-value-old {θ} {p} {s'} e' s'∈ θs'≡old p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vset-shared-value-old {.θ} {.p} {s'} {e} {.E} {e'} {s'∈} {θs'≡old})
  with s SharedVar.≟ s'
... | yes refl =
  ⊥-elim
    (s∉can-p-θ
      (canθₛₕ-membership (Env.sig θ) 0 p Env.[]env s
        (λ θ* → canₛₕ-capture-set-shared θ* p≐E⟦pin⟧)))
... | no  s≢s'
  with ready-irr-on-irr-s/ready {θ} {e} s (Env.shr-vals {s} θ s∈) s∈ (θs≢ready θs≡old⊎θs≡new)
         e'
  where θs≢ready : typeof θs≡old⊎θs≡new → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready)
        θs≢ready (inj₁ θs≡old) θs≡ready with trans (sym θs≡old) θs≡ready
        ... | ()
        θs≢ready (inj₂ θs≡new) θs≡ready with trans (sym θs≡new) θs≡ready
        ... | ()
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ shr* →
           ρ⟨ θl , GO ⟩· p sn⟶₁
           ρ⟨ (Θ (Env.sig θl) shr* (Env.var θl)) , GO ⟩·
             E ⟦ nothin ⟧e)
   (cong Env.shr
     (begin
       Env.set-shr {s'} θl s'∈Domθl SharedVar.new (δ e'')
         ≡⟨ cong (Env.set-shr {s'} θl s'∈Domθl SharedVar.new) (sym δe'≡δe'') ⟩
       Env.set-shr {s'} θl s'∈Domθl SharedVar.new (δ e')
         ≡⟨ cong (λ sig* → Θ (Env.sig θ) sig* (Env.var θ))
              (ShrMap.put-comm {_} {Env.shr θ} {_} {_}
                {SharedVar.ready ,′ θs}
                {SharedVar.new ,′ δ e'}
                s≢s') ⟩
       Env.set-shr {s} θr s∈Domθr SharedVar.ready θs
         ≡⟨ cong (Env.set-shr {s} θr s∈Domθr SharedVar.ready ∘ proj₂) (sym θrs≡θs) ⟩
       Env.set-shr {s} θr s∈Domθr SharedVar.ready
         (Env.shr-vals {s} θr s∈Domθr)                  ∎))
   (rset-shared-value-old {θl} {_} {s'} e'' s'∈Domθl
     (trans (cong proj₁ θls'≡θs') θs'≡old) p≐E⟦pin⟧) ,′
   rreadyness {θr} {_} {s} s∈Domθr
     (Data.Sum.map (trans (cong proj₁ θrs≡θs)) (trans (cong proj₁ θrs≡θs))
       θs≡old⊎θs≡new)
     (λ s∈can-E⟦nothin⟧-θr →
       s∉can-p-θ
         (canθₛₕ-subset (Env.sig θ) 0 (E ⟦ nothin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-shr s' e) p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-term-nothin θ* θ* refl (tset-shr s' e) p≐E⟦pin⟧ s*)
           s s∈can-E⟦nothin⟧-θr)))
  where
    θs = Env.shr-vals {s} θ s∈
    s∈Domθr = Env.shr-set-mono' {s} {s'} {θ} {SharedVar.new} {δ e'} {s'∈} s∈
    θrs≡θs = ShrMap.putputget {_} {Env.shr θ} {_} {_} {_} {SharedVar.new ,′ δ e'}
               s≢s' s∈ s∈Domθr refl
    s'∈Domθl = Env.shr-set-mono' {s'} {s} {θ} {SharedVar.ready} {θs} {s∈} s'∈
    θls'≡θs' = ShrMap.putputget {_} {Env.shr θ} {_} {_} {_} {SharedVar.ready ,′ θs}
                (s≢s' ∘ sym) s'∈ s'∈Domθl refl

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr} {_} {E}
               {.(s' ⇐ e)} {.nothin} {_} {_} {GO} {GO} {GO} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rset-shared-value-new {θ} {p} {s'} e' s'∈ θs'≡new p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vset-shared-value-new {.θ} {.p} {s'} {e} {.E} {e'} {s'∈} {θs'≡new})
  with ready-maint/irr S S∈ Signal.absent e'
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
            ρ⟨ θl , GO ⟩· p sn⟶₁
            ρ⟨ (θl-set-shr δe*) , GO ⟩· E ⟦ nothin ⟧e)
     (cong
       (Env.shr-vals {s'} θ s'∈ +_)
       (sym δe'≡δe''))
     (rset-shared-value-new {θl} {_} {s'} e'' s'∈ θs'≡new p≐E⟦pin⟧) ,′
   rabsence {θr} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦nothin⟧-θr →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ nothin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-shr s' e) p≐E⟦pin⟧ S*)
           S S∈can-E⟦nothin⟧-θr)))
  where
    θl-set-shr : ℕ → Env
    θl-set-shr n = Env.set-shr {s'} θl s'∈ SharedVar.new n

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr} {_} {E}
               {.(s' ⇐ e)} {.nothin} {_} {_} {GO} {GO} {GO} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rset-shared-value-new {θ} {p} {s'} e' s'∈ θs'≡new p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vset-shared-value-new {.θ} {.p} {s'} {e} {.E} {e'} {s'∈} {θs'≡new})
  with s SharedVar.≟ s'
... | yes refl =
  ⊥-elim
    (s∉can-p-θ
      (canθₛₕ-membership (Env.sig θ) 0 p Env.[]env s
        (λ θ* → canₛₕ-capture-set-shared θ* p≐E⟦pin⟧)))
... | no  s≢s'
  with ready-irr-on-irr-s/ready {θ} {e} s (Env.shr-vals {s} θ s∈) s∈ (θs≢ready θs≡old⊎θs≡new)
         e'
  where θs≢ready : typeof θs≡old⊎θs≡new → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready)
        θs≢ready (inj₁ θs≡old) θs≡ready with trans (sym θs≡old) θs≡ready
        ... | ()
        θs≢ready (inj₂ θs≡new) θs≡ready with trans (sym θs≡new) θs≡ready
        ... | ()
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ shr* →
           ρ⟨ θl , GO ⟩· p sn⟶₁
           ρ⟨ (Θ (Env.sig θl) shr* (Env.var θl)) , GO ⟩·
             E ⟦ nothin ⟧e)
   (cong Env.shr
     (begin
       Env.set-shr {s'} θl s'∈Domθl SharedVar.new (Env.shr-vals {s'} θl s'∈Domθl + δ e'')
         ≡⟨ cong
             (λ v* → Env.set-shr {s'} θl s'∈Domθl SharedVar.new (v* + δ e''))
             (cong proj₂ θls'≡θs') ⟩
       Env.set-shr {s'} θl s'∈Domθl SharedVar.new (θs' + δ e'')
         ≡⟨ cong (λ v* → Env.set-shr {s'} θl s'∈Domθl SharedVar.new
                   (θs' + v*))
                   (sym δe'≡δe'') ⟩
       Env.set-shr {s'} θl s'∈Domθl SharedVar.new (θs' + δ e')
         ≡⟨ cong (λ sig* → Θ (Env.sig θ) sig* (Env.var θ))
              (ShrMap.put-comm {_} {Env.shr θ} {_} {_}
                {SharedVar.ready ,′ θs}
                {SharedVar.new ,′ θs' + δ e'}
                s≢s') ⟩
       Env.set-shr {s} θr s∈Domθr SharedVar.ready θs
         ≡⟨ cong (Env.set-shr {s} θr s∈Domθr SharedVar.ready ∘ proj₂) (sym θrs≡θs) ⟩
       Env.set-shr {s} θr s∈Domθr SharedVar.ready
         (Env.shr-vals {s} θr s∈Domθr)                  ∎))
   (rset-shared-value-new {θl} {_} {s'} e'' s'∈Domθl
     (trans (cong proj₁ θls'≡θs') θs'≡new) p≐E⟦pin⟧) ,′
   rreadyness {θr} {_} {s} s∈Domθr
     (Data.Sum.map (trans (cong proj₁ θrs≡θs)) (trans (cong proj₁ θrs≡θs))
       θs≡old⊎θs≡new)
     (λ s∈can-E⟦nothin⟧-θr →
       s∉can-p-θ
         (canθₛₕ-subset (Env.sig θ) 0 (E ⟦ nothin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-shr s' e) p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-term-nothin θ* θ* refl (tset-shr s' e) p≐E⟦pin⟧ s*)
           s s∈can-E⟦nothin⟧-θr)))
  where
    θs' = Env.shr-vals {s'} θ s'∈
    θs = Env.shr-vals {s} θ s∈
    s∈Domθr = Env.shr-set-mono' {s} {s'} {θ} {SharedVar.new} {θs' + δ e'} {s'∈} s∈
    θrs≡θs = ShrMap.putputget {_} {Env.shr θ} {_} {_} {_} {SharedVar.new ,′ θs' + δ e'}
               s≢s' s∈ s∈Domθr refl
    s'∈Domθl = Env.shr-set-mono' {s'} {s} {θ} {SharedVar.ready} {θs} {s∈} s'∈
    θls'≡θs' = ShrMap.putputget {_} {Env.shr θ} {_} {_} {_} {SharedVar.ready ,′ θs}
                (s≢s' ∘ sym) s'∈ s'∈Domθl refl

ρ-pot-conf-rec {p} {θ} {.p} {θl}
               {.(E ⟦ ρ⟨ (Θ SigMap.empty ShrMap.empty VarMap.[ x ↦ δ e' ]) , WAIT ⟩· p' ⟧e)}
               {.θ} {_} {E}
               {.(var x ≔ e in: p')}
               {.(ρ⟨ (Θ SigMap.empty ShrMap.empty VarMap.[ x ↦ δ e' ]) , WAIT ⟩· p')}
               {_} {_} {A} {.A} {.A} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rraise-var {θ} {p} {x} {p'} {e} e' p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vraise-var {.θ} {.p} {x} {p'} {e} {.E} {e'} {.p≐E⟦pin⟧})
  with ready-maint/irr S S∈ Signal.absent e'
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
           (ρ⟨ θl , A ⟩· p) sn⟶₁
           (ρ⟨ θl , A ⟩· E ⟦ ρ⟨ ([x,δe]-env x δe*) , WAIT ⟩· p' ⟧e))
    (sym δe'≡δe'')
    (rraise-var {θl} {_} {x} {p'} {e} e'' p≐E⟦pin⟧) ,′
   rabsence {θ} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦ρΘp'⟧-θ →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ ρ⟨ [x,δe]-env x (δ e') , WAIT ⟩· p' ⟧e) p Env.[]env
           (λ θ* S* → canₛ-raise θ* (tvar (δ e') x e p') p≐E⟦pin⟧ S*)
           S S∈can-E⟦ρΘp'⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl}
               {.(E ⟦ ρ⟨ (Θ SigMap.empty ShrMap.empty VarMap.[ x ↦ δ e' ]) , WAIT ⟩· p' ⟧e)}
               {.θ} {_} {E}
               {.(var x ≔ e in: p')}
               {.(ρ⟨ (Θ SigMap.empty ShrMap.empty VarMap.[ x ↦ δ e' ]) , WAIT ⟩· p')}
               {_} {_} {A} {.A} {.A} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rraise-var {θ} {p} {x} {p'} {e} e' p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vraise-var {.θ} {.p} {x} {p'} {e} {.E} {e'} {.p≐E⟦pin⟧})
  with ready-irr-on-irr-s/ready {θ} {e} s (Env.shr-vals {s} θ s∈) s∈ (θs≢ready θs≡old⊎θs≡new)
         e'
  where θs≢ready : typeof θs≡old⊎θs≡new → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready)
        θs≢ready (inj₁ θs≡old) θs≡ready with trans (sym θs≡old) θs≡ready
        ... | ()
        θs≢ready (inj₂ θs≡new) θs≡ready with trans (sym θs≡new) θs≡ready
        ... | ()
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
           (ρ⟨ θl , A ⟩· p) sn⟶₁
           (ρ⟨ θl , A ⟩· E ⟦ ρ⟨ ([x,δe]-env x δe*) , WAIT ⟩· p' ⟧e))
    (sym δe'≡δe'')
    (rraise-var {θl} {_} {x} {p'} {e} e'' p≐E⟦pin⟧) ,′
   rreadyness {θ} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦ρΘp'⟧-θ →
       s∉can-p-θ
         (canθₛₕ-subset (Env.sig θ) 0 (E ⟦ ρ⟨ [x,δe]-env x (δ e') , WAIT ⟩· p' ⟧e) p Env.[]env
           (λ θ* S* → canₛ-raise θ* (tvar (δ e') x e p') p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-raise θ* (tvar (δ e') x e p') p≐E⟦pin⟧ s*)
           s s∈can-E⟦ρΘp'⟧-θ)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr}
               {_} {E} {.(x ≔ e)} {.nothin} {_} {_} {A} {.A} {.A} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rset-var {θ} {p} {x} {e} x∈ e' p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vset-var {.θ} {.p} {x} {e} {.E} {x∈} {e'} {.p≐E⟦pin⟧})
  with ready-maint/irr S S∈ Signal.absent e'
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
            ρ⟨ θl , A ⟩· p sn⟶₁
            ρ⟨ (θl-set-var δe*) , A ⟩· E ⟦ nothin ⟧e)
     (sym δe'≡δe'')
   (rset-var {θl} {_} {x} {e} x∈ e'' p≐E⟦pin⟧) ,′
   rabsence {θr} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦nothin⟧-θ' →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ nothin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-var x e) p≐E⟦pin⟧ S*)
           S S∈can-E⟦nothin⟧-θ')))
  where
    θl-set-var : ℕ → Env
    θl-set-var n = Env.set-var {x} θl x∈ n

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ nothin ⟧e)} {θr}
               {_} {E} {.(x ≔ e)} {.nothin} {_} {_} {A} {.A} {.A} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rset-var {θ} {p} {x} {e} x∈ e' p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vset-var {.θ} {.p} {x} {e} {.E} {x∈} {e'} {.p≐E⟦pin⟧})
  with ready-irr-on-irr-s/ready {θ} {e} s (Env.shr-vals {s} θ s∈) s∈ (θs≢ready θs≡old⊎θs≡new)
         e'
  where θs≢ready : typeof θs≡old⊎θs≡new → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready)
        θs≢ready (inj₁ θs≡old) θs≡ready with trans (sym θs≡old) θs≡ready
        ... | ()
        θs≢ready (inj₂ θs≡new) θs≡ready with trans (sym θs≡new) θs≡ready
        ... | ()
... | e'' , δe'≡δe'' =
  inj₂
  (_ , _ , _ ,
   subst (λ δe* →
            ρ⟨ θl , A ⟩· p sn⟶₁
            ρ⟨ (θl-set-var δe*) , A ⟩· E ⟦ nothin ⟧e)
     (sym δe'≡δe'')
   (rset-var {θl} {_} {x} {e} x∈ e'' p≐E⟦pin⟧) ,′
   rreadyness {θr} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦nothin⟧-θ' →
       s∉can-p-θ
         (canθₛₕ-subset (Env.sig θ) 0 (E ⟦ nothin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-var x e) p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-term-nothin θ* θ* refl (tset-var x e) p≐E⟦pin⟧ s*)
           s s∈can-E⟦nothin⟧-θ')))
  where
    θl-set-var : ℕ → Env
    θl-set-var n = Env.set-var {x} θl x∈ n

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(if x ∣⇒ th ∣⇒ qin)} {qin} {_} {_}  {_} {_} {_} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rif-false {x = x} x∈ θx≡zero p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vif-false {.θ} {.p} {th} {.qin} {x} {.E} {x∈} {θx≡zero} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   rif-false {x = x} x∈ θx≡zero p≐E⟦pin⟧ ,′
   rabsence {θ} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦qin⟧ →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ qin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-if-false θ* p≐E⟦pin⟧ S*)
           S S∈can-E⟦qin⟧)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(if x ∣⇒ th ∣⇒ qin)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rif-false {x = x} x∈ θx≡zero p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vif-false {.θ} {.p} {th} {.qin} {x} {.E} {x∈} {θx≡zero} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   rif-false {x = x} x∈ θx≡zero p≐E⟦pin⟧ ,′
   rreadyness {θ} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦qin⟧ →
       s∉can-p-θ
        (canθₛₕ-subset (Env.sig θ) 0 (E ⟦ qin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-if-false θ* p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-if-false θ* p≐E⟦pin⟧ s*)
           s s∈can-E⟦qin⟧)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(if x ∣⇒ qin ∣⇒ els)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
               {.(rif-true {x = x} {E} {n} x∈ θx≡suc p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vabsence S S∈ θS≡unknown S∉can-p-θ)
               (vif-true {.θ} {.p} {.qin} {els} {x} {.E} {n} {x∈} {θx≡suc} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   rif-true {x = x} x∈ θx≡suc p≐E⟦pin⟧ ,′
   rabsence {θ} {_} {S} S∈ θS≡unknown
     (λ S∈can-E⟦qin⟧ →
       S∉can-p-θ
         (canθₛ-subset (Env.sig θ) 0 (E ⟦ qin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-if-true θ* p≐E⟦pin⟧ S*)
           S  S∈can-E⟦qin⟧)))

ρ-pot-conf-rec {p} {θ} {.p} {θl} {.(E ⟦ qin ⟧e)} {.θ} {_} {E}
               {.(if x ∣⇒ qin ∣⇒ els)} {qin} {_} {_} {_} {_} {_} {_}
               {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
               {.(rif-true {x = x} {E} {n} x∈ θx≡suc p≐E⟦pin⟧)}
               {p≐E⟦pin⟧} {qr≐E⟦qin⟧} (CBρ cbp)
               (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
               (vif-true {.θ} {.p} {.qin} {els} {x} {.E} {n} {x∈} {θx≡suc} {.p≐E⟦pin⟧}) =
  inj₂
  (_ , _ , _ ,
   rif-true {x = x} x∈ θx≡suc p≐E⟦pin⟧ ,′
   rreadyness {θ} {_} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-E⟦qin⟧ →
       s∉can-p-θ
         (canθₛₕ-subset (Env.sig θ) 0 (E ⟦ qin ⟧e) p Env.[]env
           (λ θ* S* → canₛ-if-true θ* p≐E⟦pin⟧ S*)
           (λ θ* s* → canₛₕ-if-true θ* p≐E⟦pin⟧ s*)
           s s∈can-E⟦qin⟧)))