{-
Setting an unknown signal can only shrink Can.

  canₖ-set-sig-monotonic : ∀ p S θ S∈ status →
    Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
    ∀ k →
      k ∈ Canₖ p (Env.set-sig {S} θ S∈ status) →
      k ∈ Canₖ p θ

  (And its counterpart for Canₛ and Canₛₕ.)

There are also corresponding Canθ versions: Setting a signal that
is immediately shadowed by the inner environment does not change
the result; setting a signal not in the inner environment can only
shrink Canθ.

  canθ-set-sig-irr : ∀ sigs S'' →
    ∀ p S θ S∈ status →
      Signal.unwrap S ∈ map (_+_ S'') (SigMap.keys sigs) →
      Canθ sigs S'' p θ ≡ Canθ sigs S'' p (Env.set-sig {S} θ S∈ status)

  canθₖ-set-sig-monotonic : ∀ sigs S'' →
    ∀ p S θ S∈ status →
      Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
      Signal.unwrap S ∉ map (_+_ S'') (SigMap.keys sigs) →
      ∀ k →
        k ∈ Canθₖ sigs S'' p (Env.set-sig {S} θ S∈ status) →
        k ∈ Canθₖ sigs S'' p θ

For convenient reasoning of Canθ, we have a wrapper around canθ?-set-sig-monotonic
lemmas: changing some unknowns to present or absent in the new signals (sigs) will
only make the result smaller.

  canθₖ-add-sig-monotonic : ∀ sigs S'' p θ S status →
    ∀ k →
      k ∈ Canθₖ sigs S'' p (θ ← Θ SigMap.[ S ↦ status ] VarMap.empty ShrMap.empty) →
      k ∈ Canθₖ sigs S'' p (θ ← [S]-env S)

A similar lemma for Canθ also holds, with some proper add-sig-monotonic constriant
on the continuation. Specifically, this holds for using Canθ as the continuation.

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

  canθ'ₛ-canθ-add-sig-monotonic : ∀ sigs S sigs' S' p θ S''' status →
    ∀ S'' →
      S'' ∈ proj₁ (Canθ' sigs S (Canθ sigs' S' p)
                    (θ ← Θ SigMap.[ S''' ↦ status ] ShrMap.empty VarMap.empty)) →
      S'' ∈ proj₁ (Canθ' sigs S (Canθ sigs' S' p)
                    (θ ← [S]-env S'''))
-}
module Esterel.Lang.CanFunction.SetSigMonotonic where

open import utility

open import Esterel.Lang
-- Note: the dependency is weird here; SetSigMonotonic should be basic
-- and cannot import Base. Instead, Base relies on SetSigMonotonic.
open import Esterel.Lang.CanFunction
open import Esterel.Context
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 ; _ₛ) renaming (unwrap to _ˢ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ) renaming (unwrap to _ˢʰ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar ; _ᵥ) renaming (unwrap to _ᵛ)

open import Data.Bool
  using (Bool ; true ; false ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; [] ; _∷_ ; _++_ ; map)
open import Data.List.Properties
  using (map-id ; map-compose ; map-cong)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using (++⁻)
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)
open import Data.Nat
  using (ℕ ; zero ; suc ; _≟_ ; _+_)
open import Data.Nat.Properties.Simple
  using (+-comm)
open import Data.Maybe
  using (Maybe ; just ; nothing)
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 ; inspect ; [_] ; Reveal_·_is_
       ; module ≡-Reasoning)

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 ≡-Reasoning using (begin_ ; _≡⟨_⟩_ ; _∎)

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

canₖ-set-sig-monotonic : ∀ p S θ S∈ status →
  Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
  ∀ k →
    k ∈ Canₖ p (Env.set-sig {S} θ S∈ status) →
    k ∈ Canₖ p θ

canₛ-set-sig-monotonic : ∀ p S θ S∈ status →
  Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
  ∀ S'' →
    S'' ∈ Canₛ p (Env.set-sig {S} θ S∈ status) →
    S'' ∈ Canₛ p θ

canₛₕ-set-sig-monotonic : ∀ p S θ S∈ status →
  Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
  ∀ s →
    s ∈ Canₛₕ p (Env.set-sig {S} θ S∈ status) →
    s ∈ Canₛₕ p θ

canθ-set-sig-irr : ∀ sigs S'' →
  ∀ p S θ S∈ status →
    Signal.unwrap S ∈ map (_+_ S'') (SigMap.keys sigs) →
    Canθ sigs S'' p θ ≡ Canθ sigs S'' p (Env.set-sig {S} θ S∈ status)

canθₖ-set-sig-monotonic : ∀ sigs S'' →
  ∀ p S θ S∈ status →
    Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
    Signal.unwrap S ∉ map (_+_ S'') (SigMap.keys sigs) →
    ∀ k →
      k ∈ Canθₖ sigs S'' p (Env.set-sig {S} θ S∈ status) →
      k ∈ Canθₖ sigs S'' p θ

canθₛ-set-sig-monotonic : ∀ sigs S'' →
  ∀ p S θ S∈ status →
    Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
    Signal.unwrap S ∉ map (_+_ S'') (SigMap.keys sigs) →
    ∀ S' →
      S' ∈ Canθₛ sigs S'' p (Env.set-sig {S} θ S∈ status) →
      S' ∈ Canθₛ sigs S'' p θ

canθₛₕ-set-sig-monotonic : ∀ sigs S'' →
  ∀ p S θ S∈ status →
    Env.sig-stats {S} θ S∈ ≡ Signal.unknown →
    Signal.unwrap S ∉ map (_+_ S'') (SigMap.keys sigs) →
    ∀ s →
      s ∈ Canθₛₕ sigs S'' p (Env.set-sig {S} θ S∈ status) →
      s ∈ Canθₛₕ sigs S'' p θ

canθₖ-add-sig-monotonic : ∀ sigs S'' p θ S status →
  ∀ k →
    k ∈ Canθₖ sigs S'' p (θ ← Θ SigMap.[ S ↦ status ] VarMap.empty ShrMap.empty) →
    k ∈ Canθₖ sigs S'' p (θ ← [S]-env S)

canθₛ-add-sig-monotonic : ∀ sigs S'' p θ S status →
  ∀ S' →
    S' ∈ Canθₛ sigs S'' p (θ ← Θ SigMap.[ S ↦ status ] VarMap.empty ShrMap.empty) →
    S' ∈ Canθₛ sigs S'' p (θ ← [S]-env S)

canθₛₕ-add-sig-monotonic : ∀ sigs S'' p θ S status →
  ∀ s →
    s ∈ Canθₛₕ sigs S'' p (θ ← Θ SigMap.[ S ↦ status ] VarMap.empty ShrMap.empty) →
    s ∈ Canθₛₕ sigs S'' p (θ ← [S]-env S)

canθₖ-add-sig-monotonic sigs S'' p θ S status k k∈canθ-p-θ←[S↦status]
  with any (_≟_ (Signal.unwrap S)) (map (_+_ S'') (SigMap.keys sigs))
