module Generic.Property.Reify where

open import Generic.Core

data ExplView : Visibility -> Set where
  yes-expl : ExplView expl
  no-expl  : ∀ {v} -> ExplView v

explView : ∀ v -> ExplView v
explView expl = yes-expl
explView v    = no-expl

ExplMaybe : ∀ {α} -> Visibility -> Set α -> Set α
ExplMaybe v A with explView v
... | yes-expl = A
... | no-expl  = ⊤

caseExplMaybe : ∀ {α π} {A : Set α} (P : Visibility -> Set π)
              -> (A -> P expl) -> (∀ {v} -> P v) -> ∀ v -> ExplMaybe v A -> P v
caseExplMaybe P f y v x with explView v
... | yes-expl = f x
... | no-expl  = y

Prod : ∀ {α} β -> Visibility -> Set α -> Set (α ⊔ β) -> Set (α ⊔ β)
Prod β v A B with explView v
... | yes-expl = A × B
... | no-expl  = B

uncurryProd : ∀ {α β γ} {A : Set α} {B : Set (α ⊔ β)} {C : Set γ} v
            -> Prod β v A B -> (ExplMaybe v A -> B -> C) -> C
uncurryProd v p g with explView v | p
... | yes-expl | (x , y) = g x  y
... | no-expl  |  y      = g tt y

SemReify : ∀ {i β} {I : Set i} -> Desc I β -> Set
SemReify (var i)   = ⊤
SemReify (π i q C) = ⊥
SemReify (D ⊛ E)   = SemReify D × SemReify E

mutual
  ExtendReify : ∀ {i β} {I : Set i} -> Desc I β -> Set β
  ExtendReify (var i)   = ⊤
  ExtendReify (π i q C) = ExtendReifyᵇ i C q
  ExtendReify (D ⊛ E)   = SemReify D × ExtendReify E

  ExtendReifyᵇ : ∀ {ι α β γ q} {I : Set ι} i -> Binder α β γ i q I -> α ≤ℓ β -> Set β
  ExtendReifyᵇ {β = β} i (coerce (A , D)) q = Coerce′ q $
    Prod β (visibility i) (Reify A) (∀ {x} -> ExtendReify (D x))

-- Can't reify an irrelevant thing into its relevant representation.
postulate
  reifyᵢ : ∀ {α} {A : Set α} {{aReify : Reify A}} -> .A -> Term

instance
  {-# TERMINATING #-}
  DataReify : ∀ {i β} {I : Set i} {D : Data (Desc I β)} {j}
                {{reD : All ExtendReify (consTypes D)}} -> Reify (μ D j)
  DataReify {ι} {β} {I} {D₀} = record { reify = reifyMu } where
    mutual
      reifySem : ∀ D {{reD : SemReify D}} -> ⟦ D ⟧ (μ D₀) -> Term
      reifySem (var i)                  d      = reifyMu d
      reifySem (π i q C) {{()}}
      reifySem (D ⊛ E)   {{reD , reE}} (x , y) =
        sate _,_ (reifySem D {{reD}} x) (reifySem E {{reE}} y)

      reifyExtend : ∀ {j} D {{reD : ExtendReify D}} -> Extend D (μ D₀) j -> List Term
      reifyExtend (var i)                  lrefl  = []
      reifyExtend (π i q C)                p      = reifyExtendᵇ i C q p
      reifyExtend (D ⊛ E)   {{reD , reE}} (x , e) =
        reifySem D {{reD}} x ∷ reifyExtend E {{reE}} e

      reifyExtendᵇ : ∀ {α γ q j} i (C : Binder α β γ i q I) q′ {{reC : ExtendReifyᵇ i C q′}}
                   -> Extendᵇ i C q′ (μ D₀) j -> List Term
      reifyExtendᵇ i (coerce (A , D)) q {{reC}} p =
        uncurryProd (visibility i) (uncoerce′ q reC) λ mreA reD -> split q p λ x e ->
          let es = reifyExtend (D x) {{reD}} e in
            caseExplMaybe _ (λ reA -> elimRelValue _ (reify {{reA}}) (reifyᵢ {{reA}}) x ∷ es)
                             es
                            (visibility i)
                             mreA

      reifyDesc : ∀ {j} D {{reD : ExtendReify D}} -> Name -> Extend D (μ D₀) j -> Term
      reifyDesc D n e = vis appCon n (reifyExtend D e)

      reifyAny : ∀ {j} (Ds : List (Desc I β)) {{reD : All ExtendReify Ds}}
               -> ∀ d a b ns -> Node D₀ (packData d a b Ds ns) j -> Term
      reifyAny  []                         d a b  tt       ()
      reifyAny (D ∷ [])     {{reD , _}}    d a b (n , ns)  e       = reifyDesc D {{reD}} n e
      reifyAny (D ∷ E ∷ Ds) {{reD , reDs}} d a b (n , ns) (inj₁ e) = reifyDesc D {{reD}} n e
      reifyAny (D ∷ E ∷ Ds) {{reD , reDs}} d a b (n , ns) (inj₂ r) =
        reifyAny (E ∷ Ds) {{reDs}} d a b ns r

      reifyMu : ∀ {j} -> μ D₀ j -> Term
      reifyMu (node e) = reifyAny (consTypes D₀)
                                  (dataName  D₀)
                                  (parsTele  D₀)
                                  (indsTele  D₀)
                                  (consNames D₀)
                                   e


module sn-calculus-compatconf.same where

open import sn-calculus-compatconf.base

open import sn-calculus
open import sn-calculus-confluence.helper
  using (ready-irr-on-irr-θʳ)
open import utility renaming (_U̬_ to _∪_)
open import context-properties
  using (get-view ; wrap-rho
       ; ->E-view ; ->pot-view ; wrap-rho-pot' ; unwrap-rho
       )

open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Lang.Binding
open import Esterel.Lang.CanFunction
  using (Can ; Canₛ ; Canₛₕ ; Canₖ ; Canθ ; Canθₛ ; Canθₛₕ ; module CodeSet)
open import Esterel.Lang.CanFunction.Properties
  using (canθₛ-mergeʳ ; canθₛₕ-mergeʳ)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Context.Properties
  using (unplug ; unplugc ; plug ; plugc ; unplug-eq ; ⟦⟧c-to-⟦⟧e)
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 Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; cong ; trans ; subst ; subst₂ ; module ≡-Reasoning)
open import Data.Bool
  using (Bool ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; _∷_ ; [] ; _++_ ; map)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using ()
  renaming ( ++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ )
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _+_) renaming (_⊔_ to _⊔ℕ_)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; _×_ ; ∃)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function using (_∘_ ; id ; _∋_ ; _$_)

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

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

open EvaluationContext1
open _≐_⟦_⟧e
open Context1
open _≐_⟦_⟧c

open ListSet Data.Nat._≟_

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

{-
Modified proof from the old E-lift C-any confluence lemma.
Basically this is arbitrary multi-wrap-rho given the correct binding
of p: from a reduction (where E ⟦ ρ θ · qin ⟧ has correct binding)

    E ⟦ ρ θ · qin ⟧ sn⟶₁ E ⟦ ρ θr · ro ⟧

construct the E-wrapped reduction

    ρ θ · E ⟦ qin ⟧ sn⟶₁ ρ θr · E ⟦ ro ⟧
          ( = q )             ( = r )
-}
conf-lift-lemma : ∀ {E qin ro p q θ θr BV FV A Ar} →
  CorrectBinding p BV FV →

  p ≐ E ⟦ ρ⟨ θ , A ⟩· qin ⟧e →
  q ≐ E ⟦ qin ⟧e →

  ρ⟨ θ , A ⟩· qin sn⟶₁ ρ⟨ θr , Ar ⟩· ro →

  ∃ λ r →
    r ≐ E ⟦ ro ⟧e ×
    ρ⟨ θ , A ⟩· q sn⟶₁ ρ⟨ θr , Ar ⟩· r

conf-lift-lemma cb dehole dehole ρθ·pinsn⟶₁ρθq·qin = _ , dehole , ρθ·pinsn⟶₁ρθq·qin

conf-lift-lemma cb@(CBpar cbp' cbq' _ _ _ _) (depar₁ p≐E⟦ρθ·pin⟧) (depar₁ r≐E⟦pin⟧) ρθ·pinsn⟶₁ρθq·qin
  with conf-lift-lemma cbp' p≐E⟦ρθ·pin⟧ r≐E⟦pin⟧ ρθ·pinsn⟶₁ρθq·qin
... | q , q≐E⟦qin⟧ , ρθ·rsn⟶₁ρθq·q
  with get-view ρθ·rsn⟶₁ρθq·q
