module Syntax where

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

open import Typing hiding (send ; recv)

-- expressions
data Expr Φ : Type → Set where
  var : ∀ {t}
      → (x : t ∈ Φ)
      → Expr Φ t

  nat : (unr-Φ : All Unr Φ)
      → (i : ℕ)
      → Expr Φ TInt

  unit : (unr-Φ : All Unr Φ)
      → Expr Φ TUnit

  letbind : ∀ {Φ₁ Φ₂ t₁ t₂}
    → (sp : Split Φ Φ₁ Φ₂)
    → (e₁ : Expr Φ₁ t₁)
    → (e₂ : Expr (t₁ ∷ Φ₂) t₂)
    → Expr Φ t₂

  pair : ∀ {Φ₁ Φ₂ t₁ t₂}
    → (sp : Split Φ Φ₁ Φ₂)
    → (x₁ : t₁ ∈ Φ₁)
    → (x₂ : t₂ ∈ Φ₂)
    → Expr Φ (TPair t₁ t₂)

  letpair : ∀ {Φ₁ Φ₂ t₁ t₂ t}
    → (sp : Split Φ Φ₁ Φ₂)
    → (p : TPair t₁ t₂ ∈ Φ₁)
    → (e : Expr (t₁ ∷ t₂ ∷ Φ₂) t)
    → Expr Φ t

  fork : (e : Expr Φ TUnit)
    → Expr Φ TUnit

  new : (unr-Φ : All Unr Φ)
      → (s : SType)
      → Expr Φ (TPair (TChan (SType.force s)) (TChan (SType.force (dual s))))

  send : ∀ {Φ₁ Φ₂ s t}
      → (sp : Split Φ Φ₁ Φ₂)
      → (ch : (TChan (transmit SND t s)) ∈ Φ₁)
      → (vv : t ∈ Φ₂)
      → Expr Φ (TChan (SType.force s))

  recv : ∀ {s t}
      → (ch : (TChan (transmit RCV t s)) ∈ Φ)
      → Expr Φ (TPair (TChan (SType.force s)) t)

  close : (ch : TChan send! ∈ Φ)
      → Expr Φ TUnit

  wait : (ch : TChan send? ∈ Φ)
      → Expr Φ TUnit

  select : ∀ {s₁ s₂}
      → (lab : Selector)
      → (ch : TChan (sintern s₁ s₂) ∈ Φ)
      → Expr Φ (TChan (selection lab (SType.force s₁) (SType.force s₂)))

  branch : ∀ {s₁ s₂ Φ₁ Φ₂ t}
      → (sp : Split Φ Φ₁ Φ₂)
      → (ch : TChan (sextern s₁ s₂) ∈ Φ₁)
      → (eleft : Expr (TChan (SType.force s₁) ∷ Φ₂) t)
      → (erght : Expr (TChan (SType.force s₂) ∷ Φ₂) t)
      → Expr Φ t

  nselect : ∀ {m alt}
      → (lab : Fin m)
      → (ch : TChan (sintN m alt) ∈ Φ)
      → Expr Φ (TChan (SType.force (alt lab)))

  nbranch : ∀ {m alt Φ₁ Φ₂ t}
      → (sp : Split Φ Φ₁ Φ₂)
      → (ch : TChan (sextN m alt) ∈ Φ₁)
      → (ealts : (i : Fin m) → Expr (TChan (SType.force (alt i)) ∷ Φ₂) t)
      → Expr Φ t

  ulambda : ∀ {Φ₁ Φ₂ t₁ t₂}
      → (sp : Split Φ Φ₁ Φ₂)
      → (unr-Φ₁ : All Unr Φ₁)
      → (unr-Φ₂ : All Unr Φ₂)
      → (ebody : Expr (t₁ ∷ Φ₁) t₂)
      → Expr Φ (TFun UU t₁ t₂)

  llambda : ∀ {Φ₁ Φ₂ t₁ t₂}
      → (sp : Split Φ Φ₁ Φ₂)
      → (unr-Φ₂ : All Unr Φ₂)
      → (ebody : Expr (t₁ ∷ Φ₁) t₂)
      → Expr Φ (TFun LL t₁ t₂)

  app : ∀ {Φ₁ Φ₂ lu t₁ t₂}
      → (sp : Split Φ Φ₁ Φ₂)
      → (xfun : TFun lu t₁ t₂ ∈ Φ₁)
      → (xarg : t₁ ∈ Φ₂)
      → Expr Φ t₂

  rec : ∀ {t₁ t₂}
      → (unr-Φ : All Unr Φ)
      → let t = TFun UU t₁ t₂ in
        (ebody : Expr (t ∷ t₁ ∷ Φ) t₂)
      → Expr Φ t

  subsume : ∀ {t₁ t₂}
      → (e : Expr Φ t₁)
      → (t≤t' : SubT t₁ t₂)
      → Expr Φ t₂

unr-weaken : ∀ {Φ Φ₁ Φ₂ t} → Split Φ Φ₁ Φ₂ → All Unr Φ₂ → Expr Φ₁ t → Expr Φ t
unr-weaken sp un-Φ₂ (var x) = var (unr-weaken-var sp un-Φ₂ x)
unr-weaken sp un-Φ₂ (nat unr-Φ i) = letbind sp (nat unr-Φ i) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (unit unr-Φ) = letbind sp (unit unr-Φ) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (letbind sp₁ e e₁) = letbind sp (letbind sp₁ e e₁) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (pair sp₁ x₁ x₂) = letbind sp (pair sp₁ x₁ x₂) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (letpair sp₁ p e) = letbind sp (letpair sp₁ p e) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (fork e) = unr-weaken sp un-Φ₂ e
unr-weaken sp un-Φ₂ (new unr-Φ s) = letbind sp (new unr-Φ s) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (send sp₁ ch vv) = letbind sp (send sp₁ ch vv) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (recv ch) = letbind sp (recv ch) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (close ch) = letbind sp (close ch) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (wait ch) = letbind sp (wait ch) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (nselect lab ch) = letbind sp (nselect lab ch) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (nbranch sp₁ ch ealts) = letbind sp (nbranch sp₁ ch ealts) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (select lab ch) = letbind sp (select lab ch) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (branch sp₁ ch e e₁) with split-rotate sp sp₁
... | Φ' , sp-ΦΦ₃Φ' , sp-Φ'Φ₄Φ₂ = branch sp-ΦΦ₃Φ' ch (unr-weaken (left sp-Φ'Φ₄Φ₂) un-Φ₂ e) (unr-weaken (left sp-Φ'Φ₄Φ₂) un-Φ₂ e₁)
unr-weaken sp un-Φ₂ (ulambda sp₁ unr-Φ₁ unr-Φ₂ e) = ulambda sp (split-unr sp₁ unr-Φ₁ unr-Φ₂) un-Φ₂ (unr-weaken (left sp₁) unr-Φ₂ e)
unr-weaken sp un-Φ₂ (llambda sp₁ unr-Φ₂ e) = llambda sp un-Φ₂ (unr-weaken (left sp₁) unr-Φ₂ e)
unr-weaken sp un-Φ₂ (app sp₁ xfun xarg) = letbind sp (app sp₁ xfun xarg) (var (here un-Φ₂))
unr-weaken sp un-Φ₂ (rec unr-Φ e) = rec (split-unr sp unr-Φ un-Φ₂) (unr-weaken (left (left sp)) un-Φ₂ e)
unr-weaken sp un-Φ₂ (subsume e t≤t') = subsume (unr-weaken sp un-Φ₂ e) t≤t'

lift-expr : ∀ {Φ t tᵤ} → Unr tᵤ → Expr Φ t → Expr (tᵤ ∷ Φ) t
lift-expr unrtu (var x) = var (there unrtu x)
lift-expr unrtu (nat unr-Φ i) = nat (unrtu ∷ unr-Φ) i
lift-expr unrtu (unit unr-Φ) = unit (unrtu ∷ unr-Φ)
lift-expr unrtu (letbind sp e e₁) = letbind (left sp) (lift-expr unrtu e) e₁
lift-expr unrtu (pair sp x₁ x₂) = pair (rght sp) x₁ (there unrtu x₂)
lift-expr unrtu (letpair sp p e) = letpair (left sp) (there unrtu p) e
lift-expr unrtu (fork e) = lift-expr unrtu e
lift-expr unrtu (new unr-Φ s) = new (unrtu ∷ unr-Φ) s
lift-expr unrtu (close ch) = close (there unrtu ch)
lift-expr unrtu (wait ch) = wait (there unrtu ch)
lift-expr unrtu (send sp ch vv) = send (rght sp) ch (there unrtu vv)
lift-expr unrtu (recv ch) = recv (there unrtu ch)
lift-expr unrtu (nselect lab ch) = nselect lab (there unrtu ch)
lift-expr unrtu (nbranch sp ch ealts) = nbranch (left sp) (there unrtu ch) ealts
lift-expr unrtu (select lab ch) = select lab (there unrtu ch)
lift-expr unrtu (branch sp ch x₁ x₂) = branch (left sp) (there unrtu ch) x₁ x₂
lift-expr unrtu (ulambda sp unr-Φ unr-Φ₂ ebody) = ulambda (rght sp) unr-Φ (unrtu ∷ unr-Φ₂) ebody
lift-expr unrtu (llambda sp unr-Φ₂ ebody) = llambda (rght sp) (unrtu ∷ unr-Φ₂) ebody
lift-expr unrtu (app sp xfun xarg) = app (rght sp) xfun (there unrtu xarg)
lift-expr{Φ} unrtu (rec unr-Φ ebody) = letbind (left (split-all-right Φ)) (var (here [])) (rec (unrtu ∷ unr-Φ) (unr-weaken (left (left (rght (split-all-left Φ)))) (unrtu ∷ []) ebody))
lift-expr unrtu (subsume e t≤t') = subsume (lift-expr unrtu e) t≤t'

unr-subst : ∀ {Φ Φ₁ Φ₂ tᵤ t} → Unr tᵤ → Split Φ Φ₁ Φ₂ → All Unr Φ₁ → Expr Φ₁ tᵤ → Expr (tᵤ ∷ Φ₂) t → Expr Φ t
unr-subst unrtu sp unr-Φ₁ etu (var (here x)) = unr-weaken sp x etu
unr-subst unrtu sp unr-Φ₁ etu (var (there x x₁)) = var (unr-weaken-var (split-sym sp) unr-Φ₁ x₁)
unr-subst unrtu sp unr-Φ₁ etu (nat (unr-tu ∷ unr-Φ) i) = nat (split-unr sp unr-Φ₁ unr-Φ) i
unr-subst unrtu sp unr-Φ₁ etu (unit (_ ∷ unr-Φ)) = unit (split-unr sp unr-Φ₁ unr-Φ)
unr-subst unrtu sp unr-Φ₁ etu (letbind sp₁ e e₁) = letbind sp etu (letbind sp₁ e e₁)
unr-subst unrtu sp unr-Φ₁ etu (pair sp₁ x₁ x₂) = letbind sp etu (pair sp₁ x₁ x₂)
unr-subst unrtu sp unr-Φ₁ etu (letpair sp₁ p e) = letbind sp etu (letpair sp₁ p e)
unr-subst unrtu sp unr-Φ₁ etu (fork e) = unr-subst unrtu sp unr-Φ₁ etu e
unr-subst unrtu sp unr-Φ₁ etu (new unr-Φ s) = letbind sp etu (new unr-Φ s)
unr-subst unrtu sp unr-Φ₁ etu (send sp₁ ch vv) = letbind sp etu (send sp₁ ch vv)
unr-subst unrtu sp unr-Φ₁ etu (recv ch) = letbind sp etu (recv ch)
unr-subst unrtu sp unr-Φ₁ etu (close ch) = letbind sp etu (close ch)
unr-subst unrtu sp unr-Φ₁ etu (wait ch) = letbind sp etu (wait ch)
unr-subst unrtu sp unr-Φ₁ etu (nselect lab ch) = letbind sp etu (nselect lab ch)
unr-subst unrtu sp unr-Φ₁ etu (nbranch sp₁ ch ealts) = letbind sp etu (nbranch sp₁ ch ealts)
unr-subst unrtu sp unr-Φ₁ etu (select lab ch) = letbind sp etu (select lab ch)
unr-subst unrtu sp unr-Φ₁ etu (branch sp₁ ch e e₁) = letbind sp etu (branch sp₁ ch e e₁)
unr-subst unrtu sp unr-Φ₁ etu (ulambda sp₁ unr-Φ₂ unr-Φ₃ e) = letbind sp etu (ulambda sp₁ unr-Φ₂ unr-Φ₃ e)
unr-subst unrtu sp unr-Φ₁ etu (llambda sp₁ unr-Φ₂ e) = letbind sp etu (llambda sp₁ unr-Φ₂ e)
unr-subst unrtu sp unr-Φ₁ etu (app sp₁ xfun xarg) = letbind sp etu (app sp₁ xfun xarg)
unr-subst unrtu sp unr-Φ₁ etu (rec unr-Φ e) = letbind sp etu (rec unr-Φ e)
unr-subst unrtu sp unr-Φ₁ etu (subsume e t≤t') = subsume (unr-subst unrtu sp unr-Φ₁ etu e) t≤t'

expr-coerce : ∀ {Φ t₁ t₂ t₁' t₂'} → Expr (t₁ ∷ Φ) t₂ → SubT t₂ t₂' → SubT t₁' t₁ → Expr (t₁' ∷ Φ) t₂'
expr-coerce e t2≤t2' t1'≤t1 = letbind (left (split-all-right _)) (subsume (var (here [])) t1'≤t1) (subsume e t2≤t2')


{-
Basic properties of the Can function and utilities used in the reasoning.

The basic properties of the Can function include

- Can-θ function shadows the environment

    canθ-shadowing-irr' : ∀ sigs' S'' p S status θ θo →
      S ∈ map (_+_ S'') (SigMap.keys sigs') →
        Canθ sigs' S'' p ((θ ← [ (S ₛ) ↦ status ]) ← θo) ≡
        Canθ sigs' S'' p (θ ← θo)

    canθ-shadowing-irr : ∀ sigs' S'' p S status θ →
      Signal.unwrap S ∈ map (_+_ S'') (SigMap.keys sigs') →
        Canθ sigs' S'' p θ ≡
        Canθ sigs' S'' p (θ ← [ S ↦ status ])

- Can only look at signals in the environment. Actually, if we define Can on top
  of SigMap instead of the whole Env, this would be unnecessary:

  can-shr-var-irr : ∀ p θ θ' →
    Env.sig θ ≡ Env.sig θ' →
    Can p θ ≡ Can p θ'

- term-nothing captures those terms that cause a side-effect and reduce to nothin.

  canₖ-term-nothin : ∀ {r} θ → term-nothin r → Canₖ r θ ≡ (Code.nothin ∷ [])

  So the result of the Can function will not change:

  canₖ-term-nothin-lemma : ∀ {r₁ r₂} θ E →
    term-nothin r₁ → term-nothin r₂ →
    ∀ k →
      k ∈ Canₖ (E ⟦ r₁ ⟧e) θ →
      k ∈ Canₖ (E ⟦ r₂ ⟧e) θ

- paused terms have return code pause.

  canₖ-paused : ∀ {p} θ → paused p → Canₖ p θ ≡ (Code.pause ∷ [])

- done terms basically do nothing -- their Canₛ and Canₛₕ are empty.

  canₛ-done : ∀ {p} θ → done p → Canₛ p θ ≡ []

- Canₛ and Canₛₕ only captures free variables -- bound variables are removed. This
  property has a weaker converse: emit S and s ⇐ e in some *evaluation context*
  will be captured by Can.

  canₛ-⊆-FV-lemma : ∀ {p BV FV} θ →
    CorrectBinding p BV FV →
    ∀ S →
      S ∈ Canₛ p θ →
      S ∈ proj₁ FV

  (and its canₛₕ counterpart)

  canₛ-capture-emit-signal : ∀ {p S E} θ →
    p ≐ E ⟦ emit S ⟧e →
    Signal.unwrap S ∈ Canₛ p θ

  canₛₕ-capture-set-shared : ∀ {p s e E} θ →
    p ≐ E ⟦ s ⇐ e ⟧e →
    SharedVar.unwrap s ∈ Canₛₕ p θ

- Subset relation of Can bubbles up through Canθ (a weaker version). Note that
  the lemmas for codes and shared variables requires subset relation of the
  signals as well.

  canθₛ-subset : ∀ sigs S'' p q θ →
    (∀ θ' S →
       Signal.unwrap S ∈ Canₛ p θ' →
       Signal.unwrap S ∈ Canₛ q θ') →
    ∀ S →
      Signal.unwrap S ∈ Canθₛ sigs S'' p θ →
      Signal.unwrap S ∈ Canθₛ sigs S'' q θ

  canθₛₕ-subset : ∀ sigs S'' p q θ →
    (∀ θ' S →
       Signal.unwrap S ∈ Canₛ p θ' →
       Signal.unwrap S ∈ Canₛ q θ') →
    (∀ θ' s →
       SharedVar.unwrap s ∈ Canₛₕ p θ' →
       SharedVar.unwrap s ∈ Canₛₕ q θ') →
    ∀ s →
      SharedVar.unwrap s ∈ Canθₛₕ sigs S'' p θ →
      SharedVar.unwrap s ∈ Canθₛₕ sigs S'' q θ

  canθ'ₛ-subset-lemma : ∀ sigs S'' κ κ' θ →
    (∀ θ' S → S ∈ proj₁ (κ θ') → S ∈ proj₁ (κ' θ')) →
    (∀ θ S status S' →
      S' ∈ proj₁ (κ' (θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty)) →
      S' ∈ proj₁ (κ' (θ ← [S]-env S))) →
    ∀ S → S ∈ proj₁ (Canθ' sigs S'' κ θ) → S ∈ proj₁ (Canθ' sigs S'' κ' θ)

- Certain type of mootonicity relationship between the Can-θ function
  and the evaluation context

    canθₛ-p⊆canθₛ-E₁⟦p⟧ : ∀ sigs S'' θ E₁ pin →
      ∀ S' →
        Signal.unwrap S' ∈ Canθₛ sigs S'' pin θ →
        Signal.unwrap S' ∈ Canθₛ sigs S'' ((E₁ ∷ []) ⟦ pin ⟧e) θ

    canθₛ-E₁⟦p⟧⊆canθₛ-p : ∀ {pin E₁ E₁⟦nothin⟧ BV FV} sigs S'' θ →
      E₁⟦nothin⟧ ≐ (E₁ ∷ []) ⟦ nothin ⟧e →
      CorrectBinding E₁⟦nothin⟧ BV FV →

      distinct' (map (_+_ S'') (SigMap.keys sigs)) (proj₁ FV) →
      ∀ S' →
        Signal.unwrap S' ∉ proj₁ FV →
        Signal.unwrap S' ∈ Canθₛ sigs S'' ((E₁ ∷ []) ⟦ pin ⟧e) θ →
        Signal.unwrap S' ∈ Canθₛ sigs S'' pin θ

-}
module Esterel.Lang.CanFunction.Base where

open import utility
  renaming (_U̬_ to _∪_ ; _|̌_ to _-_)

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.CanFunction
open import Esterel.Lang.CanFunction.SetSigMonotonic public -- weird dependency here
open import Esterel.Lang.Properties
  using (halted ; paused ; done)
open import Esterel.Context
  using (EvaluationContext1 ; EvaluationContext ; _⟦_⟧e ; _≐_⟦_⟧e)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
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 EvaluationContext1
open _≐_⟦_⟧e

open import Data.Bool
  using (Bool ; not ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; [] ; _∷_ ; _++_ ; map)
open import Data.List.Properties
  using (map-id)
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 ; maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _≟_ ; _+_)
open import Data.Nat.Properties.Simple
  using (+-comm ; +-right-identity)
open import Data.Product
  using (Σ ; proj₁ ; proj₂ ; ∃ ; _,_ ; _,′_ ; _×_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function
  using (_∘_ ; id ; _∋_)
open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; trans ; sym ; cong ; subst)

open halted
open paused
open done

open ListSet Data.Nat._≟_
  using (set-subtract ; set-subtract-[] ; set-subtract-merge ;  set-subtract-split ;
         set-remove ; set-remove-removed ; set-remove-mono-∈ ; set-remove-not-removed ;
         set-subtract-[a]≡set-remove)

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

-- Shorter local notation used in Can lemmas
[_↦_] : Signal → Signal.Status → Env
[ S ↦ status ] = Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty

data term-nothin : Term → Set where
  tnothin : term-nothin nothin
  temit : ∀ S → term-nothin (emit S)
  tset-shr : ∀ s e → term-nothin (s ⇐ e)
  tset-var : ∀ x e → term-nothin (x ≔ e)

data term-raise : ShrMap.Map (SharedVar.Status × ℕ) → VarMap.Map ℕ → Term → Term → Set where
  tshared : ∀ n s e p →
    term-raise ShrMap.[ s ↦ (SharedVar.old ,′ n) ]
           VarMap.empty
           (shared s ≔ e in: p) p
  tvar : ∀ n x e p →
    term-raise ShrMap.empty
           VarMap.[ x ↦ n ]
           (var x ≔ e in: p)    p

canₖ-term-nothin : ∀ {r} θ → term-nothin r → Canₖ r θ ≡ (Code.nothin ∷ [])
canₖ-term-nothin θ tnothin = refl
canₖ-term-nothin θ (temit S) = refl
canₖ-term-nothin θ (tset-shr s e) = refl
canₖ-term-nothin θ (tset-var x e) = refl

canₖ-paused : ∀ {p} θ → paused p → Canₖ p θ ≡ (Code.pause ∷ [])
canₖ-paused θ ppause                                             = refl
canₖ-paused θ (psuspend p/paused) rewrite canₖ-paused θ p/paused = refl
canₖ-paused θ (ptrap p/paused) rewrite canₖ-paused θ p/paused    = refl
canₖ-paused θ (ppar p/paused q/paused)
  rewrite canₖ-paused θ p/paused | canₖ-paused θ q/paused
  = refl
canₖ-paused {p >> q} θ (pseq p/paused) with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | no nothin∉can-p rewrite canₖ-paused θ p/paused = refl
... | yes nothin∈can-p rewrite canₖ-paused θ p/paused with nothin∈can-p
... | here ()
... | there ()

canₖ-paused {loopˢ p q} θ (ploopˢ p/paused) = canₖ-paused θ p/paused

canₛ-done : ∀ {p} θ → done p → Canₛ p θ ≡ []
canₛ-done θ (dhalted hnothin)   = refl
canₛ-done θ (dhalted (hexit _)) = refl
canₛ-done θ (dpaused ppause) = refl
canₛ-done θ (dpaused (ppar p/paused q/paused))
  rewrite canₛ-done θ (dpaused p/paused) | canₛ-done θ (dpaused q/paused)
  = refl
canₛ-done θ (dpaused (psuspend p/paused))
  rewrite canₛ-done θ (dpaused p/paused)
  = refl
canₛ-done θ (dpaused (ptrap p/paused))
  rewrite canₛ-done θ (dpaused p/paused)
  = refl
canₛ-done {loopˢ p q} θ (dpaused (ploopˢ p/paused)) = canₛ-done θ (dpaused p/paused)
canₛ-done {p >> q} θ (dpaused (pseq p/paused)) with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | no  nothin∉can-p rewrite canₛ-done θ (dpaused p/paused) = refl
... | yes nothin∈can-p rewrite canₖ-paused θ p/paused with nothin∈can-p
... | here ()
... | there ()

canₛₕ-done : ∀ {p} θ → done p → Canₛₕ p θ ≡ []
canₛₕ-done θ (dhalted hnothin)   = refl
canₛₕ-done θ (dhalted (hexit _)) = refl
canₛₕ-done θ (dpaused ppause) = refl
canₛₕ-done θ (dpaused (ppar p/paused q/paused))
  rewrite canₛₕ-done θ (dpaused p/paused) | canₛₕ-done θ (dpaused q/paused)
  = refl
canₛₕ-done θ (dpaused (psuspend p/paused))
  rewrite canₛₕ-done θ (dpaused p/paused)
  = refl
canₛₕ-done θ (dpaused (ptrap p/paused))
  rewrite canₛₕ-done θ (dpaused p/paused)
  = refl
canₛₕ-done {loopˢ p q} θ (dpaused (ploopˢ p/paused)) = canₛₕ-done θ (dpaused p/paused)
canₛₕ-done {p >> q} θ (dpaused (pseq p/paused)) with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | no  nothin∉can-p rewrite canₛₕ-done θ (dpaused p/paused) = refl
... | yes nothin∈can-p rewrite canₖ-paused θ p/paused with nothin∈can-p
... | here ()
... | there ()

can-shr-var-irr : ∀ p θ θ' →
  Env.sig θ ≡ Env.sig θ' →
  Can p θ ≡ Can p θ'

canθ-shr-var-irr : ∀ sigs S'' p θ θ' →
  Env.sig θ ≡ Env.sig θ' →
  Canθ sigs S'' p θ ≡ Canθ sigs S'' p θ'
canθ-shr-var-irr [] S'' p θ θ' θₛ≡θ'ₛ = can-shr-var-irr p θ θ' θₛ≡θ'ₛ
canθ-shr-var-irr (just Signal.present ∷ sigs) S'' p θ θ' θₛ≡θ'ₛ
  rewrite canθ-shr-var-irr sigs (suc S'') p
            (θ  ← [S]-env-present (S'' ₛ))
            (θ' ← [S]-env-present (S'' ₛ))
            (cong (λ sig* → SigMap.union sig* (Env.sig ([S]-env-present (S'' ₛ)))) θₛ≡θ'ₛ)
  = refl
canθ-shr-var-irr (just Signal.absent  ∷ sigs)  S'' p θ θ' θₛ≡θ'ₛ
  rewrite canθ-shr-var-irr sigs (suc S'') p
            (θ  ← [S]-env-absent (S'' ₛ))
            (θ' ← [S]-env-absent (S'' ₛ))
            (cong (λ sig* → SigMap.union sig* (Env.sig ([S]-env-absent (S'' ₛ)))) θₛ≡θ'ₛ)
  = refl
canθ-shr-var-irr (just Signal.unknown ∷ sigs) S'' p θ θ' θₛ≡θ'ₛ
  with any (S'' ≟_) (proj₁ (Canθ sigs (suc S'') p (θ  ← [S]-env (S'' ₛ))))
     | any (S'' ≟_) (proj₁ (Canθ sigs (suc S'') p (θ' ← [S]-env (S'' ₛ))))
... | yes S''∈canθ-θ←[S] | yes S''∈canθ-θ'←[S]
  rewrite canθ-shr-var-irr sigs (suc S'') p
            (θ ←  [S]-env (S'' ₛ))
            (θ' ← [S]-env (S'' ₛ))
            (cong (λ sig* → SigMap.union sig* (Env.sig ([S]-env (S'' ₛ)))) θₛ≡θ'ₛ)
  = refl
... | no  S''∉canθ-θ←[S] | no  S''∉canθ-θ'←[S]
  rewrite canθ-shr-var-irr sigs (suc S'') p
            (θ ← [S]-env-absent (S'' ₛ))
            (θ' ← [S]-env-absent (S'' ₛ))
            (cong (λ sig* → SigMap.union sig* (Env.sig ([S]-env-absent (S'' ₛ)))) θₛ≡θ'ₛ)
  = refl
... | no  S''∉canθ-θ←[S] | yes S''∈canθ-θ'←[S]
  rewrite canθ-shr-var-irr sigs (suc S'') p
            (θ ←  [S]-env (S'' ₛ))
            (θ' ← [S]-env (S'' ₛ))
            (cong (λ sig* → SigMap.union sig* (Env.sig ([S]-env (S'' ₛ)))) θₛ≡θ'ₛ)
  = ⊥-elim (S''∉canθ-θ←[S] S''∈canθ-θ'←[S])
... | yes S''∈canθ-θ←[S] | no  S''∉canθ-θ'←[S]
  rewrite canθ-shr-var-irr sigs (suc S'') p
            (θ ←  [S]-env (S'' ₛ))
            (θ' ← [S]-env (S'' ₛ))
            (cong (λ sig* → SigMap.union sig* (Env.sig ([S]-env (S'' ₛ)))) θₛ≡θ'ₛ)
  = ⊥-elim (S''∉canθ-θ'←[S] S''∈canθ-θ←[S])
canθ-shr-var-irr (nothing ∷ sigs) S'' p θ θ' θₛ≡θ'ₛ
  rewrite canθ-shr-var-irr sigs (suc S'') p θ θ' θₛ≡θ'ₛ
  = refl

can-shr-var-irr nothin θ θ' θₛ≡θ'ₛ = refl
can-shr-var-irr pause θ θ' θₛ≡θ'ₛ = refl
can-shr-var-irr (signl S p) θ θ' θₛ≡θ'ₛ
  rewrite canθ-shr-var-irr (Env.sig ([S]-env S)) 0 p θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (present S ∣⇒ p ∣⇒ q) (Θ Ss ss xs) (Θ .Ss ss' xs') refl
  with Env.Sig∈ S (Θ Ss ss xs)
... | yes S∈
  rewrite can-shr-var-irr p (Θ Ss ss xs) (Θ Ss ss' xs') refl
        | can-shr-var-irr q (Θ Ss ss xs) (Θ Ss ss' xs') refl
  = refl
... | no  S∉
  rewrite can-shr-var-irr p (Θ Ss ss xs) (Θ Ss ss' xs') refl
        | can-shr-var-irr q (Θ Ss ss xs) (Θ Ss ss' xs') refl
  = refl
can-shr-var-irr (emit S) θ θ' θₛ≡θ'ₛ = refl
can-shr-var-irr (p ∥ q) θ θ' θₛ≡θ'ₛ
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
        | can-shr-var-irr q θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (loop p) θ θ' θₛ≡θ'ₛ =
  can-shr-var-irr p θ θ' θₛ≡θ'ₛ
can-shr-var-irr (loopˢ p q) θ θ' θₛ≡θ'ₛ = can-shr-var-irr p θ θ' θₛ≡θ'ₛ
can-shr-var-irr (p >> q) θ θ' θₛ≡θ'ₛ
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
     | any (Code._≟_ Code.nothin) (Canₖ p θ')
... | yes nothin∈can-p-θ | yes nothin∈can-p-θ'
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
        | can-shr-var-irr q θ θ' θₛ≡θ'ₛ
  = refl
... | yes nothin∈can-p-θ | (no nothin∉can-p-θ')
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
  = ⊥-elim (nothin∉can-p-θ' nothin∈can-p-θ)
... | no nothin∉can-p-θ | yes nothin∈can-p-θ'
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
  = ⊥-elim (nothin∉can-p-θ nothin∈can-p-θ')
... | no nothin∉can-p-θ | no nothin∉can-p-θ'
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (suspend p S) θ θ' θₛ≡θ'ₛ =
  can-shr-var-irr p θ θ' θₛ≡θ'ₛ
can-shr-var-irr (trap p) θ θ' θₛ≡θ'ₛ
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (exit x) θ θ' θₛ≡θ'ₛ = refl
can-shr-var-irr (shared s ≔ e in: p) θ θ' θₛ≡θ'ₛ
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (s ⇐ e) θ θ' θₛ≡θ'ₛ = refl
can-shr-var-irr (var x ≔ e in: p) θ θ' θₛ≡θ'ₛ
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (x ≔ e) θ θ' θₛ≡θ'ₛ = refl
can-shr-var-irr (if x ∣⇒ p ∣⇒ q) θ θ' θₛ≡θ'ₛ
  rewrite can-shr-var-irr p θ θ' θₛ≡θ'ₛ
        | can-shr-var-irr q θ θ' θₛ≡θ'ₛ
  = refl
can-shr-var-irr (ρ⟨ θ'' , A ⟩· p) θ θ' θₛ≡θ'ₛ
  rewrite canθ-shr-var-irr (Env.sig θ'') 0 p θ θ' θₛ≡θ'ₛ
  = refl

canₛ-capture-emit-signal : ∀ {p S E} θ →
  p ≐ E ⟦ emit S ⟧e →
  Signal.unwrap S ∈ Canₛ p θ
canₛ-capture-emit-signal θ dehole = here refl
canₛ-capture-emit-signal θ (depar₁ p≐E⟦emit⟧) =
  ++ˡ (canₛ-capture-emit-signal θ p≐E⟦emit⟧)
canₛ-capture-emit-signal {p ∥ _} θ (depar₂ p≐E⟦emit⟧) =
  ++ʳ (Canₛ p θ) (canₛ-capture-emit-signal θ p≐E⟦emit⟧)
canₛ-capture-emit-signal {loopˢ p _}  θ (deloopˢ p≐E⟦emit⟧) = canₛ-capture-emit-signal θ p≐E⟦emit⟧
canₛ-capture-emit-signal {p >> _}  θ (deseq p≐E⟦emit⟧)
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | yes nothin∈can-p = ++ˡ (canₛ-capture-emit-signal θ p≐E⟦emit⟧)
... | no  nothin∉can-p = canₛ-capture-emit-signal θ p≐E⟦emit⟧
canₛ-capture-emit-signal θ (desuspend p≐E⟦emit⟧) =
  canₛ-capture-emit-signal θ p≐E⟦emit⟧
canₛ-capture-emit-signal θ (detrap p≐E⟦emit⟧) =
  canₛ-capture-emit-signal θ p≐E⟦emit⟧

canₛₕ-capture-set-shared : ∀ {p s e E} θ →
  p ≐ E ⟦ s ⇐ e ⟧e →
  SharedVar.unwrap s ∈ Canₛₕ p θ
canₛₕ-capture-set-shared θ dehole = here refl
canₛₕ-capture-set-shared θ (depar₁ p≐E⟦s⇐e⟧) =
  ++ˡ (canₛₕ-capture-set-shared θ p≐E⟦s⇐e⟧)
canₛₕ-capture-set-shared {p ∥ _} θ (depar₂ q≐E⟦s⇐e⟧) =
  ++ʳ (Canₛₕ p θ) (canₛₕ-capture-set-shared θ q≐E⟦s⇐e⟧)
canₛₕ-capture-set-shared {loopˢ p _} θ (deloopˢ p≐E⟦s⇐e⟧) = canₛₕ-capture-set-shared θ p≐E⟦s⇐e⟧
canₛₕ-capture-set-shared {p >> _} θ (deseq p≐E⟦s⇐e⟧)
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | yes nothin∈can-p = ++ˡ (canₛₕ-capture-set-shared θ p≐E⟦s⇐e⟧)
... | no  nothin∉can-p = canₛₕ-capture-set-shared θ p≐E⟦s⇐e⟧
canₛₕ-capture-set-shared θ (desuspend p≐E⟦s⇐e⟧) =
  canₛₕ-capture-set-shared θ p≐E⟦s⇐e⟧
canₛₕ-capture-set-shared θ (detrap p≐E⟦s⇐e⟧) =
  canₛₕ-capture-set-shared θ p≐E⟦s⇐e⟧

canθₛ-membership : ∀ sigs S'' p θ S →
  (∀ θ' → Signal.unwrap S ∈ Canₛ p θ') →
  Signal.unwrap S ∈ Canθₛ sigs S'' p θ
canθₛ-membership [] S'' p θ S S∈can-p = S∈can-p θ
canθₛ-membership (nothing ∷ sigs) S'' p θ S S∈can-p =
  canθₛ-membership sigs (suc S'') p θ S S∈can-p
canθₛ-membership (just Signal.present ∷ sigs) S'' p θ S S∈can-p =
  canθₛ-membership sigs (suc S'') p (θ ← [S]-env-present (S'' ₛ)) S S∈can-p
canθₛ-membership (just Signal.absent ∷ sigs) S'' p θ S S∈can-p =
  canθₛ-membership sigs (suc S'') p (θ ← [S]-env-absent (S'' ₛ)) S S∈can-p
canθₛ-membership (just Signal.unknown ∷ sigs) S'' p θ S S∈can-p
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ←[S''] =
  canθₛ-membership sigs (suc S'') p (θ ← [S]-env (S'' ₛ)) S S∈can-p
... | no  S''∉canθ-p-θ←[S''] =
  canθₛ-membership sigs (suc S'') p (θ ← [S]-env-absent (S'' ₛ)) S S∈can-p

canθₛₕ-membership : ∀ sigs S'' p θ s →
  (∀ θ' → SharedVar.unwrap s ∈ Canₛₕ p θ') →
  SharedVar.unwrap s ∈ Canθₛₕ sigs S'' p θ
canθₛₕ-membership [] S'' p θ s s∈can-p = s∈can-p θ
canθₛₕ-membership (nothing ∷ sigs) S'' p θ s s∈can-p =
  canθₛₕ-membership sigs (suc S'') p θ s s∈can-p
canθₛₕ-membership (just Signal.present ∷ sigs) S'' p θ s s∈can-p =
  canθₛₕ-membership sigs (suc S'') p (θ ← [S]-env-present (S'' ₛ)) s s∈can-p
canθₛₕ-membership (just Signal.absent ∷ sigs) S'' p θ s s∈can-p =
  canθₛₕ-membership sigs (suc S'') p (θ ← [S]-env-absent (S'' ₛ)) s s∈can-p
canθₛₕ-membership (just Signal.unknown ∷ sigs) S'' p θ s s∈can-p
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ←[S''] =
  canθₛₕ-membership sigs (suc S'') p (θ ← [S]-env (S'' ₛ)) s s∈can-p
... | no  S''∉canθ-p-θ←[S''] =
  canθₛₕ-membership sigs (suc S'') p (θ ← [S]-env-absent (S'' ₛ)) s s∈can-p

canₛ-⊆-FV-lemma : ∀ {p BV FV} θ →
  CorrectBinding p BV FV →
  ∀ S →
    S ∈ Canₛ p θ →
    S ∈ proj₁ FV

canθₛ-⊆-FV-lemma : ∀ {p BV FV} sigs S'' θ →
  CorrectBinding p BV FV →
  ∀ S →
    S ∈ proj₁ (Canθ sigs S'' p θ) →
    S ∈ proj₁ FV
canθₛ-⊆-FV-lemma {FV = FV} [] S'' θ cb S S∈canθ-p-θ =
  canₛ-⊆-FV-lemma θ cb S S∈canθ-p-θ
canθₛ-⊆-FV-lemma (just Signal.present ∷ sigs) S'' θ cb S S∈canθ-p-θ =
  canθₛ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env-present (S'' ₛ)) cb S S∈canθ-p-θ
canθₛ-⊆-FV-lemma (just Signal.absent  ∷ sigs) S'' θ cb S S∈canθ-p-θ =
  canθₛ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) cb S S∈canθ-p-θ
canθₛ-⊆-FV-lemma {p} (just Signal.unknown ∷ sigs) S'' θ cb S S∈canθ-p-θ
  with any (S'' ≟_) (proj₁ (Canθ sigs (suc S'') p (θ ← [S]-env (S'' ₛ))))
... | yes S''∈canθ-p-θ←[S] =
  canθₛ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env (S'' ₛ)) cb S S∈canθ-p-θ
... | no  S''∉canθ-p-θ←[S] =
  canθₛ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) cb S S∈canθ-p-θ
canθₛ-⊆-FV-lemma (nothing ∷ sigs) S'' θ cb S S∈canθ-p-θ =
  canθₛ-⊆-FV-lemma sigs (suc S'') θ cb S S∈canθ-p-θ

canₛ-⊆-FV-lemma θ CBnothing S ()
canₛ-⊆-FV-lemma θ CBpause S ()
canₛ-⊆-FV-lemma {signl S' p} θ (CBsig {FV = FV} cb) S S∈can-sig-p
  with Signal.unwrap S' Data.Nat.≟ S
... | yes refl =
  ⊥-elim (set-remove-removed {S} {Canθₛ (Env.sig ([S]-env S')) 0 p θ} S∈can-sig-p)
... | no  S'≢S
  rewrite set-subtract-[a]≡set-remove (proj₁ FV) (Signal.unwrap S')
  = set-remove-not-removed S'≢S
    (canθₛ-⊆-FV-lemma (Env.sig ([S]-env S')) 0 θ cb S
      (set-remove-mono-∈ (Signal.unwrap S') S∈can-sig-p))
canₛ-⊆-FV-lemma {present S' ∣⇒ p ∣⇒ q} θ (CBpresent {FVp = FVp} cbp cbq) S S∈can-S'?p:q
  with Env.Sig∈ S' θ
canₛ-⊆-FV-lemma {present S' ∣⇒ p ∣⇒ q} θ (CBpresent {FVp = FVp} cbp cbq) S S∈can-S'ᵘ?p:q
  | no  S'∉Domθ with ++⁻ (Canₛ p θ) S∈can-S'ᵘ?p:q
... | inj₁ S∈can-p = ++ʳ (Signal.unwrap S' ∷  []) (++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-p))
... | inj₂ S∈can-q = ++ʳ (Signal.unwrap S' ∷ proj₁ FVp) (canₛ-⊆-FV-lemma θ cbq S S∈can-q)
canₛ-⊆-FV-lemma {present S' ∣⇒ p ∣⇒ q} θ (CBpresent {FVp = FVp} cbp cbq) S S∈can-S'ᵘ?p:q
  | yes S'∈Domθ with Env.sig-stats {S'} θ S'∈Domθ
... | Signal.present = ++ʳ (Signal.unwrap S' ∷  []) (++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-S'ᵘ?p:q))
... | Signal.absent  = ++ʳ (Signal.unwrap S' ∷ proj₁ FVp) (canₛ-⊆-FV-lemma θ cbq S S∈can-S'ᵘ?p:q)
... | Signal.unknown with ++⁻ (Canₛ p θ) S∈can-S'ᵘ?p:q
... | inj₁ S∈can-p = ++ʳ (Signal.unwrap S' ∷  []) (++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-p))
... | inj₂ S∈can-q = ++ʳ (Signal.unwrap S' ∷ proj₁ FVp) (canₛ-⊆-FV-lemma θ cbq S S∈can-q)
canₛ-⊆-FV-lemma θ CBemit S S∈can-p = S∈can-p
canₛ-⊆-FV-lemma {p ∥ q} θ (CBpar {FVp = FVp} cbp cbq BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) S S∈can-p∥q
  with ++⁻ (Canₛ p θ) S∈can-p∥q
... | inj₁ S∈can-p = ++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-p)
... | inj₂ S∈can-q = ++ʳ (proj₁ FVp) (canₛ-⊆-FV-lemma θ cbq S S∈can-q)
canₛ-⊆-FV-lemma θ (CBloop cb BV≠FV) S S∈can-p =
  canₛ-⊆-FV-lemma θ cb S S∈can-p
canₛ-⊆-FV-lemma θ (CBloopˢ CBp CBq BVp≠FVq BVq≠FVq) S S∈can-loopˢp
  with canₛ-⊆-FV-lemma θ CBp S S∈can-loopˢp
... | sub = ++ˡ sub
canₛ-⊆-FV-lemma {p >> q} θ (CBseq {FVp = FVp} cbp cbq BVp≠FVq) S S∈can-p>>q
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | no  nothin∉can-p = ++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-p>>q)
... | yes nothin∈can-p with ++⁻ (Canₛ p θ) S∈can-p>>q
... | inj₁ S∈can-p = ++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-p)
... | inj₂ S∈can-q = ++ʳ (proj₁ FVp) (canₛ-⊆-FV-lemma θ cbq S S∈can-q)
canₛ-⊆-FV-lemma θ (CBsusp cb [S]≠BVp) S S∈can-p =
  there (canₛ-⊆-FV-lemma θ cb S S∈can-p)
canₛ-⊆-FV-lemma θ CBexit S ()
canₛ-⊆-FV-lemma θ (CBtrap cb) S S∈can-p =
  canₛ-⊆-FV-lemma θ cb S S∈can-p
canₛ-⊆-FV-lemma {shared _ ≔ e in: _} θ (CBshared {FV = FV} cb) S S∈can-p
  rewrite set-subtract-[] (proj₁ FV)
  = ++ʳ (proj₁ (FVₑ e)) (canₛ-⊆-FV-lemma θ cb S S∈can-p)
canₛ-⊆-FV-lemma θ CBsset S ()
canₛ-⊆-FV-lemma {var _ ≔ e in: _} θ (CBvar {FV = FV} cb) S S∈can-p
  rewrite set-subtract-[] (proj₁ FV)
  = ++ʳ (proj₁ (FVₑ e)) (canₛ-⊆-FV-lemma θ cb S S∈can-p)
canₛ-⊆-FV-lemma θ CBvset S ()
canₛ-⊆-FV-lemma {if _ ∣⇒ p ∣⇒ q} θ (CBif {FVp = FVp} cbp cbq) S S∈can-if-p-q
  with ++⁻ (Canₛ p θ) S∈can-if-p-q
... | inj₁ S∈can-p = ++ˡ (canₛ-⊆-FV-lemma θ cbp S S∈can-p)
... | inj₂ S∈can-q = ++ʳ (proj₁ FVp) (canₛ-⊆-FV-lemma θ cbq S S∈can-q)
canₛ-⊆-FV-lemma {ρ⟨ θ' , A ⟩· p} θ (CBρ cb) S S∈can-ρθp
  with set-subtract-merge {proj₁ (Canθ (Env.sig θ') 0 p θ)} {proj₁ (Dom θ')} S∈can-ρθp
... | S∈can-p-θ←θ' , S∉Domθ'
  with set-subtract-split (canθₛ-⊆-FV-lemma (Env.sig θ') 0 θ cb S S∈can-p-θ←θ')
... | inj₁ S∈FV = S∈FV
... | inj₂ S∈Domθ' = ⊥-elim (S∉Domθ' S∈Domθ')

canₛ-⊆-FV : ∀ {p BV FV} θ →
  CorrectBinding p BV FV →
  ∀ S →
    Signal.unwrap S ∈ Canₛ p θ →
    Signal.unwrap S ∈ proj₁ FV
canₛ-⊆-FV θ cb S = canₛ-⊆-FV-lemma θ cb (Signal.unwrap S)

canₛₕ-⊆-FV-lemma : ∀ {p BV FV} θ →
  CorrectBinding p BV FV →
  ∀ s →
    s ∈ Canₛₕ p θ →
    s ∈ proj₁ (proj₂ FV)

canθₛₕ-⊆-FV-lemma : ∀ {p BV FV} sigs S'' θ →
  CorrectBinding p BV FV →
  ∀ s →
    s ∈ proj₂ (proj₂ (Canθ sigs S'' p θ)) →
    s ∈ proj₁ (proj₂ FV)
canθₛₕ-⊆-FV-lemma {FV = FV} [] S'' θ cb s s∈canθ-p-θ =
  canₛₕ-⊆-FV-lemma θ cb s s∈canθ-p-θ
canθₛₕ-⊆-FV-lemma (just Signal.present ∷ sigs) S'' θ cb s s∈canθ-p-θ =
  canθₛₕ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env-present (S'' ₛ)) cb s s∈canθ-p-θ
canθₛₕ-⊆-FV-lemma (just Signal.absent  ∷ sigs) S'' θ cb s s∈canθ-p-θ =
  canθₛₕ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) cb s s∈canθ-p-θ
canθₛₕ-⊆-FV-lemma {p} (just Signal.unknown ∷ sigs) S'' θ cb s s∈canθ-p-θ
  with any (S'' ≟_) (proj₁ (Canθ sigs (suc S'') p (θ ← [S]-env (S'' ₛ))))
... | yes S''∈canθ-p-θ←[S] =
  canθₛₕ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env (S'' ₛ)) cb s s∈canθ-p-θ
... | no  S''∉canθ-p-θ←[S] =
  canθₛₕ-⊆-FV-lemma sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) cb s s∈canθ-p-θ
canθₛₕ-⊆-FV-lemma (nothing ∷ sigs) S'' θ cb s s∈canθ-p-θ =
  canθₛₕ-⊆-FV-lemma sigs (suc S'') θ cb s s∈canθ-p-θ

canₛₕ-⊆-FV-lemma θ CBnothing s ()
canₛₕ-⊆-FV-lemma θ CBpause s ()
canₛₕ-⊆-FV-lemma {signl S' p} θ (CBsig {FV = FV} cb) s s∈can-p
  rewrite set-subtract-[] (proj₁ (proj₂ FV))
  = canθₛₕ-⊆-FV-lemma (Env.sig ([S]-env S')) 0 θ cb s s∈can-p
canₛₕ-⊆-FV-lemma {present S' ∣⇒ p ∣⇒ q} θ (CBpresent {FVp = FVp} cbp cbq) s s∈can-S'?p:q
  with Env.Sig∈ S' θ
canₛₕ-⊆-FV-lemma {present S' ∣⇒ p ∣⇒ q} θ (CBpresent {FVp = FVp} cbp cbq) s s∈can-S'ᵘ?p:q
  | no  S'∉Domθ with ++⁻ (Canₛₕ p θ) s∈can-S'ᵘ?p:q
... | inj₁ s∈can-p = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-p)
... | inj₂ s∈can-q = ++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV-lemma θ cbq s s∈can-q)
canₛₕ-⊆-FV-lemma {present S' ∣⇒ p ∣⇒ q} θ (CBpresent {FVp = FVp} cbp cbq) s s∈can-S'ᵘ?p:q
  | yes S'∈Domθ with Env.sig-stats {S'} θ S'∈Domθ
... | Signal.present = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-S'ᵘ?p:q)
... | Signal.absent  = ++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV-lemma θ cbq s s∈can-S'ᵘ?p:q)
... | Signal.unknown with ++⁻ (Canₛₕ p θ) s∈can-S'ᵘ?p:q
... | inj₁ s∈can-p = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-p)
... | inj₂ s∈can-q = ++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV-lemma θ cbq s s∈can-q)
canₛₕ-⊆-FV-lemma θ CBemit s ()
canₛₕ-⊆-FV-lemma {p ∥ q} θ (CBpar {FVp = FVp} cbp cbq BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) s s∈can-p∥q
  with ++⁻ (Canₛₕ p θ) s∈can-p∥q
... | inj₁ s∈can-p = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-p)
... | inj₂ s∈can-q = ++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV-lemma θ cbq s s∈can-q)
canₛₕ-⊆-FV-lemma θ (CBloop cb BV≠FV) s s∈can-p =
  canₛₕ-⊆-FV-lemma θ cb s s∈can-p
canₛₕ-⊆-FV-lemma θ (CBloopˢ CBp CBq BVp≠FVq BVq≠FVq) s s∈can-loopˢpq
  with canₛₕ-⊆-FV-lemma θ CBp s s∈can-loopˢpq
... | sub = ++ˡ sub
canₛₕ-⊆-FV-lemma {p >> q} θ (CBseq {FVp = FVp} cbp cbq BVp≠FVq) s s∈can-p>>q
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
... | no  nothin∉can-p = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-p>>q)
... | yes nothin∈can-p with ++⁻ (Canₛₕ p θ) s∈can-p>>q
... | inj₁ s∈can-p = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-p)
... | inj₂ s∈can-q = ++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV-lemma θ cbq s s∈can-q)
canₛₕ-⊆-FV-lemma θ (CBsusp cb [S]≠BVp) s s∈can-p =
  canₛₕ-⊆-FV-lemma θ cb s s∈can-p
canₛₕ-⊆-FV-lemma θ CBexit s ()
canₛₕ-⊆-FV-lemma θ (CBtrap cb) s s∈can-p =
  canₛₕ-⊆-FV-lemma θ cb s s∈can-p
canₛₕ-⊆-FV-lemma {shared s' ≔ e in: p} θ (CBshared {FV = FV} cb) s s∈can-shared-p
  with SharedVar.unwrap s' Data.Nat.≟ s
... | yes refl = ⊥-elim (set-remove-removed {s} {Canₛₕ p θ} s∈can-shared-p)
... | no  s'≢s
  rewrite set-subtract-[a]≡set-remove (proj₁ (proj₂ FV)) (SharedVar.unwrap s')
  = ++ʳ (proj₁ (proj₂ (FVₑ e)))
    (set-remove-not-removed s'≢s
      (canₛₕ-⊆-FV-lemma θ cb s
        (set-remove-mono-∈ (SharedVar.unwrap s') s∈can-shared-p)))
canₛₕ-⊆-FV-lemma {s' ⇐ e} θ CBsset s s∈can-p = ++ˡ s∈can-p
canₛₕ-⊆-FV-lemma {var _ ≔ e in: _} θ (CBvar {FV = FV} cb) s s∈can-p
  rewrite set-subtract-[] (proj₁ (proj₂ FV))
  = ++ʳ (proj₁ (proj₂ (FVₑ e))) (canₛₕ-⊆-FV-lemma θ cb s s∈can-p)
canₛₕ-⊆-FV-lemma θ CBvset s ()
canₛₕ-⊆-FV-lemma {if _ ∣⇒ p ∣⇒ q} θ (CBif {FVp = FVp} cbp cbq) s s∈can-if-p-q
  with ++⁻ (Canₛₕ p θ) s∈can-if-p-q
... | inj₁ s∈can-p = ++ˡ (canₛₕ-⊆-FV-lemma θ cbp s s∈can-p)
... | inj₂ s∈can-q = ++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV-lemma θ cbq s s∈can-q)
canₛₕ-⊆-FV-lemma {ρ⟨ θ' , A ⟩· p} θ (CBρ cb) s s∈can-ρθp
  with set-subtract-merge
         {proj₂ (proj₂ (Canθ (Env.sig θ') 0 p θ))}
         {proj₁ (proj₂ (Dom θ'))}
         s∈can-ρθp
... | s∈can-p-θ←θ' , s∉Domθ'
  with set-subtract-split (canθₛₕ-⊆-FV-lemma (Env.sig θ') 0 θ cb s s∈can-p-θ←θ')
... | inj₁ s∈FV = s∈FV
... | inj₂ s∈Domθ' = ⊥-elim (s∉Domθ' s∈Domθ')

canₛₕ-⊆-FV : ∀ {p BV FV} θ →
  CorrectBinding p BV FV →
  ∀ s →
    SharedVar.unwrap s ∈ Canₛₕ p θ →
    SharedVar.unwrap s ∈ proj₁ (proj₂ FV)
canₛₕ-⊆-FV θ cb s = canₛₕ-⊆-FV-lemma θ cb (SharedVar.unwrap s)

canₖ-term-nothin-lemma : ∀ {r₁ r₂} θ E →
  term-nothin r₁ → term-nothin r₂ →
  ∀ k →
    k ∈ Canₖ (E ⟦ r₁ ⟧e) θ →
    k ∈ Canₖ (E ⟦ r₂ ⟧e) θ
canₖ-term-nothin-lemma θ [] r₁' r₂' k k∈can-E⟦r2⟧-θ'
  rewrite canₖ-term-nothin θ r₁' | canₖ-term-nothin θ r₂' = k∈can-E⟦r2⟧-θ'
canₖ-term-nothin-lemma θ (epar₁ q ∷ E) r₁' r₂' k k∈can-E⟦r2⟧-θ' =
  map-mono² Code._⊔_
    (canₖ-term-nothin-lemma θ E r₁' r₂')
    (λ _ → id)
    k k∈can-E⟦r2⟧-θ'
canₖ-term-nothin-lemma θ (epar₂ p ∷ E) r₁' r₂' k k∈can-E⟦r2⟧-θ' =
  map-mono² {xs = Canₖ p θ} Code._⊔_
    (λ _ → id)
    (canₖ-term-nothin-lemma θ E r₁' r₂')
    k
    k∈can-E⟦r2⟧-θ'
canₖ-term-nothin-lemma {r₁} {r₂} θ (eloopˢ q ∷ E) r₁' r₂' k k∈can-E⟦r2⟧-θ' = canₖ-term-nothin-lemma θ E r₁' r₂' k k∈can-E⟦r2⟧-θ'
canₖ-term-nothin-lemma {r₁} {r₂} θ (eseq q ∷ E) r₁' r₂' k k∈can-E⟦r2⟧-θ'
  with any (Code._≟_ Code.nothin) (Canₖ (E ⟦ r₁ ⟧e) θ)
     | any (Code._≟_ Code.nothin) (Canₖ (E ⟦ r₂ ⟧e) θ)
... | yes nothin∈can-E⟦r₁⟧ | no  nothin∉can-E⟦r₂⟧ =
  ⊥-elim (nothin∉can-E⟦r₂⟧ (canₖ-term-nothin-lemma θ E r₁' r₂' Code.nothin nothin∈can-E⟦r₁⟧))
... | no  nothin∉can-E⟦r₁⟧ | yes nothin∈can-E⟦r₂⟧ =
  ⊥-elim (nothin∉can-E⟦r₁⟧ (canₖ-term-nothin-lemma θ E r₂' r₁' Code.nothin nothin∈can-E⟦r₂⟧))
... | no  nothin∉can-E⟦r₁⟧ | no  nothin∉can-E⟦r₂⟧ =
  canₖ-term-nothin-lemma θ E r₁' r₂' k k∈can-E⟦r2⟧-θ'
... | yes nothin∈can-E⟦r₁⟧ | yes nothin∈can-E⟦r₂⟧
  with ++⁻ (CodeSet.set-remove (Canₖ (E ⟦ r₁ ⟧e) θ) Code.nothin) k∈can-E⟦r2⟧-θ'
... | inj₂ k∈can-q =
  ++ʳ (CodeSet.set-remove (Canₖ (E ⟦ r₂ ⟧e) θ) Code.nothin) k∈can-q
... | inj₁ k∈can-E⟦r1⟧-nothin with Code.nothin Code.≟ k
... | yes refl =
  ⊥-elim (CodeSet.set-remove-removed {Code.nothin} {Canₖ (E ⟦ r₁ ⟧e) θ} k∈can-E⟦r1⟧-nothin)
... | no nothin≢k =
  ++ˡ (CodeSet.set-remove-not-removed nothin≢k
        (canₖ-term-nothin-lemma θ E r₁' r₂' k
          (CodeSet.set-remove-mono-∈ Code.nothin k∈can-E⟦r1⟧-nothin)))
canₖ-term-nothin-lemma θ (esuspend S' ∷ E) r₁' r₂' k k∈can-E⟦r2⟧-θ' =
  canₖ-term-nothin-lemma θ E r₁' r₂' k k∈can-E⟦r2⟧-θ'
canₖ-term-nothin-lemma θ (etrap ∷ E) r₁' r₂' k k∈can-E⟦r2⟧-θ' =
  map-mono Code.↓* (canₖ-term-nothin-lemma θ E r₁' r₂') k k∈can-E⟦r2⟧-θ'

canθₛ-subset-lemma : ∀ sigs S'' p q θ →
  (∀ θ' S → S ∈ Canₛ p θ' → S ∈ Canₛ q θ') →
  ∀ S → S ∈ Canθₛ sigs S'' p θ → S ∈ Canθₛ sigs S'' q θ
canθₛ-subset-lemma [] S'' p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ =
  canₛ-p⊆canₛ-q θ S S∈canθ-p-θ
canθₛ-subset-lemma (nothing ∷ sigs) S'' p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ =
  canθₛ-subset-lemma sigs (suc S'') p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ
canθₛ-subset-lemma (just Signal.present ∷ sigs) S'' p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ =
  canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-present (S'' ₛ)) canₛ-p⊆canₛ-q S S∈canθ-p-θ
canθₛ-subset-lemma (just Signal.absent ∷ sigs) S'' p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ =
  canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ)) canₛ-p⊆canₛ-q S S∈canθ-p-θ
canθₛ-subset-lemma (just Signal.unknown ∷ sigs) S'' p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') q (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ' | yes S''∈canθ-q-θ' =
  canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env (S'' ₛ)) canₛ-p⊆canₛ-q S S∈canθ-p-θ
... | no  S''∉canθ-p-θ' | no  S''∉canθ-q-θ' =
  canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ)) canₛ-p⊆canₛ-q S S∈canθ-p-θ
... | yes S''∈canθ-p-θ' | no  S''∉canθ-q-θ' =
  ⊥-elim
    (S''∉canθ-q-θ'
      (canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env (S'' ₛ)) canₛ-p⊆canₛ-q
        S'' S''∈canθ-p-θ'))
... | no  S''∉canθ-p-θ' | yes S''∈canθ-q-θ' =
  canθₛ-add-sig-monotonic sigs (suc S'') q θ (S'' ₛ) Signal.absent S
    (canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ)) canₛ-p⊆canₛ-q
      S S∈canθ-p-θ)

canθₛ-subset : ∀ sigs S'' p q θ →
  (∀ θ' S →
     Signal.unwrap S ∈ Canₛ p θ' →
     Signal.unwrap S ∈ Canₛ q θ') →
  ∀ S →
    Signal.unwrap S ∈ Canθₛ sigs S'' p θ →
    Signal.unwrap S ∈ Canθₛ sigs S'' q θ
canθₛ-subset sigs S'' p q θ canₛ-p⊆canₛ-q S S∈canθ-p-θ =
  canθₛ-subset-lemma sigs S'' p q θ
    (λ θ' S → canₛ-p⊆canₛ-q θ' (S ₛ))
    (Signal.unwrap S) S∈canθ-p-θ

canθₛₕ-subset-lemma : ∀ sigs S'' p q θ →
  (∀ θ' S → S ∈ Canₛ p θ' → S ∈ Canₛ q θ') →
  (∀ θ' s → s ∈ Canₛₕ p θ' → s ∈ Canₛₕ q θ') →
  ∀ s → s ∈ Canθₛₕ sigs S'' p θ → s ∈ Canθₛₕ sigs S'' q θ
canθₛₕ-subset-lemma [] S'' p q θ
  canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ =
  canₛₕ-p⊆canₛₕ-q θ s s∈canθ-p-θ
canθₛₕ-subset-lemma (nothing ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ =
  canθₛₕ-subset-lemma sigs (suc S'') p q θ
    canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ
canθₛₕ-subset-lemma (just Signal.present ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ =
  canθₛₕ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-present (S'' ₛ))
    canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ
canθₛₕ-subset-lemma (just Signal.absent ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ =
  canθₛₕ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ))
    canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ
canθₛₕ-subset-lemma (just Signal.unknown ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') q (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ' | yes S''∈canθ-q-θ' =
  canθₛₕ-subset-lemma sigs (suc S'') p q (θ ← [S]-env (S'' ₛ))
    canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ
... | no  S''∉canθ-p-θ' | no  S''∉canθ-q-θ' =
  canθₛₕ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ))
    canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ
... | yes S''∈canθ-p-θ' | no  S''∉canθ-q-θ' =
  ⊥-elim
    (S''∉canθ-q-θ'
      (canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env (S'' ₛ)) canₛ-p⊆canₛ-q
        S'' S''∈canθ-p-θ'))
... | no  S''∉canθ-p-θ' | yes S''∈canθ-q-θ' =
  canθₛₕ-add-sig-monotonic sigs (suc S'') q θ (S'' ₛ) Signal.absent s
    (canθₛₕ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ))
      canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ)

canθₛₕ-subset : ∀ sigs S'' p q θ →
  (∀ θ' S →
     Signal.unwrap S ∈ Canₛ p θ' →
     Signal.unwrap S ∈ Canₛ q θ') →
  (∀ θ' s →
     SharedVar.unwrap s ∈ Canₛₕ p θ' →
     SharedVar.unwrap s ∈ Canₛₕ q θ') →
  ∀ s →
    SharedVar.unwrap s ∈ Canθₛₕ sigs S'' p θ →
    SharedVar.unwrap s ∈ Canθₛₕ sigs S'' q θ
canθₛₕ-subset sigs S'' p q θ canₛ-p⊆canₛ-q canₛₕ-p⊆canₛₕ-q s s∈canθ-p-θ =
  canθₛₕ-subset-lemma sigs S'' p q θ
    (λ θ' S → canₛ-p⊆canₛ-q θ' (S ₛ)) (λ θ' s → canₛₕ-p⊆canₛₕ-q θ' (s ₛₕ))
    (SharedVar.unwrap s) s∈canθ-p-θ

canθₖ-subset-lemma : ∀ sigs S'' p q θ →
  (∀ θ' S → S ∈ Canₛ p θ' → S ∈ Canₛ q θ') →
  (∀ θ' k → k ∈ Canₖ p θ' → k ∈ Canₖ q θ') →
  ∀ k → k ∈ Canθₖ sigs S'' p θ → k ∈ Canθₖ sigs S'' q θ
canθₖ-subset-lemma [] S'' p q θ
  canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ =
  canₖ-p⊆canₖ-q θ k k∈canθ-p-θ
canθₖ-subset-lemma (nothing ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ =
  canθₖ-subset-lemma sigs (suc S'') p q θ
    canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ
canθₖ-subset-lemma (just Signal.present ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ =
  canθₖ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-present (S'' ₛ))
    canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ
canθₖ-subset-lemma (just Signal.absent ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ =
  canθₖ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ))
    canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ
canθₖ-subset-lemma (just Signal.unknown ∷ sigs) S'' p q θ
  canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') q (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ' | yes S''∈canθ-q-θ' =
  canθₖ-subset-lemma sigs (suc S'') p q (θ ← [S]-env (S'' ₛ))
    canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ
... | no  S''∉canθ-p-θ' | no  S''∉canθ-q-θ' =
  canθₖ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ))
    canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ
... | yes S''∈canθ-p-θ' | no  S''∉canθ-q-θ' =
  ⊥-elim
    (S''∉canθ-q-θ'
      (canθₛ-subset-lemma sigs (suc S'') p q (θ ← [S]-env (S'' ₛ)) canₛ-p⊆canₛ-q
        S'' S''∈canθ-p-θ'))
... | no  S''∉canθ-p-θ' | yes S''∈canθ-q-θ' =
  canθₖ-add-sig-monotonic sigs (suc S'') q θ (S'' ₛ) Signal.absent k
    (canθₖ-subset-lemma sigs (suc S'') p q (θ ← [S]-env-absent (S'' ₛ))
      canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ)

canθₖ-subset : ∀ sigs S'' p q θ →
  (∀ θ' S →
     Signal.unwrap S ∈ Canₛ p θ' →
     Signal.unwrap S ∈ Canₛ q θ') →
  (∀ θ' k →
     k ∈ Canₖ p θ' →
     k ∈ Canₖ q θ') →
  ∀ k →
    k ∈ Canθₖ sigs S'' p θ →
    k ∈ Canθₖ sigs S'' q θ
canθₖ-subset sigs S'' p q θ canₛ-p⊆canₛ-q canₖ-p⊆canₖ-q k k∈canθ-p-θ =
  canθₖ-subset-lemma sigs S'' p q θ
    (λ θ' S → canₛ-p⊆canₛ-q θ' (S ₛ)) canₖ-p⊆canₖ-q
    k k∈canθ-p-θ

canθₛ-E₁⟦p⟧⊆canθₛ-p : ∀ {pin E₁ E₁⟦nothin⟧ BV FV} sigs S'' θ →
  -- distinct (Dom sigs) (FV (E₁ ⟦ nothin ⟧))
  E₁⟦nothin⟧ ≐ (E₁ ∷ []) ⟦ nothin ⟧e →
  CorrectBinding E₁⟦nothin⟧ BV FV →

  distinct' (map (_+_ S'') (SigMap.keys sigs)) (proj₁ FV) →
  ∀ S' →
    Signal.unwrap S' ∉ proj₁ FV →
    Signal.unwrap S' ∈ Canθₛ sigs S'' ((E₁ ∷ []) ⟦ pin ⟧e) θ →
    Signal.unwrap S' ∈ Canθₛ sigs S'' pin θ
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} [] S'' θ (depar₁ pin≐E₁⟦nothin⟧) cb@(CBpar {FVp = FVp} cbp cbq _ _ _ _)
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  with ++⁻ (Canₛ pin θ) S'∈canθ-E₁⟦pin⟧-θ
... | inj₁ S'∈can-pin-θ = S'∈can-pin-θ
... | inj₂ S'∈can-q-θ = ⊥-elim (S'∉FV (++ʳ (proj₁ FVp) (canₛ-⊆-FV θ cbq S' S'∈can-q-θ)))
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} {epar₂ p} [] S'' θ (depar₂ pin≐E₁⟦nothin⟧) cb@(CBpar cbp cbq _ _ _ _)
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  with ++⁻ (Canₛ p θ) S'∈canθ-E₁⟦pin⟧-θ
... | inj₂ S'∈can-pin-θ = S'∈can-pin-θ
... | inj₁ S'∈can-p-θ = ⊥-elim (S'∉FV (++ˡ (canₛ-⊆-FV θ cbp S' S'∈can-p-θ)))
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} [] S'' θ (deloopˢ pin≐E₁⟦nothin⟧) cb@(CBloopˢ {FVp = FVp} cbp cbq _ _) = λ _ S' _ z → z
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} [] S'' θ (deseq pin≐E₁⟦nothin⟧) cb@(CBseq {FVp = FVp} cbp cbq _)
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  with any (Code._≟_ Code.nothin) (Canₖ pin θ)
... | no  nothin∉can-pin = S'∈canθ-E₁⟦pin⟧-θ
... | yes nothin∈can-pin with ++⁻ (Canₛ pin θ) S'∈canθ-E₁⟦pin⟧-θ
... | inj₁ S∈can-pin-θ = S∈can-pin-θ
... | inj₂ S∈can-q-θ = ⊥-elim (S'∉FV (++ʳ (proj₁ FVp) (canₛ-⊆-FV θ cbq S' S∈can-q-θ)))
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} [] S'' θ (desuspend pin≐E₁⟦nothin⟧) cb@(CBsusp cb' _)
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ = S'∈canθ-E₁⟦pin⟧-θ
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} [] S'' θ (detrap pin≐E₁⟦nothin⟧) cb@(CBtrap cb')
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ = S'∈canθ-E₁⟦pin⟧-θ
canθₛ-E₁⟦p⟧⊆canθₛ-p (nothing ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') θ pin≐E₁⟦nothin⟧ cb
      map-S''-+-sigs≠FV
      S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
canθₛ-E₁⟦p⟧⊆canθₛ-p (just Signal.present ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env-present (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
      S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
canθₛ-E₁⟦p⟧⊆canθₛ-p (just Signal.absent ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)) )
      S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
canθₛ-E₁⟦p⟧⊆canθₛ-p {pin} {E₁} (just Signal.unknown ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') pin (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') ((E₁ ∷ []) ⟦ pin ⟧e) (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ←[S] | yes S''∈canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
      S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
... | no  S''∉canθ-p-θ←[S] | no  S''∉canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
      S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ
... | yes S''∈canθ-p-θ←[S] | no  S''∉canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-add-sig-monotonic sigs (suc S'') pin θ (S'' ₛ) Signal.absent (Signal.unwrap S')
      (canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
        (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
        S' S'∉FV S'∈canθ-E₁⟦pin⟧-θ)
... | no  S''∉canθ-p-θ←[S] | yes S''∈canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = ⊥-elim
      (S''∉canθ-p-θ←[S]
        (canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
          (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
          (S'' ₛ) (map-S''-+-sigs≠FV S'' (here refl)) S''∈canθ-E₁⟦p⟧-θ←[S]))

canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p : ∀ {pin E₁ E₁⟦nothin⟧ BV FV} sigs S'' θ →
  -- distinct (Dom sigs) (FV (E₁ ⟦ nothin ⟧))
  E₁⟦nothin⟧ ≐ (E₁ ∷ []) ⟦ nothin ⟧e →
  CorrectBinding E₁⟦nothin⟧ BV FV →

  distinct' (map (_+_ S'') (SigMap.keys sigs)) (proj₁ FV) →
  ∀ s →
    SharedVar.unwrap s ∉ proj₁ (proj₂ FV) →
    SharedVar.unwrap s ∈ Canθₛₕ sigs S'' ((E₁ ∷ []) ⟦ pin ⟧e) θ →
    SharedVar.unwrap s ∈ Canθₛₕ sigs S'' pin θ
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} [] S'' θ (depar₁ pin≐E₁⟦nothin⟧) cb@(CBpar {FVp = FVp} cbp cbq _ _ _ _)
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  with ++⁻ (Canₛₕ pin θ) s∈canθ-E₁⟦pin⟧-θ
... | inj₁ s∈can-pin-θ = s∈can-pin-θ
... | inj₂ s∈can-q-θ = ⊥-elim (s∉FV (++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV θ cbq s s∈can-q-θ)))
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} {epar₂ p} [] S'' θ (depar₂ pin≐E₁⟦nothin⟧) cb@(CBpar cbp cbq _ _ _ _)
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  with ++⁻ (Canₛₕ p θ) s∈canθ-E₁⟦pin⟧-θ
... | inj₂ s∈can-pin-θ = s∈can-pin-θ
... | inj₁ s∈can-p-θ = ⊥-elim (s∉FV (++ˡ (canₛₕ-⊆-FV θ cbp s s∈can-p-θ)))
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} [] S'' θ (deloopˢ pin≐E₁⟦nothin⟧) cb@(CBloopˢ {FVp = FVp} cbp cbq _ _) = λ _ s _ z → z
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} [] S'' θ (deseq pin≐E₁⟦nothin⟧) cb@(CBseq {FVp = FVp} cbp cbq _)
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  with any (Code._≟_ Code.nothin) (Canₖ pin θ)
... | no  nothin∉can-pin = s∈canθ-E₁⟦pin⟧-θ
... | yes nothin∈can-pin with ++⁻ (Canₛₕ pin θ) s∈canθ-E₁⟦pin⟧-θ
... | inj₁ s∈can-pin-θ = s∈can-pin-θ
... | inj₂ s∈can-q-θ = ⊥-elim (s∉FV (++ʳ (proj₁ (proj₂ FVp)) (canₛₕ-⊆-FV θ cbq s s∈can-q-θ)))
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} [] S'' θ (desuspend pin≐E₁⟦nothin⟧) cb@(CBsusp cb' _)
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ = s∈canθ-E₁⟦pin⟧-θ
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} [] S'' θ (detrap pin≐E₁⟦nothin⟧) cb@(CBtrap cb')
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ = s∈canθ-E₁⟦pin⟧-θ
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p (nothing ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p sigs (suc S'') θ pin≐E₁⟦nothin⟧ cb
      map-S''-+-sigs≠FV
      s s∉FV s∈canθ-E₁⟦pin⟧-θ
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p (just Signal.present ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p sigs (suc S'') (θ ← [S]-env-present (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
      s s∉FV s∈canθ-E₁⟦pin⟧-θ
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p (just Signal.absent ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)) )
      s s∉FV s∈canθ-E₁⟦pin⟧-θ
canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p {pin} {E₁} (just Signal.unknown ∷ sigs) S'' θ pin≐E₁⟦nothin⟧ cb
  map-S''-+-sigs≠FV s s∉FV s∈canθ-E₁⟦pin⟧-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') pin (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') ((E₁ ∷ []) ⟦ pin ⟧e) (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-p-θ←[S] | yes S''∈canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p sigs (suc S'') (θ ← [S]-env (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
      s s∉FV s∈canθ-E₁⟦pin⟧-θ
... | no  S''∉canθ-p-θ←[S] | no  S''∉canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
      (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
      s s∉FV s∈canθ-E₁⟦pin⟧-θ
... | yes S''∈canθ-p-θ←[S] | no  S''∉canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-add-sig-monotonic sigs (suc S'') pin θ (S'' ₛ) Signal.absent (SharedVar.unwrap s)
      (canθₛₕ-E₁⟦p⟧⊆canθₛₕ-p sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
        (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
        s s∉FV s∈canθ-E₁⟦pin⟧-θ)
... | no  S''∉canθ-p-θ←[S] | yes S''∈canθ-E₁⟦p⟧-θ←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = ⊥-elim
      (S''∉canθ-p-θ←[S]
        (canθₛ-E₁⟦p⟧⊆canθₛ-p sigs (suc S'') (θ ← [S]-env (S'' ₛ)) pin≐E₁⟦nothin⟧ cb
          (distinct'-sym (dist':: (distinct'-sym map-S''-+-sigs≠FV)))
          (S'' ₛ) (map-S''-+-sigs≠FV S'' (here refl)) S''∈canθ-E₁⟦p⟧-θ←[S]))

canθₛ-p⊆canθₛ-E₁⟦p⟧ : ∀ sigs S'' θ E₁ pin →
  ∀ S' →
    Signal.unwrap S' ∈ Canθₛ sigs S'' pin θ →
    Signal.unwrap S' ∈ Canθₛ sigs S'' ((E₁ ∷ []) ⟦ pin ⟧e) θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ [] S'' θ (epar₁ q) pin S' S'∈canθ-sigs-pin-θ =
  ++ˡ S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ [] S'' θ (epar₂ p) pin S' S'∈canθ-sigs-pin-θ =
  ++ʳ (Canₛ p θ) S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ [] S'' θ (eloopˢ q) pin S' S'∈canθ-sigs-pin-θ = S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ [] S'' θ (eseq q) pin S' S'∈canθ-sigs-pin-θ
  with any (Code._≟_ Code.nothin) (Canₖ pin θ)
... | yes nothin∈can-pin = ++ˡ S'∈canθ-sigs-pin-θ
... | no  nothin∉can-pin = S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ [] S'' θ (esuspend S) pin S' S'∈canθ-sigs-pin-θ =
  S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ [] S'' θ etrap pin S' S'∈canθ-sigs-pin-θ =
  S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ (nothing ∷ sigs) S'' θ E₁ pin S' S'∈canθ-sigs-pin-θ =
  canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') θ E₁ pin S' S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ (just Signal.present ∷ sigs) S'' θ E₁ pin S' S'∈canθ-sigs-pin-θ =
  canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-present (S'' ₛ)) E₁ pin
    S' S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ (just Signal.absent ∷ sigs) S'' θ E₁ pin S' S'∈canθ-sigs-pin-θ =
  canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) E₁ pin
    S' S'∈canθ-sigs-pin-θ
canθₛ-p⊆canθₛ-E₁⟦p⟧ (just Signal.unknown ∷ sigs) S'' θ E₁ pin S' S'∈canθ-sigs-pin-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') ((E₁ ∷ []) ⟦ pin ⟧e) (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') pin (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-sigs-E₁⟦pin⟧-θ | yes S''∈canθ-sigs-pin-θ =
  canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env (S'' ₛ)) E₁ pin
    S' S'∈canθ-sigs-pin-θ
... | no  S''∉canθ-sigs-E₁⟦pin⟧   | no  S''∉canθ-sigs-pin-θ =
  canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) E₁ pin
    S' S'∈canθ-sigs-pin-θ
... | yes S''∈canθ-sigs-E₁⟦pin⟧   | no  S''∉canθ-sigs-pin-θ =
  canθₛ-add-sig-monotonic sigs (suc S'') ((E₁ ∷ []) ⟦ pin ⟧e)
    θ (S'' ₛ) Signal.absent (Signal.unwrap S')
    (canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) E₁ pin
      S' S'∈canθ-sigs-pin-θ)
... | no  S''∉canθ-sigs-E₁⟦pin⟧   | yes S''∈canθ-sigs-pin-θ =
  ⊥-elim
    (S''∉canθ-sigs-E₁⟦pin⟧
      (canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env (S'' ₛ)) E₁ pin
        (S'' ₛ) S''∈canθ-sigs-pin-θ))

canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ : ∀ sigs S'' θ E₁ pin →
  ∀ s →
    SharedVar.unwrap s ∈ Canθₛ sigs S'' pin θ →
    SharedVar.unwrap s ∈ Canθₛ sigs S'' ((E₁ ∷ []) ⟦ pin ⟧e) θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ [] S'' θ (epar₁ q) pin s s∈canθ-sigs-pin-θ =
  ++ˡ s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ [] S'' θ (epar₂ p) pin s s∈canθ-sigs-pin-θ =
  ++ʳ (Canₛ p θ) s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ [] S'' θ (eloopˢ q) pin s s∈canθ-sigs-pin-θ = s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ [] S'' θ (eseq q) pin s s∈canθ-sigs-pin-θ
  with any (Code._≟_ Code.nothin) (Canₖ pin θ)
... | yes nothin∈can-pin = ++ˡ s∈canθ-sigs-pin-θ
... | no  nothin∉can-pin = s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ [] S'' θ (esuspend S) pin s s∈canθ-sigs-pin-θ =
  s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ [] S'' θ etrap pin s s∈canθ-sigs-pin-θ =
  s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ (nothing ∷ sigs) S'' θ E₁ pin s s∈canθ-sigs-pin-θ =
  canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ sigs (suc S'') θ E₁ pin s s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ (just Signal.present ∷ sigs) S'' θ E₁ pin s s∈canθ-sigs-pin-θ =
  canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-present (S'' ₛ)) E₁ pin
    s s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ (just Signal.absent ∷ sigs) S'' θ E₁ pin s s∈canθ-sigs-pin-θ =
  canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) E₁ pin
    s s∈canθ-sigs-pin-θ
canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ (just Signal.unknown ∷ sigs) S'' θ E₁ pin s s∈canθ-sigs-pin-θ
  with any (_≟_ S'') (Canθₛ sigs (suc S'') ((E₁ ∷ []) ⟦ pin ⟧e) (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') pin (θ ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-sigs-E₁⟦pin⟧-θ | yes S''∈canθ-sigs-pin-θ =
  canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env (S'' ₛ)) E₁ pin
    s s∈canθ-sigs-pin-θ
... | no  S''∉canθ-sigs-E₁⟦pin⟧   | no  S''∉canθ-sigs-pin-θ =
  canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) E₁ pin
    s s∈canθ-sigs-pin-θ
... | yes S''∈canθ-sigs-E₁⟦pin⟧   | no  S''∉canθ-sigs-pin-θ =
  canθₛ-add-sig-monotonic sigs (suc S'') ((E₁ ∷ []) ⟦ pin ⟧e)
    θ (S'' ₛ) Signal.absent (SharedVar.unwrap s)
    (canθₛₕ-p⊆canθₛₕ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env-absent (S'' ₛ)) E₁ pin
      s s∈canθ-sigs-pin-θ)
... | no  S''∉canθ-sigs-E₁⟦pin⟧   | yes S''∈canθ-sigs-pin-θ =
  ⊥-elim
    (S''∉canθ-sigs-E₁⟦pin⟧
      (canθₛ-p⊆canθₛ-E₁⟦p⟧ sigs (suc S'') (θ ← [S]-env (S'' ₛ)) E₁ pin
        (S'' ₛ) S''∈canθ-sigs-pin-θ))

canθ-shadowing-irr' : ∀ sigs' S'' p S status θ θo →
  S ∈ map (_+_ S'') (SigMap.keys sigs') →
    Canθ sigs' S'' p ((θ ← [ (S ₛ) ↦ status ]) ← θo) ≡
    Canθ sigs' S'' p (θ ← θo)
canθ-shadowing-irr' [] S'' p S status θ θo ()
canθ-shadowing-irr' (nothing ∷ sigs') S'' p S status θ θo S∈map-+-S''-sigs'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
  = canθ-shadowing-irr' sigs' (suc S'') p S status θ θo S∈map-+-S''-sigs'
canθ-shadowing-irr' (just Signal.present ∷ sigs') S'' p S status θ θo (here refl)
  rewrite +-comm S'' 0
        | Env.sig-set-inner-clobber θ θo ([S]-env-present (S'' ₛ)) (S'' ₛ) status (Env.sig-∈-single (S'' ₛ) Signal.present)
  = refl
canθ-shadowing-irr' (just Signal.absent ∷ sigs') S'' p S status θ θo (here refl)
  rewrite +-comm S'' 0
        | Env.sig-set-inner-clobber θ θo ([S]-env-absent (S'' ₛ)) (S'' ₛ) status (Env.sig-∈-single (S'' ₛ) Signal.absent)
  = refl
canθ-shadowing-irr' (just Signal.unknown ∷ sigs') S'' p S status θ θo (here refl)
  with any (_≟_ S'') (Canθₛ sigs' (suc S'') p (((θ ← [ (S ₛ) ↦ status ]) ← θo) ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs' (suc S'') p ((θ ← θo) ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-sigs-θ←[S]-absent←θo←[S''] | yes S''∈canθ-sigs-θ←[S]←θo←[S'']
  rewrite +-comm S'' 0
        | Env.sig-set-inner-clobber θ θo ([S]-env (S'' ₛ)) (S'' ₛ) status (Env.sig-∈-single (S'' ₛ) Signal.unknown)
  = refl
... | no  S''∉canθ-sigs-θ←[S]-absent←θo←[S''] | no  S''∉canθ-sigs-θ←[S]←θo←[S'']
  rewrite +-comm S'' 0
        | Env.sig-set-inner-clobber θ θo ([S]-env-absent (S'' ₛ)) (S'' ₛ) status (Env.sig-∈-single (S'' ₛ) Signal.absent)
  = refl
... | yes S''∈canθ-sigs-θ←[S]-absent←θo←[S''] | no  S''∉canθ-sigs-θ←[S]←θo←[S'']
  rewrite +-comm S'' 0
        | Env.sig-set-inner-clobber θ θo ([S]-env (S'' ₛ)) (S'' ₛ) status (Env.sig-∈-single (S'' ₛ) Signal.unknown)
  = ⊥-elim (S''∉canθ-sigs-θ←[S]←θo←[S''] S''∈canθ-sigs-θ←[S]-absent←θo←[S''])
... | no  S''∉canθ-sigs-θ←[S]-absent←θo←[S''] | yes S''∈canθ-sigs-θ←[S]←θo←[S'']
  rewrite +-comm S'' 0
        | Env.sig-set-inner-clobber θ θo ([S]-env (S'' ₛ)) (S'' ₛ) status (Env.sig-∈-single (S'' ₛ) Signal.unknown)
  = ⊥-elim (S''∉canθ-sigs-θ←[S]-absent←θo←[S''] S''∈canθ-sigs-θ←[S]←θo←[S''])
canθ-shadowing-irr' (just Signal.present ∷ sigs') S'' p S status θ θo (there S∈map-+-S''-sigs')
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
        | sym (Env.←-assoc (θ ← [ (S ₛ) ↦ status ]) θo ([S]-env-present (S'' ₛ)))
        | sym (Env.←-assoc θ θo ([S]-env-present (S'' ₛ)))
  = canθ-shadowing-irr' sigs' (suc S'') p S status θ (θo ← [S]-env-present (S'' ₛ)) S∈map-+-S''-sigs'
canθ-shadowing-irr' (just Signal.absent ∷ sigs') S'' p S status θ θo (there S∈map-+-S''-sigs')
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
        | sym (Env.←-assoc (θ ← [ (S ₛ) ↦ status ]) θo ([S]-env-absent (S'' ₛ)))
        | sym (Env.←-assoc θ θo ([S]-env-absent (S'' ₛ)))
  = canθ-shadowing-irr' sigs' (suc S'') p S status θ (θo ← [S]-env-absent (S'' ₛ)) S∈map-+-S''-sigs'
canθ-shadowing-irr' (just Signal.unknown ∷ sigs') S'' p S status θ θo (there S∈map-+-S''-sigs')
  with any (_≟_ S'') (Canθₛ sigs' (suc S'') p (((θ ← [ (S ₛ) ↦ status ]) ← θo) ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs' (suc S'') p ((θ ← θo) ← [S]-env (S'' ₛ)))
... | yes S''∈canθ-sigs-θ←[S]-absent←θo←[S''] | yes S''∈canθ-sigs-θ←[S]←θo←[S'']
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
        | sym (Env.←-assoc (θ ← [ (S ₛ) ↦ status ]) θo ([S]-env (S'' ₛ)))
        | sym (Env.←-assoc θ θo ([S]-env (S'' ₛ)))
  = canθ-shadowing-irr' sigs' (suc S'') p S status θ (θo ← [S]-env (S'' ₛ)) S∈map-+-S''-sigs'
... | no  S''∉canθ-sigs-θ←[S]-absent←θo←[S''] | no  S''∉canθ-sigs-θ←[S]←θo←[S'']
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
        | sym (Env.←-assoc (θ ← [ (S ₛ) ↦ status ]) θo ([S]-env-absent (S'' ₛ)))
        | sym (Env.←-assoc θ θo ([S]-env-absent (S'' ₛ)))
  = canθ-shadowing-irr' sigs' (suc S'') p S status θ (θo ← [S]-env-absent (S'' ₛ)) S∈map-+-S''-sigs'
... | yes S''∈canθ-sigs-θ←[S]-absent←θo←[S''] | no  S''∉canθ-sigs-θ←[S]←θo←[S'']
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
        | sym (Env.←-assoc (θ ← [ (S ₛ) ↦ status ]) θo ([S]-env (S'' ₛ)))
        | sym (Env.←-assoc θ θo ([S]-env (S'' ₛ)))
        | canθ-shadowing-irr' sigs' (suc S'') p S status θ (θo ← [S]-env (S'' ₛ)) S∈map-+-S''-sigs'
  = ⊥-elim (S''∉canθ-sigs-θ←[S]←θo←[S''] S''∈canθ-sigs-θ←[S]-absent←θo←[S''])
... | no  S''∉canθ-sigs-θ←[S]-absent←θo←[S''] | yes S''∈canθ-sigs-θ←[S]←θo←[S'']
  rewrite map-+-compose-suc S'' (SigMap.keys sigs')
        | sym (Env.←-assoc (θ ← [ (S ₛ) ↦ status ]) θo ([S]-env (S'' ₛ)))
        | sym (Env.←-assoc θ θo ([S]-env (S'' ₛ)))
        | canθ-shadowing-irr' sigs' (suc S'') p S status θ (θo ← [S]-env (S'' ₛ)) S∈map-+-S''-sigs'
  = ⊥-elim (S''∉canθ-sigs-θ←[S]-absent←θo←[S''] S''∈canθ-sigs-θ←[S]←θo←[S''])

canθ-shadowing-irr : ∀ sigs' S'' p S status θ →
  Signal.unwrap S ∈ map (_+_ S'') (SigMap.keys sigs') →
    Canθ sigs' S'' p θ ≡
    Canθ sigs' S'' p (θ ← [ S ↦ status ])
canθ-shadowing-irr sigs' S'' p S status θ S∈map-+-S''-sigs'
  rewrite Env.←-comm Env.[]env (θ ← [ S ↦ status ]) distinct-empty-left
        | cong (Canθ sigs' S'' p) (Env.←-comm Env.[]env θ distinct-empty-left)
  = sym (canθ-shadowing-irr' sigs' S'' p (Signal.unwrap S) status
          θ Env.[]env S∈map-+-S''-sigs')

Canθₛunknown->Canₛunknown-help : ∀ S S' p →
  (S + S') ∈ Canθₛ SigMap.[ (S ₛ) ↦ Signal.unknown ] S' p Env.[]env →
  (S + S') ∈ Canₛ p [ ((S + S') ₛ) ↦ Signal.unknown ]
Canθₛunknown->Canₛunknown-help zero    S' p S+S'∈canθ-[S↦unknown]-S'
  with any (S' ≟_) (Canₛ p [ (S' ₛ) ↦ Signal.unknown ])
... | yes S'∈can-p-[S↦unknown] = S+S'∈canθ-[S↦unknown]-S'
... | no  S'∉can-p-[S↦unknown] =
  Data.Empty.⊥-elim
    (S'∉can-p-[S↦unknown]
      (Esterel.Lang.CanFunction.SetSigMonotonic.canθₛ-add-sig-monotonic
       [] 0 p Env.[]env (S' ₛ) Signal.absent S'
       S+S'∈canθ-[S↦unknown]-S'))
Canθₛunknown->Canₛunknown-help (suc S) S' p S+S'∈canθ-[S↦unknown]-S'
  -- trans (cong suc (+-comm S S')) (+-comm (suc S') S) : suc (S + S') ≡ S + (suc S')
  rewrite cong (λ n → Canₛ p [ (n ₛ) ↦ Signal.unknown ])
               (trans (cong suc (+-comm S S')) (+-comm (suc S') S))
        |       trans (cong suc (+-comm S S')) (+-comm (suc S') S)
  = Canθₛunknown->Canₛunknown-help S (suc S') p S+S'∈canθ-[S↦unknown]-S'

Canθₛunknown->Canₛunknown : ∀ S p ->
  (Signal.unwrap S) ∈ Canθₛ SigMap.[ S ↦ Signal.unknown ] 0 p Env.[]env →
  (Signal.unwrap S) ∈ Canₛ p [ S ↦ Signal.unknown ]
Canθₛunknown->Canₛunknown S p fact
  rewrite +-right-identity (Signal.unwrap S)
  with Canθₛunknown->Canₛunknown-help
          (Signal.unwrap S) zero p (add-zero (Signal.unwrap S) _ fact)
    where
    add-zero : ∀ s x -> s ∈ x -> (s + 0) ∈ x
    add-zero s x s+0∈x rewrite +-right-identity s = s+0∈x
... | thing rewrite +-right-identity (Signal.unwrap S) = thing


module MJ.Examples.DynDispatch where

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

open import MJ.Types

open import MJ.Classtable.Core 2

{-

  // We test field inheritance and
  // method call dispatching combining super calls and dynamic dispatch.
  // The Agda test is equivalent to the following Java code

  class Int {

      int x;

      public Int(int i) {
          this.x = i;
          return;
      }

      public int get() {
          System.out.println("never");
          return x;
      }

      public int set (Int y) {
          x = y.x;

          // in the test main this should dispatch to
          // the implementation of the child Int2
          return this.get();
      }
  }

  class Int2 extends Int {

      public Int2(int i) {
          super(i);
      }

      public int get() {
          return x + 1;
      }

      public int set (Int y) {
          // test super dispatch
          return super.set(new Int(y.x + 1));
      }
  }

  class Main {
      public static void main(String[] args) {
          Int y = new Int(18);
          Int2 x = new Int2(0);

          // should print 20
          // because we use the set(..) and get() of Int2
          // which both increment with one
          System.out.println(x.set(y));
      }
  }

-}

INT : Cid 2
INT = (cls (# 0))

INT+ : Cid 2
INT+ = (cls (# 1))

decls : (ns : NS) → List (String × typing ns)
decls METHOD =
    ("get" , ([] , int))
  ∷ ("set" , (ref INT ∷ [] , int))
  ∷ []
decls FIELD =
    ("x" , int)
  ∷ []

-- override methods; no extra fields
decls+ : (ns : NS) → List (String × typing ns)
decls+ METHOD =
    ("get" , ([] , int))
  ∷ ("set" , (ref INT ∷ [] , int))
  ∷ []
decls+ FIELD = []

IntegerSig = (class Object (int ∷ []) decls)
Integer+Sig = (class INT (int ∷ []) decls+)

-- class table signature
Σ : Classtable
Σ = record {
  Σ = λ{
    (cls zero) → IntegerSig ;
    (cls (suc zero)) → Integer+Sig ;
    (cls (suc (suc ()))) ;
    Object → ObjectClass} ;
  founded = refl ;
  rooted = λ{
    (cls zero) → super ◅ ε ;
    (cls (suc zero)) → super ◅ super ◅ ε ;
    (cls (suc (suc ()))) ;
    Object → ε };
  Σ-Object = refl }

open import MJ.Classtable.Code Σ
open import MJ.Syntax Σ
open import MJ.Syntax.Program Σ

-- Integer class body
IntegerImpl : Implementation INT
IntegerImpl = implementation
    (body (body
      (set
        (var (here refl))
        "x"
        (var (there (here refl))) ◅ ε)
      unit))

    -- methods
    (
      -- get
      body (body ε (get (var (here refl)) "x"))

      -- set
      ∷ (body (body
          (set
            (var (here refl))
            "x"
            {int}
            (get (var (there (here refl))) "x") ◅ ε)
          (call (var (here refl)) "get" [])))

      ∷ []
    )

-- Integer+ class body
Integer+Impl : Implementation INT+
Integer+Impl = implementation
    (body (body
      (
        set (var (here refl)) "x" (var (there (here refl)))
        ◅ ε)
      unit))

    -- methods
    (
      -- override get
      (body (body ε (iop (λ l r → l + r) (get (var (here refl)) "x") (num 1))))

      -- set
      ∷ (super _ ⟨ new INT (iop (λ l r → l + r) (get (var (there (here refl))) "x") (num 1) ∷ []) ∷ [] ⟩then
        body
          ε
          (var (here refl)))

      ∷ []
    )

-- Implementation of the class table
Lib : Code
Lib (cls zero) = IntegerImpl
Lib (cls (suc zero)) = Integer+Impl
Lib (cls (suc (suc ())))
Lib Object = implementation (body (body ε unit)) []

open import MJ.Semantics Σ Lib
open import MJ.Semantics.Values Σ

-- a simple program
p₀ : Prog int
p₀ = Lib ,
  let
    x = (here refl)
    y = (there (here refl))
  in body
    (
        loc (ref INT) -- y
      ◅ loc (ref INT+) -- x
      ◅ asgn x (new INT+ ((num 0) ∷ []))
      ◅ asgn y (new INT ((num 18) ∷ []))
      ◅ ε
    )
    (call (var x) "set" (var y ∷ []))

test0 : p₀ ⇓⟨ 100 ⟩ (λ {W} (v : Val W int) → v ≡ num 20)
test0 = refl


{-# OPTIONS --rewriting #-}
module Duality where

open import Data.Bool

open import Data.Nat hiding (compare)
open import Data.Nat.Properties
open import Data.Fin hiding (_+_)
open import Data.Product

open import Function

open import Relation.Binary.PropositionalEquality hiding (Extensionality)

open import Agda.Builtin.Equality.Rewrite

-- variables

variable
  n m : ℕ

open import Types.Direction

open import Auxiliary.Extensionality
open import Auxiliary.RewriteLemmas

----------------------------------------------------------------------
-- session types coinductively

import Types.COI as COI

----------------------------------------------------------------------
-- session type inductively with explicit rec

import Types.IND as IND

----------------------------------------------------------------------
-- provide an embedding of IND to COI

open COI
open IND hiding (_≈_ ; _≈'_ ; ≈-refl ; ≈'-refl ; ≈ᵗ-refl)

ind2coiT : IND.Type 0 → COI.Type
ind2coiS : IND.SType 0 → COI.SType
ind2coiG : IND.GType 0 → COI.STypeF COI.SType

ind2coiT TUnit = TUnit
ind2coiT TInt = TInt
ind2coiT (TPair it it₁) = TPair (ind2coiT it) (ind2coiT it₁)
ind2coiT (TChan st) = TChan (ind2coiS st)

ind2coiG (transmit d t ist) = transmit d (ind2coiT t) (ind2coiS ist)
ind2coiG (choice d m alt) = choice d m (ind2coiS ∘ alt)
ind2coiG end = end

SType.force (ind2coiS (gdd gst)) = ind2coiG gst
SType.force (ind2coiS (rec gst)) = ind2coiG (st-substG gst zero (rec gst))

----------------------------------------------------------------------

{-# TERMINATING #-}
subst-weakenS : (s : IND.SType (suc n)) (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s0 : IND.SType 0)
  → st-substS (weaken1'S (inject₁ j) s) (suc i) s0 ≡ weaken1'S j (st-substS s i s0)
subst-weakenG : (g : IND.GType (suc n)) (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s0 : IND.SType 0)
  → st-substG (weaken1'G (inject₁ j) g) (suc i) s0 ≡ weaken1'G j (st-substG g i s0)
subst-weakenT : (t : IND.Type (suc n)) (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s0 : IND.SType 0)
  → st-substT (weaken1'T (inject₁ j) t) (suc i) s0 ≡ weaken1'T j (st-substT t i s0)

subst-weakenS (gdd gst) i j le s0 = cong gdd (subst-weakenG gst i j le s0)
subst-weakenS (rec gst) i j le s0 = cong rec (subst-weakenG gst (suc i) (suc j) (s≤s le) s0)
subst-weakenS (var p x) zero zero le s0 = refl
subst-weakenS {suc n} (var p x) (suc i) zero le s0 = refl
subst-weakenS {suc n} (var p zero) (suc i) (suc j) le s0 = refl
subst-weakenS {suc n} (var p (suc x)) (suc i) (suc j) (s≤s le) s0 rewrite (weak-weakS j zero z≤n (st-substS (var p x) i s0))
  = cong (weaken1'S zero) (subst-weakenS (var p x) i j le s0)

subst-weakenG (transmit d t s) i j le s0 = cong₂ (transmit d) (subst-weakenT t i j le s0) (subst-weakenS s i j le s0)
subst-weakenG (choice d m alt) i j le s0 = cong (choice d m) (ext (λ m' → subst-weakenS (alt m') i j le s0 ))
subst-weakenG end i j le s0 = refl

subst-weakenT TUnit i j le s0 = refl
subst-weakenT TInt i j le s0 = refl
subst-weakenT (TPair t t₁) i j le s0 = cong₂ TPair (subst-weakenT t i j le s0) (subst-weakenT t₁ i j le s0)
subst-weakenT (TChan s) i j le s0 = cong TChan (subst-weakenS s i j le s0)

{-# TERMINATING #-}
subst-swap-dualT : ∀ {ist} → (t : IND.Type (suc n)) (i : Fin (suc n)) →
  st-substT t i ist ≡ st-substT (swap-polT i t) i (IND.dualS ist)
subst-swap-dualS : ∀ {ist} → (st : IND.SType (suc n)) (i : Fin (suc n)) →
  st-substS st i ist ≡ st-substS (swap-polS i st) i (IND.dualS ist)
subst-swap-dualG : ∀ {ist} → (gst : IND.GType (suc n)) (i : Fin (suc n)) →
  st-substG gst i ist ≡ st-substG (swap-polG i gst) i (IND.dualS ist)

subst-swap-dualT TUnit i = refl
subst-swap-dualT TInt i = refl
subst-swap-dualT (TPair ty ty₁) i = cong₂ TPair (subst-swap-dualT ty i) (subst-swap-dualT ty₁ i)
subst-swap-dualT (TChan x) i = cong TChan (subst-swap-dualS x i)

subst-swap-dualS (gdd gst) i = cong gdd (subst-swap-dualG gst i)
subst-swap-dualS (rec gst) i = cong rec (subst-swap-dualG gst (suc i))
subst-swap-dualS {n} {ist} (var p zero) zero = cong (weakenS n) (dual-if-dual p ist)
subst-swap-dualS {suc n} (var p zero) (suc i) = refl
subst-swap-dualS {suc n} (var p (suc x)) zero = refl
subst-swap-dualS {suc n}{ist} (var p (suc x)) (suc i)
  rewrite subst-weakenS (swap-polS i (var p x)) i zero z≤n (dualS ist)
  = cong (weaken1'S zero) (subst-swap-dualS ((var p x)) i)

subst-swap-dualG (transmit d t s) i = cong₂ (transmit d) (subst-swap-dualT t i) (subst-swap-dualS s i)
subst-swap-dualG (choice d m alt) i = cong (choice d m) (ext (λ x → subst-swap-dualS (alt x) i))
subst-swap-dualG end i = refl

----------------------------------------------------------------------

swap-i-weakenS : (i : Fin (suc n)) (s : IND.SType n) → swap-polS i (weaken1'S i s) ≡ weaken1'S i s
swap-i-weakenG : (i : Fin (suc n)) (g : IND.GType n) → swap-polG i (weaken1'G i g) ≡ weaken1'G i g
swap-i-weakenT : (i : Fin (suc n)) (t : IND.TType n) → swap-polT i (weaken1'T i t) ≡ weaken1'T i t

swap-i-weakenS i (gdd gst) = cong gdd (swap-i-weakenG i gst)
swap-i-weakenS i (rec gst) = cong rec (swap-i-weakenG (suc i) gst)
swap-i-weakenS zero (var p zero) = refl
swap-i-weakenS (suc i) (var p zero) = refl
swap-i-weakenS zero (var p (suc x)) = refl
swap-i-weakenS (suc i) (var p (suc x)) = cong weaken1S (swap-i-weakenS i (var p x))

swap-i-weakenG i (transmit d t s) = cong₂ (transmit d) (swap-i-weakenT i t) (swap-i-weakenS i s)
swap-i-weakenG i (choice d m alt) = cong (choice d m) (ext (swap-i-weakenS i ∘ alt))
swap-i-weakenG i end = refl

swap-i-weakenT i TUnit = refl
swap-i-weakenT i TInt = refl
swap-i-weakenT i (TPair t₁ t₂) = cong₂ TPair (swap-i-weakenT i t₁) (swap-i-weakenT i t₂)
swap-i-weakenT i (TChan x) = cong TChan (swap-i-weakenS i x)

{-# TERMINATING #-}
subst-swapG : (ist : IND.SType 0) (i : Fin (suc (suc n))) (j : Fin′ i) (g : GType (suc (suc n))) →
  st-substG (swap-polG (inject j) g) i ist ≡ swap-polG (inject! j) (st-substG g i ist)
subst-swapS : (ist : IND.SType 0) (i : Fin (suc (suc n))) (j : Fin′ i) (s : IND.SType (suc (suc n))) →
  st-substS (swap-polS (inject j) s) i ist ≡ swap-polS (inject! j) (st-substS s i ist)
subst-swapT : (ist : IND.SType 0) (i : Fin (suc (suc n))) (j : Fin′ i) (g : IND.Type (suc (suc n))) →
  st-substT (swap-polT (inject j) g) i ist ≡ swap-polT (inject! j) (st-substT g i ist)

subst-swapG ist i j (transmit d t s) = cong₂ (transmit d) (subst-swapT ist i j t) (subst-swapS ist i j s)
subst-swapG ist i j (choice d m alt) = cong (choice d m) (ext (λ x → subst-swapS ist i j (alt x)))
subst-swapG ist i j end = refl

subst-swapS ist i j (gdd gst) = cong gdd (subst-swapG ist i j gst)
subst-swapS ist i j (rec gst) = cong rec (subst-swapG ist (suc i) (suc j) gst)
subst-swapS{zero} ist zero () (var p zero)
subst-swapS {zero} ist (suc zero) zero (var p zero) = refl
subst-swapS {zero} ist (suc zero) zero (var p (suc x))
  rewrite swap-i-weakenS zero (st-substS (var p x) zero ist) = refl
subst-swapS{suc n} ist (suc i) zero (var p zero) = refl
subst-swapS{suc n} ist (suc i) (suc j) (var p zero) = refl
subst-swapS{suc n} ist zero () (var p (suc x))
subst-swapS{suc n} ist (suc i) zero (var p (suc x))
  rewrite swap-i-weakenS zero (st-substS (var p x) i ist) = refl
subst-swapS{suc n} ist (suc i) (suc j) (var p (suc x))
  rewrite subst-weakenS (swap-polS (inject j) (var p x)) i zero z≤n ist
  | swap-weakenS (inject! j) (st-substS (var p x) i ist)
  = cong weaken1S (subst-swapS ist i j (var p x))

subst-swapT ist i j TUnit = refl
subst-swapT ist i j TInt = refl
subst-swapT ist i j (TPair t t₁) = cong₂ TPair (subst-swapT ist i j t) (subst-swapT ist i j t₁)
subst-swapT ist i j (TChan x) = cong TChan (subst-swapS ist i j x)

----------------------------------------------------------------------

dual-recT' : (t : TType (suc n)) (i : Fin (suc n)) (ist : IND.SType 0)
  → st-substT (swap-polT i t) i (dualS ist) ≡ st-substT t i ist
dual-recG' : (g : GType (suc n)) (i : Fin (suc n)) (ist : IND.SType 0)
  → st-substG (swap-polG i g) i (dualS ist) ≡ st-substG g i ist
dual-recS' : (s : IND.SType (suc n)) (i : Fin (suc n)) (ist : IND.SType 0)
  → st-substS (swap-polS i s) i (dualS ist) ≡ st-substS s i ist

dual-recT' TUnit i ist = refl
dual-recT' TInt i ist = refl
dual-recT' (TPair t t₁) i ist = cong₂ TPair (dual-recT' t i ist) (dual-recT' t₁ i ist)
dual-recT' (TChan s) i ist = cong TChan (dual-recS' s i ist)

dual-recG' (transmit d t s) i ist = cong₂ (transmit d) (dual-recT' t i ist) (dual-recS' s i ist)
dual-recG' (choice d m alt) i ist = cong (choice d m) (ext (λ m' → dual-recS' (alt m') i ist))
dual-recG' end i ist = refl

dual-recS' (gdd gst) i ist = cong gdd (dual-recG' gst i ist)
dual-recS' (rec gst) i ist = cong rec (dual-recG' gst (suc i) ist)
dual-recS' (var p zero) zero ist rewrite (dual-if-dual p ist) = refl
dual-recS' (var p (suc x)) zero ist = trivial-subst-var p x (dualS ist) (ist)
dual-recS' (var p zero) (suc i) ist = trivial-subst-var' p i (dualS ist) (ist)
dual-recS' (var p (suc x)) (suc i) ist rewrite (subst-swap-dualS{ist = ist} (var p (suc x)) (suc i))
  = refl

----------------------------------------------------------------------

-- show that the dualS function is compatible with unfolding
-- that is
-- COI.dual ∘ ind2coi ≈ ind2coi ∘ IND.dual

{-# TERMINATING #-}
dual-lemmaS : (s : IND.SType (suc n)) (j : Fin (suc n)) (s0 : IND.SType 0)
  → st-substS (dualS s) j s0 ≡ dualS (st-substS s j s0)
dual-lemmaG : (g : IND.GType (suc n)) (j : Fin (suc n)) (s0 : IND.SType 0)
  → st-substG (dualG g) j s0 ≡ dualG (st-substG g j s0)

dual-lemmaS (gdd gst) j s0 = cong gdd (dual-lemmaG gst j s0)
dual-lemmaS (rec gst) j s0 rewrite (subst-swapG s0 (suc j) zero (dualG gst)) =
  let rst = dual-lemmaG gst (suc j) s0 in cong rec (cong (swap-polG zero) rst)
dual-lemmaS {n} (var POS zero) zero s0          = sym (dual-weakenS' n s0)
dual-lemmaS {n} (var NEG zero) zero s0 rewrite (sym (dual-weakenS' n s0)) | (sym (dual-invS (weakenS n s0))) = refl
dual-lemmaS {suc n} (var POS zero) (suc j) s0 = refl
dual-lemmaS {suc n} (var NEG zero) (suc j) s0 = refl
dual-lemmaS {suc n} (var POS (suc x)) zero s0 = refl
dual-lemmaS {suc n} (var NEG (suc x)) zero s0 = refl
dual-lemmaS {suc n} (var POS (suc x)) (suc j) s0 rewrite (dual-weakenS zero (st-substS (var POS x) j s0)) = cong (weaken1'S zero) (dual-lemmaS (var POS x) j s0)
dual-lemmaS {suc n} (var NEG (suc x)) (suc j) s0 rewrite (dual-weakenS zero (st-substS (var NEG x) j s0)) = cong (weaken1'S zero) (dual-lemmaS (var NEG x) j s0)

dual-lemmaG (transmit d t s) j s0 = cong₂ (transmit (dual-dir d)) refl (dual-lemmaS s j s0)
dual-lemmaG (choice d m alt) j s0 = cong (choice (dual-dir d) m) (ext (λ m' → dual-lemmaS (alt m') j s0))
dual-lemmaG end j s0 = refl

----------------------------------------------------------------------
-- main result
dual-compatibleS : (ist : IND.SType 0) →
  COI.dual (ind2coiS ist) ≈ ind2coiS (IND.dualS ist)
dual-compatibleG : (gst : IND.GType 0) →
  COI.dualF (ind2coiG gst) ≈' ind2coiG (IND.dualG gst)

Equiv.force (dual-compatibleS (gdd gst)) = dual-compatibleG gst
Equiv.force (dual-compatibleS (rec gst))
  rewrite (dual-recG' (dualG gst) zero (rec gst))
          | dual-lemmaG gst zero (rec gst) = dual-compatibleG (st-substG gst zero (rec gst))

dual-compatibleG (transmit d t s) = eq-transmit (dual-dir d) ≈ᵗ-refl (dual-compatibleS s)
dual-compatibleG (choice d m alt) = eq-choice (dual-dir d) (dual-compatibleS ∘ alt)
dual-compatibleG end = eq-end


open import Data.Bool.Base using (Bool)
------------------------------------------------------------------------
-- The Agda standard library
--
-- IO
------------------------------------------------------------------------

open import Coinduction
open import Data.Unit
open import Data.String
open import Data.Colist
open import Function
import IO.Primitive as Prim
open import Level

------------------------------------------------------------------------
-- The IO monad

-- One cannot write "infinitely large" computations with the
-- postulated IO monad in IO.Primitive without turning off the
-- termination checker (or going via the FFI, or perhaps abusing
-- something else). The following coinductive deep embedding is
-- introduced to avoid this problem. Possible non-termination is
-- isolated to the run function below.

infixl 1 _>>=_ _>>_

data IO {a} (A : Set a) : Set (suc a) where
  lift   : (m : Prim.IO A) → IO A
  return : (x : A) → IO A
  _>>=_  : {B : Set a} (m : ∞ (IO B)) (f : (x : B) → ∞ (IO A)) → IO A
  _>>_   : {B : Set a} (m₁ : ∞ (IO B)) (m₂ : ∞ (IO A)) → IO A

{-# NON_TERMINATING #-}

run : ∀ {a} {A : Set a} → IO A → Prim.IO A
run (lift m)   = m
run (return x) = Prim.return x
run (m  >>= f) = Prim._>>=_ (run (♭ m )) λ x → run (♭ (f x))
run (m₁ >> m₂) = Prim._>>=_ (run (♭ m₁)) λ _ → run (♭ m₂)

putStr∞ : Costring → IO ⊤
putStr∞ s =
  ♯ lift (Prim.putStr s) >>
  ♯ return _

putStr : String → IO ⊤
putStr s = putStr∞ (toCostring s)

putStrLn∞ : Costring → IO ⊤
putStrLn∞ s =
  ♯ lift (Prim.putStrLn s) >>
  ♯ return _

putStrLn : String → IO ⊤
putStrLn s = putStrLn∞ (toCostring s)

_∨_ : Bool → Bool → Bool
Bool.true ∨ _  = Bool.true
Bool.false ∨ b = b

_∧_ : Bool → Bool → Bool
Bool.false ∧ _ = Bool.false
Bool.true ∧ b  = b

if_then_else_ : {A : Set} → Bool → A → A → A
if Bool.true  then a else _ = a
if Bool.false then _ else b = b

----------------------------------------

_>>>_ : String → String → String
_>>>_ = primStringAppend

infixl 1 _>>>_

----------------------------------------

data Principle : Set where
  # : String → Principle

_=p=_ : Principle → Principle → Bool
(# a) =p= (# b) = a == b

----------------------------------------

data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A
infixr 5 _∷_

[[_]] : {A : Set} → A → List A
[[ x ]] = x ∷ []

any : {A : Set} → (A → Bool) → List A → Bool
any _ []       = Bool.false
any f (x ∷ xs) = (f x) ∨ (any f xs)

_∈∈_ : Principle → List Principle → Bool
x ∈∈ []       = Bool.false
x ∈∈ (y ∷ ys) with x =p= y
...             | Bool.true  = Bool.true
...             | Bool.false = x ∈∈ ys

_∋∋_ : List Principle → Principle → Bool
xs ∋∋ y = y ∈∈ xs

----------------------------------------

data Arrow : Set where
  ⇒_  : Principle → Arrow
  _⇒_ : Principle → Arrow → Arrow

_≡≡_ : Arrow → Arrow → Bool
(⇒ q) ≡≡ (⇒ s)     = q =p= s
(p ⇒ q) ≡≡ (r ⇒ s) = (p =p= r) ∧ (q ≡≡ s)
_ ≡≡ _             = Bool.false

_∈∈∈∈_ : Arrow → List Arrow → Bool
x ∈∈∈∈ []       = Bool.false
x ∈∈∈∈ (y ∷ ys) with x ≡≡ y
...              | Bool.true  = Bool.true
...              | Bool.false = x ∈∈∈∈ ys

closure : List Arrow → List Principle → List Principle
closure [] found               = found
closure ((⇒ n) ∷ rest) found   = n ∷ (closure rest (n ∷ found))
closure ((n ⇒ q) ∷ rest) found with (n ∈∈ found) ∨ (n ∈∈ (closure rest found))
...                               | Bool.true  = closure (q ∷ rest) found
...                               | Bool.false = closure rest found

_,_⊢_ : List Arrow → List Principle → Principle → Bool
cs , ps ⊢ q = q ∈∈ (closure cs ps)

_⊢_ : List Arrow → Arrow → Bool
cs ⊢ (⇒ q)   = q ∈∈ (closure cs [])
cs ⊢ (p ⇒ q) = ((⇒ p) ∷ cs) ⊢ q

----------------------------------------

data Separation : Set where
  model : List Principle → List Principle → Separation

modelsupports : Separation → List Arrow → Principle → Bool
modelsupports (model holds _) cs n = cs , holds ⊢ n

modeldenies : Separation → List Arrow → Principle → Bool
modeldenies (model _ fails) cs n = any (_∋∋_ (closure cs ([[ n ]]))) fails

_⟪!_⟫_ : List Arrow → Separation → Arrow → Bool
cs ⟪! m ⟫ (⇒ q) = modeldenies m cs q
cs ⟪! m ⟫ (p ⇒ q) = (modelsupports m cs p) ∧ (cs ⟪! m ⟫ q)

_⟪_⟫_ : List Arrow → List Separation → Arrow → Bool
cs ⟪ [] ⟫ arr     = Bool.false
cs ⟪ m ∷ ms ⟫ arr = (cs ⟪! m ⟫ arr) ∨ (cs ⟪ ms ⟫ arr)

----------------------------------------

data Relation : Set where
  Proved    : Relation
  Derivable : Relation
  Separated : Relation
  Unknown   : Relation

consider : List Arrow → List Separation → Arrow → Relation
consider cs ms arr with (arr ∈∈∈∈ cs)
...                   | Bool.true  = Proved
...                   | Bool.false with (cs ⊢ arr)
...                              | Bool.true  = Derivable
...                              | Bool.false with (cs ⟪ ms ⟫ arr)
...                                         | Bool.true  = Separated
...                                         | Bool.false = Unknown

proofs : List Arrow
proofs =
   ((# "3") ⇒ (⇒ (# "4"))) ∷
--   ((# "5") ⇒ (⇒ (# "4"))) ∷
   ((# "6") ⇒ (⇒ (# "4"))) ∷
   ((# "3") ⇒ (⇒ (# "3"))) ∷
   ((# "3") ⇒ (⇒ (# "3"))) ∷
   ((# "9") ⇒ (⇒ (# "3"))) ∷
   ((# "9") ⇒ (⇒ (# "3"))) ∷
   ((# "5") ⇒ (⇒ (# "7"))) ∷
   ((# "9") ⇒ (⇒ (# "7"))) ∷
   ((# "6") ⇒ (⇒ (# "8"))) ∷
   ((# "10") ⇒ (⇒ (# "8"))) ∷
   ((# "10") ⇒ (⇒ (# "7"))) ∷
   ((# "5") ⇒ (⇒ (# "10"))) ∷
   ((# "10") ⇒ (⇒ (# "4"))) ∷
   ((# "5") ⇒ (⇒ (# "11"))) ∷
   ((# "6") ⇒ (⇒ (# "11"))) ∷
   ((# "11") ⇒ (⇒ (# "4"))) ∷
   ((# "10") ⇒ (⇒ (# "7"))) ∷
   ((# "8") ⇒ (⇒ (# "4"))) ∷
   ((# "9") ⇒ (⇒ (# "7"))) ∷
   ((# "9") ⇒ (⇒ (# "8"))) ∷
   ((# "3") ⇒ (⇒ (# "8"))) ∷
   ((# "5") ⇒ ((# "3") ⇒ (⇒ (# "9")))) ∷
   ((# "6") ⇒ ((# "7") ⇒ (⇒ (# "10")))) ∷
   ((# "6") ⇒ ((# "3") ⇒ (⇒ (# "3")))) ∷
   ((# "7") ⇒ (⇒ (# "7"))) ∷
   ((# "7") ⇒ (⇒ (# "7"))) ∷
   ((# "7") ⇒ ((# "8") ⇒ (⇒ (# "10")))) ∷
   ((# "3") ⇒ ((# "10") ⇒ (⇒ (# "9")))) ∷
   ((# "5") ⇒ (⇒ (# "1"))) ∷
   ((# "3") ⇒ ((# "1") ⇒ (⇒ (# "9")))) ∷
   ((# "1") ⇒ (⇒ (# "2"))) ∷
   ((# "10") ⇒ (⇒ (# "2"))) ∷ []

cms : List Separation
cms =
  (model ((# "12") ∷ (# "6") ∷ (# "11") ∷ (# "4") ∷ (# "1") ∷ []) ((# "5") ∷ (# "3") ∷ (# "7") ∷ (# "7") ∷ [])) ∷
  (model ((# "6") ∷ (# "3") ∷ (# "11") ∷ (# "4") ∷ (# "7") ∷ (# "8") ∷ (# "3") ∷ (# "9") ∷ (# "10") ∷ (# "1") ∷ []) ((# "5") ∷ [])) ∷
  (model ((# "12") ∷ (# "5") ∷ (# "11") ∷ (# "4") ∷ (# "1") ∷ []) ((# "6") ∷ (# "3") ∷ [])) ∷
  (model ((# "5") ∷ (# "3") ∷ (# "11") ∷ (# "4") ∷ (# "7") ∷ (# "8") ∷ (# "3") ∷ (# "9") ∷ (# "10") ∷ (# "1") ∷ []) ((# "6") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "11") ∷ []) ((# "5") ∷ (# "6") ∷ (# "3") ∷ (# "8") ∷ (# "9") ∷ (# "1") ∷ [])) ∷
  (model ((# "12") ∷ (# "5") ∷ (# "6") ∷ (# "4") ∷ (# "11") ∷ (# "1") ∷ []) ((# "3") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "11") ∷ (# "7") ∷ []) ((# "9") ∷ (# "5") ∷ (# "6") ∷ (# "10") ∷ (# "8") ∷ (# "1") ∷ [])) ∷
  (model ((# "10") ∷ (# "9") ∷ []) ((# "1") ∷ [])) ∷
  (model ((# "3") ∷ (# "4") ∷ (# "11") ∷ []) ((# "9") ∷ (# "5") ∷ (# "6") ∷ (# "10") ∷ (# "7") ∷ (# "1") ∷ [])) ∷
  (model ((# "12") ∷ (# "7") ∷ (# "1") ∷ []) ((# "4") ∷ (# "11") ∷ (# "8") ∷ [])) ∷
  (model ((# "9") ∷ (# "3") ∷ (# "10") ∷ (# "8") ∷ (# "1") ∷ []) ((# "11") ∷ [])) ∷
  (model ((# "12") ∷ (# "4") ∷ (# "10") ∷ (# "1") ∷ []) ((# "11") ∷ (# "3") ∷ [])) ∷
  (model ((# "3") ∷ (# "6") ∷ (# "5") ∷ []) ([])) ∷
  (model ((# "1") ∷ (# "2") ∷ (# "3") ∷ (# "4") ∷ (# "5") ∷ (# "6") ∷ (# "7") ∷ (# "8") ∷ (# "9") ∷ (# "10") ∷ (# "11") ∷ []) ((# "12") ∷ [])) ∷ []

testp : Relation
testp = consider proofs cms ((# "5") ⇒ (⇒ (# "10")))

testd : Relation
testd = consider proofs cms ((# "5") ⇒ (⇒ (# "4")))

tests : Relation
tests = consider proofs cms ((# "5") ⇒ (⇒ (# "3")))

testu : Relation
testu = consider proofs cms ((# "6") ⇒ (⇒ (# "1")))

testcl : List Principle
testcl = closure proofs ((# "5") ∷ [])

stringifylp : List Principle → String
stringifylp [] = "[]"
stringifylp ((# s) ∷ xs) = s >>> " ∷ " >>> (stringifylp xs)

main = run (putStrLn (stringifylp testcl))