... | yes S∈map-S''+-sigs =
  subst (k ∈_)
    (trans
      (cong (Canθₖ sigs S'' p)
        (begin
             θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty
         ≡⟨ cong (θ ←_) (sym (Env.sig-put-1map-overwrite' S Signal.unknown status S∈[S])) ⟩
             θ ← Env.set-sig {S} ([S]-env S) S∈[S] status
         ≡⟨ Env.sig-switch-right S status θ ([S]-env S) S∈[S] S∈Domθ←[S] ⟩
             Env.set-sig {S} (θ ← [S]-env S) S∈Domθ←[S] status
         ∎))
      (cong (proj₁ ∘ proj₂)
        (sym
          (canθ-set-sig-irr sigs S'' p S (θ ← [S]-env S) S∈Domθ←[S] status S∈map-S''+-sigs))))
     k∈canθ-p-θ←[S↦status]
  where S∈[S]         = Env.sig-∈-single S Signal.unknown
        S∈Domθ←[S]    = Env.sig-←-monoʳ S ([S]-env S) θ S∈[S]
... | no  S∉map-S''+-sigs =
  canθₖ-set-sig-monotonic sigs S'' p S (θ ← [S]-env S) S∈Domθ←[S] status
    (trans ⟨θ←[S]⟩S≡[S]S (Env.sig-stats-1map' S Signal.unknown S∈[S])) S∉map-S''+-sigs k
    (subst (k ∈_)
      (cong (Canθₖ sigs S'' p)
        (begin
             θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty
         ≡⟨ cong (θ ←_) (sym (Env.sig-put-1map-overwrite' S Signal.unknown status S∈[S])) ⟩
             θ ← Env.set-sig {S} ([S]-env S) S∈[S] status
         ≡⟨ Env.sig-switch-right S status θ ([S]-env S) S∈[S] S∈Domθ←[S] ⟩
             Env.set-sig {S} (θ ← [S]-env S) S∈Domθ←[S] status
         ∎))
       k∈canθ-p-θ←[S↦status])
  where S∈[S]         = Env.sig-∈-single S Signal.unknown
        S∈Domθ←[S]    = Env.sig-←-monoʳ S ([S]-env S) θ S∈[S]
        ⟨θ←[S]⟩S≡[S]S = Env.sig-stats-←-right-irr' S θ ([S]-env S) S∈[S] S∈Domθ←[S]

canθₛ-add-sig-monotonic sigs S'' p θ S status S' S'∈canθ-p-θ←[S↦status]
  with any (_≟_ (Signal.unwrap S)) (map (_+_ S'') (SigMap.keys sigs))
... | yes S∈map-S''+-sigs =
  subst (S' ∈_)
    (trans
      (cong (Canθₛ sigs S'' p)
        (begin
             θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty
         ≡⟨ cong (θ ←_) (sym (Env.sig-put-1map-overwrite' S Signal.unknown status S∈[S])) ⟩
             θ ← Env.set-sig {S} ([S]-env S) S∈[S] status
         ≡⟨ Env.sig-switch-right S status θ ([S]-env S) S∈[S] S∈Domθ←[S] ⟩
             Env.set-sig {S} (θ ← [S]-env S) S∈Domθ←[S] status
         ∎))
      (cong proj₁
        (sym
          (canθ-set-sig-irr sigs S'' p S (θ ← [S]-env S) S∈Domθ←[S] status S∈map-S''+-sigs))))
     S'∈canθ-p-θ←[S↦status]
  where S∈[S]         = Env.sig-∈-single S Signal.unknown
        S∈Domθ←[S]    = Env.sig-←-monoʳ S ([S]-env S) θ S∈[S]
... | no  S∉map-S''+-sigs =
  canθₛ-set-sig-monotonic sigs S'' p S (θ ← [S]-env S) S∈Domθ←[S] status
    (trans ⟨θ←[S]⟩S≡[S]S (Env.sig-stats-1map' S Signal.unknown S∈[S])) S∉map-S''+-sigs S'
    (subst (S' ∈_)
      (cong (Canθₛ sigs S'' p)
        (begin
             θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty
         ≡⟨ cong (θ ←_) (sym (Env.sig-put-1map-overwrite' S Signal.unknown status S∈[S])) ⟩
             θ ← Env.set-sig {S} ([S]-env S) S∈[S] status
         ≡⟨ Env.sig-switch-right S status θ ([S]-env S) S∈[S] S∈Domθ←[S] ⟩
             Env.set-sig {S} (θ ← [S]-env S) S∈Domθ←[S] status
         ∎))
       S'∈canθ-p-θ←[S↦status])
  where S∈[S]         = Env.sig-∈-single S Signal.unknown
        S∈Domθ←[S]    = Env.sig-←-monoʳ S ([S]-env S) θ S∈[S]
        ⟨θ←[S]⟩S≡[S]S = Env.sig-stats-←-right-irr' S θ ([S]-env S) S∈[S] S∈Domθ←[S]

canθₛₕ-add-sig-monotonic sigs S'' p θ S status s s∈canθ-p-θ←[S↦status]
  with any (_≟_ (Signal.unwrap S)) (map (_+_ S'') (SigMap.keys sigs))
... | yes S∈map-S''+-sigs =
  subst (s ∈_)
    (trans
      (cong (Canθₛₕ sigs S'' p)
        (begin
             θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty
         ≡⟨ cong (θ ←_) (sym (Env.sig-put-1map-overwrite' S Signal.unknown status S∈[S])) ⟩
             θ ← Env.set-sig {S} ([S]-env S) S∈[S] status
         ≡⟨ Env.sig-switch-right S status θ ([S]-env S) S∈[S] S∈Domθ←[S] ⟩
             Env.set-sig {S} (θ ← [S]-env S) S∈Domθ←[S] status
         ∎))
      (cong (proj₂ ∘ proj₂)
        (sym
          (canθ-set-sig-irr sigs S'' p S (θ ← [S]-env S) S∈Domθ←[S] status S∈map-S''+-sigs))))
     s∈canθ-p-θ←[S↦status]
  where S∈[S]         = Env.sig-∈-single S Signal.unknown
        S∈Domθ←[S]    = Env.sig-←-monoʳ S ([S]-env S) θ S∈[S]
... | no  S∉map-S''+-sigs =
  canθₛₕ-set-sig-monotonic sigs S'' p S (θ ← [S]-env S) S∈Domθ←[S] status
    (trans ⟨θ←[S]⟩S≡[S]S (Env.sig-stats-1map' S Signal.unknown S∈[S])) S∉map-S''+-sigs s
    (subst (s ∈_)
      (cong (Canθₛₕ sigs S'' p)
        (begin
             θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty
         ≡⟨ cong (θ ←_) (sym (Env.sig-put-1map-overwrite' S Signal.unknown status S∈[S])) ⟩
             θ ← Env.set-sig {S} ([S]-env S) S∈[S] status
         ≡⟨ Env.sig-switch-right S status θ ([S]-env S) S∈[S] S∈Domθ←[S] ⟩
             Env.set-sig {S} (θ ← [S]-env S) S∈Domθ←[S] status
         ∎))
       s∈canθ-p-θ←[S↦status])
  where S∈[S]         = Env.sig-∈-single S Signal.unknown
        S∈Domθ←[S]    = Env.sig-←-monoʳ S ([S]-env S) θ S∈[S]
        ⟨θ←[S]⟩S≡[S]S = Env.sig-stats-←-right-irr' S θ ([S]-env S) S∈[S] S∈Domθ←[S]

canₖ-set-sig-monotonic nothin S θ S∈ status θS≡unknown k k∈can-p-θ' = k∈can-p-θ'
canₖ-set-sig-monotonic pause S θ S∈ status θS≡unknown k k∈can-p-θ' = k∈can-p-θ'
canₖ-set-sig-monotonic (signl S' p) S θ S∈ status θS≡unknown k k∈can-p-θ'
  with Env.Sig∈ S ([S]-env S')
... | yes S∈Dom[S]-env
  rewrite sym (map-id (proj₁ (Dom ([S]-env S'))))
        | canθ-set-sig-irr (Env.sig ([S]-env S')) 0 p S θ S∈ status S∈Dom[S]-env
  = k∈can-p-θ'
... | no S∉Dom[S]-env
  rewrite sym (map-id (proj₁ (Dom ([S]-env S'))))
  = canθₖ-set-sig-monotonic
      (Env.sig ([S]-env S')) 0 p S θ S∈ status θS≡unknown
      S∉Dom[S]-env
      k k∈can-p-θ'
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ' with S' Signal.≟ S
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  S'≢S with Env.Sig∈ S' θ | Env.Sig∈ S' (Env.set-sig {S} θ S∈ status)
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  S'≢S | yes S'∈θ | no  S'∉θ' =
  ⊥-elim (S'∉θ' (Env.sig-set-mono' {S'} {S} {θ} {status} {S∈} S'∈θ))
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  S'≢S | no  S'∉θ | yes S'∈θ' with Env.sig-stats {S'} (Env.set-sig {S} θ S∈ status) S'∈θ'
... | Signal.present =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ')
... | Signal.absent  =
  ++ʳ (Canₖ p θ) (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-p-θ')
... | Signal.unknown
  with ++⁻ (Canₖ p (Env.set-sig {S} θ S∈ status)) k∈can-p-θ'
... | inj₁ k∈can-p'-θ' =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p'-θ')
... | inj₂ k∈can-q'-θ' =
  ++ʳ (Canₖ p θ) (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-q'-θ')
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  S'≢S | no  S'∉θ | no  S'∉θ'
  with ++⁻ (Canₖ p (Env.set-sig {S} θ S∈ status)) k∈can-p-θ'
... | inj₁ k∈can-p'-θ' =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p'-θ')
... | inj₂ k∈can-q'-θ' =
  ++ʳ (Canₖ p θ) (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-q'-θ')
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  S'≢S | yes S'∈θ | yes S'∈θ'
  with Env.sig-stats {S'} θ S'∈θ
     | Env.sig-putputget {S'} {S} {θ} {_} {status} S'≢S S'∈θ S∈ S'∈θ' refl
... | Signal.present | eq rewrite eq = canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'
... | Signal.absent  | eq rewrite eq = canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-p-θ'
... | Signal.unknown | eq rewrite eq
  with ++⁻ (Canₖ p (Env.set-sig {S} θ S∈ status)) k∈can-p-θ'
... | inj₁ k∈can-p'-θ' =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p'-θ')
... | inj₂ k∈can-q'-θ' =
  ++ʳ (Canₖ p θ) (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-q'-θ')
canₖ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | yes refl with Env.Sig∈ S' θ | Env.Sig∈ S' (Env.set-sig {S} θ S∈ status)
... | no  S'∉θ  | S'∈θ'?    = ⊥-elim (S'∉θ S∈)
... | yes S'∈θ  | no  S'∉θ' = ⊥-elim (S'∉θ' (Env.sig-set-mono' {S'} {S} {θ} {status} {S∈} S'∈θ))
... | yes S'∈θ  | yes S'∈θ'
  rewrite Env.sig-stats-∈-irr {S'} {θ} S'∈θ S∈ | θS≡unknown
  with Env.sig-stats {S'} (Env.set-sig {S} θ S∈ status) S'∈θ'
... | Signal.present =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ')
... | Signal.absent =
  ++ʳ (Canₖ p θ) (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-p-θ')
... | Signal.unknown
  with ++⁻ (Canₖ p (Env.set-sig {S} θ S∈ status)) k∈can-p-θ'
... | inj₁ k∈can-p'-θ' =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p'-θ')
... | inj₂ k∈can-q'-θ' =
  ++ʳ (Canₖ p θ) (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-q'-θ')
canₖ-set-sig-monotonic (emit S') S θ S∈ status θS≡unknown k k∈can-p-θ' = k∈can-p-θ'
canₖ-set-sig-monotonic (p ∥ q) S θ S∈ status
  θS≡unknown k k∈can-p-θ' =
  map-mono² Code._⊔_
    (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown)
    (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown)
    k k∈can-p-θ'
canₖ-set-sig-monotonic (loop p) S θ S∈ status θS≡unknown k k∈can-p-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'
canₖ-set-sig-monotonic (loopˢ p q) S θ S∈ status θS≡unknown k s∈can-loopˢpq-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k s∈can-loopˢpq-θ'

canₖ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
     | any (Code._≟_ Code.nothin) (Canₖ p (Env.set-sig {S} θ S∈ status))
canₖ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | yes nothin∈can-p-θ | yes nothin∈can-p-θ'
  with Code.nothin Code.≟ k
     | ++⁻ (CodeSet.set-remove (Canₖ p (Env.set-sig {S} θ S∈ status)) Code.nothin) k∈can-p-θ'
... | nothin≟k    | inj₂ k∈can-q-θ' =
  ++ʳ (CodeSet.set-remove (Canₖ p θ) Code.nothin)
      (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-q-θ')
... | yes refl    | inj₁ nothin∈can-p-θ'-[nothin] =
  ⊥-elim (CodeSet.set-remove-removed {Code.nothin} {Canₖ p (Env.set-sig {S} θ S∈ status)}
                                     nothin∈can-p-θ'-[nothin])
... | no nothin≢k | inj₁ k∈can-p-θ'-[nothin] =
  ++ˡ (CodeSet.set-remove-not-removed
        nothin≢k
        (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k
           (CodeSet.set-remove-mono-∈ Code.nothin k∈can-p-θ'-[nothin])))
canₖ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | yes nothin∈can-p-θ | no  nothin∉can-p-θ'
  with Code.nothin Code.≟ k
... | yes refl    = ⊥-elim (nothin∉can-p-θ' k∈can-p-θ')
... | no nothin≢k =
  ++ˡ (CodeSet.set-remove-not-removed
        nothin≢k
        (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'))
canₖ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  nothin∉can-p-θ | yes nothin∈can-p-θ'
  = ⊥-elim (nothin∉can-p-θ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown Code.nothin nothin∈can-p-θ'))
canₖ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown k k∈can-p-θ'
  | no  nothin∉can-p-θ | no  nothin∉can-p-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'
canₖ-set-sig-monotonic (suspend p S') S θ S∈ status θS≡unknown k k∈can-p-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'
canₖ-set-sig-monotonic (trap p) S θ S∈ status θS≡unknown k k∈can-p-θ' =
  map-mono Code.↓* (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown) k k∈can-p-θ'
canₖ-set-sig-monotonic (exit n) S θ S∈ status θS≡unknown k k∈can-p-θ' = k∈can-p-θ'
canₖ-set-sig-monotonic (shared s ≔ e in: p) S θ S∈ status θS≡unknown k k∈can-p-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'
canₖ-set-sig-monotonic (s ⇐ e) S θ S∈ status θS≡unknown k k∈can-p-θ' = k∈can-p-θ'
canₖ-set-sig-monotonic (var x ≔ e in: p) S θ S∈ status θS≡unknown k k∈can-p-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ'
canₖ-set-sig-monotonic (x ≔ e) S θ S∈ status θS≡unknown k k∈can-p-θ' = k∈can-p-θ'
canₖ-set-sig-monotonic (if x ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown k k∈can-if-θ'
  with ++⁻ (Canₖ p (Env.set-sig {S} θ S∈ status)) k∈can-if-θ'
... | inj₁ k∈can-p-θ' =
  ++ˡ (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈can-p-θ')
... | inj₂ k∈can-q-θ' =
  ++ʳ
   (Canₖ p θ)
   (canₖ-set-sig-monotonic q S θ S∈ status θS≡unknown k k∈can-q-θ')
canₖ-set-sig-monotonic (ρ⟨ θ' , A ⟩· p) S θ S∈ status θS≡unknown k k∈can-p-θ'
  with Env.Sig∈ S θ'
... | yes S∈Domθ'
  rewrite sym (map-id (proj₁ (Dom θ')))
        | canθ-set-sig-irr (Env.sig θ') 0 p S θ S∈ status S∈Domθ'
  = k∈can-p-θ'
... | no  S∉Domθ'
  rewrite sym (map-id (proj₁ (Dom θ')))
  = canθₖ-set-sig-monotonic (Env.sig θ') 0 p S θ S∈ status θS≡unknown S∉Domθ' k k∈can-p-θ'

canₛ-set-sig-monotonic nothin S θ S∈ status θS≡unknown S'' S''∈can-p-θ' = S''∈can-p-θ'
canₛ-set-sig-monotonic pause S θ S∈ status θS≡unknown S'' S''∈can-p-θ' = S''∈can-p-θ'
canₛ-set-sig-monotonic (signl S' p) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  with Env.Sig∈ S ([S]-env S')
... | yes S∈Dom[S]-env
  rewrite sym (map-id (proj₁ (Dom ([S]-env S'))))
        | canθ-set-sig-irr (Env.sig ([S]-env S')) 0 p S θ S∈ status S∈Dom[S]-env
  = S''∈can-p-θ'
... | no S∉Dom[S]-env rewrite sym (map-id (proj₁ (Dom ([S]-env S'))))
  with Signal.unwrap S' ≟ S''
... | yes refl =
  ⊥-elim
    (set-remove-removed {S''}
      {Canθₛ (Env.sig ([S]-env S')) 0 p (Env.set-sig {S} θ S∈ status)}
      S''∈can-p-θ')
... | no S'≢S'' =
  set-remove-not-removed S'≢S''
    (canθₛ-set-sig-monotonic
      (Env.sig ([S]-env S')) 0 p S θ S∈ status θS≡unknown
      S∉Dom[S]-env S''
      (set-remove-mono-∈ (Signal.unwrap S') S''∈can-p-θ'))
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  with S' Signal.≟ S
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  | no  S'≢S with Env.Sig∈ S' θ | Env.Sig∈ S' (Env.set-sig {S} θ S∈ status)
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  | no  S'≢S | yes S'∈θ | no  S'∉θ' =
  ⊥-elim (S'∉θ' (Env.sig-set-mono' {S'} {S} {θ} {status} {S∈} S'∈θ))
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  | no  S'≢S | no  S'∉θ | yes S'∈θ' with Env.sig-stats {S'} (Env.set-sig {S} θ S∈ status) S'∈θ'
... | Signal.present =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | Signal.absent  =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | Signal.unknown
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-p-θ'
... | inj₁ S''∈can-p'-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p'-θ')
... | inj₂ S''∈can-q'-θ' =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q'-θ')
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  | no  S'≢S | no  S'∉θ | no  S'∉θ'
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-p-θ'
... | inj₁ S''∈can-p'-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p'-θ')
... | inj₂ S''∈can-q'-θ' =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q'-θ')
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  | no  S'≢S | yes S'∈θ | yes S'∈θ'
  with Env.sig-stats {S'} θ S'∈θ
     | Env.sig-putputget {S'} {S} {θ} {_} {status} S'≢S S'∈θ S∈ S'∈θ' refl
... | Signal.present | eq rewrite eq = canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
... | Signal.absent  | eq rewrite eq = canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
... | Signal.unknown | eq rewrite eq
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-p-θ'
... | inj₁ S''∈can-p'-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p'-θ')
... | inj₂ S''∈can-q'-θ' =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q'-θ')
canₛ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
  | yes refl with Env.Sig∈ S' θ | Env.Sig∈ S' (Env.set-sig {S} θ S∈ status)
... | no  S'∉θ  | S'∈θ'?    = ⊥-elim (S'∉θ S∈)
... | yes S'∈θ  | no  S'∉θ' = ⊥-elim (S'∉θ' (Env.sig-set-mono' {S'} {S} {θ} {status} {S∈} S'∈θ))
... | yes S'∈θ  | yes S'∈θ'
  rewrite Env.sig-stats-∈-irr {S'} {θ} S'∈θ S∈ | θS≡unknown
  with Env.sig-stats {S'} (Env.set-sig {S} θ S∈ status) S'∈θ'
... | Signal.present =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | Signal.absent =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | Signal.unknown
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-p-θ'
... | inj₁ S''∈can-p'-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p'-θ')
... | inj₂ S''∈can-q'-θ' =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q'-θ')
canₛ-set-sig-monotonic (emit S') S θ S∈ status θS≡unknown S'' S''∈can-p-θ' = S''∈can-p-θ'
canₛ-set-sig-monotonic (p ∥ q) S θ S∈ status θS≡unknown S'' S''∈can-p∥q-θ'
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-p∥q-θ'
... | inj₁ S''∈can-p-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | inj₂ S''∈can-q-θ' =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q-θ')
canₛ-set-sig-monotonic (loop p) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
canₛ-set-sig-monotonic (loopˢ p q) S θ S∈ status θS≡unknown S'' s∈can-loopˢpq-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' s∈can-loopˢpq-θ'

canₛ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown S'' S''∈can-p>>q-θ'
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
     | any (Code._≟_ Code.nothin) (Canₖ p (Env.set-sig {S} θ S∈ status))
... | no  nothin∉can-p-θ | yes nothin∈can-p-θ' =
  ⊥-elim
    (nothin∉can-p-θ
      (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown
        Code.nothin nothin∈can-p-θ'))
... | no  nothin∉can-p-θ | no  nothin∉can-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p>>q-θ'
... | yes nothin∈can-p-θ | no  nothin∉can-p-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p>>q-θ')
... | yes nothin∈can-p-θ | yes nothin∈can-p-θ'
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-p>>q-θ'
... | inj₁ S''∈can-p-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | inj₂ S''∈can-q-θ' =
  ++ʳ (Canₛ p θ) (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q-θ')
canₛ-set-sig-monotonic (suspend p S') S θ S∈ status θS≡unknown S'' S''∈can-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
canₛ-set-sig-monotonic (trap p) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
canₛ-set-sig-monotonic (exit n) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' = S''∈can-p-θ'
canₛ-set-sig-monotonic (shared s' ≔ e in: p) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
canₛ-set-sig-monotonic (s' ⇐ e) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' = S''∈can-p-θ'
canₛ-set-sig-monotonic (var x ≔ e in: p) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ'
canₛ-set-sig-monotonic (x ≔ e) S θ S∈ status θS≡unknown S'' S''∈can-p-θ' = S''∈can-p-θ'
canₛ-set-sig-monotonic (if x ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown S'' S''∈can-if-θ'
  with ++⁻ (Canₛ p (Env.set-sig {S} θ S∈ status)) S''∈can-if-θ'
... | inj₁ S''∈can-p-θ' =
  ++ˡ (canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S'' S''∈can-p-θ')
... | inj₂ S''∈can-q-θ' =
  ++ʳ
   (Canₛ p θ)
   (canₛ-set-sig-monotonic q S θ S∈ status θS≡unknown S'' S''∈can-q-θ')
canₛ-set-sig-monotonic (ρ⟨ θ' , A ⟩· p) S θ S∈ status θS≡unknown S'' S''∈can-ρθ'p-θ'
  with Env.Sig∈ S θ'
... | yes S∈Domθ'
  rewrite sym (map-id (proj₁ (Dom θ')))
        | canθ-set-sig-irr (Env.sig θ') 0 p S θ S∈ status S∈Domθ'
  = S''∈can-ρθ'p-θ'
... | no  S∉Domθ'
  with set-subtract-merge {xs = Canθₛ (Env.sig θ') 0 p (Env.set-sig {S} θ S∈ status)}
                          {ys = proj₁ (Dom θ')}
                          S''∈can-ρθ'p-θ'
... | S''∈canθ-p-θ' , S''∉Domθ'
  rewrite sym (map-id (proj₁ (Dom θ')))
  with set-subtract-split
         (canθₛ-set-sig-monotonic (Env.sig θ') 0 p S θ S∈ status θS≡unknown S∉Domθ'
           S'' S''∈canθ-p-θ')
... | inj₂ S''∈Domθ' = ⊥-elim (S''∉Domθ' S''∈Domθ')
... | inj₁ S''∈canθ-p-θ-Domθ' = S''∈canθ-p-θ-Domθ'

canₛₕ-set-sig-monotonic nothin S θ S∈ status θS≡unknown s s∈can-p-θ' = s∈can-p-θ'
canₛₕ-set-sig-monotonic pause S θ S∈ status θS≡unknown s s∈can-p-θ' = s∈can-p-θ'
canₛₕ-set-sig-monotonic (signl S' p) S θ S∈ status θS≡unknown s s∈can-p-θ'
  with Env.Sig∈ S ([S]-env S')
... | yes S∈Dom[S]-env
  rewrite sym (map-id (proj₁ (Dom ([S]-env S'))))
        | canθ-set-sig-irr (Env.sig ([S]-env S')) 0 p S θ S∈ status S∈Dom[S]-env
  = s∈can-p-θ'
... | no S∉Dom[S]-env
  rewrite sym (map-id (proj₁ (Dom ([S]-env S'))))
  = canθₛₕ-set-sig-monotonic
      (Env.sig ([S]-env S')) 0 p S θ S∈ status θS≡unknown
      S∉Dom[S]-env
      s s∈can-p-θ'
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  with S' Signal.≟ S
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  | no  S'≢S with Env.Sig∈ S' θ | Env.Sig∈ S' (Env.set-sig {S} θ S∈ status)
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  | no  S'≢S | yes S'∈θ | no  S'∉θ' =
  ⊥-elim (S'∉θ' (Env.sig-set-mono' {S'} {S} {θ} {status} {S∈} S'∈θ))
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  | no  S'≢S | no  S'∉θ | yes S'∈θ' with Env.sig-stats {S'} (Env.set-sig {S} θ S∈ status) S'∈θ'
... | Signal.present =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ')
... | Signal.absent  =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-p-θ')
... | Signal.unknown
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-p-θ'
... | inj₁ s∈can-p'-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p'-θ')
... | inj₂ s∈can-q'-θ' =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q'-θ')
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  | no  S'≢S | no  S'∉θ | no  S'∉θ'
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-p-θ'
... | inj₁ s∈can-p'-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p'-θ')
... | inj₂ s∈can-q'-θ' =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q'-θ')
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  | no  S'≢S | yes S'∈θ | yes S'∈θ'
  with Env.sig-stats {S'} θ S'∈θ
     | Env.sig-putputget {S'} {S} {θ} {_} {status} S'≢S S'∈θ S∈ S'∈θ' refl
... | Signal.present | eq rewrite eq = canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ'
... | Signal.absent  | eq rewrite eq = canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-p-θ'
... | Signal.unknown | eq rewrite eq
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-p-θ'
... | inj₁ s∈can-p'-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p'-θ')
... | inj₂ s∈can-q'-θ' =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q'-θ')
canₛₕ-set-sig-monotonic (present S' ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-p-θ'
  | yes refl with Env.Sig∈ S' θ | Env.Sig∈ S' (Env.set-sig {S} θ S∈ status)
... | no  S'∉θ  | S'∈θ'?    = ⊥-elim (S'∉θ S∈)
... | yes S'∈θ  | no  S'∉θ' = ⊥-elim (S'∉θ' (Env.sig-set-mono' {S'} {S} {θ} {status} {S∈} S'∈θ))
... | yes S'∈θ  | yes S'∈θ'
  rewrite Env.sig-stats-∈-irr {S'} {θ} S'∈θ S∈ | θS≡unknown
  with Env.sig-stats {S'} (Env.set-sig {S} θ S∈ status) S'∈θ'
... | Signal.present =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ')
... | Signal.absent =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-p-θ')
... | Signal.unknown
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-p-θ'
... | inj₁ s∈can-p'-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p'-θ')
... | inj₂ s∈can-q'-θ' =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q'-θ')
canₛₕ-set-sig-monotonic (emit S') S θ S∈ status θS≡unknown s s∈can-p-θ' = s∈can-p-θ'
canₛₕ-set-sig-monotonic (p ∥ q) S θ S∈ status θS≡unknown s s∈can-p∥q-θ'
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-p∥q-θ'
... | inj₁ s∈can-p-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ')
... | inj₂ s∈can-q-θ' =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q-θ')
canₛₕ-set-sig-monotonic (loop p) S θ S∈ status θS≡unknown s s∈can-p-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ'
canₛₕ-set-sig-monotonic (loopˢ p q) S θ S∈ status θS≡unknown s s∈can-loopˢpq-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-loopˢpq-θ'
canₛₕ-set-sig-monotonic (p >> q) S θ S∈ status θS≡unknown s s∈can-p>>q-θ'
  with any (Code._≟_ Code.nothin) (Canₖ p θ)
     | any (Code._≟_ Code.nothin) (Canₖ p (Env.set-sig {S} θ S∈ status))
... | no  nothin∉can-p-θ | yes nothin∈-can-p-θ' =
  ⊥-elim
    (nothin∉can-p-θ
      (canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown
        Code.nothin nothin∈-can-p-θ'))
... | no  nothin∉can-p-θ | no  nothin∉-can-p-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p>>q-θ'
... | yes nothin∈can-p-θ | no  nothin∉-can-p-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p>>q-θ')
... | yes nothin∈can-p-θ | yes nothin∈-can-p-θ'
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-p>>q-θ'
... | inj₁ s∈can-p-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ')
... | inj₂ s∈can-q-θ' =
  ++ʳ (Canₛₕ p θ) (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q-θ')
canₛₕ-set-sig-monotonic (suspend p S') S θ S∈ status θS≡unknown s s∈can-p-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ'
canₛₕ-set-sig-monotonic (trap p) S θ S∈ status θS≡unknown s s∈can-p-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ'
canₛₕ-set-sig-monotonic (exit n) S θ S∈ status θS≡unknown s s∈can-p-θ' = s∈can-p-θ'
canₛₕ-set-sig-monotonic (shared s' ≔ e in: p) S θ S∈ status θS≡unknown s s∈can-p-θ'
  with SharedVar.unwrap s' Data.Nat.≟ s
... | yes refl =
  ⊥-elim (set-remove-removed {SharedVar.unwrap s'} {Canₛₕ p (Env.set-sig {S} θ S∈ status)}
            s∈can-p-θ')
... | no  s'≢s =
  set-remove-not-removed s'≢s
    (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s
      (set-remove-mono-∈ (SharedVar.unwrap s') s∈can-p-θ'))
canₛₕ-set-sig-monotonic (s' ⇐ e) S θ S∈ status θS≡unknown s s∈can-p-θ' = s∈can-p-θ'
canₛₕ-set-sig-monotonic (var x ≔ e in: p) S θ S∈ status θS≡unknown s s∈can-p-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ'
canₛₕ-set-sig-monotonic (x ≔ e) S θ S∈ status θS≡unknown s s∈can-p-θ' = s∈can-p-θ'
canₛₕ-set-sig-monotonic (if x ∣⇒ p ∣⇒ q) S θ S∈ status θS≡unknown s s∈can-if-θ'
  with ++⁻ (Canₛₕ p (Env.set-sig {S} θ S∈ status)) s∈can-if-θ'
... | inj₁ s∈can-p-θ' =
  ++ˡ (canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈can-p-θ')
... | inj₂ s∈can-q-θ' =
  ++ʳ
   (Canₛₕ p θ)
   (canₛₕ-set-sig-monotonic q S θ S∈ status θS≡unknown s s∈can-q-θ')
canₛₕ-set-sig-monotonic (ρ⟨ θ' , A ⟩· p) S θ S∈ status θS≡unknown s s∈can-ρθ'p-θ'
  with Env.Sig∈ S θ'
... | yes S∈Domθ'
  rewrite sym (map-id (proj₁ (Dom θ')))
        | canθ-set-sig-irr (Env.sig θ') 0 p S θ S∈ status S∈Domθ'
  = s∈can-ρθ'p-θ'
... | no  S∉Domθ'
  with set-subtract-merge {xs = Canθₛₕ (Env.sig θ') 0 p (Env.set-sig {S} θ S∈ status)}
                          {ys = proj₁ (proj₂ (Dom θ'))}
                          s∈can-ρθ'p-θ'
... | s∈canθ-p-θ' , s∉Domθ'
  rewrite sym (map-id (proj₁ (Dom θ')))
  with set-subtract-split
         (canθₛₕ-set-sig-monotonic (Env.sig θ') 0 p S θ S∈ status θS≡unknown S∉Domθ'
           s s∈canθ-p-θ')
... | inj₂ s∈Domθ' = ⊥-elim (s∉Domθ' s∈Domθ')
... | inj₁ s∈canθ-p-θ-Domθ' = s∈canθ-p-θ-Domθ'

canθ-set-sig-irr [] S'' p S θ S∈Domθ status ()
canθ-set-sig-irr (nothing ∷ sigs) S'' p S θ S∈Domθ status S∈sigs
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθ-set-sig-irr sigs (suc S'') p S θ S∈Domθ status S∈sigs
canθ-set-sig-irr (just Signal.present ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  with (S'' ₛ) Signal.≟ S
... | yes refl
  rewrite Env.sig-set-←-← S status θ ([S]-env-present S)
            S∈Domθ (Env.sig-∈-single S Signal.present)
  = refl
... | no  S''≢S with S | S∈S'∷sigs
... | _      | here S≡S''+0 rewrite +-comm S'' 0 =
  ⊥-elim (S''≢S (Signal.unwrap-injective (sym S≡S''+0)))
... | zero ₛ | there S∈sigs
  rewrite map-+-swap-suc S'' (SigMap.keys sigs)
  = ⊥-elim (SigM.0∈S S∈sigs)
... | suc S' ₛ | there S∈sigs
  rewrite sym (Env.sig-switch (suc S' ₛ) status θ ([S]-env-present (S'' ₛ))
                S∈Domθ (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env-present (S'' ₛ)) S∈Domθ)
                (Env.sig-∉-single (suc S' ₛ) (S'' ₛ) Signal.present (S''≢S ∘ sym)))
        | map-+-compose-suc S'' (SigMap.keys sigs)
  = canθ-set-sig-irr sigs (suc S'') p (suc S' ₛ) (θ ← [S]-env-present (S'' ₛ))
      (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env-present (S'' ₛ)) S∈Domθ) status
      S∈sigs
canθ-set-sig-irr (just Signal.absent ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  with (S'' ₛ) Signal.≟ S
... | yes refl
  rewrite Env.sig-set-←-← S status θ ([S]-env-absent S)
            S∈Domθ (Env.sig-∈-single S Signal.absent)
  = refl
... | no  S''≢S with S | S∈S'∷sigs
... | _      | here S≡S''+0 rewrite +-comm S'' 0 =
  ⊥-elim (S''≢S (Signal.unwrap-injective (sym S≡S''+0)))
... | zero ₛ | there S∈sigs
  rewrite map-+-swap-suc S'' (SigMap.keys sigs)
  = ⊥-elim (SigM.0∈S S∈sigs)
... | suc S' ₛ | there S∈sigs
  rewrite sym (Env.sig-switch (suc S' ₛ) status θ ([S]-env-absent (S'' ₛ))
                S∈Domθ (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env-absent (S'' ₛ)) S∈Domθ)
                (Env.sig-∉-single (suc S' ₛ) (S'' ₛ) Signal.absent (S''≢S ∘ sym)))
        | map-+-compose-suc S'' (SigMap.keys sigs)
  = canθ-set-sig-irr sigs (suc S'') p (suc S' ₛ) (θ ← [S]-env-absent (S'' ₛ))
      (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env-absent (S'' ₛ)) S∈Domθ) status
      S∈sigs
canθ-set-sig-irr (just Signal.unknown ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') p
         ((Env.set-sig {S} θ S∈Domθ status) ← [S]-env (S'' ₛ)))
canθ-set-sig-irr (just Signal.unknown ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  | yes S''∈canθ-p-θ←[S''] | yes S''∈canθ-p-θ'←[S'']
  with (S'' ₛ) Signal.≟ S
... | yes refl
  rewrite Env.sig-set-←-← S status θ ([S]-env S)
            S∈Domθ (Env.sig-∈-single S Signal.unknown)
  = refl
... | no  S''≢S with S | S∈S'∷sigs
... | _      | here S≡S''+0 rewrite +-comm S'' 0 =
  ⊥-elim (S''≢S (Signal.unwrap-injective (sym S≡S''+0)))
... | zero ₛ | there S∈sigs
  rewrite map-+-swap-suc S'' (SigMap.keys sigs)
  = ⊥-elim (SigM.0∈S S∈sigs)
... | suc S' ₛ | there S∈sigs
  rewrite sym (Env.sig-switch (suc S' ₛ) status θ ([S]-env (S'' ₛ))
                S∈Domθ (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env (S'' ₛ)) S∈Domθ)
                (Env.sig-∉-single (suc S' ₛ) (S'' ₛ) Signal.unknown (S''≢S ∘ sym)))
        | map-+-compose-suc S'' (SigMap.keys sigs)
  = canθ-set-sig-irr sigs (suc S'') p (suc S' ₛ) (θ ← [S]-env (S'' ₛ))
      (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env (S'' ₛ)) S∈Domθ) status
      S∈sigs
canθ-set-sig-irr (just Signal.unknown ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  | no  S''∉can-pθ-θ←[S''] | no  S''∉can-pθ-θ'←[S'']
  with (S'' ₛ) Signal.≟ S
... | yes refl
  rewrite Env.sig-set-←-← S status θ ([S]-env-absent S)
            S∈Domθ (Env.sig-∈-single S Signal.absent)
  = refl
... | no  S''≢S with S | S∈S'∷sigs
... | _      | here S≡S''+0 rewrite +-comm S'' 0 =
  ⊥-elim (S''≢S (Signal.unwrap-injective (sym S≡S''+0)))
... | zero ₛ | there S∈sigs
  rewrite map-+-swap-suc S'' (SigMap.keys sigs)
  = ⊥-elim (SigM.0∈S S∈sigs)
... | suc S' ₛ | there S∈sigs
  rewrite sym (Env.sig-switch (suc S' ₛ) status θ ([S]-env-absent (S'' ₛ))
                S∈Domθ (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env-absent (S'' ₛ)) S∈Domθ)
                (Env.sig-∉-single (suc S' ₛ) (S'' ₛ) Signal.absent (S''≢S ∘ sym)))
        | map-+-compose-suc S'' (SigMap.keys sigs)
  = canθ-set-sig-irr sigs (suc S'') p (suc S' ₛ) (θ ← [S]-env-absent (S'' ₛ))
      (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env-absent (S'' ₛ)) S∈Domθ) status
      S∈sigs
canθ-set-sig-irr (just Signal.unknown ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  | yes S''∈canθ-p-θ←[S''] | no  S''∉canθ-p-θ'←[S'']
  with (S'' ₛ) Signal.≟ S
... | yes refl
  rewrite Env.sig-set-←-← S status θ ([S]-env S)
            S∈Domθ (Env.sig-∈-single S Signal.unknown)
  = ⊥-elim (S''∉canθ-p-θ'←[S''] S''∈canθ-p-θ←[S''])
... | no  S''≢S with S | S∈S'∷sigs
... | _      | here S≡S''+0 rewrite +-comm S'' 0 =
  ⊥-elim (S''≢S (Signal.unwrap-injective (sym S≡S''+0)))
... | zero ₛ | there S∈sigs
  rewrite map-+-swap-suc S'' (SigMap.keys sigs)
  = ⊥-elim (SigM.0∈S S∈sigs)
... | suc S' ₛ | there S∈sigs
  rewrite sym (Env.sig-switch (suc S' ₛ) status θ ([S]-env (S'' ₛ))
                S∈Domθ (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env (S'' ₛ)) S∈Domθ)
                (Env.sig-∉-single (suc S' ₛ) (S'' ₛ) Signal.unknown (S''≢S ∘ sym)))
        | map-+-compose-suc S'' (SigMap.keys sigs)
        | canθ-set-sig-irr sigs (suc S'') p (suc S' ₛ) (θ ← [S]-env (S'' ₛ))
           (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env (S'' ₛ)) S∈Domθ) status
           S∈sigs
  = ⊥-elim (S''∉canθ-p-θ'←[S''] S''∈canθ-p-θ←[S''])
canθ-set-sig-irr (just Signal.unknown ∷ sigs) S'' p S θ S∈Domθ status S∈S'∷sigs
  | no  S''∉canθ-p-θ←[S''] | yes S''∈canθ-p-θ'←[S'']
  with (S'' ₛ) Signal.≟ S
... | yes refl
  rewrite Env.sig-set-←-← S status θ ([S]-env S)
            S∈Domθ (Env.sig-∈-single S Signal.unknown)
  = ⊥-elim (S''∉canθ-p-θ←[S''] S''∈canθ-p-θ'←[S''])
... | no  S''≢S with S | S∈S'∷sigs
... | _      | here S≡S''+0 rewrite +-comm S'' 0 =
  ⊥-elim (S''≢S (Signal.unwrap-injective (sym S≡S''+0)))
... | zero ₛ | there S∈sigs
  rewrite map-+-swap-suc S'' (SigMap.keys sigs)
  = ⊥-elim (SigM.0∈S S∈sigs)
... | suc S' ₛ | there S∈sigs
  rewrite sym (Env.sig-switch (suc S' ₛ) status θ ([S]-env (S'' ₛ))
                S∈Domθ (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env (S'' ₛ)) S∈Domθ)
                (Env.sig-∉-single (suc S' ₛ) (S'' ₛ) Signal.unknown (S''≢S ∘ sym)))
        | map-+-compose-suc S'' (SigMap.keys sigs)
        | canθ-set-sig-irr sigs (suc S'') p (suc S' ₛ) (θ ← [S]-env (S'' ₛ))
           (Env.sig-←-monoˡ (suc S' ₛ) θ ([S]-env (S'' ₛ)) S∈Domθ) status
           S∈sigs
  = ⊥-elim (S''∉canθ-p-θ←[S''] S''∈canθ-p-θ'←[S''])

canθₖ-set-sig-monotonic [] S'' p S θ S∈ status θS≡unknown S∉sigs k k∈canθ-p-θ' =
  canₖ-set-sig-monotonic p S θ S∈ status θS≡unknown k k∈canθ-p-θ'
canθₖ-set-sig-monotonic (nothing ∷ sigs) S'' p S θ S∈ status θS≡unknown S∉sigs k k∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₖ-set-sig-monotonic sigs (suc S'') p S θ S∈ status θS≡unknown S∉sigs
    k k∈canθ-p-θ'
canθₖ-set-sig-monotonic (just Signal.present ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs k k∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₖ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-present (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) k
      (subst (k ∈_)
        (cong (Canθₖ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-present (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-present (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.present
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        k∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-present (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-present (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.present
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₖ-set-sig-monotonic (just Signal.absent ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs k k∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₖ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-absent (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) k
      (subst (k ∈_)
        (cong (Canθₖ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.absent
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        k∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.absent
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₖ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status θS≡unknown S∉sigs k k∈canθ-p-θ'
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') p ((Env.set-sig {S} θ S∈ status) ← [S]-env (S'' ₛ)))
canθₖ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs k k∈canθ-p-θ'
  | yes S''∈canθ-p-θ←[S] | yes S''∈canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₖ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) k
      (subst (k ∈_)
        (cong (Canθₖ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        k∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₖ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs k k∈canθ-p-θ'
  | no  S''∉canθ-p-θ←[S] | no  S''∉canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₖ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-absent (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) k
      (subst (k ∈_)
        (cong (Canθₖ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.absent
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        k∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.absent
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₖ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs k k∈canθ-p-θ'
  | no  S''∉canθ-p-θ←[S] | yes S''∈canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
        | cong (Canθₖ sigs (suc S'') p)
           (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))
  = ⊥-elim
      (S''∉canθ-p-θ←[S]
        (canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S''
      (subst (S'' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S''∈canθ-p-θ'←[S])))
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₖ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs k k∈canθ-p-θ'
  | yes S''∈canθ-p-θ←[S] | no  S''∉canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₖ-add-sig-monotonic sigs (suc S'') p θ (S'' ₛ) Signal.absent
      k k∈canθ-p-θ←[S↦absent]
  where S''∈[S'']      = Env.sig-∈-single (S'' ₛ) Signal.unknown
        S∈Domθ←[S'']   = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        S''∈Domθ←[S''] = Env.sig-←-monoʳ (S'' ₛ) ([S]-env (S'' ₛ)) θ S''∈[S'']
        θS≡⟨θ←[S'']⟩S  = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                           (Env.sig-∉-single S (S'' ₛ) Signal.absent
                             (S∉sigs ∘ here ∘ cong Signal.unwrap))
                           S∈Domθ←[S'']
        ⟨θ←[S'']⟩S''≡[S'']S'' = Env.sig-stats-←-right-irr' (S'' ₛ) θ ([S]-env (S'' ₛ))
                                  S''∈[S''] S''∈Domθ←[S'']
        k∈canθ-p-θ←[S↦absent] =
          canθₖ-set-sig-monotonic sigs (suc S'') p S
            (θ ← [S]-env-absent (S'' ₛ))
            S∈Domθ←[S''] status
            (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
            (S∉sigs ∘ there) k
            (subst (k ∈_)
              (cong (Canθₖ sigs (suc S'') p)
                (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                        S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                        (Env.sig-∉-single S (S'' ₛ) Signal.absent
                          (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
              k∈canθ-p-θ')

canθₛ-set-sig-monotonic [] S'' p S θ S∈ status θS≡unknown S∉sigs S' S'∈canθ-p-θ' =
  canₛ-set-sig-monotonic p S θ S∈ status θS≡unknown S' S'∈canθ-p-θ'
canθₛ-set-sig-monotonic (nothing ∷ sigs) S'' p S θ S∈ status θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛ-set-sig-monotonic sigs (suc S'') p S θ S∈ status θS≡unknown S∉sigs
    S' S'∈canθ-p-θ'
canθₛ-set-sig-monotonic (just Signal.present ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-present (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S'
      (subst (S' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-present (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-present (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.present
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S'∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-present (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-present (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.present
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛ-set-sig-monotonic (just Signal.absent ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-absent (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S'
      (subst (S' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.absent
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S'∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.absent
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') p ((Env.set-sig {S} θ S∈ status) ← [S]-env (S'' ₛ)))
canθₛ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  | yes S''∈canθ-p-θ←[S] | yes S''∈canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S'
      (subst (S' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S'∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  | no  S''∉canθ-p-θ←[S] | no  S''∉canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-absent (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S'
      (subst (S' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.absent
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S'∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.absent
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  | no  S''∉canθ-p-θ←[S] | yes S''∈canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
        | cong (Canθₛ sigs (suc S'') p)
           (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))
  = ⊥-elim
      (S''∉canθ-p-θ←[S]
        (canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S''
      (subst (S'' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S''∈canθ-p-θ'←[S])))
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs S' S'∈canθ-p-θ'
  | yes S''∈canθ-p-θ←[S] | no  S''∉canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛ-add-sig-monotonic sigs (suc S'') p θ (S'' ₛ) Signal.absent
      S' S'∈canθ-p-θ←[S↦absent]
  where S''∈[S'']      = Env.sig-∈-single (S'' ₛ) Signal.unknown
        S∈Domθ←[S'']   = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        S''∈Domθ←[S''] = Env.sig-←-monoʳ (S'' ₛ) ([S]-env (S'' ₛ)) θ S''∈[S'']
        θS≡⟨θ←[S'']⟩S  = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                           (Env.sig-∉-single S (S'' ₛ) Signal.absent
                             (S∉sigs ∘ here ∘ cong Signal.unwrap))
                           S∈Domθ←[S'']
        ⟨θ←[S'']⟩S''≡[S'']S'' = Env.sig-stats-←-right-irr' (S'' ₛ) θ ([S]-env (S'' ₛ))
                                  S''∈[S''] S''∈Domθ←[S'']
        S'∈canθ-p-θ←[S↦absent] =
          canθₛ-set-sig-monotonic sigs (suc S'') p S
            (θ ← [S]-env-absent (S'' ₛ))
            S∈Domθ←[S''] status
            (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
            (S∉sigs ∘ there) S'
            (subst (S' ∈_)
              (cong (Canθₛ sigs (suc S'') p)
                (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                        S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                        (Env.sig-∉-single S (S'' ₛ) Signal.absent
                          (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
              S'∈canθ-p-θ')

canθₛₕ-set-sig-monotonic [] S'' p S θ S∈ status θS≡unknown S∉sigs s s∈canθ-p-θ' =
  canₛₕ-set-sig-monotonic p S θ S∈ status θS≡unknown s s∈canθ-p-θ'
canθₛₕ-set-sig-monotonic (nothing ∷ sigs) S'' p S θ S∈ status θS≡unknown S∉sigs s s∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
  = canθₛₕ-set-sig-monotonic sigs (suc S'') p S θ S∈ status θS≡unknown S∉sigs
    s s∈canθ-p-θ'
canθₛₕ-set-sig-monotonic (just Signal.present ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs s s∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛₕ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-present (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) s
      (subst (s ∈_)
        (cong (Canθₛₕ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-present (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-present (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.present
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        s∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-present (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-present (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.present
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛₕ-set-sig-monotonic (just Signal.absent ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs s s∈canθ-p-θ'
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛₕ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-absent (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) s
      (subst (s ∈_)
        (cong (Canθₛₕ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.absent
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        s∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.absent
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛₕ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status θS≡unknown S∉sigs s s∈canθ-p-θ'
  with any (_≟_ S'') (Canθₛ sigs (suc S'') p (θ ← [S]-env (S'' ₛ)))
     | any (_≟_ S'') (Canθₛ sigs (suc S'') p ((Env.set-sig {S} θ S∈ status) ← [S]-env (S'' ₛ)))
canθₛₕ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs s s∈canθ-p-θ'
  | yes S''∈canθ-p-θ←[S] | yes S''∈canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛₕ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) s
      (subst (s ∈_)
        (cong (Canθₛₕ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        s∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛₕ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs s s∈canθ-p-θ'
  | no  S''∉canθ-p-θ←[S] | no  S''∉canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛₕ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env-absent (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) s
      (subst (s ∈_)
        (cong (Canθₛₕ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.absent
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        s∈canθ-p-θ')
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.absent
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛₕ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs s s∈canθ-p-θ'
  | no  S''∉canθ-p-θ←[S] | yes S''∈canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
        | cong (Canθₛₕ sigs (suc S'') p)
           (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))
  = ⊥-elim
      (S''∉canθ-p-θ←[S]
        (canθₛ-set-sig-monotonic sigs (suc S'') p S
      (θ ← [S]-env (S'' ₛ))
      S∈Domθ←[S''] status
      (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
      (S∉sigs ∘ there) S''
      (subst (S'' ∈_)
        (cong (Canθₛ sigs (suc S'') p)
          (sym (Env.sig-switch S status θ ([S]-env (S'' ₛ))
                  S∈ (Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈)
                  (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                    (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
        S''∈canθ-p-θ'←[S])))
  where S∈Domθ←[S'']  = Env.sig-←-monoˡ S θ ([S]-env (S'' ₛ)) S∈
        θS≡⟨θ←[S'']⟩S = Env.sig-←-∉-irr-stats' S θ ([S]-env (S'' ₛ)) S∈
                          (Env.sig-∉-single S (S'' ₛ) Signal.unknown
                            (S∉sigs ∘ here ∘ cong Signal.unwrap))
                          S∈Domθ←[S'']
canθₛₕ-set-sig-monotonic (just Signal.unknown ∷ sigs) S'' p S θ S∈ status
  θS≡unknown S∉sigs s s∈canθ-p-θ'
  | yes S''∈canθ-p-θ←[S] | no  S''∉canθ-p-θ'←[S]
  rewrite map-+-compose-suc S'' (SigMap.keys sigs)
        | +-comm S'' 0
  = canθₛₕ-add-sig-monotonic sigs (suc S'') p θ (S'' ₛ) Signal.absent
      s s∈canθ-p-θ←[S↦absent]
  where S''∈[S'']      = Env.sig-∈-single (S'' ₛ) Signal.unknown
        S∈Domθ←[S'']   = Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈
        S''∈Domθ←[S''] = Env.sig-←-monoʳ (S'' ₛ) ([S]-env (S'' ₛ)) θ S''∈[S'']
        θS≡⟨θ←[S'']⟩S  = Env.sig-←-∉-irr-stats' S θ ([S]-env-absent (S'' ₛ)) S∈
                           (Env.sig-∉-single S (S'' ₛ) Signal.absent
                             (S∉sigs ∘ here ∘ cong Signal.unwrap))
                           S∈Domθ←[S'']
        ⟨θ←[S'']⟩S''≡[S'']S'' = Env.sig-stats-←-right-irr' (S'' ₛ) θ ([S]-env (S'' ₛ))
                                  S''∈[S''] S''∈Domθ←[S'']
        s∈canθ-p-θ←[S↦absent] =
          canθₛₕ-set-sig-monotonic sigs (suc S'') p S
            (θ ← [S]-env-absent (S'' ₛ))
            S∈Domθ←[S''] status
            (trans (sym θS≡⟨θ←[S'']⟩S) θS≡unknown)
            (S∉sigs ∘ there) s
            (subst (s ∈_)
              (cong (Canθₛₕ sigs (suc S'') p)
                (sym (Env.sig-switch S status θ ([S]-env-absent (S'' ₛ))
                        S∈ (Env.sig-←-monoˡ S θ ([S]-env-absent (S'' ₛ)) S∈)
                        (Env.sig-∉-single S (S'' ₛ) Signal.absent
                          (S∉sigs ∘ here ∘ cong Signal.unwrap)))))
              s∈canθ-p-θ')

private -- re-defined and exported in Base; so we put it in private here
  [_↦_] : Signal → Signal.Status → Env
  [ S ↦ status ] = Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty

canθₛ-cong-←-add-sig-monotonic : ∀ sigs S'' p θ θ' S status →
  ∀ S' →
    S' ∈ Canθₛ sigs S'' p ((θ ← Θ SigMap.[ S ↦ status ] ShrMap.empty VarMap.empty) ← θ') →
    S' ∈ Canθₛ sigs S'' p ((θ ← [S]-env S) ← θ')
canθₛ-cong-←-add-sig-monotonic sigs S'' p θ θ' S status S' S'∈
  with Env.Sig∈ S θ'
... | yes S∈Domθ'
  rewrite sym (Env.←-assoc θ [ S ↦ status ] θ')
        | cong (θ ←_) (Env.←-single-overwrite-sig S status θ' S∈Domθ')
        | sym (Env.←-assoc θ ([S]-env S) θ')
        | cong (θ ←_) (Env.←-single-overwrite-sig S Signal.unknown θ' S∈Domθ')
  = S'∈
... | no  S∉Domθ'
  rewrite Env.←-assoc-comm θ ([S]-env S) θ'
            (Env.sig-single-notin-distinct S Signal.unknown θ' S∉Domθ')
  = canθₛ-add-sig-monotonic sigs S'' p (θ ← θ') S status S'
      (subst (S' ∈_)
        (cong (proj₁ ∘ Canθ sigs S'' p)
          (Env.←-assoc-comm θ [ S ↦ status ] θ'
            (Env.sig-single-notin-distinct S status θ' S∉Domθ')))
        S'∈)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Helper reflection functions
------------------------------------------------------------------------

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

module Tactic.RingSolver.Core.ReflectionHelp where

open import Agda.Builtin.Reflection

open import Data.List as List using (List; []; _∷_)
open import Data.Nat.Base as ℕ using (ℕ; suc; zero)
open import Data.Nat.GeneralisedArithmetic using (fold)
open import Data.Fin.Base as Fin using (Fin)
open import Data.Vec.Base as Vec using (Vec; []; _∷_)
open import Data.String using (String)
open import Data.Maybe.Base as Maybe using (Maybe; just; nothing)
open import Data.Product
open import Function
open import Level using (Level)
open import Reflection.Term
open import Reflection.Argument

open import Tactic.RingSolver.Core.NatSet as NatSet
private
  variable
    a : Level
    A : Set a

-- TO-DO - once `Reflection` is --safe after v1.3 a lot of this can be simplified

hlams : ∀ {n} → Vec String n → Term → Term
hlams vs xs = Vec.foldr (const Term) (λ v vs → lam hidden (abs v vs)) xs vs

vlams : ∀ {n} → Vec String n → Term → Term
vlams vs xs = Vec.foldr (const Term) (λ v vs → lam visible (abs v vs)) xs vs

getVisible : Arg Term → Maybe Term
getVisible (arg (arg-info visible relevant) x) = just x
getVisible _                                   = nothing

getArgs : ∀ n → Term → Maybe (Vec Term n)
getArgs n (def _ xs) = Maybe.map Vec.reverse (List.foldl f c (List.mapMaybe getVisible xs) n)
  where
  f : (∀ n → Maybe (Vec Term n)) → Term → ∀ n → Maybe (Vec Term n)
  f xs x zero    = just []
  f xs x (suc n) = Maybe.map (x ∷_) (xs n)

  c : ∀ n → Maybe (Vec Term n)
  c zero     = just []
  c (suc _ ) = nothing
getArgs _ _ = nothing

underPi : Term → ∃[ n ] (Vec String n × Term)
underPi = go (λ xs y → _ , xs , y)
  where
  go : (∀ {n} → Vec String n → Term → A) → Term → A
  go k (pi a (abs s x)) = go (k ∘ (s ∷_)) x
  go k t                = k [] t

curriedTerm : NatSet → Term
curriedTerm = List.foldr go (quote Vec.[] ⟨ con ⟩ 2 ⋯⟅∷⟆ []) ∘ NatSet.toList
  where
  go : ℕ → Term → Term
  go x xs = quote Vec._∷_ ⟨ con ⟩ 3 ⋯⟅∷⟆ var x [] ⟨∷⟩ xs ⟨∷⟩ []


------------------------------------------------------------------------
-- Code used to construct tactics aimed at making equational reasoning
-- proofs more readable
------------------------------------------------------------------------

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

open import Equality

module Tactic.By {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq

import Agda.Builtin.Bool as B
open import Agda.Builtin.Nat using (_==_)
open import Agda.Builtin.String

open import Prelude

open import List eq
open import Monad eq
open import Monad.State eq hiding (set)
open import TC-monad eq as TC hiding (Type)

-- Constructs the type of a "cong" function for functions with the
-- given number of arguments. The first argument must be a function
-- that constructs the type of equalities between its two arguments.

type-of-cong : (Term → Term → TC.Type) → ℕ → TC.Type
type-of-cong equality n = levels (suc n)
  where
  -- The examples below are given for n = 3.

  -- Generates x₁ x₂ x₃ or y₁ y₂ y₃.
  arguments : ℕ → ℕ → List (Arg Term)
  arguments delta (suc m) = varg (var (delta + 2 * m + 1 + n) []) ∷
                            arguments delta m
  arguments delta zero    = []

  -- Generates x₁ ≡ y₁ → x₂ ≡ y₂ → x₃ ≡ y₃ → f x₁ x₂ x₃ ≡ f y₁ y₂ y₃.
  equalities : ℕ → TC.Type
  equalities (suc m) =
    pi (varg (equality (var (1 + 2 * m + 1 + (n ∸ suc m)) [])
                       (var (0 + 2 * m + 1 + (n ∸ suc m)) []))) $
       abs "x≡y" $
       equalities m
  equalities zero =
    equality (var n (arguments 1 n))
             (var n (arguments 0 n))

  -- Generates A → B → C → D.
  function-type : ℕ → TC.Type
  function-type (suc m) = pi (varg (var (3 * n) []))
                             (abs "_" (function-type m))
  function-type zero    = var (3 * n) []

  -- Generates ∀ {x₁ y₁ x₂ y₂ x₃ y₃} → …
  variables : ℕ → TC.Type
  variables (suc m) =
    pi (harg unknown) $ abs "x"   $
    pi (harg unknown) $ abs "y"   $
       variables m
  variables zero    =
    pi (varg (function-type n)) $ abs "f" $
       equalities n

  -- Generates
  -- {A : Set a} {B : Set b} {C : Set c} {D : Set d} → ….
  types : ℕ → TC.Type
  types (suc m) = pi (harg (agda-sort (set (var n [])))) $ abs "A" $
                     types m
  types zero    = variables n

  -- Generates {a b c d : Level} → ….
  levels : ℕ → TC.Type
  levels (suc n) = pi (harg (def (quote Level) [])) $ abs "a" $
                      levels n
  levels zero    = types (suc n)

-- Used to mark the subterms that should be rewritten by the ⟨by⟩
-- tactic.
--
-- The idea to mark subterms in this way is taken from Bradley
-- Hardy, who used it in the Holes library
-- (https://github.com/bch29/agda-holes).

⟨_⟩ : ∀ {a} {A : Type a} → A → A
⟨_⟩ = id

{-# NOINLINE ⟨_⟩ #-}

module _
  (deconstruct-equality :
     TC.Type → TC (Maybe (Term × TC.Type × Term × Term)))
  -- Tries to deconstruct a type which is expected to be an equality,
  -- _≡_ {a = a} {A = A} x y, but in reduced form. Upon success the
  -- level a, the type A, the left-hand side x, and the right-hand
  -- side y are returned. If it is hard to determine a or A, then
  -- unknown can be returned instead. If the type does not have the
  -- right form, then nothing is returned.
  where

  private

    -- A variant of blockOnMeta which can print a debug message.

    blockOnMeta′ : {A : Type} → String → Meta → TC A
    blockOnMeta′ s m = do
      debugPrint "by" 20
        (strErr "by/⟨by⟩ is blocking on meta" ∷
         strErr (primShowMeta m) ∷ strErr "in" ∷ strErr s ∷ [])
      blockOnMeta m

    -- A variant of deconstruct-equality with the following
    -- differences:
    -- * If the type is a meta-variable, then the computation blocks.
    -- * If the type does not have the right form (and is not a
    --   meta-variable), then a type error is raised, and the given
    --   list is used as the error message.

    deconstruct-equality′ :
      List ErrorPart → TC.Type → TC (Term × TC.Type × Term × Term)
    deconstruct-equality′ err (meta m _) =
      blockOnMeta′ "deconstruct-equality′" m
    deconstruct-equality′ err t = do
      just r ← deconstruct-equality t
        where nothing → typeError err
      return r

    -- The computation apply-to-metas A t tries to apply the term t to
    -- as many fresh meta-variables as possible (based on its type,
    -- A). The type of the resulting term is returned.

    apply-to-metas : TC.Type → Term → TC (TC.Type × Term)
    apply-to-metas A t = apply A t =<< compute-args fuel [] A
      where
      -- Fuel, used to ensure termination.

      fuel : ℕ
      fuel = 100

      mutual

        compute-args :
          ℕ → List (Arg Term) → TC.Type → TC (List (Arg Term))
        compute-args zero _ _ =
          typeError (strErr "apply-to-metas failed" ∷ [])
        compute-args (suc n) args τ =
          compute-args′ n args =<< reduce τ

        compute-args′ :
          ℕ → List (Arg Term) → TC.Type → TC (List (Arg Term))
        compute-args′ n args (pi a@(arg i _) (abs _ τ)) =
          extendContext a $
          compute-args n (arg i unknown ∷ args) τ
        compute-args′ n args (meta x _) =
          blockOnMeta′ "apply-to-metas" x
        compute-args′ n args _ = return (reverse args)

  -- The ⟨by⟩ tactic.
  --
  -- The tactic ⟨by⟩ t is intended for use with goals of the form
  -- C [ ⟨ e₁ ⟩ ] ≡ e₂ (with some limitations). The tactic tries to
  -- generate the term cong (λ x → C [ x ]) t′, where t′ is t applied
  -- to as many meta-variables as possible (based on its type), and if
  -- that term fails to unify with the goal type, then the term
  -- cong (λ x → C [ x ]) (sym t′) is generated instead.

  module ⟨By⟩
    {Ctxt : Type}
    (context : TC Ctxt)
    -- A "context" type and a computation that computes some information
    -- related to the current context. The information is only
    -- guaranteed to be valid in the current context.
    (sym : Ctxt → Term → Term)
    -- An implementation of symmetry.
    (cong : Ctxt → Term → Term → Term → Term → Term)
    -- An implementation of cong. Arguments: left-hand side,
    -- right-hand side, function, equality.
    (cong-with-lhs-and-rhs : Bool)
    -- Should the cong function be applied to the "left-hand side" and
    -- the "right-hand side" (the two sides of the inferred type of
    -- the constructed equality proof), or should those arguments be
    -- left for Agda's unification machinery?
    where

    private

      -- A non-macro variant of ⟨by⟩ that returns the (first)
      -- constructed term.

      ⟨by⟩-tactic : ∀ {a} {A : Type a} → A → Term → TC Term
      ⟨by⟩-tactic {A = A} t goal = do
        -- To avoid wasted work the first block below, which can block
        -- the tactic, is run before the second one.

        goal-type       ← reduce =<< inferType goal
        _ , _ , lhs , _ ← deconstruct-equality′ err₁ goal-type
        f               ← construct-context lhs

        A     ← quoteTC A
        t     ← quoteTC t
        A , t ← apply-to-metas A t

        if not cong-with-lhs-and-rhs
          then conclude unknown unknown f t
          else do
            A                 ← reduce A
            _ , _ , lhs , rhs ← deconstruct-equality′ err₂ A
            conclude lhs rhs f t
        where
        err₁ = strErr "⟨by⟩: ill-formed goal"  ∷ []
        err₂ = strErr "⟨by⟩: ill-formed proof" ∷ []

        try : Term → TC ⊤
        try t = do
          debugPrint "by" 10 $
            strErr "Term tried by ⟨by⟩:" ∷ termErr t ∷ []
          unify t goal

        conclude : Term → Term → Term → Term → TC Term
        conclude lhs rhs f t = do
          ctxt ← context
          let t₁ = cong ctxt lhs rhs f t
              t₂ = cong ctxt rhs lhs f (sym ctxt t)
          catchTC (try t₁) (try t₂)
          return t₁

        mutual

          -- The natural number argument is the variable that should
          -- be used for the hole. The natural number in the state is
          -- the number of occurrences of the marker that have been
          -- found.

          -- The code traverses arguments from right to left: in some
          -- cases it is better to block on the last meta-variable
          -- than the first one (because the first one might get
          -- instantiated before the last one, so when the last one is
          -- instantiated all the others have hopefully already been
          -- instantiated).

          context-term : ℕ → Term → StateT ℕ TC Term
          context-term n = λ where
            (def f args)  → if eq-Name f (quote ⟨_⟩)
                            then modify suc >> return (var n [])
                            else def f ⟨$⟩ context-args n args
            (var x args)  → var (weaken-var n 1 x) ⟨$⟩
                            context-args n args
            (con c args)  → con c ⟨$⟩ context-args n args
            (lam v t)     → lam v ⟨$⟩ context-abs n t
            (pi a b)      → flip pi ⟨$⟩ context-abs n b ⊛ context-arg n a
            (meta m _)    → liftʳ $ blockOnMeta′ "construct-context" m
            t             → return (weaken-term n 1 t)

          context-abs : ℕ → Abs Term → StateT ℕ TC (Abs Term)
          context-abs n (abs s t) = abs s ⟨$⟩ context-term (suc n) t

          context-arg : ℕ → Arg Term → StateT ℕ TC (Arg Term)
          context-arg n (arg i t) = arg i ⟨$⟩ context-term n t

          context-args :
            ℕ → List (Arg Term) → StateT ℕ TC (List (Arg Term))
          context-args n = λ where
            []       → return []
            (a ∷ as) → flip _∷_ ⟨$⟩ context-args n as ⊛ context-arg n a

        construct-context : Term → TC Term
        construct-context lhs = do
          debugPrint "by" 20
            (strErr "⟨by⟩ was given the left-hand side" ∷
             termErr lhs ∷ [])
          body , n ← run (context-term 0 lhs) 0
          case n of λ where
            (suc _) → return (lam visible (abs "x" body))
            zero    → typeError $
              strErr "⟨by⟩: no occurrence of ⟨_⟩ found" ∷ []

    macro

      -- The ⟨by⟩ tactic.

      ⟨by⟩ : ∀ {a} {A : Type a} → A → Term → TC ⊤
      ⟨by⟩ t goal = do
        ⟨by⟩-tactic t goal
        return _

      -- Unit tests can be found in Tactic.By.Parametrised.Tests,
      -- Tactic.By.Propositional, Tactic.By.Path and Tactic.By.Id.

      -- If ⟨by⟩ t would have been successful, then debug-⟨by⟩ t
      -- raises an error message that includes the (first) term that
      -- would have been constructed by ⟨by⟩.

      debug-⟨by⟩ : ∀ {a} {A : Type a} → A → Term → TC ⊤
      debug-⟨by⟩ t goal = do
        t ← ⟨by⟩-tactic t goal
        typeError (strErr "Term found by ⟨by⟩:" ∷ termErr t ∷ [])

  -- The by tactic.

  module By
    (sym : Term → Term)
    -- An implementation of symmetry.
    (equality : Term → Term → TC.Type)
    -- Constructs the type of equalities between its two arguments.
    (refl : Term → Term → Term → Term)
    -- An implementation of reflexivity. Should take a level a, a type
    -- A : Set a, and a value x : A, and return a proof of x ≡ x.
    (make-cong : ℕ → TC Name)
    -- The computation make-cong n should generate a "cong" function
    -- for functions with n arguments. The type of this function
    -- should match that generated by type-of-cong equality n. (The
    -- functions are used fully applied, and implicit arguments are
    -- not given explicitly, so hopefully the ordering of implicit
    -- arguments with respect to each other and the explicit arguments
    -- does not matter.)
    (extra-check-in-try-refl : Bool)
    -- When the by tactic tries to solve a subgoal using reflexivity,
    -- should it make sure that, afterwards, the goal meta-variable
    -- reduces to something that is not a meta-variable?
    where

    private

      -- The call by-tactic t goal tries to use (non-dependent) "cong"
      -- functions, reflexivity and t (via refine) to solve the given
      -- goal (which must be an equality).
      --
      -- The constructed term is returned.

      by-tactic : ∀ {a} {A : Type a} → A → Term → TC Term
      by-tactic {A = A} t goal = do
        A ← quoteTC A
        t ← quoteTC t
        _ , t ← apply-to-metas A t
        by-tactic′ fuel t goal
        where
        -- Fuel, used to ensure termination. (Termination could
        -- perhaps be proved in some way, but using fuel was easier.)

        fuel : ℕ
        fuel = 100

        -- The tactic's main loop.

        by-tactic′ : ℕ → Term → Term → TC Term
        by-tactic′ zero    _ _    = typeError
                                      (strErr "by: no more fuel" ∷ [])
        by-tactic′ (suc n) t goal = do
          goal-type ← reduce =<< inferType goal
          block-if-meta goal-type
          catchTC (try-refl goal-type) $
            catchTC (try t) $
              catchTC (try (sym t)) $
                try-cong goal-type
          where
          -- Error messages.

          ill-formed : List ErrorPart
          ill-formed = strErr "by: ill-formed goal" ∷ []

          failure : {A : Type} → TC A
          failure = typeError (strErr "by failed" ∷ [])

          -- Blocks if the goal type is not sufficiently concrete.
          -- Raises a type error if the goal type is not an equality.

          block-if-meta : TC.Type → TC ⊤
          block-if-meta type = do
            eq ← deconstruct-equality′ ill-formed type
            case eq of λ where
              (_ , _ , meta m _ , _) → blockOnMeta′
                                         "block-if-meta (left)"  m
              (_ , _ , _ , meta m _) → blockOnMeta′
                                         "block-if-meta (right)" m
              _                      → return _

          -- Tries to solve the goal using reflexivity.

          try-refl : TC.Type → TC Term
          try-refl type = do
            a , A , lhs , _ ← deconstruct-equality′ ill-formed type

            let t′ = refl a A lhs
            unify t′ goal

            if not extra-check-in-try-refl
              then return t′
              else do
              -- If unification succeeds, but the goal is solved by a
              -- meta-variable, then this attempt is aborted. (A check
              -- similar to this one was suggested by Ulf Norell.)
              -- Potential future improvement: If unification results
              -- in unsolved constraints, block until progress has
              -- been made on those constraints.
              goal ← reduce goal
              case goal of λ where
                (meta _ _) → failure
                _          → return t′

          -- Tries to solve the goal using the given term.

          try : Term → TC Term
          try t = do
            unify t goal
            return t

          -- Tries to solve the goal using one of the "cong"
          -- functions.

          try-cong : TC.Type → TC Term
          try-cong type = do
            _ , _ , y , z  ← deconstruct-equality′ ill-formed type
            head , ys , zs ← heads y z
            args           ← arguments ys zs
            cong           ← make-cong (length args)
            let t = def cong (varg head ∷ args)
            unify t goal
            return t
            where
            -- Checks if the heads are equal. If they are, then the
            -- function figures out how many arguments are equal, and
            -- returns the (unique) head applied to these arguments,
            -- plus two lists containing the remaining arguments.

            heads : Term → Term →
                    TC (Term × List (Arg Term) × List (Arg Term))
            heads = λ
              { (def y ys) (def z zs) → helper (primQNameEquality y z)
                                               (def y) (def z) ys zs
              ; (con y ys) (con z zs) → helper (primQNameEquality y z)
                                               (con y) (con z) ys zs
              ; (var y ys) (var z zs) → helper (y == z)
                                               (var y) (var z) ys zs
              ; _          _          → failure
              }
              where
              find-equal-arguments :
                List (Arg Term) → List (Arg Term) →
                List (Arg Term) × List (Arg Term) × List (Arg Term)
              find-equal-arguments []       zs       = [] , [] , zs
              find-equal-arguments ys       []       = [] , ys , []
              find-equal-arguments (y ∷ ys) (z ∷ zs) with eq-Arg y z
              ... | false = [] , y ∷ ys , z ∷ zs
              ... | true  with find-equal-arguments ys zs
              ...   | (es , ys′ , zs′) = y ∷ es , ys′ , zs′

              helper : B.Bool → _ → _ → _ → _ → _
              helper B.false y z _  _  =
                typeError (strErr "by: distinct heads:" ∷
                           termErr (y []) ∷ termErr (z []) ∷ [])
              helper B.true  y _ ys zs =
                let es , ys′ , zs′ = find-equal-arguments ys zs in
                return (y es , ys′ , zs′)

            -- Tries to prove that the argument lists are equal.

            arguments : List (Arg Term) → List (Arg Term) →
                        TC (List (Arg Term))
            arguments [] []                             = return []
            arguments (arg (arg-info visible _) y ∷ ys)
                      (arg (arg-info visible _) z ∷ zs) = do
                       -- Relevance is ignored.

              goal ← checkType unknown (equality y z)
              t    ← by-tactic′ n t goal
              args ← arguments ys zs
              return (varg t ∷ args)

            -- Hidden and instance arguments are ignored.

            arguments (arg (arg-info hidden _) _ ∷ ys) zs    = arguments ys zs
            arguments (arg (arg-info instance′ _) _ ∷ ys) zs = arguments ys zs
            arguments ys (arg (arg-info hidden _) _ ∷ zs)    = arguments ys zs
            arguments ys (arg (arg-info instance′ _) _ ∷ zs) = arguments ys zs

            arguments _ _ = failure

    macro

      -- The call by t tries to use t (along with congruence,
      -- reflexivity and symmetry) to solve the goal, which must be an
      -- equality.

      by : ∀ {a} {A : Type a} → A → Term → TC ⊤
      by t goal = do
        by-tactic t goal
        return _

      -- Unit tests can be found in Tactic.By.Propositional,
      -- Tactic.By.Path and Tactic.By.Id.

      -- If by t would have been successful, then debug-by t raises an
      -- error message that includes the term that would have been
      -- constructed by by.

      debug-by : ∀ {a} {A : Type a} → A → Term → TC ⊤
      debug-by t goal = do
        t ← by-tactic t goal
        typeError (strErr "Term found by by:" ∷ termErr t ∷ [])

    -- A definition that provides no information. Intended to be used
    -- together with the by tactic: "by definition".

    definition : ⊤
    definition = _

-- A module that exports both tactics. The "context" type is not
-- supported.

module Tactics
  (deconstruct-equality :
     TC.Type → TC (Maybe (Term × TC.Type × Term × Term)))
  (equality : Term → Term → TC.Type)
  (refl : Term → Term → Term → Term)
  (sym : Term → Term)
  (cong : Term → Term → Term → Term → Term)
  (cong-with-lhs-and-rhs : Bool)
  (make-cong : ℕ → TC Name)
  (extra-check-in-try-refl : Bool)
  where

  open ⟨By⟩ deconstruct-equality (return tt) (λ _ → sym) (λ _ → cong)
            cong-with-lhs-and-rhs public
  open By deconstruct-equality sym equality refl make-cong
          extra-check-in-try-refl public


open import Prelude hiding (id; Bool)

module Implicits.Resolution.Deterministic.Incomplete where

open import Implicits.Syntax
open import Implicits.WellTyped
open import Implicits.Substitutions

open import Data.Product
open import Data.List hiding ([_])
open import Data.List.Any
open Membership-≡
open import Extensions.ListFirst

Bool : Type 0
Bool = simpl $ tc 0

Int : Type 0
Int = simpl $ tc 1

-- We'll proof incompleteness with a simple example that we'll be able to resolve
-- using the ambigous resolution rules, but not with the deterministic rules.
-- This proofs that the ambiguous rules are stronger, such that together with Oliveira's
-- proof that determinstic resolution is sound w.r.t. ambiguous resolution, we have the
-- result that deterministic resolution is incomplete (or ambiguous resolution is strictly stronger)

Δ : ICtx 0
Δ = (Int ⇒ Bool) ∷ Bool List.∷ List.[]

open import Implicits.Resolution.Deterministic.Resolution as D
open import Implicits.Resolution.Ambiguous.Resolution as A
open import Extensions.ListFirst

private
  -- proof that Bool is not derivable under the deterministic resolution rules
  deterministic-cant : ¬ (Δ D.⊢ᵣ Bool)
  deterministic-cant (r-simp fst fst↓bool) with
    FirstLemmas.first-unique (here (m-iabs m-simp) (Bool List.∷ List.[])) fst
  deterministic-cant (r-simp fst (i-iabs (r-simp r _) b)) | refl = ¬r◁Int (, r)
    where
      ¬r◁Int : ¬ (∃ λ r → Δ ⟨ tc 1 ⟩= r)
      ¬r◁Int (._ , here (m-iabs ()) ._)
      ¬r◁Int (._ , there _ _ (here () .List.[]))
      ¬r◁Int ( _ , there _ _ (there _ _ ()))

  -- proof that Bool is derivable under the "Ambiguous" resolution rules
  ambiguous-can : Δ A.⊢ᵣ Bool
  ambiguous-can = r-ivar (there (here refl))

incomplete : ∃ λ ν → ∃₂ λ (Δ : ICtx ν) r → (Δ A.⊢ᵣ r) × (¬ Δ D.⊢ᵣ r)
incomplete = , (Δ , (Bool , (ambiguous-can , deterministic-cant)))


module erase where

open import syntax-util
open import lib
open import cedille-types
open import general-util
open import constants
open import is-free

{-# TERMINATING #-}
erase : { ed : exprd } → ⟦ ed ⟧ → ⟦ ed ⟧
erase-term : term → term
erase-type : type → type
erase-kind : kind → kind
erase-lterms : term → lterms → term
erase-tk : tk → tk
erase-liftingType : liftingType → liftingType
erase-cases : cases → cases
erase-case : case → case
erase-caseArgs : caseArgs → caseArgs
erase-term-args : args → 𝕃 term

erase-if : 𝔹 → { ed : exprd } → ⟦ ed ⟧ → ⟦ ed ⟧
erase-if tt = erase
erase-if ff = id

erase-term (Parens _ t _) = erase-term t
erase-term (App t1 Erased t2) = erase-term t1
erase-term (App t1 NotErased t2) = App (erase-term t1) NotErased (erase-term t2)
erase-term (AppTp t tp) = erase-term t
erase-term (Lam _ Erased _ _ _ t) = erase-term t
erase-term (Lam _ NotErased _ x oc t) = Lam posinfo-gen NotErased posinfo-gen x NoClass (erase-term t)
erase-term (Let _ NotErased (DefTerm _ x _ t) t') =
  let body = erase-term t'
  in if is-free-in skip-erased x t'
     then Let posinfo-gen ff (DefTerm posinfo-gen x NoType (erase-term t)) body
     -- if x does not occur in an unerase position in t', then the binding is irrelevant in the erasure
     else body
erase-term (Let _ Erased (DefTerm _ x _ t) t') = erase-term t'
erase-term (Let _ _ (DefType _ _ _ _) t) = erase-term t
erase-term (Open _ _ _ _ t) = erase-term t
erase-term (Var _ x) = Var posinfo-gen x
erase-term (Beta _ _ NoTerm) = id-term
erase-term (Beta _ _ (SomeTerm t _)) = erase-term t
erase-term (IotaPair _ t1 t2 _ _) = erase-term t1
erase-term (IotaProj t n _) = erase-term t
erase-term (Epsilon _ lr _ t) = erase-term t
erase-term (Sigma _ t) = erase-term t
erase-term (Hole pi) = Hole pi -- Retain position, so jumping to hole works
erase-term (Phi _ t t₁ t₂ _) = erase-term t₂
erase-term (Rho _ _ _ t _ t') = erase-term t'
erase-term (Chi _ T t') = erase-term t'
erase-term (Delta _ T t) = id-term
erase-term (Theta _ u t ls) = erase-lterms (erase-term t) ls
erase-term (Mu _ _ x t ot _ c _) = Mu posinfo-gen posinfo-gen x (erase-term t) NoType posinfo-gen (erase-cases c) posinfo-gen
erase-term (Mu' _ _ t _ _ c _)  = Mu' posinfo-gen NoTerm (erase-term t) NoType posinfo-gen (erase-cases c) posinfo-gen

erase-cases = map erase-case

erase-case (Case _ x as t) = Case posinfo-gen x (erase-caseArgs as) (erase-term t)

erase-caseArgs [] = []
erase-caseArgs ((CaseTermArg pi NotErased t) :: as) = CaseTermArg posinfo-gen NotErased t :: erase-caseArgs as
erase-caseArgs (_ :: as) = erase-caseArgs as

erase-term-args [] = []
erase-term-args (TermArg NotErased t :: as) = erase t :: erase-term-args as
erase-term-args (_ :: as) = erase-term-args as

-- Only erases TERMS in types, leaving the structure of types the same
erase-type (Abs _ b _ v atk tp) = Abs posinfo-gen b posinfo-gen v (erase-tk atk) (erase-type tp)
erase-type (Iota _ _ v otp tp) = Iota posinfo-gen posinfo-gen v (erase-type otp) (erase-type tp)
erase-type (Lft _ _ v t lt) = Lft posinfo-gen posinfo-gen v (erase-term t) (erase-liftingType lt)
erase-type (NoSpans tp _) = NoSpans (erase-type tp) posinfo-gen
erase-type (TpApp tp tp') = TpApp (erase-type tp) (erase-type tp')
erase-type (TpAppt tp t) = TpAppt (erase-type tp) (erase-term t)
erase-type (TpArrow tp at tp') = TpArrow (erase-type tp) at (erase-type tp')
erase-type (TpEq _ t t' _) = TpEq posinfo-gen (erase-term t) (erase-term t') posinfo-gen
erase-type (TpLambda _ _ v atk tp) = TpLambda posinfo-gen posinfo-gen v (erase-tk atk) (erase-type tp)
erase-type (TpParens _ tp _) = erase-type tp
erase-type (TpHole pi) = TpHole pi -- Retain position, so jumping to hole works
erase-type (TpVar _ x) = TpVar posinfo-gen x
erase-type (TpLet _ (DefTerm _ x _ t) T) = TpLet posinfo-gen (DefTerm posinfo-gen x NoType (erase-term t)) (erase-type T)
erase-type (TpLet _ (DefType _ x k T) T') = TpLet posinfo-gen (DefType posinfo-gen x (erase-kind k) (erase-type T)) (erase-type T')

-- Only erases TERMS in types in kinds, leaving the structure of kinds and types in those kinds the same
erase-kind (KndArrow k k') = KndArrow (erase-kind k) (erase-kind k')
erase-kind (KndParens _ k _) = erase-kind k
erase-kind (KndPi _ _ v atk k) = KndPi posinfo-gen posinfo-gen v (erase-tk atk) (erase-kind k)
erase-kind (KndTpArrow tp k) = KndTpArrow (erase-type tp) (erase-kind k)
erase-kind (KndVar _ x ps) = KndVar posinfo-gen x ps
erase-kind (Star _) = Star posinfo-gen

erase{TERM} t = erase-term t
erase{TYPE} tp = erase-type tp
erase{KIND} k = erase-kind k
erase{LIFTINGTYPE} lt = erase-liftingType lt
erase{TK} atk = erase-tk atk
erase{ARG} a = a
erase{QUALIF} q = q

erase-tk (Tkt tp) = Tkt (erase-type tp)
erase-tk (Tkk k) = Tkk (erase-kind k)

erase-liftingType (LiftArrow lt lt') = LiftArrow (erase-liftingType lt) (erase-liftingType lt')
erase-liftingType (LiftParens _ lt _) = erase-liftingType lt
erase-liftingType (LiftPi _ v tp lt) = LiftPi posinfo-gen v (erase-type tp) (erase-liftingType lt)
erase-liftingType (LiftTpArrow tp lt) = LiftTpArrow (erase-type tp) (erase-liftingType lt)
erase-liftingType lt = lt

erase-lterms t [] = t
erase-lterms t ((Lterm Erased t') :: ls) = erase-lterms t ls
erase-lterms t ((Lterm NotErased t') :: ls) = erase-lterms (App t NotErased (erase-term t')) ls