... | inj₁ (E' , pin' , qin' , r≐E'⟦pin'⟧ , q≐E'⟦qin'⟧ , e-view) =
  _ , depar₁ q≐E⟦qin⟧ ,′
  proj₁ (wrap-rho ρθ·rsn⟶₁ρθq·q r≐E'⟦pin'⟧ q≐E'⟦qin'⟧ e-view _
          (depar₁ r≐E'⟦pin'⟧) (depar₁ q≐E'⟦qin'⟧))
... | inj₂ (refl , refl , pot) with wrap-rho-pot' (depar₁ p≐E⟦ρθ·pin⟧) cb ρθ·rsn⟶₁ρθq·q pot
... | _ , depar₁ dehole , ρθ·p'∥tsn⟶₁ρθq·p'∥t , pot' = -- need pattern matching for LHS of sn⟶₁
  _ , depar₁ q≐E⟦qin⟧ ,′
    ρθ·p'∥tsn⟶₁ρθq·p'∥t

conf-lift-lemma cb@(CBpar cbp' cbq' _ _ _ _) (depar₂ p≐E⟦ρθ·pin⟧) (depar₂ r≐E⟦pin⟧) ρθ·pinsn⟶₁ρθq·qin
  with conf-lift-lemma cbq' p≐E⟦ρθ·pin⟧ r≐E⟦pin⟧ ρθ·pinsn⟶₁ρθq·qin
... | q , q≐E⟦qin⟧ , ρθ·rsn⟶₁ρθq·q
  with get-view ρθ·rsn⟶₁ρθq·q
... | inj₁ (E' , pin' , qin' , r≐E'⟦pin'⟧ , q≐E'⟦qin'⟧ , e-view) =
  _ , depar₂ q≐E⟦qin⟧ ,′
  proj₁ (wrap-rho ρθ·rsn⟶₁ρθq·q r≐E'⟦pin'⟧ q≐E'⟦qin'⟧ e-view _
          (depar₂ r≐E'⟦pin'⟧) (depar₂ q≐E'⟦qin'⟧))
... | inj₂ (refl , refl , pot) with wrap-rho-pot' (depar₂ p≐E⟦ρθ·pin⟧) cb ρθ·rsn⟶₁ρθq·q pot
... | _ , depar₂ dehole , ρθ·t∥q'sn⟶₁ρθq·t∥q' , pot' =
  _ , depar₂ q≐E⟦qin⟧ ,′
    ρθ·t∥q'sn⟶₁ρθq·t∥q'

conf-lift-lemma cb@(CBseq cbp' cbq' _) (deseq p≐E⟦ρθ·pin⟧) (deseq r≐E⟦pin⟧) ρθ·pinsn⟶₁ρθq·qin
  with conf-lift-lemma cbp' p≐E⟦ρθ·pin⟧ r≐E⟦pin⟧ ρθ·pinsn⟶₁ρθq·qin
... | q , q≐E⟦qin⟧ , ρθ·rsn⟶₁ρθq·q
  with get-view ρθ·rsn⟶₁ρθq·q
... | inj₁ (E' , pin' , qin' , r≐E'⟦pin'⟧ , q≐E'⟦qin'⟧ , e-view) =
  _ , deseq q≐E⟦qin⟧ ,′
  proj₁ (wrap-rho ρθ·rsn⟶₁ρθq·q r≐E'⟦pin'⟧ q≐E'⟦qin'⟧ e-view _
          (deseq r≐E'⟦pin'⟧) (deseq q≐E'⟦qin'⟧))
... | inj₂ (refl , refl , pot) with wrap-rho-pot' (deseq p≐E⟦ρθ·pin⟧) cb ρθ·rsn⟶₁ρθq·q pot
... | _ , deseq dehole , ρθ·t>>q'sn⟶₁ρθq·t>>q' , pot' =
  _ , deseq q≐E⟦qin⟧ ,′
    ρθ·t>>q'sn⟶₁ρθq·t>>q'

conf-lift-lemma cb@(CBloopˢ cbp' cbq' _ _) (deloopˢ p≐E⟦ρθ·pin⟧) (deloopˢ r≐E⟦pin⟧) ρθ·pinsn⟶₁ρθq·qin
  with conf-lift-lemma cbp' p≐E⟦ρθ·pin⟧ r≐E⟦pin⟧ ρθ·pinsn⟶₁ρθq·qin
... | q , q≐E⟦qin⟧ , ρθ·rsn⟶₁ρθq·q
  with get-view ρθ·rsn⟶₁ρθq·q
... | inj₁ (E' , pin' , qin' , r≐E'⟦pin'⟧ , q≐E'⟦qin'⟧ , e-view) =
  _ , deloopˢ q≐E⟦qin⟧ ,′
  proj₁ (wrap-rho ρθ·rsn⟶₁ρθq·q r≐E'⟦pin'⟧ q≐E'⟦qin'⟧ e-view _
          (deloopˢ r≐E'⟦pin'⟧) (deloopˢ q≐E'⟦qin'⟧))
... | inj₂ (refl , refl , pot) with wrap-rho-pot' (deloopˢ p≐E⟦ρθ·pin⟧) cb ρθ·rsn⟶₁ρθq·q pot
... | _ , deloopˢ dehole , ρθ·t>>q'sn⟶₁ρθq·t>>q' , pot' =
  _ , deloopˢ q≐E⟦qin⟧ ,′
    ρθ·t>>q'sn⟶₁ρθq·t>>q'

conf-lift-lemma cb@(CBsusp cb' _) (desuspend p≐E⟦ρθ·pin⟧) (desuspend r≐E⟦pin⟧) ρθ·pinsn⟶₁ρθq·qin
  with conf-lift-lemma cb' p≐E⟦ρθ·pin⟧ r≐E⟦pin⟧ ρθ·pinsn⟶₁ρθq·qin
... | q , q≐E⟦qin⟧ , ρθ·rsn⟶₁ρθq·q
  with get-view ρθ·rsn⟶₁ρθq·q
... | inj₁ (E' , pin' , qin' , r≐E'⟦pin'⟧ , q≐E'⟦qin'⟧ , e-view) =
  _ , desuspend q≐E⟦qin⟧ ,′
  proj₁ (wrap-rho ρθ·rsn⟶₁ρθq·q r≐E'⟦pin'⟧ q≐E'⟦qin'⟧ e-view _
          (desuspend r≐E'⟦pin'⟧) (desuspend q≐E'⟦qin'⟧))
... | inj₂ (refl , refl , pot) with wrap-rho-pot' (desuspend p≐E⟦ρθ·pin⟧) cb ρθ·rsn⟶₁ρθq·q pot
... | _ , desuspend dehole , ρθ·susptsn⟶₁ρθq·suspt , pot' =
  _ , desuspend q≐E⟦qin⟧ ,′
    ρθ·susptsn⟶₁ρθq·suspt

conf-lift-lemma cb@(CBtrap cb') (detrap p≐E⟦ρθ·pin⟧) (detrap r≐E⟦pin⟧) ρθ·pinsn⟶₁ρθq·qin
  with conf-lift-lemma cb' p≐E⟦ρθ·pin⟧ r≐E⟦pin⟧ ρθ·pinsn⟶₁ρθq·qin
... | q , q≐E⟦qin⟧ , ρθ·rsn⟶₁ρθq·q
  with get-view ρθ·rsn⟶₁ρθq·q
... | inj₁ (E' , pin' , qin' , r≐E'⟦pin'⟧ , q≐E'⟦qin'⟧ , e-view) =
  _ , detrap q≐E⟦qin⟧ ,′
  proj₁ (wrap-rho ρθ·rsn⟶₁ρθq·q r≐E'⟦pin'⟧ q≐E'⟦qin'⟧ e-view _
          (detrap r≐E'⟦pin'⟧) (detrap q≐E'⟦qin'⟧))
... | inj₂ (refl , refl , pot) with wrap-rho-pot' (detrap p≐E⟦ρθ·pin⟧) cb ρθ·rsn⟶₁ρθq·q pot
... | _ , detrap dehole , ρθ·traptsn⟶₁ρθq·trapt , pot' =
  _ , detrap q≐E⟦qin⟧ ,′
    ρθ·traptsn⟶₁ρθq·trapt

{-
Base case where (E, C) = ([], []).

  The most complicated case where LHS is  ρθ.ρθ'.qin sn⟶₁ ρ(θ←θ').qin   (qin = ρθ'.rin)
  and RHS is  (ρθ.) ρθ'.rin sn⟶₁ (ρθ.) ρθr.ro,  i.e. arbitrary ->E-view and ->pot-view.

     p
  ρθ. E⟦ρθ'.qin⟧   -- sn⟶₁ ->    ρ(θ←θ'). E⟦qin⟧
 (ρθ) E⟦ρθ'.qin⟧   -- sn⟶₁ ->   (ρθ)      E⟦ρθr.ro⟧
-}
1-steplρ-E-view-ecsame : ∀{E p qin q qo rin r ro θ θ←θ' BV FV A A⊓A'} →
  {ρθ·psn⟶₁ρθ←θ'·q  :  ρ⟨ θ , A ⟩· p sn⟶₁ ρ⟨ θ←θ' , A⊓A' ⟩· q} →
  CorrectBinding p BV FV →

  (p≐E⟦qin⟧  :  p ≐ E ⟦ qin ⟧e) →
  (q≐E⟦qo⟧   :  q ≐ E ⟦ qo ⟧e) →
  ->E-view  ρθ·psn⟶₁ρθ←θ'·q  p≐E⟦qin⟧  q≐E⟦qo⟧ →

  (p≐E⟦rin⟧  :  p ≐ (map ceval E) ⟦ rin ⟧c) →
  (r≐E⟦ro⟧   :  r ≐ (map ceval E) ⟦ ro ⟧c) →
  -- rinsn⟶₁ro can only be  (ρ⟨ θ' , A' ⟩· qin) sn⟶₁ (ρ⟨ θr , Ar ⟩· ro)
  (rinsn⟶₁ro  :  rin sn⟶₁ ro) →

  Σ ((Env × Ctrl × Term) × EvaluationContext × Term × Term) λ { ((θo , Ao , po) , E' , roin , poin) →
    ρ⟨ θ←θ' , A⊓A' ⟩· q sn⟶₁ ρ⟨ θo , Ao ⟩· po ×
    Σ[ ρθ·rsn⟶₁ρθo·po  ∈  ρ⟨ θ , A ⟩·    r sn⟶₁ ρ⟨ θo , Ao ⟩· po ]
    Σ[ r≐E'⟦roin⟧     ∈  r ≐ E' ⟦ roin ⟧e ]
    Σ[ po≐E'⟦poin⟧    ∈  po ≐ E' ⟦ poin ⟧e ]
      ->E-view  ρθ·rsn⟶₁ρθo·po  r≐E'⟦roin⟧  po≐E'⟦poin⟧
    }

1-steplρ-E-view-ecsame cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ e-view p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro
  with unplug-eq p≐E⟦ρθ'·qin⟧ (⟦⟧c-to-⟦⟧e p≐C⟦rin⟧)
1-steplρ-E-view-ecsame cb _ _ vis-present           _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vis-absent            _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vemit                 _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vraise-shared         _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vset-shared-value-old _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vset-shared-value-new _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vraise-var            _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vset-var              _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vif-false             _ _ () | refl
1-steplρ-E-view-ecsame cb _ _ vif-true              _ _ () | refl

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb
  p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge
  p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl
  with ρ-stays-ρ-sn⟶₁ rinsn⟶₁ro
... | θr , roin , Ar , refl
  with conf-lift-lemma cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ rinsn⟶₁ro
... | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r' -- q ≐ E ⟦ qin ⟧
  with get-view ρθ'·qsn⟶₁ρθr·r'

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦present⟧ , r'≐E⟦roin'⟧ ,
          vis-present {.θ'} {S} {E = .E'} {S∈Domθ'} {θ'S≡present} {q≐E'⟦present⟧}) =
  _ ,
      (ris-present {S = S}
        (Env.sig-←-monoʳ S θr θ S∈Domθ')
        (trans
          (SigMap.get-U-right-irr-m {_} S (Env.sig θ) (Env.sig θr)
            (Env.sig-←-monoʳ S θr θ S∈Domθ') S∈Domθ')
          θ'S≡present)
        q≐E'⟦present⟧) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , q≐E⟦qo'⟧ , r'≐E⟦roin'⟧ ,
          vis-absent {.θ'} {S} {E = .E'} {S∈Domθ'} {θ'S≡absent} {q≐E'⟦absent⟧}) =
  _ ,
      (ris-absent {S = S}
        (Env.sig-←-monoʳ S θr θ S∈Domθ')
        (trans
          (SigMap.get-U-right-irr-m {_} S (Env.sig θ) (Env.sig θr)
            (Env.sig-←-monoʳ S θr θ S∈Domθ') S∈Domθ')
          θ'S≡absent)
        q≐E'⟦absent⟧) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦if⟧ , r'≐E⟦roin'⟧ ,
          vif-false {x = x} {.E'} {x∈Domθ'} {θ'x≡zero} {q≐E'⟦if⟧}) =
  _ ,
      (rif-false {x = x}
        (Env.seq-←-monoʳ x θr θ x∈Domθ')
        (trans
          (VarMap.get-U-right-irr-m {_} x (Env.var θ) (Env.var θr)
            (Env.seq-←-monoʳ x θr θ x∈Domθ') x∈Domθ')
          θ'x≡zero)
        q≐E'⟦if⟧) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦if⟧ , r'≐E⟦roin'⟧ ,
          vif-true {x = x} {.E'} {_} {x∈Domθ'} {θ'x≡suc} {q≐E'⟦if⟧}) =
  _ ,
      (rif-true {x = x}
        (Env.seq-←-monoʳ x θr θ x∈Domθ')
        (trans
          (Env.var-vals-←-right-irr' x θ θr x∈Domθ' (Env.seq-←-monoʳ x θr θ x∈Domθ'))
          θ'x≡suc)
        q≐E'⟦if⟧) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦shared⟧ , r'≐E⟦roin'⟧ ,
          vraise-shared {s = s} {E = .E'} {e'} {q≐E'⟦shared⟧})
  with ready-irr-on-irr-θʳ θ e'
... | e'' , δe'≡δe'' rewrite δe'≡δe'' =
  _ ,
      rraise-shared e'' q≐E'⟦shared⟧ ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦var⟧ , r'≐E⟦roin'⟧ ,
            vraise-var {E = .E'} {e'} {q≐E'⟦var⟧})
  with ready-irr-on-irr-θʳ θ e'
... | e'' , δe'≡δe'' rewrite δe'≡δe'' =
  _ ,
      rraise-var e'' q≐E'⟦var⟧ ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} {A₁ = A} {.GO} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦emit⟧ , r'≐E⟦roin'⟧ ,
            vemit {S = S} {.E'} {S∈Domθ'} {θ'S≢absent} {q≐E'⟦emit⟧}) =
  _ ,
       (subst₂ (λ θ* go → ρ⟨ (θ ← θ') , go ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , go ⟩· E' ⟦ nothin ⟧e)
        (begin
            Env.set-sig {S} (θ ← θ') S∈Domθ←θ' Signal.present
          ≡⟨ Env.sig-set=← (θ ← θ') S Signal.present S∈Domθ←θ' ⟩
            (θ ← θ') ← [S↦present]
          ≡⟨ sym (Env.←-assoc θ θ' [S↦present]) ⟩
            θ ← (θ' ← [S↦present])
          ≡⟨ cong (θ ←_) (sym (Env.sig-set=← θ' S Signal.present S∈Domθ')) ⟩
            θ ← (Env.set-sig {S} θ' S∈Domθ' Signal.present)
         ∎)
         (sym $ A-max-GO-≡-right A)
        (remit {θ ← θ'} {S = S} S∈Domθ←θ'
          (θ'S≢absent ∘ trans (sym ⟨θ←θ'⟩S≡θ'S))
          q≐E'⟦emit⟧))   ,′
       (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))
  where
    [S↦present] = Θ SigMap.[ S ↦ Signal.present ] ShrMap.empty VarMap.empty
    S∈Domθ←θ'   = Env.sig-←-monoʳ S θ' θ S∈Domθ'
    ⟨θ←θ'⟩S≡θ'S = Env.sig-stats-←-right-irr' S θ θ' S∈Domθ' S∈Domθ←θ'

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} {A₁ = A} {.GO} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦s⇐e⟧ , r'≐E⟦roin'⟧ ,
          vset-shared-value-old {s = s} {E = .E'} {e'} {s∈Domθ'} {θ's≡old} {q≐E'⟦s⇐e⟧})
  with ready-irr-on-irr-θʳ θ e'
... | e'' , δe'≡δe'' rewrite δe'≡δe'' =
  _ ,
       (subst₂ (λ θ* go → ρ⟨ (θ ← θ') , go ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , go ⟩· E' ⟦ nothin ⟧e)
        (begin
            Env.set-shr {s} (θ ← θ') s∈Domθ←θ' SharedVar.new (δ e'')
          ≡⟨ Env.shr-set=← (θ ← θ') s SharedVar.new (δ e'') s∈Domθ←θ' ⟩
            (θ ← θ') ← [s↦new,δe'']
          ≡⟨ sym (Env.←-assoc θ θ' [s↦new,δe'']) ⟩
            θ ← (θ' ← [s↦new,δe''])
          ≡⟨ cong (θ ←_) (sym (Env.shr-set=← θ' s SharedVar.new (δ e'') s∈Domθ')) ⟩
            θ ← (Env.set-shr {s} θ' s∈Domθ' SharedVar.new (δ e''))
         ∎)
         (sym $ A-max-GO-≡-right A)
        (rset-shared-value-old {θ ← θ'} e'' s∈Domθ←θ'
          (trans (Env.shr-stats-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ') θ's≡old)
          q≐E'⟦s⇐e⟧))   ,′
       (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))
 where
    [s↦new,δe''] = [s,δe-new]-env s (δ e'')
    s∈Domθ←θ'   = Env.shr-←-monoʳ s θ' θ s∈Domθ'

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E}  {A₁ = A} {.GO} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , .q≐E'⟦s⇐e⟧ , r'≐E⟦roin'⟧ ,
          vset-shared-value-new {s = s} {E = .E'} {e'} {s∈Domθ'} {θ's≡old} {q≐E'⟦s⇐e⟧})
  with ready-irr-on-irr-θʳ θ e'
... | e'' , δe'≡δe'' rewrite δe'≡δe'' =
  _ ,
       (subst₂ (λ θ* go → ρ⟨ (θ ← θ') , go ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , go ⟩· E' ⟦ nothin ⟧e)
        (begin
            Env.set-shr {s} (θ ← θ') s∈Domθ←θ' SharedVar.new (⟨θ←θ'⟩s + δ e'')
          ≡⟨ cong(Env.set-shr{s}(θ ← θ')s∈Domθ←θ' SharedVar.new ∘ (_+ δ e''))⟨θ←θ'⟩s≡θ's ⟩
            Env.set-shr {s} (θ ← θ') s∈Domθ←θ' SharedVar.new (θ's + δ e'')
          ≡⟨ Env.shr-set=← (θ ← θ') s SharedVar.new (θ's + δ e'') s∈Domθ←θ' ⟩
            (θ ← θ') ← [s↦new,θ's+δe'']
          ≡⟨ sym (Env.←-assoc θ θ' [s↦new,θ's+δe'']) ⟩
            θ ← (θ' ← [s↦new,θ's+δe''])
          ≡⟨ cong (θ ←_) (sym (Env.shr-set=← θ' s SharedVar.new (θ's + δ e'') s∈Domθ')) ⟩
            θ ← (Env.set-shr {s} θ' s∈Domθ' SharedVar.new (θ's + δ e''))
         ∎)
         (sym $ A-max-GO-≡-right A)
        (rset-shared-value-new {θ ← θ'} e'' s∈Domθ←θ'
          (trans (Env.shr-stats-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ') θ's≡old)
          q≐E'⟦s⇐e⟧))  ,′
       (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))
 where
    s∈Domθ←θ'   = Env.shr-←-monoʳ s θ' θ s∈Domθ'
    θ's = Env.shr-vals {s} θ' s∈Domθ'
    ⟨θ←θ'⟩s = Env.shr-vals {s} (θ ← θ') s∈Domθ←θ'
    ⟨θ←θ'⟩s≡θ's = Env.shr-vals-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ'
    [s↦new,θ's+δe''] = [s,δe-new]-env s (θ's + δ e'')

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} {A₁ = A} {A'} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , q≐E⟦qo'⟧ , r'≐E⟦roin'⟧ ,
          vset-var {x = x} {E = .E'} {x∈Domθ'} {e'} {q≐E'⟦x≔e⟧})
  with ready-irr-on-irr-θʳ θ e'
... | e'' , δe'≡δe'' rewrite δe'≡δe'' =
  _ ,
      (subst (λ θ* → ρ⟨ (θ ← θ') , A-max A A' ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , A-max A A' ⟩· E' ⟦ nothin ⟧e)
        (begin
            Env.set-var {x} (θ ← θ') x∈Domθ←θ' (δ e'')
          ≡⟨ Env.seq-set=← (θ ← θ') x (δ e'') x∈Domθ←θ' ⟩
            (θ ← θ') ← [x↦δe'']
          ≡⟨ sym (Env.←-assoc θ θ' [x↦δe'']) ⟩
            θ ← (θ' ← [x↦δe''])
          ≡⟨ cong (θ ←_) (sym (Env.seq-set=← θ' x (δ e'') x∈Domθ')) ⟩
            θ ← (Env.set-var {x} θ' x∈Domθ' (δ e''))
         ∎)
        (rset-var {θ ← θ'} x∈Domθ←θ' e'' q≐E'⟦x≔e⟧)) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))
 where
    [x↦δe'']  = [x,δe]-env x (δ e'')
    x∈Domθ←θ' = Env.seq-←-monoʳ x θ' θ x∈Domθ'

1-steplρ-E-view-ecsame {E} {A = A} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} {A₂ = A'} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | (.(θ' ← θr) , roin , .(A-max A' Ar) , refl)
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₁ (E' , qo' , roin' , q≐E⟦qo'⟧ , r'≐E⟦roin'⟧ ,
          vmerge {.θ'} {θr} {_} {.roin'} {.E'} {_} {Ar} {q≐E'⟦ρθr·roin'⟧}) =
  ((_ , (A-max A (A-max A' Ar)) , _) , _) ,
       (subst₂ (λ θ* A* → ρ⟨ (θ ← θ') , A-max A A' ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , A* ⟩· E' ⟦ roin' ⟧e)
         (sym (Env.←-assoc θ θ' θr))
         (sym (A-max-assoc A A' Ar))
         (rmerge {θ ← θ'} {θr} {A₁ = A-max A A'} {Ar} q≐E'⟦ρθr·roin'⟧))   ,′
       (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₂ (refl , refl , vabsence S S∈Domθ' θ'S≡unknown S∉canθ-θ'-q-[]) =
  _ ,
      (subst (λ θ* → ρ⟨ (θ ← θ') , _ ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , _ ⟩· E ⟦ qin ⟧e)
        (begin
            Env.set-sig {S} (θ ← θ') S∈Domθ←θ' Signal.absent
          ≡⟨ Env.sig-set=← (θ ← θ') S Signal.absent S∈Domθ←θ' ⟩
            (θ ← θ') ← [S↦absent]
          ≡⟨ sym (Env.←-assoc θ θ' [S↦absent]) ⟩
            θ ← (θ' ← [S↦absent])
          ≡⟨ cong (θ ←_) (sym (Env.sig-set=← θ' S Signal.absent S∈Domθ')) ⟩
            θ ← (Env.set-sig {S} θ' S∈Domθ' Signal.absent)
         ∎)
        (rabsence {θ ← θ'} {S = S} S∈Domθ←θ'
          (trans (Env.sig-stats-←-right-irr' S θ θ' S∈Domθ' S∈Domθ←θ') θ'S≡unknown)
          (λ S∈canθ-θ←θ''-q-[] →
            S∉canθ-θ'-q-[]
              (canθₛ-mergeʳ (Env.sig θ) θ' (E ⟦ qin ⟧e) Env.[]env (λ _ ())
                 S S∈canθ-θ←θ''-q-[])))) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))
  where
    [S↦absent] = Θ SigMap.[ S ↦ Signal.absent ] ShrMap.empty VarMap.empty
    S∈Domθ←θ'   = Env.sig-←-monoʳ S θ' θ S∈Domθ'

1-steplρ-E-view-ecsame {E} {ρθ·psn⟶₁ρθ←θ'·q = rmerge {θ} {θ'} {_} {qin} {.E} .p≐E⟦ρθ'·qin⟧}
  cb p≐E⟦ρθ'·qin⟧ q≐E⟦qin⟧ vmerge p≐C⟦rin⟧ r≐C⟦ro⟧ rinsn⟶₁ro | refl | θr , roin , Ar , refl
  | r' , r'≐E⟦roin⟧ , ρθ'·qsn⟶₁ρθr·r'
  | inj₂ (refl , refl , vreadyness s s∈Domθ' θ's≡old⊎θ's≡new s∉canθ-θ'-q-[]) =
  _ ,
      (subst (λ θ* → ρ⟨ (θ ← θ') , _ ⟩· E ⟦ qin ⟧e sn⟶₁ ρ⟨ θ* , _ ⟩· E ⟦ qin ⟧e)
        (begin
            Env.set-shr {s} (θ ← θ') s∈Domθ←θ' SharedVar.ready ⟨θ←θ'⟩s
          ≡⟨ cong (Env.set-shr {s} (θ ← θ') s∈Domθ←θ' SharedVar.ready) ⟨θ←θ'⟩s≡θ's ⟩
            Env.set-shr {s} (θ ← θ') s∈Domθ←θ' SharedVar.ready θ's
          ≡⟨ Env.shr-set=← (θ ← θ') s SharedVar.ready θ's s∈Domθ←θ' ⟩
            (θ ← θ') ← [s↦ready,θ's]
          ≡⟨ sym (Env.←-assoc θ θ' [s↦ready,θ's]) ⟩
            θ ← (θ' ← [s↦ready,θ's])
          ≡⟨ cong (θ ←_) (sym (Env.shr-set=← θ' s SharedVar.ready θ's s∈Domθ')) ⟩
            θ ← (Env.set-shr {s} θ' s∈Domθ' SharedVar.ready θ's)
         ∎)
        (rreadyness {θ ← θ'} {s = s} s∈Domθ←θ'
          (Data.Sum.map
            (trans (Env.shr-stats-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ'))
            (trans (Env.shr-stats-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ'))
            θ's≡old⊎θ's≡new)
          (λ s∈canθ-θ←θ''-q-[] →
            s∉canθ-θ'-q-[]
              (canθₛₕ-mergeʳ (Env.sig θ) θ' (E ⟦ qin ⟧e) Env.[]env (λ _ ())
                 s s∈canθ-θ←θ''-q-[])))) ,′
      (subst (λ po* → Σ[ r ∈ ρ⟨ _ , _ ⟩· _ sn⟶₁ ρ⟨ _ , _ ⟩· po* ]
                      Σ[ a ∈ _ ≐ _ ⟦ _ ⟧e ]
                      Σ[ b ∈ po* ≐ _ ⟦ _ ⟧e ]
                        ->E-view r a b)
        (unplug r'≐E⟦roin⟧)
        (rmerge (⟦⟧c-to-⟦⟧e r≐C⟦ro⟧) ,
         _ , plug refl , vmerge))
  where
    s∈Domθ←θ'   = Env.shr-←-monoʳ s θ' θ s∈Domθ'
    θ's = Env.shr-vals {s} θ' s∈Domθ'
    ⟨θ←θ'⟩s = Env.shr-vals {s} (θ ← θ') s∈Domθ←θ'
    ⟨θ←θ'⟩s≡θ's = Env.shr-vals-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ'
    [s↦ready,θ's] =
      Θ ShrMap.empty ShrMap.[ s ↦ (SharedVar.ready , θ's) ] VarMap.empty


module datatype-util where
open import constants
open import ctxt
open import syntax-util
open import general-util
open import type-util
open import cedille-types
open import subst
open import rename
open import free-vars

{-# TERMINATING #-}
decompose-arrows : ctxt → type → params × type
decompose-arrows Γ (TpAbs me x atk T) =
  let x' = fresh-var-new Γ x in
  case decompose-arrows (ctxt-var-decl x' Γ) (rename-var Γ x x' T) of λ where
    (ps , T') → Param me x' atk :: ps , T'
decompose-arrows Γ T = [] , T

decompose-ctr-type : ctxt → type → type × params × 𝕃 tmtp
decompose-ctr-type Γ T with decompose-arrows Γ T
...| ps , Tᵣ with decompose-tpapps Tᵣ
...| Tₕ , as = Tₕ , ps , as

{-# TERMINATING #-}
kind-to-indices : ctxt → kind → indices
kind-to-indices Γ (KdAbs x atk k) =
  let x' = fresh-var-new Γ x in
  Index x' atk :: kind-to-indices (ctxt-var-decl x' Γ) (rename-var Γ x x' k)
kind-to-indices Γ _ = []

rename-indices-h : ctxt → renamectxt → indices → 𝕃 tmtp → indices
rename-indices-h Γ ρ (Index x atk :: is) (ty :: tys) =
  Index x' atk' ::
    rename-indices-h (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') is tys
  where
  x' = fresh-var-renamectxt Γ ρ (maybe-else x id (is-var-unqual ty))
  atk' = subst-renamectxt Γ ρ -tk atk
rename-indices-h Γ ρ (Index x atk :: is) [] =
  let x' = fresh-var-renamectxt Γ ρ x in
  Index x' (subst-renamectxt Γ ρ -tk atk) ::
    rename-indices-h (ctxt-var-decl x' Γ) (renamectxt-insert ρ x x') is []
rename-indices-h _ _ [] _ = []

rename-indices : ctxt → indices → 𝕃 tmtp → indices
rename-indices Γ = rename-indices-h Γ empty-renamectxt

positivity : Set
positivity = 𝔹 × 𝔹 -- occurs positively × occurs negatively

pattern occurs-nil = ff , ff
pattern occurs-pos = tt , ff
pattern occurs-neg = ff , tt
pattern occurs-all = tt , tt

--positivity-inc : positivity → positivity
--positivity-dec : positivity → positivity
positivity-neg : positivity → positivity
positivity-add : positivity → positivity → positivity

--positivity-inc = map-fst λ _ → tt
--positivity-dec = map-snd λ _ → tt
positivity-neg = uncurry $ flip _,_
positivity-add (+ₘ , -ₘ) (+ₙ , -ₙ) = (+ₘ || +ₙ) , (-ₘ || -ₙ)

-- just tt = negative occurrence; just ff = not in the return type; nothing = okay
module positivity (x : var) where

  open import conversion

  not-free : ∀ {ed} → ⟦ ed ⟧ → maybe 𝔹
  not-free = maybe-map (λ _ → tt) ∘' maybe-if ∘' is-free-in x

  if-free : ∀ {ed} → ⟦ ed ⟧ → positivity
  if-free t with is-free-in x t
  ...| f = f , f

  if-free-args : args → positivity
  if-free-args as with stringset-contains (free-vars-args as) x
  ...| f = f , f

  hnf' : ∀ {ed} → ctxt → ⟦ ed ⟧ → ⟦ ed ⟧
  hnf' Γ T = hnf Γ unfold-no-defs T

  mtt = maybe-else tt id
  mff = maybe-else ff id

  posₒ = fst
  negₒ = snd

  occurs : positivity → maybe 𝔹
  occurs p = maybe-if (negₒ p) >> just tt

  {-# TERMINATING #-}
  arrs+ : ctxt → type → maybe 𝔹
  type+ : ctxt → type → positivity
  kind+ : ctxt → kind → positivity
  tpkd+ : ctxt → tpkd → positivity
  tpapp+ : ctxt → type → positivity

  arrs+ Γ (TpAbs me x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
    occurs (tpkd+ Γ $ hnf' Γ -tk atk) maybe-or arrs+ Γ' (hnf' Γ' T)
  arrs+ Γ (TpApp T tT) = occurs (tpapp+ Γ $ hnf' Γ (TpApp T tT))
                       --arrs+ Γ T maybe-or (not-free -tT' tT)
  arrs+ Γ (TpLam x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
    occurs (tpkd+ Γ $ hnf' Γ -tk atk) maybe-or arrs+ Γ' (hnf' Γ' T)
  arrs+ Γ (TpVar x') = maybe-if (~ x =string x') >> just ff
  arrs+ Γ T = just ff

  type+ Γ (TpAbs me x' atk T) =
    let Γ' = ctxt-var-decl x' Γ in
    positivity-add (positivity-neg $ tpkd+ Γ $ hnf' Γ -tk atk) (type+ Γ' $ hnf' Γ' T)
  type+ Γ (TpIota x' T T') =
    let Γ' = ctxt-var-decl x' Γ in
    positivity-add (type+ Γ $ hnf' Γ T) (type+ Γ' $ hnf' Γ' T')
  type+ Γ (TpApp T tT) = tpapp+ Γ $ hnf' Γ $ TpApp T tT
  type+ Γ (TpEq tₗ tᵣ) = occurs-nil
  type+ Γ (TpHole _) = occurs-nil
  type+ Γ (TpLam x' atk T)=
    let Γ' = ctxt-var-decl x' Γ in
    positivity-add (positivity-neg $ tpkd+ Γ $ hnf' Γ -tk atk) (type+ Γ' (hnf' Γ' T))
  type+ Γ (TpVar x') = x =string x' , ff

  tpapp+ Γ T with decompose-tpapps T
  ...| TpVar x' , as =
    let f = if-free-args (tmtps-to-args NotErased as) in
    if x =string x'
      then positivity-add occurs-pos f
      else maybe-else' (data-lookup Γ x' as) f
        λ {(mk-data-info x'' xₒ'' asₚ asᵢ ps kᵢ k cs csₚₛ eds gds) →
          type+ Γ (hnf' Γ $ TpAbs tt x'' (Tkk k) $ foldr (uncurry λ cₓ cₜ → TpAbs ff ignored-var (Tkt cₜ)) (TpVar x'') (inst-ctrs Γ ps asₚ cs))}
  ...| _ , _ = if-free T

  kind+ Γ (KdAbs x' atk k) =
    let Γ' = ctxt-var-decl x' Γ in
    positivity-add (positivity-neg $ tpkd+ Γ $ hnf' Γ -tk atk) (kind+ Γ' k)
  kind+ Γ _ = occurs-nil

  tpkd+ Γ (Tkt T) = type+ Γ (hnf' Γ T)
  tpkd+ Γ (Tkk k) = kind+ Γ k

  ctr-positive : ctxt → type → maybe 𝔹
  ctr-positive Γ = arrs+ Γ ∘ hnf' Γ


module ProcessRun where

open import Data.Bool
open import Data.List
open import Data.Maybe
open import Data.Product

open import Relation.Binary.PropositionalEquality

open import Typing
open import ProcessSyntax

open import Channel
open import Global
open import Values
open import Session
open import Schedule

-- auxiliary lemmas
list-right-zero : ∀ {A : Set} → (xs : List A) → xs ++ [] ≡ xs
list-right-zero [] = refl
list-right-zero (x ∷ xs) = cong (_∷_ x) (list-right-zero xs)

list-assoc : ∀ {A : Set} → (xs ys zs : List A) → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
list-assoc [] ys zs = refl
list-assoc (x ∷ xs) ys zs = cong (_∷_ x) (list-assoc xs ys zs)

cons-assoc : ∀ {A : Set} → (x : A) (xs ys : List A) → (x ∷ xs) ++ ys ≡ x ∷ (xs ++ ys)
cons-assoc x xs ys = refl

inactive-clone : (G : SCtx) → SCtx
inactive-clone [] = []
inactive-clone (x ∷ G) = nothing ∷ inactive-clone G

inactive-extension : ∀ {G} → Inactive G → (G' : SCtx) → Inactive (inactive-clone G' ++ G)
inactive-extension inaG [] = inaG
inactive-extension inaG (x ∷ G') = ::-inactive (inactive-extension inaG G')

splitting-extension : ∀ {G G₁ G₂} (G' : SCtx)
  → SSplit G G₁ G₂ → SSplit (inactive-clone G' ++ G) (inactive-clone G' ++ G₁) (inactive-clone G' ++ G₂)
splitting-extension [] ss = ss
splitting-extension (x ∷ G') ss = ss-both (splitting-extension G' ss)

left-right : (G' G'' : SCtx)
  → SSplit (G' ++ G'') (G' ++ inactive-clone G'') (inactive-clone G' ++ G'')
left-right [] [] = ss-[]
left-right [] (just x ∷ G'') = ss-right (left-right [] G'')
left-right [] (nothing ∷ G'') = ss-both (left-right [] G'')
left-right (x ∷ G') G'' with left-right G' G''
... | ss-G'G'' with x
left-right (x ∷ G') G'' | ss-G'G'' | just x₁ = ss-left ss-G'G''
left-right (x ∷ G') G'' | ss-G'G'' | nothing = ss-both ss-G'G''

ssplit-append : { G11 G12  G21 G22 : SCtx} (G1 G2 : SCtx) → SSplit G1 G11 G12 → SSplit G2 G21 G22 → SSplit (G1 ++ G2) (G11 ++ G21) (G12 ++ G22)
ssplit-append _ _ ss-[] ss2 = ss2
ssplit-append _ _ (ss-both ss1) ss2 = ss-both (ssplit-append _ _ ss1 ss2)
ssplit-append _ _ (ss-left ss1) ss2 = ss-left (ssplit-append _ _ ss1 ss2)
ssplit-append _ _ (ss-right ss1) ss2 = ss-right (ssplit-append _ _ ss1 ss2)
ssplit-append _ _ (ss-posneg ss1) ss2 = ss-posneg (ssplit-append _ _ ss1 ss2)
ssplit-append _ _ (ss-negpos ss1) ss2 = ss-negpos (ssplit-append _ _ ss1 ss2)

-- weakening #1
weaken1-cr : ∀ {G b s} G' → ChannelRef G b s → ChannelRef (inactive-clone G' ++ G) b s
weaken1-cr [] cr = cr
weaken1-cr (x ∷ G') cr = there (weaken1-cr G' cr)

weaken1-val : ∀ {G t} G' → Val G t → Val (inactive-clone G' ++ G) t
weaken1-venv : ∀ {G Φ} G' → VEnv G Φ → VEnv (inactive-clone G' ++ G) Φ

weaken1-val G' (VUnit inaG) = VUnit (inactive-extension inaG G')
weaken1-val G' (VInt i inaG) = VInt i (inactive-extension inaG G')
weaken1-val G' (VPair ss-GG₁G₂ v v₁) = VPair (splitting-extension G' ss-GG₁G₂) (weaken1-val G' v) (weaken1-val G' v₁)
weaken1-val G' (VChan b vcr) = VChan b (weaken1-cr G' vcr)
weaken1-val G' (VFun x ϱ e) = VFun x (weaken1-venv G' ϱ) e
weaken1-venv G' (vnil ina) = vnil (inactive-extension ina G')
weaken1-venv G' (vcons ssp v ϱ) = vcons (splitting-extension G' ssp) (weaken1-val G' v) (weaken1-venv G' ϱ)

weaken1-cont : ∀ {G t φ} G' → Cont G φ t → Cont (inactive-clone G' ++ G) φ t
weaken1-cont G' (halt inaG un-t) = halt (inactive-extension inaG G') un-t
weaken1-cont G' (bind ts ss e₂ ϱ₂ κ) = bind ts (splitting-extension G' ss) e₂ (weaken1-venv G' ϱ₂) (weaken1-cont G' κ)
weaken1-cont G' (bind-thunk ts ss e₂ ϱ₂ κ) = bind-thunk ts (splitting-extension G' ss) e₂ (weaken1-venv G' ϱ₂) (weaken1-cont G' κ)
weaken1-cont G' (subsume x κ) = subsume x (weaken1-cont G' κ)

weaken1-command : ∀ {G} G' → Command G → Command (inactive-clone G' ++ G)
weaken1-command G' (Fork ss κ₁ κ₂) = Fork (splitting-extension G' ss) (weaken1-cont G' κ₁) (weaken1-cont G' κ₂)
weaken1-command G' (Ready ss v κ) = Ready (splitting-extension G' ss) (weaken1-val G' v) (weaken1-cont G' κ)
weaken1-command G' (Halt x x₁ x₂) = Halt (inactive-extension x G') x₁ (weaken1-val G' x₂)
weaken1-command G' (New s κ) = New s (weaken1-cont G' κ)
weaken1-command G' (Close ss v κ) = Close (splitting-extension G' ss) (weaken1-val G' v) (weaken1-cont G' κ)
weaken1-command G' (Wait ss v κ) = Wait (splitting-extension G' ss) (weaken1-val G' v) (weaken1-cont G' κ)
weaken1-command G' (Send ss ss-args vch v κ) = Send (splitting-extension G' ss) (splitting-extension G' ss-args) (weaken1-val G' vch) (weaken1-val G' v) (weaken1-cont G' κ)
weaken1-command G' (Recv ss vch κ) = Recv (splitting-extension G' ss) (weaken1-val G' vch) (weaken1-cont G' κ)
weaken1-command G' (Select ss lab vch κ) = Select (splitting-extension G' ss) lab (weaken1-val G' vch) (weaken1-cont G' κ)
weaken1-command G' (Branch ss vch dcont) = Branch (splitting-extension G' ss) (weaken1-val G' vch) λ lab → weaken1-cont G' (dcont lab)
weaken1-command G' (NSelect ss lab vch κ) = NSelect (splitting-extension G' ss) lab (weaken1-val G' vch) (weaken1-cont G' κ)
weaken1-command G' (NBranch ss vch dcont) = NBranch (splitting-extension G' ss) (weaken1-val G' vch) λ lab → weaken1-cont G' (dcont lab)

weaken1-threadpool : ∀ {G} G' → ThreadPool G → ThreadPool (inactive-clone G' ++ G)
weaken1-threadpool G' (tnil ina) = tnil (inactive-extension ina G')
weaken1-threadpool G' (tcons ss cmd tp) = tcons (splitting-extension G' ss) (weaken1-command G' cmd) (weaken1-threadpool G' tp)

-- auxiliary

inactive-insertion : ∀ {G} G' G'' → Inactive (G' ++ G) → Inactive (G' ++ inactive-clone G'' ++ G)
inactive-insertion [] G'' ina-G'G = inactive-extension ina-G'G G''
inactive-insertion (just x ∷ G') G'' ()
inactive-insertion (nothing ∷ G') G'' (::-inactive ina-G'G) = ::-inactive (inactive-insertion G' G'' ina-G'G)

splitting-insertion : ∀ {G G₁ G₂} {G' G₁' G₂'} G''
  → SSplit G' G₁' G₂'
  → SSplit G G₁ G₂
  → SSplit (G' ++ inactive-clone G'' ++ G) (G₁' ++ inactive-clone G'' ++ G₁) (G₂' ++ inactive-clone G'' ++ G₂)
splitting-insertion G'' ss-[] ss = splitting-extension G'' ss
splitting-insertion G'' (ss-both ss') ss = ss-both (splitting-insertion G'' ss' ss)
splitting-insertion G'' (ss-left ss') ss = ss-left (splitting-insertion G'' ss' ss)
splitting-insertion G'' (ss-right ss') ss = ss-right (splitting-insertion G'' ss' ss)
splitting-insertion G'' (ss-posneg ss') ss = ss-posneg (splitting-insertion G'' ss' ss)
splitting-insertion G'' (ss-negpos ss') ss = ss-negpos (splitting-insertion G'' ss' ss)

split-append : ∀ {G G1 G2} G'
  → SSplit (G' ++ G) G1 G2
  → ∃ λ G₁' → ∃ λ G₂' → ∃ λ G₁ → ∃ λ G₂
  → SSplit G' G₁' G₂' × SSplit G G₁ G₂ × G1 ≡ G₁' ++ G₁ × G2 ≡ G₂' ++ G₂
split-append [] ss = _ , _ , _ , _ , ss-[] , ss , refl , refl
split-append (.nothing ∷ G') (ss-both ss) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-both ss') , ss0 , refl , refl
split-append (.(just _) ∷ G') (ss-left ss) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-left ss') , ss0 , refl , refl
split-append (.(just _) ∷ G') (ss-right ss) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-right ss') , ss0 , refl , refl
split-append (.(just (_ , POSNEG)) ∷ G') (ss-posneg ss) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-posneg ss') , ss0 , refl , refl
split-append (.(just (_ , POSNEG)) ∷ G') (ss-negpos ss) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = _ , _ , _ , _ , (ss-negpos ss') , ss0 , refl , refl

-- weakening #2

weaken2-cr : ∀ {G b s} G' G'' → ChannelRef (G' ++ G) b s → ChannelRef (G' ++ inactive-clone G'' ++ G) b s
weaken2-cr [] G'' cr = weaken1-cr G'' cr
weaken2-cr (.(just (_ , POS)) ∷ G') G'' (here-pos ina-G x) = here-pos (inactive-insertion G' G'' ina-G) x
weaken2-cr (.(just (_ , NEG)) ∷ G') G'' (here-neg ina-G x) = here-neg (inactive-insertion G' G'' ina-G) x
weaken2-cr (.nothing ∷ G') G'' (there cr) = there (weaken2-cr G' G'' cr)

weaken2-val : ∀ {G t} G' G'' → Val (G' ++ G) t → Val (G' ++ inactive-clone G'' ++ G) t
weaken2-venv : ∀ {G Φ} G' G'' → VEnv (G' ++ G) Φ → VEnv (G' ++ inactive-clone G'' ++ G) Φ

weaken2-val G' G'' (VUnit inaG) = VUnit (inactive-insertion G' G'' inaG)
weaken2-val G' G'' (VInt i inaG) = VInt i (inactive-insertion G' G'' inaG)
weaken2-val G' G'' (VPair ss-GG₁G₂ v₁ v₂) with split-append G' ss-GG₁G₂
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = VPair (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v₁) (weaken2-val G₂' G'' v₂)
weaken2-val G' G'' (VChan b vcr) = VChan b (weaken2-cr G' G'' vcr)
weaken2-val G' G'' (VFun x ϱ e) = VFun x (weaken2-venv G' G'' ϱ) e

weaken2-venv G' G'' (vnil ina) = vnil (inactive-insertion G' G'' ina)
weaken2-venv G' G'' (vcons{G₁ = Gv}{G₂ = Gϱ} ssp v ϱ) with split-append G' ssp
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = vcons (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-venv G₂' G'' ϱ)

weaken2-cont : ∀ {G t φ} G' G'' → Cont (G' ++ G) φ t → Cont (G' ++ inactive-clone G'' ++ G) φ t
weaken2-cont G' G'' (halt x un-t) = halt (inactive-insertion G' G'' x) un-t
weaken2-cont G' G'' (bind ts ss e₂ ϱ₂ κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = bind ts (splitting-insertion G'' ss' ss0) e₂ (weaken2-venv G₁' G'' ϱ₂) (weaken2-cont G₂' G'' κ)
weaken2-cont G' G'' (bind-thunk ts ss e₂ ϱ₂ κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = bind-thunk ts (splitting-insertion G'' ss' ss0) e₂ (weaken2-venv G₁' G'' ϱ₂) (weaken2-cont G₂' G'' κ)
weaken2-cont G' G'' (subsume x κ) = subsume x (weaken2-cont G' G'' κ)

weaken2-command : ∀ {G} G' G'' → Command (G' ++ G) → Command (G' ++ inactive-clone G'' ++ G)
weaken2-command G' G'' (Fork ss κ₁ κ₂) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Fork (splitting-insertion G'' ss' ss0) (weaken2-cont G₁' G'' κ₁) (weaken2-cont G₂' G'' κ₂)
weaken2-command G' G'' (Ready ss v κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Ready (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (Halt x x₁ x₂) = Halt (inactive-insertion G' G'' x) x₁ (weaken2-val G' G'' x₂)
weaken2-command G' G'' (New s κ) = New s (weaken2-cont G' G'' κ)
weaken2-command G' G'' (Close ss v κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Close (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (Wait ss v κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Wait (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' v) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (Send ss ss-args vch v κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl with split-append G₁' ss-args
... | G₁₁' , G₁₂' , G₁₁ , G₁₂ , ss-args' , ss0-args , refl , refl = Send (splitting-insertion G'' ss' ss0) (splitting-insertion G'' ss-args' ss0-args) (weaken2-val G₁₁' G'' vch) (weaken2-val G₁₂' G'' v) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (Recv ss vch κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Recv (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' vch) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (Select ss lab vch κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Select (splitting-insertion G'' ss' ss0) lab (weaken2-val G₁' G'' vch) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (Branch ss vch dcont) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = Branch (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' vch) λ lab → weaken2-cont G₂' G'' (dcont lab)
weaken2-command G' G'' (NSelect ss lab vch κ) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = NSelect (splitting-insertion G'' ss' ss0) lab (weaken2-val G₁' G'' vch) (weaken2-cont G₂' G'' κ)
weaken2-command G' G'' (NBranch ss vch dcont) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = NBranch (splitting-insertion G'' ss' ss0) (weaken2-val G₁' G'' vch) λ lab → weaken2-cont G₂' G'' (dcont lab)

weaken2-threadpool : ∀ {G} G' G'' → ThreadPool (G' ++ G) → ThreadPool (G' ++ inactive-clone G'' ++ G)
weaken2-threadpool G' G'' (tnil ina) = tnil (inactive-insertion G' G'' ina)
weaken2-threadpool G' G'' (tcons ss cmd tp) with split-append G' ss
... | G₁' , G₂' , G₁ , G₂ , ss' , ss0 , refl , refl = tcons (splitting-insertion G'' ss' ss0) (weaken2-command G₁' G'' cmd) (weaken2-threadpool G₂' G'' tp)

-- translate a process term to semantics (i.e., a list of commands)
runProc : ∀ {Φ} → (G : SCtx) → Proc Φ → VEnv G Φ → ∃ λ G' → ThreadPool (G' ++ G)

runProc G (exp e) ϱ with ssplit-refl-left-inactive G
... | G' , ina-G' , sp-GGG' = [] , (tcons sp-GGG' (run (split-all-left _) sp-GGG' e ϱ (halt ina-G' UUnit)) (tnil ina-G'))

runProc G (par sp P₁ P₂) ϱ with split-env sp ϱ
... | (G₁ , G₂) , ss-GG1G2 , ϱ₁ , ϱ₂ with runProc G₁ P₁ ϱ₁ | runProc G₂ P₂ ϱ₂
... | (G₁' , tp1) | (G₂' , tp2) with weaken1-threadpool G₁' tp2
... | tp2' with weaken2-threadpool G₁' G₂' tp1
... | tp1' with left-right G₁' G₂'
... | ss-G1'G2' rewrite sym (list-assoc G₁' (inactive-clone G₂') G₁) | sym (list-assoc (inactive-clone G₁') G₂' G₂) = (G₁' ++ G₂') , tappend ssfinal tp1' tp2'
  where
    ssfinal : SSplit ((G₁' ++ G₂') ++ G) ((G₁' ++ inactive-clone G₂') ++ G₁) ((inactive-clone G₁' ++ G₂') ++ G₂)
    ssfinal = ssplit-append (G₁' ++ G₂') G ss-G1'G2' ss-GG1G2

runProc G (res s P) ϱ with ssplit-refl-right-inactive G
... | G1 , ina-G1 , ss-GG1G with runProc (just (SType.force s , POSNEG) ∷ G) P (vcons (ss-posneg ss-GG1G) (VChan POS (here-pos ina-G1 (subF-refl _))) (vcons (ss-left ss-GG1G) (VChan NEG (here-neg ina-G1 (subF-refl _))) (lift-venv ϱ)))
... | G' , tp = G' ++ just (SType.force s , POSNEG) ∷ [] , tp'
  where
    tp' : ThreadPool ((G' ++ just (SType.force s , POSNEG) ∷ []) ++ G)
    tp' rewrite list-assoc G' (just (SType.force s , POSNEG) ∷ []) G = tp

startProc : Gas → Proc [] → Outcome
startProc f P with runProc [] P (vnil []-inactive)
... | G , tp = schedule f tp


{-# OPTIONS --rewriting #-}

module Term.Core where

open import Context
open import Type

open import Function
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Data.Empty
open import Data.Unit.Base
open import Data.Sum.Base

{-# BUILTIN REWRITE _≡_ #-}

{-# REWRITE foldlᶜ-▻-ε #-}
{-# REWRITE mapᶜ-▻▻    #-}

{-# REWRITE keep-id      #-}
{-# REWRITE dupl-keep-vs #-}

{-# REWRITE renᵗ-id #-}
{-# REWRITE renᵗ-∘  #-}

{-# REWRITE subᵗ-idᵉ  #-}
{-# REWRITE subᵗ-renᵗ #-}
{-# REWRITE subᵗ-Var  #-}

{-# REWRITE inject-foldr-⇒-renᵗ #-}
{-# REWRITE inject-foldr-⇒-subᵗ #-}

infix  3 _⊢_
infix  4 Λ_ ƛ_
infixl 7 _·_
infix  9 _[_]

unfold : ∀ {Θ κ} -> Θ ⊢ᵗ (κ ⇒ᵏ ⋆) ⇒ᵏ κ ⇒ᵏ ⋆ -> Θ ⊢ᵗ κ -> Θ ⊢ᵗ ⋆
unfold ψ α = normalize $ ψ ∙ Lam (μ (shiftᵗ ψ) (Var vz)) ∙ α

data _⊢_ : ∀ {Θ} -> Con (Star Θ) -> Star Θ -> Set where
  var  : ∀ {Θ Γ} {α : Star Θ}   -> α ∈ Γ -> Γ ⊢ α
  Λ_   : ∀ {Θ Γ σ} {α : Star (Θ ▻ σ)} -> shiftᶜ Γ ⊢ α -> Γ ⊢ π σ α
  -- A normalizing at the type level type instantiation.
  _[_] : ∀ {Θ Γ σ} {β : Star (Θ ▻ σ)} -> Γ ⊢ π σ β -> (α : Θ ⊢ᵗ σ) -> Γ ⊢ β [ α ]ᵗ
  -- A non-normalizing at the type level type instantiation.
  _<_> : ∀ {Θ Γ σ} {β : Star (Θ ▻ σ)} -> Γ ⊢ π σ β -> (α : Θ ⊢ᵗ σ) -> Γ ⊢ β < α >ᵗ
  -- A shorthand for `_< Var vz >` with more convenient computation at the type level.
  _<>  : ∀ {Θ σ Γ} {β : Star (Θ ▻ σ ▻ σ)} -> Γ ⊢ π σ β -> Γ ⊢ unshiftᵗ β
  ƛ_   : ∀ {Θ Γ} {α β : Star Θ} -> Γ ▻ α ⊢ β -> Γ ⊢ α ⇒ β
  _·_  : ∀ {Θ Γ} {α β : Star Θ} -> Γ ⊢ α ⇒ β -> Γ ⊢ α -> Γ ⊢ β
  iwrap  : ∀ {Θ Γ κ ψ} {α : Θ ⊢ᵗ κ} -> Γ ⊢ unfold ψ α -> Γ ⊢ μ ψ α
  unwrap : ∀ {Θ Γ κ ψ} {α : Θ ⊢ᵗ κ} -> Γ ⊢ μ ψ α -> Γ ⊢ unfold ψ α

Term⁺ : Star⁺ -> Set
Term⁺ α = ∀ {Θ} {Γ : Con (Star Θ)} -> Γ ⊢ normalize α

Term⁻ : ∀ {Θ} -> Star Θ -> Set
Term⁻ α = ∀ {Γ} -> Γ ⊢ normalize α

bind : ∀ {Θ Γ} {α β : Star Θ} -> Γ ⊢ α -> Γ ▻ α ⊢ β -> Γ ⊢ β
bind term body = (ƛ body) · term

ren : ∀ {Θ Γ Δ} {α : Star Θ} -> Γ ⊆ Δ -> Γ ⊢ α -> Δ ⊢ α
ren ι (var v)       = var (renᵛ ι v)
ren ι (Λ body)      = Λ (ren (mapᶜ-⊆ ι) body)
ren ι (fun [ α ])   = ren ι fun [ α ]
ren ι (fun < α >)   = ren ι fun < α >
ren ι (fun <>)      = ren ι fun <>
ren ι (ƛ body)      = ƛ (ren (keep ι) body)
ren ι (fun · arg)   = ren ι fun · ren ι arg
ren ι (iwrap  term) = iwrap (ren ι term)
ren ι (unwrap term) = unwrap (ren ι term)

shiftⁿ : ∀ {Θ Γ} {α : Star Θ} Δ -> Γ ⊢ α -> Γ ▻▻ Δ ⊢ α
shiftⁿ = ren ∘ extʳ

shift : ∀ {Θ Γ} {α β : Star Θ} -> Γ ⊢ α -> Γ ▻ β ⊢ α
shift = shiftⁿ (ε ▻ _)

instNonRec : ∀ {Θ Γ Δ} {α : Star Θ} -> Seq (Γ ⊢_) Δ -> Γ ▻▻ Δ ⊢ α -> Γ ⊢ α
instNonRec              ø           body = body
instNonRec {Δ = Δ ▻ _} (seq ▶ term) body = instNonRec seq (bind (shiftⁿ Δ term) body)

module Y where
  self : Type⁺ (⋆ ⇒ᵏ ⋆)
  self = Lam μ (Lam Lam (Var (vs vz) ∙ Var vz ⇒ Var vz)) (Var vz)

  unfoldˢ : Term⁺ (π ⋆ $ self ∙ Var vz ⇒ self ∙ Var vz ⇒ Var vz)
  unfoldˢ = Λ ƛ unwrap (var vz)

  unrollˢ : Term⁺ (π ⋆ $ self ∙ Var vz ⇒ Var vz)
  unrollˢ = Λ ƛ unfoldˢ [ Var vz ] · var vz · var vz

  fix : Term⁺ (π ⋆ $ (Var vz ⇒ Var vz) ⇒ Var vz)
  fix = Λ ƛ unrollˢ [ Var vz ] · iwrap (ƛ var (vs vz) · (unrollˢ [ Var vz ] · var vz))
open Y using (fix)

tuple : ∀ {Θ} -> Star (Θ ▻ ⋆) -> Star Θ
tuple Fv = π ⋆ $ Fv ⇒ Var vz

endo : ∀ {Θ} -> Star (Θ ▻ ⋆) -> Star Θ
endo Fv = π ⋆ $ Fv ⇒ Fv

fixBy
  : ∀ {Θ} {Γ : Con (Star Θ)}
  -> (Fv : Star (Θ ▻ ⋆))
  -> Γ ⊢ (tuple Fv ⇒ tuple Fv) ⇒ endo Fv ⇒ tuple Fv
fixBy Fv =
  ƛ fix < endo Fv ⇒ tuple Fv > ·
    (ƛ ƛ Λ ƛ (var (vs vs vs vz) ·
      (Λ ƛ (var (vs vs vs vz) · var (vs vs vz)) <> ·
        -- `bind` is in order to make REWRITE rules fire (yeah, it's silly).
        (bind (var (vs vs vz) <>) (var vz) · var vz))) <> · var vz)

ƛⁿ
  : ∀ {Θ Ξ Γ} {f : Star Ξ -> Star Θ} {β}
  -> ∀ Δ -> Γ ▻▻ mapᶜ f Δ ⊢ β -> Γ ⊢ conToTypeBy f Δ β
ƛⁿ  ε      term = term
ƛⁿ (Δ ▻ τ) body = ƛⁿ Δ (ƛ body)

ƛⁿ'
  : ∀ {Θ Γ} {β : Star Θ}
  -> ∀ Δ -> Γ ▻▻ Δ ⊢ β -> Γ ⊢ conToTypeBy id Δ β
ƛⁿ'  ε      term = term
ƛⁿ' (Δ ▻ τ) body = ƛⁿ' Δ (ƛ body)

applyⁿ
  : ∀ {Θ Ξ Γ} {β : Star Θ} {f : Star Ξ -> Star Θ}
  -> ∀ Δ -> Γ ⊢ conToTypeBy f Δ β -> Seq (λ τ -> Γ ⊢ f τ) Δ -> Γ ⊢ β
applyⁿ _ y  ø        = y
applyⁿ _ f (seq ▶ x) = applyⁿ _ f seq · x

deeply
  : ∀ {Θ Ξ Γ} {f : Star Ξ -> Star Θ} {β γ}
  -> ∀ Δ
  -> Γ ▻▻ mapᶜ f Δ ⊢ β ⇒ γ
  -> Γ ⊢ conToTypeBy f Δ β
  -> Γ ⊢ conToTypeBy f Δ γ
deeply  ε      g y = g · y
deeply (Δ ▻ τ) g f = deeply Δ (ƛ ƛ shiftⁿ (ε ▻ _ ▻ _) (ƛ g) · var vz · (var (vs vz) · var vz)) f

conToTypeShift : ∀ {Θ} -> Con (Star Θ) -> Star (Θ ▻ ⋆)
conToTypeShift Δ = conToTypeBy shiftᵗ Δ (Var vz)

-- This is not easy, but makes perfect sense and should be doable.
postulate
  shift-⊢ : ∀ {Θ Γ β} {α : Star Θ} -> Γ ⊢ α -> shiftᶜ {τ = β} Γ ⊢ shiftᵗ α

recursive
  : ∀ {Θ} {Γ : Con (Star (Θ ▻ ⋆))}
  -> (Δ : Con (Star Θ))
  -> Γ ⊢ π ⋆ (conToTypeBy (shiftᵗⁿ (ε ▻ _ ▻ _)) Δ (Var vz) ⇒ Var vz)
  -> Seq (λ β -> Γ ⊢ shiftᵗ β) Δ
recursive  ε      h = ø
recursive (Δ ▻ τ) h
  = recursive Δ (Λ ƛ shift (shift-⊢ h <>) · deeply Δ (ƛ ƛ var (vs vz)) (var vz))
  ▶ h < shiftᵗ τ > · (ƛⁿ Δ (ƛ var vz)) where

byCon : ∀ {Θ} (Δ : Con (Star Θ)) -> let F = conToTypeShift Δ in ∀ {Γ} -> Γ ⊢ tuple F ⇒ tuple F
byCon Δ = ƛ Λ ƛ applyⁿ Δ (var vz) (recursive Δ (var (vs vz)))

fixCon : ∀ {Θ} (Δ : Con (Star Θ)) -> let F = conToTypeShift Δ in ∀ {Γ} -> Γ ⊢ endo F ⇒ tuple F
fixCon Δ = fixBy (conToTypeShift Δ) · byCon Δ

record Tuple {Θ} (Γ Δ : Con (Star Θ)) : Set where
  constructor PackTuple
  field tupleTerm : Γ ⊢ tuple (conToTypeShift Δ)

mutualFix : ∀ {Θ} {Γ Δ : Con (Star Θ)} -> Seq (Γ ▻▻ Δ ⊢_) Δ -> Tuple Γ Δ
mutualFix {Γ = Γ} {Δ} seq
  = PackTuple
  $ fixCon Δ
  · (Λ ƛ ƛⁿ Δ (applyⁿ Δ (var (vsⁿ (shiftᶜ Δ))) $
      mapˢ (ren (keepⁿ (shiftᶜ Δ) ∘ extʳ $ ε ▻ _) ∘′ shift-⊢) seq))

-- Note that we do not perform the "pass the whole tuple in and extract each its element
-- separately" trick, because we do know the type of the result (it's `α`).
bindTuple : ∀ {Θ Γ Δ} {α : Star Θ} -> Tuple Γ Δ -> Γ ▻▻ Δ ⊢ α -> Γ ⊢ α
bindTuple {Θ} {Γ} {Δ} {α} (PackTuple tup) body = tup < α > · (ƛⁿ Δ body)

instRec : ∀ {Θ Γ Δ} {α : Star Θ} -> Seq (Γ ▻▻ Δ ⊢_) Δ -> Γ ▻▻ Δ ⊢ α -> Γ ⊢ α
instRec = bindTuple ∘ mutualFix


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

module Definition.Conversion.EqRelInstance where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening using (_∷_⊆_; wkEq)
open import Definition.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Universe
open import Definition.Conversion.Stability
open import Definition.Conversion.Soundness
open import Definition.Conversion.Lift
open import Definition.Conversion.Conversion
open import Definition.Conversion.Symmetry
open import Definition.Conversion.Transitivity
open import Definition.Conversion.Weakening
open import Definition.Typed.EqualityRelation
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Equality
open import Definition.Typed.Consequences.Reduction
open import Definition.Typed.Consequences.Inversion

open import Tools.Nat
open import Tools.Product
import Tools.PropositionalEquality as PE
open import Tools.Function

-- Algorithmic equality of neutrals with injected conversion.
record _⊢_~_∷_ (Γ : Con Term) (k l A : Term) : Set where
  inductive
  constructor ↑
  field
    {B} : Term
    A≡B : Γ ⊢ A ≡ B
    k~↑l : Γ ⊢ k ~ l ↑ B

-- Properties of algorithmic equality of neutrals with injected conversion.

~-var : ∀ {x A Γ} → Γ ⊢ var x ∷ A → Γ ⊢ var x ~ var x ∷ A
~-var x =
  let ⊢A = syntacticTerm x
  in  ↑ (refl ⊢A) (var-refl x PE.refl)

~-app : ∀ {f g a b F G Γ}
      → Γ ⊢ f ~ g ∷ Π F ▹ G
      → Γ ⊢ a [conv↑] b ∷ F
      → Γ ⊢ f ∘ a ~ g ∘ b ∷ G [ a ]
~-app (↑ A≡B x) x₁ =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΠFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΠHE = Π≡A ΠFG≡B′ whnfB′
      F≡H , G≡E = injectivity (PE.subst (λ x → _ ⊢ _ ≡ x) B≡ΠHE ΠFG≡B′)
      _ , ⊢f , _ = syntacticEqTerm (soundnessConv↑Term x₁)
  in  ↑ (substTypeEq G≡E (refl ⊢f))
        (app-cong (PE.subst (λ x → _ ⊢ _ ~ _ ↓ x)
                            B≡ΠHE
                            ([~] _ (red D) whnfB′ x))
             (convConvTerm x₁ F≡H))

~-fst : ∀ {Γ p r F G}
      → Γ ⊢ p ~ r ∷ Σ F ▹ G
      → Γ ⊢ fst p ~ fst r ∷ F
~-fst (↑ A≡B p~r) =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΣFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΣHE = Σ≡A ΣFG≡B′ whnfB′
      F≡H , G≡E = Σ-injectivity (PE.subst (λ x → _ ⊢ _ ≡ x) B≡ΣHE ΣFG≡B′)
      p~r↓ = PE.subst (λ x → _ ⊢ _ ~ _ ↓ x)
                      B≡ΣHE
                      ([~] _ (red D) whnfB′ p~r)
  in  ↑ F≡H (fst-cong p~r↓)

~-snd : ∀ {Γ p r F G}
      → Γ ⊢ p ~ r ∷ Σ F ▹ G
      → Γ ⊢ snd p ~ snd r ∷ G [ fst p ]
~-snd (↑ A≡B p~r) =
  let ⊢ΣFG , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ΣFG≡B′ = trans A≡B (subset* (red D))
      H , E , B≡ΣHE = Σ≡A ΣFG≡B′ whnfB′
      F≡H , G≡E = Σ-injectivity (PE.subst (λ x → _ ⊢ _ ≡ x) B≡ΣHE ΣFG≡B′)
      p~r↓ = PE.subst (λ x → _ ⊢ _ ~ _ ↓ x)
                      B≡ΣHE
                      ([~] _ (red D) whnfB′ p~r)
      ⊢F , ⊢G = syntacticΣ ⊢ΣFG
      _ , ⊢p , _ = syntacticEqTerm (soundness~↑ p~r)
      ⊢fst = fstⱼ ⊢F ⊢G (conv ⊢p (sym A≡B))
  in  ↑ (substTypeEq G≡E (refl ⊢fst)) (snd-cong p~r↓)

~-natrec : ∀ {z z′ s s′ n n′ F F′ Γ}
         → (Γ ∙ ℕ) ⊢ F [conv↑] F′ →
      Γ ⊢ z [conv↑] z′ ∷ (F [ zero ]) →
      Γ ⊢ s [conv↑] s′ ∷ (Π ℕ ▹ (F ▹▹ F [ suc (var 0) ]↑)) →
      Γ ⊢ n ~ n′ ∷ ℕ →
      Γ ⊢ natrec F z s n ~ natrec F′ z′ s′ n′ ∷ (F [ n ])
~-natrec x x₁ x₂ (↑ A≡B x₄) =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      ℕ≡B′ = trans A≡B (subset* (red D))
      B≡ℕ = ℕ≡A ℕ≡B′ whnfB′
      k~l′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡ℕ
                      ([~] _ (red D) whnfB′ x₄)
      ⊢F , _ = syntacticEq (soundnessConv↑ x)
      _ , ⊢n , _ = syntacticEqTerm (soundness~↓ k~l′)
  in  ↑ (refl (substType ⊢F ⊢n))
        (natrec-cong x x₁ x₂ k~l′)

~-Emptyrec : ∀ {n n′ F F′ Γ}
         → Γ ⊢ F [conv↑] F′ →
      Γ ⊢ n ~ n′ ∷ Empty →
      Γ ⊢ Emptyrec F n ~ Emptyrec F′ n′ ∷ F
~-Emptyrec x (↑ A≡B x₄) =
  let _ , ⊢B = syntacticEq A≡B
      B′ , whnfB′ , D = whNorm ⊢B
      Empty≡B′ = trans A≡B (subset* (red D))
      B≡Empty = Empty≡A Empty≡B′ whnfB′
      k~l′ = PE.subst (λ x → _ ⊢ _ ~ _ ↓ x) B≡Empty
                      ([~] _ (red D) whnfB′ x₄)
      ⊢F , _ = syntacticEq (soundnessConv↑ x)
      _ , ⊢n , _ = syntacticEqTerm (soundness~↓ k~l′)
  in  ↑ (refl ⊢F)
        (Emptyrec-cong x k~l′)

~-sym : {k l A : Term} {Γ : Con Term} → Γ ⊢ k ~ l ∷ A → Γ ⊢ l ~ k ∷ A
~-sym (↑ A≡B x) =
  let ⊢Γ = wfEq A≡B
      B , A≡B′ , l~k = sym~↑ (reflConEq ⊢Γ) x
  in  ↑ (trans A≡B A≡B′) l~k

~-trans : {k l m A : Term} {Γ : Con Term}
        → Γ ⊢ k ~ l ∷ A → Γ ⊢ l ~ m ∷ A
        → Γ ⊢ k ~ m ∷ A
~-trans (↑ x x₁) (↑ x₂ x₃) =
  let ⊢Γ = wfEq x
      k~m , _ = trans~↑ x₁ x₃
  in  ↑ x k~m

~-wk : {k l A : Term} {ρ : Wk} {Γ Δ : Con Term} →
      ρ ∷ Δ ⊆ Γ →
      ⊢ Δ → Γ ⊢ k ~ l ∷ A → Δ ⊢ wk ρ k ~ wk ρ l ∷ wk ρ A
~-wk x x₁ (↑ x₂ x₃) = ↑ (wkEq x x₁ x₂) (wk~↑ x x₁ x₃)

~-conv : {k l A B : Term} {Γ : Con Term} →
      Γ ⊢ k ~ l ∷ A → Γ ⊢ A ≡ B → Γ ⊢ k ~ l ∷ B
~-conv (↑ x x₁) x₂ = ↑ (trans (sym x₂) x) x₁

~-to-conv : {k l A : Term} {Γ : Con Term} →
      Γ ⊢ k ~ l ∷ A → Γ ⊢ k [conv↑] l ∷ A
~-to-conv (↑ x x₁) = convConvTerm (lift~toConv↑ x₁) (sym x)

-- Algorithmic equality instance of the generic equality relation.
instance eqRelInstance : EqRelSet
eqRelInstance = record {
  _⊢_≅_ = _⊢_[conv↑]_;
  _⊢_≅_∷_ = _⊢_[conv↑]_∷_;
  _⊢_~_∷_ = _⊢_~_∷_;
  ~-to-≅ₜ = ~-to-conv;
  ≅-eq = soundnessConv↑;
  ≅ₜ-eq = soundnessConv↑Term;
  ≅-univ = univConv↑;
  ≅-sym = symConv;
  ≅ₜ-sym = symConvTerm;
  ~-sym = ~-sym;
  ≅-trans = transConv;
  ≅ₜ-trans = transConvTerm;
  ~-trans = ~-trans;
  ≅-conv = convConvTerm;
  ~-conv = ~-conv;
  ≅-wk = wkConv↑;
  ≅ₜ-wk = wkConv↑Term;
  ~-wk = ~-wk;
  ≅-red = λ x x₁ x₂ x₃ x₄ → reductionConv↑ x x₁ x₄;
  ≅ₜ-red = λ x x₁ x₂ x₃ x₄ x₅ x₆ → reductionConv↑Term x x₁ x₂ x₆;
  ≅-Urefl = liftConv ∘ᶠ U-refl;
  ≅-ℕrefl = liftConv ∘ᶠ ℕ-refl;
  ≅ₜ-ℕrefl = λ x → liftConvTerm (univ (ℕⱼ x) (ℕⱼ x) (ℕ-refl x));
  ≅-Emptyrefl = liftConv ∘ᶠ Empty-refl;
  ≅ₜ-Emptyrefl = λ x → liftConvTerm (univ (Emptyⱼ x) (Emptyⱼ x) (Empty-refl x));
  ≅-Unitrefl = liftConv ∘ᶠ Unit-refl;
  ≅ₜ-Unitrefl = λ ⊢Γ → liftConvTerm (univ (Unitⱼ ⊢Γ) (Unitⱼ ⊢Γ) (Unit-refl ⊢Γ));
  ≅ₜ-η-unit = λ [e] [e'] → let u , uWhnf , uRed = whNormTerm [e]
                               u' , u'Whnf , u'Red = whNormTerm [e']
                               [u] = ⊢u-redₜ uRed
                               [u'] = ⊢u-redₜ u'Red
                           in  [↑]ₜ Unit u u'
                               (red (idRed:*: (syntacticTerm [e])))
                               (redₜ uRed)
                               (redₜ u'Red)
                               Unitₙ uWhnf u'Whnf
                               (η-unit [u] [u'] uWhnf u'Whnf);
  ≅-Π-cong = λ x x₁ x₂ → liftConv (Π-cong x x₁ x₂);
  ≅ₜ-Π-cong = λ x x₁ x₂ → let _ , F∷U , H∷U = syntacticEqTerm (soundnessConv↑Term x₁)
                              _ , G∷U , E∷U = syntacticEqTerm (soundnessConv↑Term x₂)
                              ⊢Γ = wfTerm F∷U
                              F<>H = univConv↑ x₁
                              G<>E = univConv↑ x₂
                              F≡H = soundnessConv↑ F<>H
                              E∷U′ = stabilityTerm (reflConEq ⊢Γ ∙ F≡H) E∷U
                          in  liftConvTerm (univ (Πⱼ F∷U ▹ G∷U) (Πⱼ H∷U ▹ E∷U′)
                                                (Π-cong x F<>H G<>E));
  ≅-Σ-cong = λ x x₁ x₂ → liftConv (Σ-cong x x₁ x₂);
  ≅ₜ-Σ-cong = λ x x₁ x₂ → let _ , F∷U , H∷U = syntacticEqTerm (soundnessConv↑Term x₁)
                              _ , G∷U , E∷U = syntacticEqTerm (soundnessConv↑Term x₂)
                              ⊢Γ = wfTerm F∷U
                              F<>H = univConv↑ x₁
                              G<>E = univConv↑ x₂
                              F≡H = soundnessConv↑ F<>H
                              E∷U′ = stabilityTerm (reflConEq ⊢Γ ∙ F≡H) E∷U
                          in  liftConvTerm (univ (Σⱼ F∷U ▹ G∷U) (Σⱼ H∷U ▹ E∷U′)
                                                (Σ-cong x F<>H G<>E));
  ≅ₜ-zerorefl = liftConvTerm ∘ᶠ zero-refl;
  ≅-suc-cong = liftConvTerm ∘ᶠ suc-cong;
  ≅-η-eq = λ x x₁ x₂ x₃ x₄ x₅ → liftConvTerm (η-eq x₁ x₂ x₃ x₄ x₅);
  ≅-Σ-η = λ x x₁ x₂ x₃ x₄ x₅ x₆ x₇ → (liftConvTerm (Σ-η x₂ x₃ x₄ x₅ x₆ x₇));
  ~-var = ~-var;
  ~-app = ~-app;
  ~-fst = λ x x₁ x₂ → ~-fst x₂;
  ~-snd = λ x x₁ x₂ → ~-snd x₂;
  ~-natrec = ~-natrec;
  ~-Emptyrec = ~-Emptyrec }


-- Andreas, 2014-06-27
-- {-# OPTIONS -v tc.lhs:40 #-}
{-# OPTIONS --copatterns #-}

record Coind : Set where
  coinductive
  field ind : Coind

open Coind

loop : Set -> Coind
ind A (loop B) = ind (loop A)

-- WAS: Internal error.

-- NOW: Proper error.
-- Cannot eliminate type Coind with pattern ind A (did you supply too many arguments?)
-- when checking that the clause ind A (loop B) = ind (loop A) has
-- type Set → Coind


------------------------------------------------------------------------
-- Lemmas related to expansion and CCS
------------------------------------------------------------------------

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

open import Prelude hiding (module W; step-→)

module Expansion.CCS {ℓ} {Name : Type ℓ} where

open import Equality.Propositional
open import Prelude.Size

open import Function-universe equality-with-J hiding (id; _∘_)

import Bisimilarity.CCS as SL
import Bisimilarity.Equational-reasoning-instances
import Bisimilarity.Weak.Equational-reasoning-instances
open import Equational-reasoning
import Expansion.Equational-reasoning-instances
open import Labelled-transition-system.CCS Name
open import Relation

open import Bisimilarity CCS as S using (_∼_)
open import Bisimilarity.Weak CCS as W using (_≈_; force)
open import Expansion CCS
import Labelled-transition-system.Equational-reasoning-instances CCS
  as Dummy

-- Some lemmas used to prove the congruence lemmas below as well as
-- similar results in Bisimilarity.Weak.CCS.

module Cong-lemmas
  ({R} R′ : Proc ∞ → Proc ∞ → Type ℓ)
  ⦃ _ : Reflexive R′ ⦄
  ⦃ _ : Convertible R R′ ⦄
  ⦃ _ : Convertible R′ R′ ⦄
  ⦃ _ : Transitive′ R′ _∼_ ⦄
  ⦃ _ : Transitive _∼_ R′ ⦄
  {_[_]↝_ : Proc ∞ → Label → Proc ∞ → Type ℓ}
  (right-to-left :
   ∀ {P Q} → R P Q →
   ∀ {Q′ μ} → Q [ μ ]⟶ Q′ → ∃ λ P′ → P [ μ ]↝ P′ × R′ P′ Q′)
  ⦃ _ : ∀ {μ} → Convertible _[ μ ]↝_ _[ μ ]↝_ ⦄
  ⦃ _ : ∀ {μ} → Convertible _[ μ ]⟶_ _[ μ ]↝_ ⦄
  (↝→[]⇒ : ∀ {P Q a} → P [ name a ]↝ Q → P [ name a ]⇒ Q)
  ([]⇒→↝ : ∀ {P Q} → P [ τ ]⇒ Q → P [ τ ]↝ Q)
  (map-↝ :
    {F : Proc ∞ → Proc ∞} →
    (∀ {P P′ μ} → P [ μ ]⟶ P′ → F P [ μ ]⟶ F P′) →
    ∀ {P P′ μ} → P [ μ ]↝ P′ → F P [ μ ]↝ F P′)
  (map-↝′ :
    ∀ {μ} {F : Proc ∞ → Proc ∞} →
    (∀ {P P′ μ} → Silent μ → P [ μ ]⟶ P′ → F P [ μ ]⟶ F P′) →
    (∀ {P P′} → P [ μ ]⟶ P′ → F P [ μ ]⟶ F P′) →
    ∀ {P P′} → P [ μ ]↝ P′ → F P [ μ ]↝ F P′)
  (zip-↝ :
    {F : Proc ∞ → Proc ∞ → Proc ∞} →
    (∀ {P P′ Q μ} → P [ μ ]⟶ P′ → F P Q [ μ ]⟶ F P′ Q) →
    (∀ {P Q Q′ μ} → Q [ μ ]⟶ Q′ → F P Q [ μ ]⟶ F P Q′) →
    ∀ {μ₁ μ₂ μ₃} →
    (Silent μ₁ → Silent μ₂ → Silent μ₃) →
    (∀ {P P′ Q} → P [ μ₁ ]⟶ P′ → Silent μ₂ → F P Q [ μ₃ ]⟶ F P′ Q) →
    (∀ {P Q Q′} → Silent μ₁ → Q [ μ₂ ]⟶ Q′ → F P Q [ μ₃ ]⟶ F P Q′) →
    (∀ {P P′ Q Q′} →
     P [ μ₁ ]⟶ P′ → Q [ μ₂ ]⟶ Q′ → F P Q [ μ₃ ]⟶ F P′ Q′) →
    ∀ {P P′ Q Q′} →
    P [ μ₁ ]↝ P′ → Q [ μ₂ ]↝ Q′ → F P Q [ μ₃ ]↝ F P′ Q′)
  (!-lemma :
    (∀ {P Q μ} → P [ μ ]⇒ Q → ! P [ μ ]⇒ ! P ∣ Q) →
    ∀ {P Q μ} → P [ μ ]↝ Q →
    ∃ λ P′ → ((! P) [ μ ]↝ P′) × P′ ∼ ! P ∣ Q)
  where

  private

    infix -3 rl-result-↝

    rl-result-↝ : ∀ {P P′ Q′} μ → P [ μ ]↝ P′ → R′ P′ Q′ →
                  ∃ λ P′ → (P [ μ ]↝ P′) × R′ P′ Q′
    rl-result-↝ _ P↝P′ P′≳′Q′ = _ , P↝P′ , P′≳′Q′

    syntax rl-result-↝ μ P↝P′ P′≳′Q′ = P↝P′ ↝[ μ ] P′≳′Q′

  ∣-cong :
    (∀ {P P′ Q Q′} → R′ P P′ → R′ Q Q′ → R′ (P ∣ Q) (P′ ∣ Q′)) →
    ∀ {P₁ P₂ Q₁ Q₂ R₂ μ} →
    R P₁ P₂ → R Q₁ Q₂ → P₂ ∣ Q₂ [ μ ]⟶ R₂ →
    ∃ λ R₁ → ((P₁ ∣ Q₁) [ μ ]↝ R₁) × R′ R₁ R₂
  ∣-cong _∣-cong′_ P₁≳P₂ Q₁≳Q₂ = λ where
    (par-left  tr)  → Σ-map (_∣ _)
                        (Σ-map (map-↝ par-left)
                               (_∣-cong′ convert Q₁≳Q₂))
                        (right-to-left P₁≳P₂ tr)
    (par-right tr)  → Σ-map (_ ∣_)
                        (Σ-map (map-↝ par-right)
                               (convert P₁≳P₂ ∣-cong′_))
                        (right-to-left Q₁≳Q₂ tr)
    (par-τ tr₁ tr₂) → Σ-zip _∣_
                        (Σ-zip (zip-↝ par-left par-right
                                      (λ ()) (λ _ ()) (λ ())
                                      par-τ)
                               _∣-cong′_)
                        (right-to-left P₁≳P₂ tr₁)
                        (right-to-left Q₁≳Q₂ tr₂)

  ·-cong :
    ∀ {P₁ P₂ Q₂ μ μ′} →
    R′ (force P₁) (force P₂) → μ · P₂ [ μ′ ]⟶ Q₂ →
    ∃ λ Q₁ → ((μ · P₁) [ μ′ ]↝ Q₁) × R′ Q₁ Q₂
  ·-cong P₁≳P₂ action = _ , convert (⟶: action) , P₁≳P₂

  ⟨ν⟩-cong :
    (∀ {a P P′} → R′ P P′ → R′ (⟨ν a ⟩ P) (⟨ν a ⟩ P′)) →
    ∀ {a μ P P′ Q′} →
    R P P′ → ⟨ν a ⟩ P′ [ μ ]⟶ Q′ →
    ∃ λ Q → (⟨ν a ⟩ P [ μ ]↝ Q) × R′ Q Q′
  ⟨ν⟩-cong ⟨ν⟩-cong′ {a} {μ} {P} P≳P′
           (restriction {P′ = Q′} a∉μ P′⟶Q′) =
    case right-to-left P≳P′ P′⟶Q′ of λ where
      (Q , P↝Q , Q≳′Q′) →
        ⟨ν a ⟩ P   →⟨ map-↝′ (restriction ∘ ∉τ) (restriction a∉μ) P↝Q ⟩■
          ↝[ μ ]
        ⟨ν a ⟩ Q   ∼⟨ ⟨ν⟩-cong′ Q≳′Q′ ⟩■
        ⟨ν a ⟩ Q′

  !-cong-lemma₁ : ∀ {P Q μ} → P [ μ ]⇒ Q → ! P [ μ ]⇒ ! P ∣ Q
  !-cong-lemma₁ {P} {Q} {μ} = λ where
    (steps {q′ = Q′} done P⟶Q′ Q′⇒Q) →
      ! P       [ μ ]⇒⟨ replication (par-right P⟶Q′) ⟩
      ! P ∣ Q′  →⟨ map-⇒ par-right Q′⇒Q ⟩■
      ! P ∣ Q

    (steps {p′ = P″} {q′ = Q′}
           (step {q = P′} {μ = μ′} μ′s P⟶P′ P′⇒P″)
           P″⟶Q′ Q′⇒Q) →
      ! P       →⟨ ⟶→⇒ μ′s (replication (par-right P⟶P′)) ⟩
      ! P ∣ P′  →⟨ map-⇒ par-right P′⇒P″ ⟩
      ! P ∣ P″  [ μ ]⇒⟨ par-right P″⟶Q′ ⟩
      ! P ∣ Q′  →⟨ map-⇒ par-right Q′⇒Q ⟩■
      ! P ∣ Q

  !-cong-lemma₂ :
    ∀ {P Q₁ Q₂ a} →
    P [ name a ]⇒ Q₁ → P [ name (co a) ]⇒ Q₂ →
    ∃ λ R → ! P [ τ ]⇒ R × R ∼ (! P ∣ Q₁) ∣ Q₂
  !-cong-lemma₂ {P} {Q₁} {Q₂} {a} = λ where
    (steps {q′ = Q₁′} done P⟶Q₁′ Q₁′⇒Q₁)
      (steps {q′ = Q₂′} done P⟶Q₂′ Q₂′⇒Q₂) →
        _
      , (! P                [ τ ]⇒⟨ replication (par-τ (replication (par-right P⟶Q₁′)) P⟶Q₂′) ⟩
         (! P ∣ Q₁′) ∣ Q₂′  →⟨ zip-⇒ par-left par-right (map-⇒ par-right Q₁′⇒Q₁) Q₂′⇒Q₂ ⟩■
         (! P ∣ Q₁) ∣ Q₂)
      , reflexive

    (steps {q′ = Q₁′} done P⟶Q₁′ Q₁′⇒Q₁)
      (steps {p′ = P₂″} {q′ = Q₂′}
             (step {q = P₂′} {μ = μ} μs P⟶P₂′ P₂′⇒P₂″)
             P₂″⟶Q₂′ Q₂′⇒Q₂) →
        _
      , (! P                →⟨ ⟶→⇒ μs (replication (par-right P⟶P₂′)) ⟩
         ! P ∣ P₂′          →⟨ map-⇒ par-right P₂′⇒P₂″ ⟩
         ! P ∣ P₂″          [ τ ]⇒⟨ par-τ (replication (par-right P⟶Q₁′)) P₂″⟶Q₂′ ⟩
         (! P ∣ Q₁′) ∣ Q₂′  →⟨ zip-⇒ par-left par-right (map-⇒ par-right Q₁′⇒Q₁) Q₂′⇒Q₂ ⟩■
         (! P ∣ Q₁) ∣ Q₂)
      , reflexive

    (steps {p′ = P₁″} {q′ = Q₁′}
           (step {q = P₁′} {μ = μ} μs P⟶P₁′ P₁′⇒P₁″)
           P₁″⟶Q₁′ Q₁′⇒Q₁)
      (steps {q′ = Q₂′} done P⟶Q₂′ Q₂′⇒Q₂) →
        _
      , (! P                →⟨ ⟶→⇒ μs (replication (par-right P⟶P₁′)) ⟩
         ! P ∣ P₁′          →⟨ map-⇒ par-right P₁′⇒P₁″ ⟩
         ! P ∣ P₁″          [ τ ]⇒⟨ par-τ′ (sym $ co-involutive a) (replication (par-right P⟶Q₂′)) P₁″⟶Q₁′ ⟩
         (! P ∣ Q₂′) ∣ Q₁′  →⟨ zip-⇒ par-left par-right (map-⇒ par-right Q₂′⇒Q₂) Q₁′⇒Q₁ ⟩■
         (! P ∣ Q₂) ∣ Q₁)
      , ((! P ∣ Q₂) ∣ Q₁  ∼⟨ SL.swap-rightmost ⟩■
         (! P ∣ Q₁) ∣ Q₂)

    (steps {p′ = P₁″} {q′ = Q₁′}
           (step {q = P₁′} {μ = μ₁} μ₁s P⟶P₁′ P₁′⇒P₁″)
           P₁″⟶Q₁′ Q₁′⇒Q₁)
      (steps {p′ = P₂″} {q′ = Q₂′}
             (step {q = P₂′} {μ = μ₂} μ₂s P⟶P₂′ P₂′⇒P₂″)
             P₂″⟶Q₂′ Q₂′⇒Q₂) →
        _
      , (! P                →⟨ ⟶→⇒ μ₂s (replication (par-right P⟶P₂′)) ⟩
         ! P ∣ P₂′          →⟨ ⟶→⇒ μ₁s (par-left (replication (par-right P⟶P₁′))) ⟩
         (! P ∣ P₁′) ∣ P₂′  →⟨ zip-⇒ par-left par-right (map-⇒ par-right P₁′⇒P₁″) P₂′⇒P₂″ ⟩
         (! P ∣ P₁″) ∣ P₂″  [ τ ]⇒⟨ par-τ (par-right P₁″⟶Q₁′) P₂″⟶Q₂′ ⟩
         (! P ∣ Q₁′) ∣ Q₂′  →⟨ zip-⇒ par-left par-right (map-⇒ par-right Q₁′⇒Q₁) Q₂′⇒Q₂ ⟩■
         (! P ∣ Q₁) ∣ Q₂)
      , reflexive

  !-cong :
    (∀ {P P′ Q Q′} → R′ P P′ → R′ Q Q′ → R′ (P ∣ Q) (P′ ∣ Q′)) →
    (∀ {P P′} → R′ P P′ → R′ (! P) (! P′)) →
    ∀ {P P′ Q′ μ} →
    R P P′ → ! P′ [ μ ]⟶ Q′ →
    ∃ λ Q → ((! P) [ μ ]↝ Q) × R′ Q Q′
  !-cong _∣-cong′_ !-cong′_ {P} {P′} {Q′} {μ} P≳P′ !P′⟶Q′ =
    case SL.6-1-3-2 !P′⟶Q′ of λ where

      (inj₁ (P″ , P′⟶P″ , Q′∼!P′∣P″)) →
        let Q , P↝Q  , Q≳′P″  = right-to-left P≳P′ P′⟶P″
            R , !P↝R , R∼!P∣Q = !-lemma !-cong-lemma₁ P↝Q
        in
          ! P        →⟨ !P↝R ⟩■
            ↝[ μ ]
          R          ∼⟨ R∼!P∣Q ⟩
          ! P ∣ Q    ∼′⟨ (!-cong′ (convert P≳P′)) ∣-cong′ Q≳′P″ ⟩
          ! P′ ∣ P″  ∼⟨ symmetric Q′∼!P′∣P″ ⟩■
          Q′

      (inj₂ (refl , P″ , P‴ , a , P′⟶P″ , P′⟶P‴ , Q′∼!P′∣P″∣P‴)) →
        let Q₁ , P↝Q₁ , Q₁≳′P″ = right-to-left P≳P′ P′⟶P″
            Q₂ , P↝Q₂ , Q₂≳′P‴ = right-to-left P≳P′ P′⟶P‴

            R , !P⇒R , R∼[!P∣Q₁]∣Q₂ =
              !-cong-lemma₂ (↝→[]⇒ P↝Q₁) (↝→[]⇒ P↝Q₂)
        in
          ! P               →⟨ []⇒→↝ !P⇒R ⟩■
            ↝[ τ ]
          R                 ∼⟨ R∼[!P∣Q₁]∣Q₂ ⟩
          (! P ∣ Q₁) ∣ Q₂   ∼′⟨ ((!-cong′ (convert P≳P′)) ∣-cong′ Q₁≳′P″) ∣-cong′ Q₂≳′P‴ ⟩
          (! P′ ∣ P″) ∣ P‴  ∼⟨ symmetric Q′∼!P′∣P″∣P‴ ⟩■
          Q′

  ⊕·-cong :
    ∀ {P Q Q′ S′ μ μ′} →
    R′ (force Q) (force Q′) → P ⊕ μ · Q′ [ μ′ ]⟶ S′ →
    ∃ λ S → ((P ⊕ μ · Q) [ μ′ ]↝ S) × R′ S S′
  ⊕·-cong {P} {Q} {Q′} {S′} {μ} {μ′} Q≳Q′ = λ where
    (sum-left P⟶S′) →
      P ⊕ μ · Q  →⟨ ⟶: sum-left P⟶S′ ⟩■
        ↝[ μ′ ]
      S′         ■

    (sum-right action) →
      P ⊕ μ · Q  →⟨ ⟶: sum-right action ⟩■
        ↝[ μ ]
      force Q    ∼⟨ Q≳Q′ ⟩■
      force Q′

  ·⊕·-cong :
    ∀ {μ₁ μ₂ P₁ P₁′ P₂ P₂′ S′ μ} →
    R′ (force P₁) (force P₁′) → R′ (force P₂) (force P₂′) →
    μ₁ · P₁′ ⊕ μ₂ · P₂′ [ μ ]⟶ S′ →
    ∃ λ S → ((μ₁ · P₁ ⊕ μ₂ · P₂) [ μ ]↝ S) × R′ S S′
  ·⊕·-cong {μ₁} {μ₂} {P₁} {P₁′} {P₂} {P₂′} P₁≳P₁′ P₂≳P₂′ = λ where
    (sum-left action) →
      μ₁ · P₁ ⊕ μ₂ · P₂  →⟨ ⟶: sum-left action ⟩■
        ↝[ μ₁ ]
      force P₁           ∼⟨ P₁≳P₁′ ⟩■
      force P₁′

    (sum-right action) →
      μ₁ · P₁ ⊕ μ₂ · P₂  →⟨ ⟶: sum-right action ⟩■
        ↝[ μ₂ ]
      force P₂           ∼⟨ P₂≳P₂′ ⟩■
      force P₂′

private
  module CL {i} =
    Cong-lemmas
      [ i ]_≳′_ right-to-left id id
      map-[]⇒ map-[]⇒′ (λ f g _ _ _ → zip-[]⇒ f g)
      (λ hyp P⇒Q → _ , hyp P⇒Q , reflexive)

mutual

  -- _∣_ preserves the expansion relation.

  infix 6 _∣-cong_ _∣-cong′_

  _∣-cong_ : ∀ {i P P′ Q Q′} →
             [ i ] P ≳ P′ → [ i ] Q ≳ Q′ → [ i ] P ∣ Q ≳ P′ ∣ Q′
  _∣-cong_ {i} P≳P′ Q≳Q′ =
    ⟨ lr P≳P′ Q≳Q′
    , CL.∣-cong _∣-cong′_ P≳P′ Q≳Q′
    ⟩
    where
    lr : ∀ {P P′ Q Q′ R μ} →
         [ i ] P ≳ P′ → [ i ] Q ≳ Q′ → P ∣ Q [ μ ]⟶ R →
         ∃ λ R′ → P′ ∣ Q′ [ μ ]⟶̂ R′ × [ i ] R ≳′ R′
    lr P≳P′ Q≳Q′ (par-left  tr)  = Σ-map (_∣ _)
                                         (Σ-map (map-⟶̂ par-left)
                                                (_∣-cong′ convert {a = ℓ} Q≳Q′))
                                     (left-to-right P≳P′ tr)
    lr P≳P′ Q≳Q′ (par-right tr)  = Σ-map (_ ∣_)
                                         (Σ-map (map-⟶̂ par-right)
                                                (convert {a = ℓ} P≳P′ ∣-cong′_))
                                     (left-to-right Q≳Q′ tr)
    lr P≳P′ Q≳Q′ (par-τ tr₁ tr₂) = Σ-zip _∣_
                                         (Σ-zip (zip-⟶̂ (λ ()) (λ _ ())
                                                       (λ ()) par-τ)
                                                _∣-cong′_)
                                     (left-to-right P≳P′ tr₁)
                                     (left-to-right Q≳Q′ tr₂)

  _∣-cong′_ : ∀ {i P P′ Q Q′} →
              [ i ] P ≳′ P′ → [ i ] Q ≳′ Q′ → [ i ] P ∣ Q ≳′ P′ ∣ Q′
  force (P≳P′ ∣-cong′ Q≳Q′) = force P≳P′ ∣-cong force Q≳Q′

-- _·_ preserves the expansion relation.

infix 12 _·-cong_ _·-cong′_

_·-cong_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ≳′ force P′ → [ i ] μ · P ≳ μ′ · P′
_·-cong_ {i} {μ} {P = P} {P′} refl P≳P′ = ⟨ lr , CL.·-cong P≳P′ ⟩
  where
  lr : ∀ {Q μ″} →
       μ · P [ μ″ ]⟶ Q →
       ∃ λ Q′ → μ · P′ [ μ″ ]⟶̂ Q′ × [ i ] Q ≳′ Q′
  lr action = _ , ⟶→⟶̂ action , P≳P′

_·-cong′_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ≳′ force P′ → [ i ] μ · P ≳′ μ′ · P′
force (μ≡μ′ ·-cong′ P≳P′) = μ≡μ′ ·-cong P≳P′

-- _∙_ preserves the expansion relation.

infix 12 _∙-cong_ _∙-cong′_

_∙-cong_ : ∀ {i μ μ′ P P′} →
           μ ≡ μ′ → [ i ] P ≳ P′ → [ i ] μ ∙ P ≳ μ′ ∙ P′
refl ∙-cong P≳P′ = refl ·-cong convert {a = ℓ} P≳P′

_∙-cong′_ : ∀ {i μ μ′ P P′} →
            μ ≡ μ′ → [ i ] P ≳′ P′ → [ i ] μ ∙ P ≳′ μ′ ∙ P′
force (μ≡μ′ ∙-cong′ P≳P′) = μ≡μ′ ∙-cong force P≳P′

-- _∙ turns equal actions into processes related by the expansion
-- relation.

infix 12 _∙-cong _∙-cong′

_∙-cong : ∀ {μ μ′} → μ ≡ μ′ → μ ∙ ≳ μ′ ∙
refl ∙-cong = reflexive

_∙-cong′ : ∀ {μ μ′} → μ ≡ μ′ → μ ∙ ≳′ μ′ ∙
refl ∙-cong′ = reflexive

mutual

  -- ⟨ν_⟩ preserves the expansion relation.

  ⟨ν_⟩-cong : ∀ {i a a′ P P′} →
              a ≡ a′ → [ i ] P ≳ P′ → [ i ] ⟨ν a ⟩ P ≳ ⟨ν a′ ⟩ P′
  ⟨ν_⟩-cong {i} {a} {P = P} {P′} refl P≳P′ =
    ⟨ lr
    , CL.⟨ν⟩-cong ⟨ν refl ⟩-cong′ P≳P′
    ⟩
    where
    lr : ∀ {Q μ} →
         ⟨ν a ⟩ P [ μ ]⟶ Q →
         ∃ λ Q′ → ⟨ν a ⟩ P′ [ μ ]⟶̂ Q′ × [ i ] Q ≳′ Q′
    lr {μ = μ} (restriction {P′ = Q} a∉μ P⟶Q)
      with left-to-right P≳P′ P⟶Q
    ... | Q′ , step P′⟶Q′ , Q≳′Q′ =
      ⟨ν a ⟩ Q   ∼⟨ ⟨ν refl ⟩-cong′ Q≳′Q′ ⟩■
      ⟨ν a ⟩ Q′
        ⟵̂[ μ ]   ←⟨ ⟶: restriction a∉μ P′⟶Q′ ⟩■
      ⟨ν a ⟩ P′

    ... | _ , done μs , Q≳′P′ =
      ⟨ν a ⟩ Q   ∼⟨ ⟨ν refl ⟩-cong′ Q≳′P′ ⟩■
      ⟨ν a ⟩ P′
        ⟵̂[ μ ]   ←⟨ ⟶̂: done μs ⟩■
      ⟨ν a ⟩ P′

  ⟨ν_⟩-cong′ : ∀ {i a a′ P P′} →
               a ≡ a′ → [ i ] P ≳′ P′ → [ i ] ⟨ν a ⟩ P ≳′ ⟨ν a′ ⟩ P′
  force (⟨ν a≡a′ ⟩-cong′ P≳P′) = ⟨ν a≡a′ ⟩-cong (force P≳P′)

mutual

  -- !_ preserves the expansion relation.

  infix 10 !-cong_ !-cong′_

  !-cong_ : ∀ {i P P′} →
            [ i ] P ≳ P′ → [ i ] ! P ≳ ! P′
  !-cong_ {i} {P} {P′} P≳P′ =
    ⟨ lr
    , CL.!-cong _∣-cong′_ !-cong′_ P≳P′
    ⟩
    where
    lr : ∀ {Q μ} →
         ! P [ μ ]⟶ Q →
         ∃ λ Q′ → ! P′ [ μ ]⟶̂ Q′ × [ i ] Q ≳′ Q′
    lr {Q} {μ} !P⟶Q = case SL.6-1-3-2 !P⟶Q of λ where

      (inj₁ (P″ , P⟶P″ , Q∼!P∣P″)) → case left-to-right P≳P′ P⟶P″ of λ where
        (_ , done s , P″≳′P′) → case silent≡τ s of λ where
          refl →
              _
            , (! P′  ■)
            , (Q          ∼⟨ Q∼!P∣P″ ⟩
               ! P  ∣ P″  ∼′⟨ !-cong′ (convert {a = ℓ} P≳P′) ∣-cong′ P″≳′P′ ⟩ S.∼:
               ! P′ ∣ P′  ∼⟨ SL.6-1-2 ⟩■
               ! P′)

        (Q′ , step P′⟶Q′ , P″≳′Q′) →
            _
          , (! P′ ∣ Q′  ←⟨ ⟶: replication (par-right P′⟶Q′) ⟩■
             ! P′)
          , (Q          ∼⟨ Q∼!P∣P″ ⟩
             ! P  ∣ P″  ∼⟨ !-cong′ (convert {a = ℓ} P≳P′) ∣-cong′ P″≳′Q′ ⟩■
             ! P′ ∣ Q′)

      (inj₂ (refl , P″ , P‴ , a , P⟶P″ , P⟶P‴ , Q≳!P∣P″∣P‴)) →
        case left-to-right P≳P′ P⟶P″ ,′
             left-to-right P≳P′ P⟶P‴ of λ where
          ((Q′ , step P′⟶Q′ , P″≳′Q′) ,
           (Q″ , step P′⟶Q″ , P‴≳′Q″)) →
              _
            , ((! P′ ∣ Q′) ∣ Q″  ←⟨ ⟶: replication (par-τ (replication (par-right P′⟶Q′)) P′⟶Q″) ⟩■
               ! P′)
            , (Q                 ∼⟨ Q≳!P∣P″∣P‴ ⟩
               (! P ∣ P″) ∣ P‴   ∼⟨ (!-cong′ (convert {a = ℓ} P≳P′) ∣-cong′ P″≳′Q′) ∣-cong′ P‴≳′Q″ ⟩■
               (! P′ ∣ Q′) ∣ Q″)

          ((_ , done () , _) , _)
          (_ , (_ , done () , _))

  !-cong′_ : ∀ {i P P′} → [ i ] P ≳′ P′ → [ i ] ! P ≳′ ! P′
  force (!-cong′ P≳P′) = !-cong (force P≳P′)

-- It is not necessarily the case that, if P expands P′, then P ⊕ Q is
-- weakly bisimilar to P′ ⊕ Q (assuming that Name is inhabited).
--
-- I based the counterexample on one in "Enhancements of the
-- bisimulation proof method" by Pous and Sangiorgi.

¬⊕-congˡ-≳≈ : Name → ¬ (∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≈ P′ ⊕ Q)
¬⊕-congˡ-≳≈ x =
  (∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≈ P′ ⊕ Q)  ↝⟨ _$ τa≳a ⟩
  τ ∙ (a ∙) ⊕ b ∙ ≈ a ∙ ⊕ b ∙             ↝⟨ τa⊕b≉a⊕b ⟩□
  ⊥                                       □
  where
  a = x , true
  b = x , false

  τa≳a : ∀ {a} → τ ∙ (a ∙) ≳ a ∙
  τa≳a {a} =
    ⟨ (λ where
        action →
          a ∙       ■
            ⟵̂[ τ ]
          a ∙       ■)
    , (λ where
        action →
          τ ∙ (a ∙)      →⟨ ⟶: action ⟩
          a ∙            →⟨ ⟶: action ⟩■
            ⇒[ name a ]
          ∅              ■)
    ⟩

  τa⊕b≉a⊕b : ¬ τ ∙ (a ∙) ⊕ b ∙ ≈ a ∙ ⊕ b ∙
  τa⊕b≉a⊕b τa⊕b≈a⊕b
    with W.left-to-right τa⊕b≈a⊕b (sum-left action)
  ... | _ , non-silent ¬s _ , _ = ⊥-elim (¬s _)
  ... | _ , silent _ (step () (sum-left  action) _) , _
  ... | _ , silent _ (step () (sum-right action) _) , _
  ... | _ , silent _ done , a≈′a⊕b
    with W.right-to-left (force a≈′a⊕b) (sum-right action)
  ...   | _ , silent () _ , _
  ...   | _ , non-silent _ (steps done () _) , _
  ...   | _ , non-silent _ (steps (step () action _) _ _) , _

-- It is not necessarily the case that, if Q expands Q′, then P ⊕ Q is
-- weakly bisimilar to P ⊕ Q′ (assuming that Name is inhabited).

¬⊕-congʳ-≳≈ : Name → ¬ (∀ {P Q Q′} → Q ≳ Q′ → P ⊕ Q ≈ P ⊕ Q′)
¬⊕-congʳ-≳≈ x ⊕-congʳ-≳≈ = ¬⊕-congˡ-≳≈ x ⊕-congˡ-≳≈
  where
  ⊕-congˡ-≳≈ : ∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≈ P′ ⊕ Q
  ⊕-congˡ-≳≈ {P} {P′} {Q} P≳P′ =
    P ⊕ Q   ∼⟨ SL.⊕-comm ⟩
    Q ⊕ P   ∼′⟨ ⊕-congʳ-≳≈ P≳P′ ⟩ S.∼:
    Q ⊕ P′  ∼⟨ SL.⊕-comm ⟩■
    P′ ⊕ Q

-- _⊕_ does not, in general, preserve the expansion relation in its
-- first argument (assuming that Name is inhabited).

¬⊕-congˡ : Name → ¬ (∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≳ P′ ⊕ Q)
¬⊕-congˡ x =
  (∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≳ P′ ⊕ Q)  ↝⟨ W.≳⇒≈ ∘_ ⟩
  (∀ {P P′ Q} → P ≳ P′ → P ⊕ Q ≈ P′ ⊕ Q)  ↝⟨ ¬⊕-congˡ-≳≈ x ⟩□
  ⊥                                       □

-- _⊕_ does not, in general, preserve the expansion relation in its
-- second argument (assuming that Name is inhabited).

¬⊕-congʳ : Name → ¬ (∀ {P Q Q′} → Q ≳ Q′ → P ⊕ Q ≳ P ⊕ Q′)
¬⊕-congʳ x =
  (∀ {P Q Q′} → Q ≳ Q′ → P ⊕ Q ≳ P ⊕ Q′)  ↝⟨ W.≳⇒≈ ∘_ ⟩
  (∀ {P Q Q′} → Q ≳ Q′ → P ⊕ Q ≈ P ⊕ Q′)  ↝⟨ ¬⊕-congʳ-≳≈ x ⟩□
  ⊥                                       □

-- Some congruence lemmas for combinations of _⊕_ and _·_.

⊕·-cong : ∀ {i P μ Q Q′} →
          [ i ] force Q ≳′ force Q′ → [ i ] P ⊕ μ · Q ≳ P ⊕ μ · Q′
⊕·-cong {i} {P} {μ} {Q} {Q′} Q≳Q′ =
  ⟨ lr , CL.⊕·-cong Q≳Q′ ⟩
  where
  lr : ∀ {R μ′} →
       P ⊕ μ · Q [ μ′ ]⟶ R →
       ∃ λ R′ → P ⊕ μ · Q′ [ μ′ ]⟶̂ R′ × [ i ] R ≳′ R′
  lr {R} {μ′} = λ where
    (sum-left P⟶R) →
      R           ■
        ⟵̂[ μ′ ]   ←⟨ ⟶: sum-left P⟶R ⟩■
      P ⊕ μ · Q′

    (sum-right action) →
      force Q     ∼⟨ Q≳Q′ ⟩■
      force Q′
        ⟵̂[ μ ]    ←⟨ ⟶: sum-right action ⟩■
      P ⊕ μ · Q′

⊕·-cong′ : ∀ {i P μ Q Q′} →
           [ i ] force Q ≳′ force Q′ → [ i ] P ⊕ μ · Q ≳′ P ⊕ μ · Q′
force (⊕·-cong′ Q≳Q′) = ⊕·-cong Q≳Q′

·⊕-cong : ∀ {i P P′ μ Q} →
          [ i ] force P ≳′ force P′ → [ i ] μ · P ⊕ Q ≳ μ · P′ ⊕ Q
·⊕-cong {P = P} {P′} {μ} {Q} P≳P′ =
  μ · P ⊕ Q   ∼⟨ SL.⊕-comm ⟩
  Q ⊕ μ · P   ∼′⟨ ⊕·-cong P≳P′ ⟩ S.∼:
  Q ⊕ μ · P′  ∼⟨ SL.⊕-comm ⟩■
  μ · P′ ⊕ Q

·⊕-cong′ : ∀ {i P P′ μ Q} →
           [ i ] force P ≳′ force P′ → [ i ] μ · P ⊕ Q ≳′ μ · P′ ⊕ Q
force (·⊕-cong′ P≳P′) = ·⊕-cong P≳P′

infix 8 _·⊕·-cong_ _·⊕·-cong′_

_·⊕·-cong_ :
  ∀ {i μ₁ μ₂ P₁ P₁′ P₂ P₂′} →
  [ i ] force P₁ ≳′ force P₁′ → [ i ] force P₂ ≳′ force P₂′ →
  [ i ] μ₁ · P₁ ⊕ μ₂ · P₂ ≳ μ₁ · P₁′ ⊕ μ₂ · P₂′
_·⊕·-cong_ {i} {μ₁} {μ₂} {P₁} {P₁′} {P₂} {P₂′} P₁≳P₁′ P₂≳P₂′ =
  ⟨ lr , CL.·⊕·-cong P₁≳P₁′ P₂≳P₂′ ⟩
  where
  lr : ∀ {R μ} → μ₁ · P₁ ⊕ μ₂ · P₂ [ μ ]⟶ R →
       ∃ λ R′ → μ₁ · P₁′ ⊕ μ₂ · P₂′ [ μ ]⟶̂ R′ × [ i ] R ≳′ R′
  lr = λ where
    (sum-left action) →
      force P₁             ∼⟨ P₁≳P₁′ ⟩■
      force P₁′
        ⟵̂[ μ₁ ]            ←⟨ ⟶: sum-left action ⟩■
      μ₁ · P₁′ ⊕ μ₂ · P₂′

    (sum-right action) →
      force P₂             ∼⟨ P₂≳P₂′ ⟩■
      force P₂′
        ⟵̂[ μ₂ ]            ←⟨ ⟶: sum-right action ⟩■
      μ₁ · P₁′ ⊕ μ₂ · P₂′

_·⊕·-cong′_ :
  ∀ {i μ₁ μ₂ P₁ P₁′ P₂ P₂′} →
  [ i ] force P₁ ≳′ force P₁′ → [ i ] force P₂ ≳′ force P₂′ →
  [ i ] μ₁ · P₁ ⊕ μ₂ · P₂ ≳′ μ₁ · P₁′ ⊕ μ₂ · P₂′
force (P₁≳′P₁′ ·⊕·-cong′ P₂≳′P₂′) = P₁≳′P₁′ ·⊕·-cong P₂≳′P₂′

-- _[_] preserves the expansion relation for non-degenerate contexts.
-- (This result is related to Theorem 6.5.25 in "Enhancements of the
-- bisimulation proof method" by Pous and Sangiorgi.)

infix 5 _[_]-cong _[_]-cong′

_[_]-cong :
  ∀ {i n Ps Qs} {C : Context ∞ n} →
  Non-degenerate ∞ C → (∀ x → [ i ] Ps x ≳ Qs x) →
  [ i ] C [ Ps ] ≳ C [ Qs ]
hole     [ Ps≳Qs ]-cong = Ps≳Qs _
∅        [ Ps≳Qs ]-cong = reflexive
D₁ ∣ D₂  [ Ps≳Qs ]-cong = (D₁ [ Ps≳Qs ]-cong) ∣-cong (D₂ [ Ps≳Qs ]-cong)
action D [ Ps≳Qs ]-cong = refl ·-cong λ { .force → force D [ Ps≳Qs ]-cong }
⟨ν⟩ D    [ Ps≳Qs ]-cong = ⟨ν refl ⟩-cong (D [ Ps≳Qs ]-cong)
! D      [ Ps≳Qs ]-cong = !-cong (D [ Ps≳Qs ]-cong)
D₁ ⊕ D₂  [ Ps≳Qs ]-cong = ⊕-cong Ps≳Qs D₁ D₂
  where
  _[_]-cong′ :
    ∀ {i n Ps Qs} {C : Context ∞ n} →
    Non-degenerate′ ∞ C → (∀ x → [ i ] Ps x ≳ Qs x) →
    [ i ] C [ Ps ] ≳′ C [ Qs ]
  force (D [ Ps≳Qs ]-cong′) = force D [ Ps≳Qs ]-cong

  ⊕-cong :
    ∀ {i n Ps Qs} {C₁ C₂ : Context ∞ n} →
    (∀ x → [ i ] Ps x ≳ Qs x) →
    Non-degenerate-summand ∞ C₁ →
    Non-degenerate-summand ∞ C₂ →
    [ i ] (C₁ [ Ps ]) ⊕ (C₂ [ Ps ]) ≳ (C₁ [ Qs ]) ⊕ (C₂ [ Qs ])
  ⊕-cong {Ps = Ps} {Qs} Ps≳Qs = λ where
    (process P₁) (process P₂) →
      (context P₁ [ Ps ]) ⊕ (context P₂ [ Ps ])  ∼⟨ symmetric (SL.≡→∼ (context-[] P₁) SL.⊕-cong SL.≡→∼ (context-[] P₂)) ⟩
      P₁ ⊕ P₂                                    ∼⟨ SL.≡→∼ (context-[] P₁) SL.⊕-cong SL.≡→∼ (context-[] P₂) ⟩■
      (context P₁ [ Qs ]) ⊕ (context P₂ [ Qs ])

    (process P₁) (action {μ = μ₂} {C = C₂} D₂) →
      (context P₁ [ Ps ]) ⊕ μ₂ · (C₂ [ Ps ]′)  ∼⟨ symmetric (SL.≡→∼ (context-[] P₁)) SL.⊕-cong (_ ■) ⟩
      P₁ ⊕ μ₂ · (C₂ [ Ps ]′)                   ∼′⟨ ⊕·-cong (D₂ [ Ps≳Qs ]-cong′) ⟩ S.∼:
      P₁ ⊕ μ₂ · (C₂ [ Qs ]′)                   ∼⟨ SL.≡→∼ (context-[] P₁) SL.⊕-cong (_ ■) ⟩■
      (context P₁ [ Qs ]) ⊕ μ₂ · (C₂ [ Qs ]′)

    (action {μ = μ₁} {C = C₁} D₁) (process P₂) →
      μ₁ · (C₁ [ Ps ]′) ⊕ (context P₂ [ Ps ])  ∼⟨ (_ ■) SL.⊕-cong symmetric (SL.≡→∼ (context-[] P₂)) ⟩
      μ₁ · (C₁ [ Ps ]′) ⊕ P₂                   ∼′⟨ ·⊕-cong (D₁ [ Ps≳Qs ]-cong′) ⟩ S.∼:
      μ₁ · (C₁ [ Qs ]′) ⊕ P₂                   ∼⟨ (_ ■) SL.⊕-cong SL.≡→∼ (context-[] P₂) ⟩■
      μ₁ · (C₁ [ Qs ]′) ⊕ (context P₂ [ Qs ])

    (action {μ = μ₁} {C = C₁} D₁) (action {μ = μ₂} {C = C₂} D₂) →
      μ₁ · (C₁ [ Ps ]′) ⊕ μ₂ · (C₂ [ Ps ]′)  ∼⟨ (D₁ [ Ps≳Qs ]-cong′) ·⊕·-cong (D₂ [ Ps≳Qs ]-cong′) ⟩■
      μ₁ · (C₁ [ Qs ]′) ⊕ μ₂ · (C₂ [ Qs ]′)

_[_]-cong′ :
  ∀ {i n Ps Qs} {C : Context ∞ n} →
  Non-degenerate ∞ C → (∀ x → [ i ] Ps x ≳′ Qs x) →
  [ i ] C [ Ps ] ≳′ C [ Qs ]
force (C [ Ps≳Qs ]-cong′) = C [ (λ x → force (Ps≳Qs x)) ]-cong


open import Data.Empty
open import Data.List renaming (_∷_ to _∷ₗ_ ; [_] to [_]ₗ)
open import Data.Maybe
open import Data.Product
open import Data.Sum
open import Data.Unit

open import AEff
open import AwaitingComputations
open import EffectAnnotations
open import Finality
open import Preservation
open import ProcessPreservation
open import ProcessProgress
open import Progress
open import Renamings
open import Substitutions
open import Types

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Negation

module ProcessFinality where

-- SMALL-STEP OPERATIONAL SEMANTICS FOR WELL-TYPED PROCESSES
-- WITH INLINED EVALUATION CONTEXT RULES

infix 10 _[_]↝↝_

data _[_]↝↝_ {Γ : Ctx} : {o o' : O} {PP : PType o} {QQ : PType o'} → Γ ⊢P⦂ PP → PP ⇝ QQ → Γ ⊢P⦂ QQ → Set where

  -- RUNNING INDIVIDUAL COMPUTATIONS

  run   : {X : VType}
          {o : O}
          {i : I}
          {M N : Γ ⊢M⦂ X ! (o , i)} →
          M ↝↝ N →
          ---------------------------
          (run M) [ id ]↝↝ (run N)

  -- BROADCAST RULES

  ↑-∥ₗ   : {o o' : O}
           {PP : PType o}
           {QQ : PType o'}
           {op : Σₛ} →
           (p : op ∈ₒ o) →
           (V : Γ ⊢V⦂ `` (payload op)) →
           (P : Γ ⊢P⦂ PP) →
           (Q : Γ ⊢P⦂ QQ) →
           ------------------------------------------
           ((↑ op p V P) ∥ Q)
           [ par ⇝-refl (⇝-↓ₚ {op = op}) ]↝↝
           ↑ op (∪ₒ-inl op p) V (P ∥ ↓ op V Q)

  ↑-∥ᵣ   : {o o' : O}
           {PP : PType o}
           {QQ : PType o'}
           {op : Σₛ} →
           (p : op ∈ₒ o') →
           (V : Γ ⊢V⦂ `` (payload op)) →
           (P : Γ ⊢P⦂ PP) →
           (Q : Γ ⊢P⦂ QQ) →
           ------------------------------------------
           (P ∥ (↑ op p V Q))
           [ par (⇝-↓ₚ {op = op}) ⇝-refl ]↝↝
           ↑ op (∪ₒ-inr op p) V (↓ op V P ∥ Q)

  -- INTERRUPT PROPAGATION RULES

  ↓-run : {X : VType}
          {o : O}
          {i : I}
          {op : Σₛ} →
          (V : Γ ⊢V⦂ `` (payload op)) →
          (M : Γ ⊢M⦂ X ! (o , i)) →
          -----------------------------
          ↓ op V (run M)
          [ id ]↝↝
          run (↓ op V M)

  ↓-∥   : {o o' : O}
          {PP : PType o}
          {QQ : PType o'}
          {op : Σₛ}
          (V : Γ ⊢V⦂ `` (payload op)) →
          (P : Γ ⊢P⦂ PP) →
          (Q : Γ ⊢P⦂ QQ) →
          -----------------------------
          ↓ op V (P ∥ Q)
          [ ⇝-refl ]↝↝
          ((↓ op V P) ∥ (↓ op V Q))

  ↓-↑   : {o : O}
          {PP : PType o}
          {op : Σₛ}
          {op' : Σₛ} →
          (p : op' ∈ₒ o) →
          (V : Γ ⊢V⦂ ``(payload op)) →
          (W : Γ ⊢V⦂ ``(payload op')) →
          (P : Γ ⊢P⦂ PP) →
          -----------------------------------
          ↓ op V (↑ op' p W P)
          [ ⇝-refl ]↝↝
          ↑ op' (↓ₚₚ-⊑ₒ PP op' p) W (↓ op V P)

  -- SIGNAL HOISTING RULE

  ↑     : {X : VType}
          {o : O}
          {i : I} →
          {op : Σₛ} →
          (p : op ∈ₒ o) →
          (V : Γ ⊢V⦂ `` (payload op)) →
          (M : Γ ⊢M⦂ X ! (o , i)) →
          -----------------------------
          run (↑ op p V M)
          [ id ]↝↝
          ↑ op p V (run M)

  -- EVALUATION CONTEXT RULES

  context-∥ₗ : {o o' o'' : O}
               {PP : PType o}
               {PP' : PType o''}
               {QQ : PType o'}
               {P : Γ ⊢P⦂ PP}
               {P' : Γ ⊢P⦂ PP'}
               {Q : Γ ⊢P⦂ QQ}
               {p : PP ⇝ PP'} →
               P [ p ]↝↝ P' →
               ------------------
               P ∥ Q
               [ par p ⇝-refl ]↝↝
               P' ∥ Q

  context-∥ᵣ : {o o' o'' : O}
               {PP : PType o}
               {QQ : PType o'}
               {QQ' : PType o''}
               {P : Γ ⊢P⦂ PP}
               {Q : Γ ⊢P⦂ QQ}
               {Q' : Γ ⊢P⦂ QQ'}
               {r : QQ ⇝ QQ'} →
               Q [ r ]↝↝ Q' →
               ------------------
               P ∥ Q
               [ par ⇝-refl r ]↝↝
               P ∥ Q'

  context-↑ : {o o' : O}
              {PP : PType o}
              {PP' : PType o'}
              {op : Σₛ}
              {p : op ∈ₒ o} →
              {V : Γ ⊢V⦂ ``(payload op)}
              {P : Γ ⊢P⦂ PP}
              {P' : Γ ⊢P⦂ PP'}
              {r : PP ⇝ PP'} →
              P [ r ]↝↝ P' →
              --------------------------
              ↑ op p V P
              [ r ]↝↝
              ↑ op (⇝-⊑ₒ r op p) V P'

  context-↓ : {o o' : O}
              {PP : PType o}
              {PP' : PType o'}
              {op : Σₛ}
              {V : Γ ⊢V⦂ ``(payload op)}
              {P : Γ ⊢P⦂ PP}
              {P' : Γ ⊢P⦂ PP'}
              {r : PP ⇝ PP'} →
              P [ r ]↝↝ P' →
              ----------------------
              ↓ op V P
              [ ⇝-↓ₚ-cong r ]↝↝
              ↓ op V P'

-- ONE-TO-ONE CORRESPONDENCE BETWEEN THE TWO SETS OF REDUCTION RULES

[]↝↝-to-[]↝ : {Γ : Ctx}
              {o o' : O}
              {PP : PType o}
              {QQ : PType o'}
              {P : Γ ⊢P⦂ PP}
              {Q : Γ ⊢P⦂ QQ}
              {r : PP ⇝ QQ} →
              P [ r ]↝↝ Q →
              -----------------
              P [ r ]↝ Q

[]↝↝-to-[]↝ (run r) =
  run (↝↝-to-↝ r)
[]↝↝-to-[]↝ (↑-∥ₗ p V P Q) =
  ↑-∥ₗ p V P Q
[]↝↝-to-[]↝ (↑-∥ᵣ p V P Q) =
  ↑-∥ᵣ p V P Q
[]↝↝-to-[]↝ (↓-run V M) =
  ↓-run V M
[]↝↝-to-[]↝ (↓-∥ V P Q) =
  ↓-∥ V P Q
[]↝↝-to-[]↝ (↓-↑ p V W P) =
  ↓-↑ p V W P
[]↝↝-to-[]↝ (↑ p V M) =
  ↑ p V M
[]↝↝-to-[]↝ (context-∥ₗ r) =
  context (_ ∥ₗ _) ([]↝↝-to-[]↝ r)
[]↝↝-to-[]↝ (context-∥ᵣ r) =
  context (_ ∥ᵣ _) ([]↝↝-to-[]↝ r)
[]↝↝-to-[]↝ (context-↑ r) =
  context (↑ _ _ _ _) ([]↝↝-to-[]↝ r)
[]↝↝-to-[]↝ (context-↓ r) =
  context (↓ _ _ _) ([]↝↝-to-[]↝ r)

≡-app₂ : {X : Set}
         {Y Z : X → Set}
         {f g : (x : X) → Y x → Z x} →
         f ≡ g →
         (x : X) →
         (y : Y x) →
         -----------------------------
         f x y ≡ g x y

≡-app₂ refl x y =
  refl

[]↝-context-to-[]↝↝-aux : {Γ : Ctx}
                          {o o' : O}
                          {op : Σₛ}
                          {p : op ∈ₒ o}
                          {PP : PType o}
                          {QQ : PType o'} →
                          (F : Γ ⊢F⦂ PP) →
                          (r : proj₂ (hole-ty-f F) ⇝ QQ) →
                          ----------------------------------------------------------
                          ⇝-⊑ₒ (proj₂ (proj₂ (⇝-f-⇝ F r))) op p ≡ ⇝-f-∈ₒ F r op p

[]↝-context-to-[]↝↝-aux {Γ} {o} {o'} {op} {p} F r =
  ≡-app₂ (⊑ₒ-irrelevant (⇝-⊑ₒ (proj₂ (proj₂ (⇝-f-⇝ F r)))) (⇝-f-∈ₒ F r)) op p

mutual

  []↝-context-to-[]↝↝ : {Γ : Ctx}
                        {o o' : O}
                        {PP : PType o}
                        {QQ : PType o'} →
                        (F : Γ ⊢F⦂ PP) →
                        {P : Γ ⊢P⦂ proj₂ (hole-ty-f F)}
                        {Q : Γ ⊢P⦂ QQ}
                        {r : proj₂ (hole-ty-f F) ⇝ QQ} →
                        P [ r ]↝ Q →
                        -----------------------------------------------------------------------------
                        F [ P ]f
                        [ proj₂ (proj₂ (⇝-f-⇝ F r)) ]↝↝
                        (⇝-f F r) [ subst-i PType (λ o QQ → Γ ⊢P⦂ QQ) (⇝-f-tyₒ F r) (⇝-f-ty F r) Q ]f

  []↝-context-to-[]↝↝ [-] r =
    []↝-to-[]↝↝ r
  []↝-context-to-[]↝↝ (F ∥ₗ Q) r =
    context-∥ₗ ([]↝-context-to-[]↝↝ F r)
  []↝-context-to-[]↝↝ (P ∥ᵣ F) r =
    context-∥ᵣ ([]↝-context-to-[]↝↝ F r)
  []↝-context-to-[]↝↝ {Γ} {o} {o'} {PP} {QQ} (↑ op p V F) {P} {Q} {r'} r
    rewrite sym ([]↝-context-to-[]↝↝-aux {op = op} {p = p} F r') =
      context-↑ ([]↝-context-to-[]↝↝ F r)
  []↝-context-to-[]↝↝ (↓ op V F) r =
    context-↓ ([]↝-context-to-[]↝↝ F r)

  []↝-to-[]↝↝ : {Γ : Ctx}
                {o o' : O}
                {PP : PType o}
                {QQ : PType o'}
                {P : Γ ⊢P⦂ PP}
                {Q : Γ ⊢P⦂ QQ}
                {r : PP ⇝ QQ} →
                P [ r ]↝ Q →
                -----------------
                P [ r ]↝↝ Q

  []↝-to-[]↝↝ (run r) =
    run (↝-to-↝↝ r)
  []↝-to-[]↝↝ (↑-∥ₗ p V P Q) =
    ↑-∥ₗ p V P Q
  []↝-to-[]↝↝ (↑-∥ᵣ p V P Q) =
    ↑-∥ᵣ p V P Q
  []↝-to-[]↝↝ (↓-run V M) =
    ↓-run V M
  []↝-to-[]↝↝ (↓-∥ V P Q) =
    ↓-∥ V P Q
  []↝-to-[]↝↝ (↓-↑ p V W P) =
    ↓-↑ p V W P
  []↝-to-[]↝↝ (↑ p V M) =
    ↑ p V M
  []↝-to-[]↝↝ (context F r) =
    []↝-context-to-[]↝↝ _ r

-- FINALITY OF RESULT FORMS

par-finality-↝↝ : {o o' : O}
                  {PP : PType o}
                  {QQ : PType o'}
                  {P : [] ⊢P⦂ PP} →
                  {Q : [] ⊢P⦂ QQ} →
                  ParResult⟨ P ⟩ →
                  (r : PP ⇝ QQ) →
                  P [ r ]↝↝ Q →
                  -----------------
                  ⊥

par-finality-↝↝ (run R) .id (run r) =
  run-finality-↝↝ R r
par-finality-↝↝ (run R) .id (↑ p V M) =
  run-↑-⊥ R
par-finality-↝↝ (par R S) .(par _ ⇝-refl) (context-∥ₗ r') =
  par-finality-↝↝ R _ r'
par-finality-↝↝ (par R S) .(par ⇝-refl _) (context-∥ᵣ r') =
  par-finality-↝↝ S _ r'

proc-finality-↝↝ : {o o' : O}
                  {PP : PType o}
                  {QQ : PType o'}
                  {P : [] ⊢P⦂ PP} →
                  {Q : [] ⊢P⦂ QQ} →
                  ProcResult⟨ P ⟩ →
                  (r : PP ⇝ QQ) →
                  P [ r ]↝↝ Q →
                  -----------------
                  ⊥

proc-finality-↝↝ (proc R) r r' =
  par-finality-↝↝ R r r'
proc-finality-↝↝ (signal R) r (context-↑ r') =
  proc-finality-↝↝ R r r'

{- LEMMA 4.2 -}

proc-finality : {o o' : O}
                {PP : PType o}
                {QQ : PType o'}
                {P : [] ⊢P⦂ PP} →
                {Q : [] ⊢P⦂ QQ} →
                ProcResult⟨ P ⟩ →
                (r : PP ⇝ QQ) →
                P [ r ]↝ Q →
                -----------------
                ⊥

proc-finality R r r' =
  proc-finality-↝↝ R r ([]↝-to-[]↝↝ r')