{-
This file proves the monotonicity of potential function over reductions.
CorrectBinding is required in order to guarantee that SI and SC introduced
by the loop never accidentally capture signals in the loop body.

canₖ-monotonic : ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ k →
    k ∈ Canₖ r' θ →
    k ∈ Canₖ r θ

canₛ-monotonic : ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ S' →
    Signal.unwrap S' ∈ Canₛ r' θ →
    Signal.unwrap S' ∈ Canₛ r θ

canₛₕ-monotonic : ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ s' →
    SharedVar.unwrap s' ∈ Canₛₕ r' θ →
    SharedVar.unwrap s' ∈ Canₛₕ r θ

In addition to the main lemmas, there are various random small propositions
dealing with the computatin of the calculation of Can in the loop body
(the big ρ-θ-emit-present term introduced by the loop-unroll rule).
-}
module can-function-preserve where

open import sn-calculus
open import utility

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.Properties
open import Esterel.Lang.CanFunction
open import Esterel.Lang.CanFunction.Properties
open import Esterel.Context
  using (EvaluationContext1 ; EvaluationContext ; _⟦_⟧e ; _≐_⟦_⟧e)
open import Esterel.Context.Properties
  using (unplug ; Erefl)
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; Dom ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import Esterel.Variable.Signal as Signal
  using (Signal ; _ₛ)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar ; _ₛₕ)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)

open import Data.Bool
  using (Bool ; true ; false ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; [] ; _∷_ ; _++_ ; map ; concatMap ; foldr)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using (++⁻)
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _≟_ ; _+_)
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 EvaluationContext1
open _≐_⟦_⟧e

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

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

canₛ-present-lemma : ∀ S p q θ →
  ∀ S' →
    Signal.unwrap S' ∈ Canₛ (present S ∣⇒ p ∣⇒ q) θ →
    Signal.unwrap S' ∈ Canₛ p θ ⊎ Signal.unwrap S' ∈ Canₛ q θ
canₛ-present-lemma S p q θ S' S'∈can-present with Env.Sig∈ S θ
canₛ-present-lemma S p q θ S' S'∈can-present | yes S∈
  with Env.sig-stats {S} θ S∈
... | Signal.present = inj₁ S'∈can-present
... | Signal.absent  = inj₂ S'∈can-present
... | Signal.unknown = ++⁻ (Canₛ p θ) S'∈can-present
canₛ-present-lemma S p q θ S' S'∈can-present | no  S∉ =
  ++⁻ (Canₛ p θ) S'∈can-present

canₛₕ-present-lemma : ∀ S p q θ →
  Canₛₕ p θ ≡ [] → Canₛₕ q θ ≡ [] →
  Canₛₕ (present S ∣⇒ p ∣⇒ q) θ ≡ []
canₛₕ-present-lemma S p q θ can-p≡[] can-q≡[] with Env.Sig∈ S θ
canₛₕ-present-lemma S p q θ can-p≡[] can-q≡[] | yes S∈
  with Env.sig-stats {S} θ S∈
... | Signal.present = can-p≡[]
... | Signal.absent  = can-q≡[]
... | Signal.unknown rewrite can-p≡[] | can-q≡[] = refl
canₛₕ-present-lemma S p q θ can-p≡[] can-q≡[] | no  S∉
  rewrite can-p≡[] | can-q≡[] = refl

canₖ-monotonic : ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ k →
    k ∈ Canₖ r' θ →
    k ∈ Canₖ r θ

canₛ-monotonic : ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ S' →
    Signal.unwrap S' ∈ Canₛ r' θ →
    Signal.unwrap S' ∈ Canₛ r θ

canₛₕ-monotonic : ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ s' →
    SharedVar.unwrap s' ∈ Canₛₕ r' θ →
    SharedVar.unwrap s' ∈ Canₛₕ r θ

canθₖ-monotonic : ∀ sigs S' → ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ k →
    k ∈ Canθₖ sigs S' r' θ →
    k ∈ Canθₖ sigs S' r θ

canθₛ-monotonic : ∀ sigs S'' → ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ S' →
    Signal.unwrap S' ∈ Canθₛ sigs S'' r' θ →
    Signal.unwrap S' ∈ Canθₛ sigs S'' r θ

canθₛₕ-monotonic : ∀ sigs S' → ∀ {BV FV} θ r r' →
  CorrectBinding r BV FV →
  r sn⟶₁ r' →
  ∀ s' →
    SharedVar.unwrap s' ∈ Canθₛₕ sigs S' r' θ →
    SharedVar.unwrap s' ∈ Canθₛₕ sigs S' r θ

canθₖ-monotonic [] S' cb red = canₖ-monotonic cb red
canθₖ-monotonic (nothing ∷ sigs) S' = canθₖ-monotonic sigs (suc S')
canθₖ-monotonic (just Signal.present ∷ sigs) S' θ
  = canθₖ-monotonic sigs (suc S') (θ ← _)
canθₖ-monotonic (just Signal.absent ∷ sigs) S' θ
  = canθₖ-monotonic sigs (suc S') (θ ← _)
canθₖ-monotonic (just Signal.unknown ∷ sigs) S' θ r r' cb red
  with any (_≟_ S') (Canθₛ sigs (suc S') r  (θ ← ([S]-env (S' ₛ))))
     | any (_≟_ S') (Canθₛ sigs (suc S') r' (θ ← ([S]-env (S' ₛ))))
... | yes S'∈Canr | yes S'∈Canr' = canθₖ-monotonic sigs (suc S') (θ ← [S]-env (S' ₛ)) r r' cb red
... | no  S'∉Canr | no  S'∉Canr' = canθₖ-monotonic sigs (suc S') (θ ← [S]-env-absent (S' ₛ)) r r' cb red
... | no  S'∉Canr | yes S'∈Canr'
  = ⊥-elim (S'∉Canr (canθₛ-monotonic sigs (suc S') (θ ← [S]-env (S' ₛ)) r r' cb red (S' ₛ) S'∈Canr'))
... | yes S'∈Canr | no  S'∉Canr'
   with (canθₖ-monotonic sigs (suc S') (θ ← [S]-env-absent (S' ₛ)) r r' cb red)
... | rec rewrite sym (Env.sig-set-clobber-single-as-← (S' ₛ) Signal.absent Signal.unknown θ (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ))
  = λ k k∈ →  canθₖ-set-sig-monotonic sigs (suc S') r (S' ₛ) (θ ← [S]-env (S' ₛ))
                                      (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ) Signal.absent
                                      (Env.sig-stats-1map-right-← (S' ₛ) Signal.unknown θ (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ))
                                      (n∉map-suc-n-+ S' (SigM.Dom' sigs))
                                      k (rec k k∈)

canθₛ-monotonic [] S' cb red = canₛ-monotonic cb red
canθₛ-monotonic (nothing ∷ sigs) S' = canθₛ-monotonic sigs (suc S')
canθₛ-monotonic (just Signal.present ∷ sigs) S' θ
  = canθₛ-monotonic sigs (suc S') (θ ← _)
canθₛ-monotonic (just Signal.absent ∷ sigs) S' θ
  = canθₛ-monotonic sigs (suc S') (θ ← _)
canθₛ-monotonic (just Signal.unknown ∷ sigs) S' θ r r' cb red
  with any (_≟_ S') (Canθₛ sigs (suc S') r  (θ ← ([S]-env (S' ₛ))))
     | any (_≟_ S') (Canθₛ sigs (suc S') r' (θ ← ([S]-env (S' ₛ))))
... | yes S'∈Canr | yes S'∈Canr' = canθₛ-monotonic sigs (suc S') (θ ← [S]-env (S' ₛ)) r r' cb red
... | no  S'∉Canr | no  S'∉Canr' = canθₛ-monotonic sigs (suc S') (θ ← [S]-env-absent (S' ₛ)) r r' cb red
... | no  S'∉Canr | yes S'∈Canr'
  = ⊥-elim (S'∉Canr (canθₛ-monotonic sigs (suc S') (θ ← [S]-env (S' ₛ)) r r' cb red (S' ₛ) S'∈Canr'))
... | yes S'∈Canr | no  S'∉Canr'
   with (canθₛ-monotonic sigs (suc S') (θ ← [S]-env-absent (S' ₛ)) r r' cb red)
... | rec rewrite sym (Env.sig-set-clobber-single-as-← (S' ₛ) Signal.absent Signal.unknown θ (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ))
  = λ k k∈ →  canθₛ-set-sig-monotonic sigs (suc S') r (S' ₛ) (θ ← [S]-env (S' ₛ))
                                      (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ) Signal.absent
                                      (Env.sig-stats-1map-right-← (S' ₛ) Signal.unknown θ (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ))
                                      (n∉map-suc-n-+ S' (SigM.Dom' sigs))
                                      (Signal.unwrap k) (rec k k∈)

canθₛₕ-monotonic [] S' cb red = canₛₕ-monotonic cb red
canθₛₕ-monotonic (nothing ∷ sigs) S' = canθₛₕ-monotonic sigs (suc S')
canθₛₕ-monotonic (just Signal.present ∷ sigs) S' θ
  = canθₛₕ-monotonic sigs (suc S') (θ ← _)
canθₛₕ-monotonic (just Signal.absent ∷ sigs) S' θ
  = canθₛₕ-monotonic sigs (suc S') (θ ← _)
canθₛₕ-monotonic (just Signal.unknown ∷ sigs) S' θ r r' cb red
  with any (_≟_ S') (Canθₛ sigs (suc S') r  (θ ← ([S]-env (S' ₛ))))
     | any (_≟_ S') (Canθₛ sigs (suc S') r' (θ ← ([S]-env (S' ₛ))))
... | yes S'∈Canr | yes S'∈Canr' = canθₛₕ-monotonic sigs (suc S') (θ ← [S]-env (S' ₛ)) r r' cb red
... | no  S'∉Canr | no  S'∉Canr' = canθₛₕ-monotonic sigs (suc S') (θ ← [S]-env-absent (S' ₛ)) r r' cb red
... | no  S'∉Canr | yes S'∈Canr'
  = ⊥-elim (S'∉Canr (canθₛ-monotonic sigs (suc S') (θ ← [S]-env (S' ₛ)) r r' cb red (S' ₛ) S'∈Canr'))
... | yes S'∈Canr | no  S'∉Canr'
   with (canθₛₕ-monotonic sigs (suc S') (θ ← [S]-env-absent (S' ₛ)) r r' cb red)
... | rec rewrite sym (Env.sig-set-clobber-single-as-← (S' ₛ) Signal.absent Signal.unknown θ (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ))
  = λ k k∈ →  canθₛₕ-set-sig-monotonic sigs (suc S') r (S' ₛ) (θ ← [S]-env (S' ₛ))
                                      (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ) Signal.absent
                                      (Env.sig-stats-1map-right-← (S' ₛ) Signal.unknown θ (Env.sig-∈-single-right-← (S' ₛ) Signal.unknown θ))
                                      (n∉map-suc-n-+ S' (SigM.Dom' sigs))
                                      (SharedVar.unwrap k) (rec k k∈)

canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-right hnothin q/done) k k∈can-r'-θ =
  any-map⁺² {xs = Code.nothin ∷ []} (λ k' → map (Code._⊔_ k') (Canₖ q θ))
    (here refl) (any-map⁺ (Code._⊔_ Code.nothin) k∈can-r'-θ)
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-right (hexit n) (dhalted hnothin)) k k∈can-r'-θ =
  k∈can-r'-θ
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-right (hexit n) (dhalted (hexit m))) k k∈can-r'-θ =
  k∈can-r'-θ
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-right (hexit n) (dpaused q/paused)) k k∈can-r'-θ
  rewrite canₖ-paused θ q/paused
  = k∈can-r'-θ
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left (dhalted hnothin) q/halted) k k∈can-r'-θ =
  any-map⁺² {xs = Code.nothin ∷ []} (λ k' → map (Code._⊔_ k') (Canₖ q θ))
    (here refl) (any-map⁺ (Code._⊔_ Code.nothin) k∈can-r'-θ)
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left (dhalted (hexit n)) hnothin) k k∈can-r'-θ =
  k∈can-r'-θ
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left (dhalted (hexit n)) (hexit m)) k k∈can-r'-θ =
  k∈can-r'-θ
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left (dpaused p/paused) hnothin) k k∈can-r'-θ
  rewrite canₖ-paused θ p/paused =
  k∈can-r'-θ
canₖ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left (dpaused p/paused) (hexit m)) k k∈can-r'-θ
  rewrite canₖ-paused θ p/paused =
  k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (ris-present {S = S} {p = p} {E = E} S∈ θ'S≡present r≐E⟦present⟧) k k∈can-r'-θ
  rewrite canθ-is-present (Env.sig θ') S∈ θ r≐E⟦present⟧  θ'S≡present
  =   k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (ris-absent {S = S} S∈ θ'S≡absent r≐E⟦present⟧) k k∈can-r'-θ
  rewrite canθ-is-absent (Env.sig θ') S∈ θ r≐E⟦present⟧ θ'S≡absent
  =  k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (remit {S = S} {E = E} S∈ θ'S≢absent r≐E⟦emit⟧) k k∈can-r'-θ
  = canθₖ-emit θ' S∈ θ r≐E⟦emit⟧ θ'S≢absent ((canθₛ-membership (Env.sig θ') 0 r θ S
                                                (λ θ* → canₛ-capture-emit-signal θ* r≐E⟦emit⟧)))
               k k∈can-r'-θ
canₖ-monotonic θ (loop r) r' cb rloop-unroll k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ .(nothin >> r') r' cb
  rseq-done k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ .(exit _ >> _) .(exit _) cb
  rseq-exit k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ .(loopˢ (exit _)  _) .(exit _) cb
  rloopˢ-exit k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ (suspend r S) .r cb
  (rsuspend-done r/halted) k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ (trap r) .nothin   cb
  (rtrap-done hnothin) k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ (trap r) .nothin   cb
  (rtrap-done (hexit zero)) k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ (trap r) .(exit n) cb
  (rtrap-done (hexit (suc n))) k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ (signl S r) r' cb
  rraise-signal k k∈can-r'-θ = k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rraise-shared {s = s} {e = e} {p = p} {E = E} e' r≐E⟦shared⟧) k k∈can-r'-θ
  rewrite sym (unplug r≐E⟦shared⟧)
        | sym (canθₖ-raise-lemma{A = WAIT} (Env.sig θ') 0 θ E (tshared (δ e') s e p))
  =   k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rset-shared-value-old {s = s} {e = e} {E = E} e' s∈ θ's≡old r≐E⟦s⇐e⟧) k k∈can-r'-θ
  rewrite canθ-shr-var-irr (Env.sig (Env.set-shr {s} θ' s∈ SharedVar.new (δ e'))) 0 r θ θ refl
        | sym (unplug r≐E⟦s⇐e⟧)
  =   canθₖ-term-nothin-lemma
      (Env.sig (Env.set-shr {s} θ' s∈ SharedVar.new (δ e')))
      0
      θ
      E (tset-shr s e) k k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rset-shared-value-new {s = s} {e = e} {E = E} e' s∈ θ's≡new r≐E⟦s⇐e⟧) k k∈can-r'-θ
  rewrite canθ-shr-var-irr (Env.sig (Env.set-shr {s} θ' s∈ SharedVar.new (Env.shr-vals {s} θ' s∈ + δ e')))
                           0 r θ θ refl
        | sym (unplug r≐E⟦s⇐e⟧)
  = canθₖ-term-nothin-lemma
      (Env.sig (Env.set-shr {s} θ' s∈ SharedVar.new (Env.shr-vals {s} θ' s∈ + δ e')))
      0
      θ
      E (tset-shr s e) k k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rraise-var {x = x} {p = p} {e = e} {E = E} e' r≐E⟦var⟧) k k∈can-r'-θ
  rewrite sym (unplug r≐E⟦var⟧)
        | (canθₖ-raise-lemma (Env.sig θ') 0 θ E (tvar (δ e') x e p))
  =  k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rset-var {x = x} {e = e} {E = E} x∈ e' r≐E⟦x≔e⟧) k k∈can-r'-θ
  rewrite canθ-shr-var-irr (Env.sig (Env.set-var {x} θ' x∈ (δ e'))) 0 r θ θ refl
        | sym (unplug r≐E⟦x≔e⟧)
  =  canθₖ-term-nothin-lemma
      (Env.sig (Env.set-var {x} θ' x∈ (δ e')))
      0
      θ
      E (tset-var x e) k k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rif-false {p = p} {q = q} {x = x} {E = E} x∈ θ'x≡zero r≐E⟦if⟧) k k∈can-r'-θ
  rewrite sym (unplug r≐E⟦if⟧)
  =  canθₖ-if-false-lemma (Env.sig θ' ) 0 x p q θ E k k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rif-true {p = p} {q = q} {x = x} {E = E} x∈ θ'x≡suc r≐E⟦if⟧) k k∈can-r'-θ
  rewrite sym (unplug r≐E⟦if⟧)
  =  canθₖ-if-true-lemma (Env.sig θ') 0 x p q θ E k k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rabsence {S = S} S∈ θ'S≡unknown S∉can-r-θ') k k∈can-r'-θ
  rewrite Env.sig-switch-right S Signal.absent θ θ' S∈ (Env.sig-←-monoʳ S θ' θ S∈)
  = canθₖ-set-sig-monotonic-absence-lemma (Env.sig θ') 0 r S θ  S∈
      θ'S≡unknown k k∈can-r'-θ
  where
    θ←θ'        = θ ← θ'
    S∈Domθ←θ'   = Env.sig-←-monoʳ S θ' θ S∈
    ⟨θ←θ'⟩S≡θ'S = Env.sig-stats-←-right-irr' S θ θ' S∈ S∈Domθ←θ'
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (rreadyness {s = s} s∈ θ's≡old⊎θ's≡new s∉can-r-θ') k k∈can-r'-θ
  rewrite can-shr-var-irr r (θ ← θ')
            (θ ← Env.set-shr {s} θ' s∈ SharedVar.ready (Env.shr-vals {s} θ' s∈)) refl
  = k∈can-r'-θ
canₖ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb@(CBρ cb')
  (rmerge {θ₁ = .θ'} {θ₂ = θ''} {p = rin} {E = E} r≐E⟦ρθ''·rin⟧) k k∈can-r'-θ
  = canθₖ-mergeˡ (Env.sig θ') θ cb' r≐E⟦ρθ''·rin⟧ k k∈can-r'-θ

canₛ-monotonic θ (p ∥ q) _ cb
  (rpar-done-right p/halted q/done) S' S'∈can-r'-θ
  rewrite canₛ-done θ (value-max-done (dhalted p/halted) q/done (inj₁ p/halted))
  with S'∈can-r'-θ
... | ()
canₛ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left p/done q/halted) S' S'∈can-r'-θ
  rewrite canₛ-done θ (value-max-done p/done (dhalted q/halted) (inj₂ q/halted))
  with S'∈can-r'-θ
... | ()
canₛ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (ris-present {S = S} S∈ θ'S≡present r≐E⟦present⟧) S' S'∈can-r'-θ
    rewrite canθ-is-present (Env.sig θ') S∈ θ r≐E⟦present⟧  θ'S≡present
  =  S'∈can-r'-θ
canₛ-monotonic θ (ρ⟨ θ' , A ⟩· r) r' cb
  (ris-absent {S = S} S∈ θ'S≡absent r≐E⟦absent⟧) S' S'∈can-r'-θ
    rewrite canθ-is-absent (Env.sig θ') S∈ θ r≐E⟦absent⟧  θ'S≡absent
  =  S'∈can-r'-θ
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (remit {S = S} {E = E} S∈ θ'S≢absent r≐E⟦emit⟧) S' S'∈can-ρθ''·r'-θ
  with set-subtract-merge
         {xs = Canθₛ (Env.sig (Env.set-sig {S} θ' S∈ Signal.present)) 0 r' θ}
         {ys = proj₁ (Dom θ'')}
         S'∈can-ρθ''·r'-θ
... | S'∈can-r'-θ←θ'' , S'∉Domθ''
  with set-subtract-split {ys = proj₁ (Dom θ')}
         (canθₛ-emit θ' S∈ θ r≐E⟦emit⟧ θ'S≢absent
           (canθₛ-membership (Env.sig θ') 0 r θ S
               (λ θ* → canₛ-capture-emit-signal θ* r≐E⟦emit⟧))
           S' S'∈can-r'-θ←θ'')
... | inj₁ S'∈can-r-θ←θ'-θ' = S'∈can-r-θ←θ'-θ'
... | inj₂ S'∈Domθ' =
  ⊥-elim (S'∉Domθ'' (Env.sig-set-mono' {S'} {S} {θ'} {Signal.present} {S∈} S'∈Domθ'))
canₛ-monotonic θ (loop r) r' cb rloop-unroll S' S'∈can-r'-θ = S'∈can-r'-θ
canₛ-monotonic θ .(nothin >> r') r' cb
  rseq-done S' S'∈can-r'-θ = S'∈can-r'-θ
canₛ-monotonic θ .(exit _ >> _) .(exit _) cb
  rseq-exit S' S'∈can-r'-θ = S'∈can-r'-θ
canₛ-monotonic θ .(loopˢ (exit _) _) .(exit _) cb
  rloopˢ-exit S' S'∈can-r'-θ = S'∈can-r'-θ
canₛ-monotonic θ (suspend r S) .r cb
  (rsuspend-done r/halted) S' S'∈can-r'-θ
  rewrite canₛ-done θ (dhalted r/halted) with S'∈can-r'-θ
... | ()
canₛ-monotonic θ (trap r) r' cb
  (rtrap-done r/halted) S' S'∈can-r'-θ
  rewrite canₛ-done θ (dhalted (↓-well-behaved _ r/halted)) with S'∈can-r'-θ
... | ()
canₛ-monotonic θ (signl S r) r' cb
  rraise-signal S' S'∈can-r'-θ
  rewrite SigMap.keys-1map S Signal.unknown
        | set-subtract-[a]≡set-remove (Canθₛ (Env.sig ([S]-env S)) 0 r θ) (Signal.unwrap S)
  =  S'∈can-r'-θ
canₛ-monotonic θ (ρ⟨ θ' , A ⟩· r) (ρ⟨ .θ' , .A ⟩· r') cb
  (rraise-shared {s = s} {e = e} {p = p} {E = E} e' r≐E⟦shared⟧) S' S'∈can-ρθ'·r'-θ
    rewrite sym (unplug r≐E⟦shared⟧)
          | sym (canθₛ-raise-lemma{A = WAIT} (Env.sig θ') 0 θ E (tshared (δ e') s e p))
    =  S'∈can-ρθ'·r'-θ

canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (rset-shared-value-old{s = s}{e = e}{E = E} e' s∈ θ's≡old r≐E⟦s⇐e⟧) S' S'∈can-ρθ''·r'-θ
  with set-subtract-merge{xs = Canθₛ (Env.sig θ'') 0 r' θ}{ys = proj₁ (Dom θ'')} S'∈can-ρθ''·r'-θ
... | S'∈can-r'-θ←θ'' , S'∉Domθ''
  with set-subtract-split {xs = Canθₛ (Env.sig θ') 0 r θ} {ys = proj₁ (Dom θ')} {z = Signal.unwrap S'}
         (subst
            (λ x → _ ∈ Canθₛ (Env.sig θ') 0 x θ)
            (unplug r≐E⟦s⇐e⟧)
            (canθₛ-term-nothin-lemma (Env.sig θ'') 0 θ E (tset-shr s e)
                              (Signal.unwrap S')  S'∈can-r'-θ←θ'' )  )
... | inj₁ S'∈can-r-θ←θ'-θ' = S'∈can-r-θ←θ'-θ' -- θ' and θ'' differ only by shared var Dom
... | inj₂ S'∈Domθ' = ⊥-elim (S'∉Domθ'' S'∈Domθ')
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (rset-shared-value-new{s = s}{e = e}{E = E} e' s∈ θ's≡new r≐E⟦s⇐e⟧) S' S'∈can-ρθ''·r'-θ
  with set-subtract-merge{xs = Canθₛ (Env.sig θ'') 0 r' θ}{ys = proj₁ (Dom θ'')} S'∈can-ρθ''·r'-θ
... | S'∈can-r'-θ←θ'' , S'∉Domθ''
  with set-subtract-split {xs = Canθₛ (Env.sig θ') 0 r θ} {ys = proj₁ (Dom θ')} {z = Signal.unwrap S'}
         (subst
            (λ x → _ ∈ Canθₛ (Env.sig θ') 0 x θ)
            (unplug r≐E⟦s⇐e⟧)
            (canθₛ-term-nothin-lemma (Env.sig θ'') 0 θ E (tset-shr s e)
                              (Signal.unwrap S')  S'∈can-r'-θ←θ'' ))
... | inj₁ S'∈can-r-θ←θ'-θ' = S'∈can-r-θ←θ'-θ'
... | inj₂ S'∈Domθ' = ⊥-elim (S'∉Domθ'' S'∈Domθ')
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rraise-var {x = x} {p = p} {e = e} {E = E} e' r≐E⟦var⟧) S' S'∈can-ρθ'·r'-θ
  rewrite sym (canθₛ-raise-lemma{A = WAIT} (Env.sig θ') 0 θ E (tvar (δ e') x e p)) | (unplug r≐E⟦var⟧) = S'∈can-ρθ'·r'-θ
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (rset-var {x = x} {e = e} {E = E}  x∈ e' r≐E⟦x≔e⟧) S' S'∈can-ρθ''·r'-θ
  with set-subtract-merge {xs = Canθₛ (Env.sig θ'') 0 r' θ}{ys = proj₁ (Dom θ'')} S'∈can-ρθ''·r'-θ
... | S'∈can-r'-θ←θ'' , S'∉Domθ''
  with set-subtract-split {xs = Canθₛ (Env.sig θ') 0 r θ} {ys = proj₁ (Dom θ')}{z = Signal.unwrap S'}
         ( (subst
            (λ x → _ ∈ Canθₛ (Env.sig θ') 0 x θ)
            (unplug r≐E⟦x≔e⟧)
            (canθₛ-term-nothin-lemma (Env.sig θ'') 0 θ E (tset-var x e)
                              (Signal.unwrap S')  S'∈can-r'-θ←θ'' )) )
... | inj₁ S'∈can-r-θ←θ'-θ' = S'∈can-r-θ←θ'-θ' -- θ' and θ'' differ only by seq var Dom
... | inj₂ S'∈Domθ' = ⊥-elim (S'∉Domθ'' S'∈Domθ')
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rif-false {p = p} {q = q} {x = x} {E = E} x∈ θ'x≡zero r≐E⟦if⟧) S' S'∈can-ρθ'·r'-θ
    with set-subtract-merge{xs = (proj₁ (Canθ (Env.sig θ') 0 r' θ))} {ys = proj₁ (Dom θ')}{z = (Signal.unwrap S')} S'∈can-ρθ'·r'-θ
... | S'∈can-r'-θ←θ' , S'∉Domθ' rewrite sym (unplug r≐E⟦if⟧) =
  set-subtract-notin (canθₛ-if-false-lemma (Env.sig θ') 0 x p q θ E (Signal.unwrap S')  S'∈can-r'-θ←θ') S'∉Domθ'
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rif-true {p = p} {q = q} {x = x} {E = E} x∈ θ'x≡suc r≐E⟦if⟧) S' S'∈can-ρθ'·r'-θ
    with set-subtract-merge{xs = (proj₁ (Canθ (Env.sig θ') 0 r' θ))} {ys = proj₁ (Dom θ')}{z = (Signal.unwrap S')} S'∈can-ρθ'·r'-θ
... | S'∈can-r'-θ←θ' , S'∉Domθ' rewrite sym (unplug r≐E⟦if⟧) =
  set-subtract-notin (canθₛ-if-true-lemma (Env.sig θ') 0 x p q θ E (Signal.unwrap S')  S'∈can-r'-θ←θ') S'∉Domθ'
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· .r) cb
  (rabsence {S = S} S∈ θ'S≡unknown S∉can-r-θ') S' S'∈can-ρθ''·r-θ
  rewrite Env.sig-switch-right S Signal.absent θ θ' S∈ (Env.sig-←-monoʳ S θ' θ S∈)
  with set-subtract-merge{xs = Canθₛ (Env.sig θ'') 0 r θ } {ys = proj₁ (Dom θ'')} S'∈can-ρθ''·r-θ
... | S'∈can-r-θ←θ'' , S'∉Domθ''
  with set-subtract-split{xs = (Canθₛ (Env.sig θ') 0 r θ)}{ys = fst (Dom θ')}
         (canθₛ-set-sig-monotonic-absence-lemma (Env.sig θ') 0 r S θ S∈
           θ'S≡unknown (Signal.unwrap S') S'∈can-r-θ←θ'')
  where
    θ←θ'        = θ ← θ'
    S∈Domθ←θ'   = Env.sig-←-monoʳ S θ' θ S∈
    ⟨θ←θ'⟩S≡θ'S = Env.sig-stats-←-right-irr' S θ θ' S∈ S∈Domθ←θ'
... | inj₁ S'∈can-r-θ←θ'-θ' = S'∈can-r-θ←θ'-θ'
... | inj₂ S'∈Domθ' =
  ⊥-elim
    (S'∉Domθ''
      (Env.sig-set-mono' {S'} {S} {θ'} {Signal.absent} {S∈}
        S'∈Domθ'))
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) r' cb
  (rreadyness {s = s} s∈ θ's≡old⊎θ's≡new s∉can-r-θ') S' S'∈can-r'-θ
  = S'∈can-r'-θ
canₛ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .(θ' ← θ'') , .(A-max A' _) ⟩· r') cb@(CBρ cb')
  (rmerge {θ₁ = .θ'} {θ₂ = θ''} {p = rin} {E = E} r≐E⟦ρθ''·rin⟧) S' S'∈can-ρθ'←θ''·r'-θ
  with set-subtract-merge
         {xs = Canθₛ (Env.sig (θ' ← θ'')) 0 r' θ}
         {ys = proj₁ (Dom (θ' ← θ''))}
         S'∈can-ρθ'←θ''·r'-θ
... | S'∈can-r'-θ←θ'←θ'' , S'∉Domθ'←θ''
  = set-subtract-notin
      (canθₛ-mergeˡ (Env.sig θ') θ cb' r≐E⟦ρθ''·rin⟧
        S' (S'∉Domθ'←θ'' ∘ Env.sig-←-monoʳ S' θ'' θ') S'∈can-r'-θ←θ'←θ'')
      (S'∉Domθ'←θ'' ∘ Env.sig-←-monoˡ S' θ' θ'')

canₛₕ-monotonic θ (p ∥ q) _ cb
  (rpar-done-right p/halted q/done) s' s'∈can-r'-θ
  rewrite canₛₕ-done θ (value-max-done (dhalted p/halted) q/done (inj₁ p/halted))
  with s'∈can-r'-θ
... | ()
canₛₕ-monotonic θ (p ∥ q) _ cb
  (rpar-done-left p/done q/halted) s' s'∈can-r'-θ
  rewrite canₛₕ-done θ (value-max-done p/done (dhalted q/halted) (inj₂ q/halted))
  with s'∈can-r'-θ
... | ()
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) r' cb
  (ris-present {S = S} S∈ θ'S≡present r≐E⟦present⟧) s' s'∈can-r'-θ
  rewrite canθ-is-present (Env.sig θ') S∈ θ r≐E⟦present⟧ θ'S≡present
  =  s'∈can-r'-θ
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) r' cb
  (ris-absent {S = S} S∈ θ'S≡absent r≐E⟦present⟧) s' s'∈can-r'-θ
  rewrite canθ-is-absent (Env.sig θ') S∈ θ r≐E⟦present⟧ θ'S≡absent
  =  s'∈can-r'-θ
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (remit {S = S} {E = E} S∈ θ'S≢absent r≐E⟦emit⟧) s' s'∈can-ρθ''·r'-θ
  with set-subtract-merge
         {xs = Canθₛₕ (Env.sig (Env.set-sig {S} θ' S∈ Signal.present)) 0 r' θ}
         {ys = proj₁ (proj₂ (Dom θ''))}
         s'∈can-ρθ''·r'-θ
... | s'∈can-r'-θ←θ'' , s'∉Domθ''
  with set-subtract-split {ys = proj₁ (proj₂ (Dom θ'))}
         (canθₛₕ-emit θ' S∈ θ r≐E⟦emit⟧ θ'S≢absent
           (canθₛ-membership (Env.sig θ') 0 r θ S
             (λ θ* → canₛ-capture-emit-signal θ* r≐E⟦emit⟧))
           s' s'∈can-r'-θ←θ'')
... | inj₁ s'∈can-r-θ←θ'-θ' = s'∈can-r-θ←θ'-θ'
... | inj₂ s'∈Domθ' = ⊥-elim (s'∉Domθ'' s'∈Domθ') -- θ' and θ'' differ only by sig
canₛₕ-monotonic θ (loop r) r' cb rloop-unroll s' s'∈can-r'-θ = s'∈can-r'-θ
canₛₕ-monotonic θ .(nothin >> r') r' cb
  rseq-done s' s'∈can-r'-θ = s'∈can-r'-θ
canₛₕ-monotonic θ .(exit _ >> _) .(exit _) cb
  rseq-exit s' s'∈can-r'-θ = s'∈can-r'-θ
canₛₕ-monotonic θ .(loopˢ (exit _) _) .(exit _) cb
  rloopˢ-exit s' s'∈can-r'-θ = s'∈can-r'-θ
canₛₕ-monotonic θ (suspend r S) .r cb
  (rsuspend-done r/halted) s' s'∈can-r'-θ
  rewrite canₛₕ-done θ (dhalted r/halted) with s'∈can-r'-θ
... | ()
canₛₕ-monotonic θ (trap r) r' cb
  (rtrap-done r/halted) s' s'∈can-r'-θ
  rewrite canₛₕ-done θ (dhalted (↓-well-behaved _ r/halted)) with s'∈can-r'-θ
... | ()
canₛₕ-monotonic θ (signl S r) r' cb
  rraise-signal s' s'∈can-r'-θ
  rewrite set-subtract-[] (Canθₛₕ (Env.sig ([S]-env S)) 0 r θ)
  =  s'∈can-r'-θ
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rraise-shared {s = s} {e = e} {p = p} {E = E} e' r≐E⟦shared⟧) s' s'∈can-ρθ'·r'-θ
  with set-subtract-merge {ys = proj₁ (proj₂ (Dom θ'))} s'∈can-ρθ'·r'-θ
... | s'∈can-r'-θ←θ' , s'∉Domθ' =

  set-subtract-notin
    (canθₛₕ-subset (Env.sig θ') 0 (E ⟦ ρ⟨ [s,δe]-env s (δ e') , WAIT ⟩· p ⟧e) r
       θ (λ θ* S* → canₛ-raise θ* (tshared (δ e') s e p) r≐E⟦shared⟧ S*)
       (λ θ* s* → canₛₕ-raise θ* (tshared (δ e') s e p) r≐E⟦shared⟧ s*) s'
       s'∈can-r'-θ←θ')
    s'∉Domθ'

canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (rset-shared-value-old {s = s} {e = e} {E = E} e' s∈ θ's≡old r≐E⟦s⇐e⟧) s' s'∈can-ρθ''·r'-θ
  with set-subtract-merge {ys = proj₁ (proj₂ (Dom θ''))} s'∈can-ρθ''·r'-θ
... | s'∈can-r'-θ←θ'' , s'∉Domθ''
  with set-subtract-split {ys = proj₁ (proj₂ (Dom θ'))}
         (canθₛₕ-subset (Env.sig θ') 0 (E ⟦ nothin ⟧e) r θ
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-shr s e) r≐E⟦s⇐e⟧ S*)
           (λ θ* s* → canₛₕ-term-nothin θ* θ* refl (tset-shr s e) r≐E⟦s⇐e⟧ s*)
           s' s'∈can-r'-θ←θ'')
... | inj₁ s'∈can-r-θ←θ'-θ' = s'∈can-r-θ←θ'-θ'
... | inj₂ s'∈Domθ' =
  ⊥-elim
    (s'∉Domθ''
      (Env.shr-set-mono' {s'} {s} {θ'} {SharedVar.new} {δ e'} {s∈}
        s'∈Domθ'))
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (rset-shared-value-new {s = s} {e = e} {E = E} e' s∈ θ's≡new r≐E⟦s⇐e⟧) s' s'∈can-ρθ''·r'-θ
  with set-subtract-merge {ys = proj₁ (proj₂ (Dom θ''))} s'∈can-ρθ''·r'-θ
... | s'∈can-r'-θ←θ'' , s'∉Domθ''
  with set-subtract-split {ys = proj₁ (proj₂ (Dom θ'))}
         (canθₛₕ-subset (Env.sig θ') 0 (E ⟦ nothin ⟧e) r θ
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-shr s e) r≐E⟦s⇐e⟧ S*)
           (λ θ* s* → canₛₕ-term-nothin θ* θ* refl (tset-shr s e) r≐E⟦s⇐e⟧ s*)
           s' s'∈can-r'-θ←θ'')
... | inj₁ s'∈can-r-θ←θ'-θ' = s'∈can-r-θ←θ'-θ'
... | inj₂ s'∈Domθ' =
  ⊥-elim
    (s'∉Domθ''
      (Env.shr-set-mono' {s'} {s} {θ'} {SharedVar.new}
        {Env.shr-vals {s} θ' s∈ + δ e'} {s∈}
        s'∈Domθ'))
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rraise-var {x = x} {p = p} {e = e} {E = E} e' r≐E⟦var⟧) s' s'∈can-ρθ'·r'-θ
  with set-subtract-merge {ys = proj₁ (proj₂ (Dom θ'))} s'∈can-ρθ'·r'-θ
... | s'∈can-r'-θ←θ' , s'∉Domθ' =
  set-subtract-notin
    (canθₛₕ-subset (Env.sig θ') 0 (E ⟦ ρ⟨ [x,δe]-env x (δ e') , WAIT ⟩· p ⟧e) r θ
      (λ θ* S* → canₛ-raise θ* (tvar (δ e') x e p) r≐E⟦var⟧ S*)
      (λ θ* s* → canₛₕ-raise θ* (tvar (δ e') x e p) r≐E⟦var⟧ s*)
      s' s'∈can-r'-θ←θ')
    s'∉Domθ'
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· r') cb
  (rset-var {x = x} {e = e} {E = E} x∈ e' r≐E⟦x≔e⟧) s' s'∈can-ρθ''·r'-θ
  with set-subtract-merge {ys = proj₁ (proj₂ (Dom θ''))} s'∈can-ρθ''·r'-θ
... | s'∈can-r'-θ←θ'' , s'∉Domθ''
  with set-subtract-split {ys = proj₁ (proj₂ (Dom θ'))}
         (canθₛₕ-subset (Env.sig θ') 0 (E ⟦ nothin ⟧e) r θ
           (λ θ* S* → canₛ-term-nothin θ* θ* refl (tset-var x e) r≐E⟦x≔e⟧ S*)
           (λ θ* s* → canₛₕ-term-nothin θ* θ* refl (tset-var x e) r≐E⟦x≔e⟧ s*)
           s' s'∈can-r'-θ←θ'')
... | inj₁ s'∈can-r-θ←θ'-θ' = s'∈can-r-θ←θ'-θ' -- θ' and θ'' differ only by seq var Dom
... | inj₂ s'∈Domθ' = ⊥-elim (s'∉Domθ'' s'∈Domθ')
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rif-false {p = p} {q = q} {x = x} {E = E} x∈ θ'x≡zero r≐E⟦if⟧) s' s'∈can-ρθ'·r'-θ
  with set-subtract-merge{xs = (thd (Canθ (Env.sig θ') 0 r' θ))} {ys = snd (Dom θ')}{z = (SharedVar.unwrap s')} s'∈can-ρθ'·r'-θ
... |  s'∈can-r'-θ←θ' , s'∉Domθ'
    rewrite sym (unplug r≐E⟦if⟧)
  = set-subtract-notin
      (canθₛₕ-if-false-lemma (Env.sig θ' ) 0 x p q θ E (SharedVar.unwrap s')   s'∈can-r'-θ←θ' )
      s'∉Domθ'
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .θ' , .A' ⟩· r') cb
  (rif-true {p = p} {q = q} {x = x} {E = E} x∈ θ'x≡suc r≐E⟦if⟧) s' s'∈can-ρθ'·r'-θ
    with set-subtract-merge{xs = (thd (Canθ (Env.sig θ') 0 r' θ))} {ys = snd (Dom θ')}{z = (SharedVar.unwrap s')} s'∈can-ρθ'·r'-θ
... |  s'∈can-r'-θ←θ' , s'∉Domθ'
    rewrite sym (unplug r≐E⟦if⟧)
  = set-subtract-notin
      (canθₛₕ-if-true-lemma (Env.sig θ' ) 0 x p q θ E (SharedVar.unwrap s')   s'∈can-r'-θ←θ' )
      s'∉Domθ'
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ θ'' , A'' ⟩· .r) cb
  (rabsence {S = S} S∈ θ'S≡unknown S∉can-r-θ') s' s'∈can-ρθ''·r-θ
  rewrite Env.sig-switch-right S Signal.absent θ θ' S∈ (Env.sig-←-monoʳ S θ' θ S∈)
 with set-subtract-merge {xs = Canθₛₕ (Env.sig θ'') 0 r θ }{ys = proj₁ (proj₂ (Dom θ''))} s'∈can-ρθ''·r-θ
... | s'∈can-r-θ←θ'' , s'∉Domθ''
  with set-subtract-split
         (canθₛₕ-set-sig-monotonic-absence-lemma (Env.sig θ') 0 r S θ S∈
            θ'S≡unknown (SharedVar.unwrap s') s'∈can-r-θ←θ'')
  where
    θ←θ'        = θ ← θ'
    S∈Domθ←θ'   = Env.sig-←-monoʳ S θ' θ S∈
    ⟨θ←θ'⟩S≡θ'S = Env.sig-stats-←-right-irr' S θ θ' S∈ S∈Domθ←θ'
... | inj₁ s'∈can-r-θ←θ'-θ' = s'∈can-r-θ←θ'-θ'
... | inj₂ s'∈Domθ' = ⊥-elim (s'∉Domθ'' s'∈Domθ') -- θ' and θ'' differ only by sig
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) r' cb
  (rreadyness {s = s} s∈ θ's≡old⊎θ's≡new s∉can-r-θ') s' s'∈can-r'-θ
  rewrite cong (proj₁ ∘ proj₂)
            (Env.shr-set-dom-eq s SharedVar.ready (Env.shr-vals {s} θ' s∈) θ' s∈)
        | can-shr-var-irr r (θ ← θ')
            (θ ← Env.set-shr {s} θ' s∈ SharedVar.ready (Env.shr-vals {s} θ' s∈)) refl
  = s'∈can-r'-θ
canₛₕ-monotonic θ (ρ⟨ θ' , A' ⟩· r) (ρ⟨ .(θ' ← θ'') , .(A-max A' _) ⟩· r') cb@(CBρ cb')
  (rmerge {θ₁ = .θ'} {θ₂ = θ''} {p = rin} {E = E} r≐E⟦ρθ''·rin⟧) s' s'∈can-ρθ'←θ''·r'-θ
  with set-subtract-merge
         {xs = Canθₛₕ (Env.sig (θ' ← θ'')) 0 r' θ}
         {ys = proj₁ (proj₂ (Dom (θ' ← θ'')))}
         s'∈can-ρθ'←θ''·r'-θ
 -- rewrite Env.←-assoc θ θ' θ''
... | s'∈can-r'-θ←θ'←θ'' , s'∉Domθ'←θ'' =
  set-subtract-notin
    (canθₛₕ-mergeˡ (Env.sig θ') θ cb' r≐E⟦ρθ''·rin⟧
      s' (s'∉Domθ'←θ'' ∘ Env.shr-←-monoʳ s' θ'' θ')
      s'∈can-r'-θ←θ'←θ'')
    (s'∉Domθ'←θ'' ∘ Env.shr-←-monoˡ s' θ' θ'')

infix 4 _⊑₃_
_⊑₃_ : SigSet.ST × CodeSet.ST × ShrSet.ST -> SigSet.ST × CodeSet.ST × ShrSet.ST -> Set
_⊑₃_ (Ss , ks , ss)  (Ss' , ks' , ss') =
  ((∀ S → (Signal.unwrap S) ∈ Ss → (Signal.unwrap S) ∈ Ss') ×
   (∀ k → k ∈ ks → k ∈ ks') ×
   (∀ s → (SharedVar.unwrap s) ∈ ss → (SharedVar.unwrap s) ∈ ss'))

can-antimonotonic :
  ∀ θ p q →
    CB p →
    p sn⟶₁ q →
  Can q θ ⊑₃ Can p θ
can-antimonotonic θ r r' CBr rsn⟶₁r' =
  (canₛ-monotonic  θ r r' CBr rsn⟶₁r' ,′
   canₖ-monotonic  θ r r' CBr rsn⟶₁r' ,′
   canₛₕ-monotonic  θ r r' CBr rsn⟶₁r')


------------------------------------------------------------------------
-- ω-continuous functions
------------------------------------------------------------------------

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

module Partiality-algebra.Omega-continuous where

open import Equality.Propositional.Cubical
open import Prelude

open import Bijection equality-with-J using (_↔_)
import Equivalence equality-with-J as Eq
open import Function-universe equality-with-J
open import H-level.Closure equality-with-J

open import Partiality-algebra as PA
open import Partiality-algebra.Monotone

-- Definition of ω-continuous functions.

record [_⟶_]
         {a₁ p₁ q₁} {A₁ : Type a₁} (P₁ : Partiality-algebra p₁ q₁ A₁)
         {a₂ p₂ q₂} {A₂ : Type a₂} (P₂ : Partiality-algebra p₂ q₂ A₂) :
         Type (p₁ ⊔ p₂ ⊔ q₁ ⊔ q₂) where
  private
    module P₁ = Partiality-algebra P₁
    module P₂ = Partiality-algebra P₂

  field
    monotone-function : [ P₁ ⟶ P₂ ]⊑

  open [_⟶_]⊑ monotone-function public

  field
    ω-continuous :
      ∀ s → function (P₁.⨆ s) ≡ P₂.⨆ [ monotone-function $ s ]-inc

open [_⟶_]

-- Identity.

idω : ∀ {a p q} {A : Type a} {P : Partiality-algebra p q A} →
      [ P ⟶ P ]
monotone-function idω   = id⊑
ω-continuous      idω _ = refl

-- Composition.

infixr 40 _∘ω_

_∘ω_ :
  ∀ {a₁ p₁ q₁} {A₁ : Type a₁} {P₁ : Partiality-algebra p₁ q₁ A₁}
    {a₂ p₂ q₂} {A₂ : Type a₂} {P₂ : Partiality-algebra p₂ q₂ A₂}
    {a₃ p₃ q₃} {A₃ : Type a₃} {P₃ : Partiality-algebra p₃ q₃ A₃} →
  [ P₂ ⟶ P₃ ] → [ P₁ ⟶ P₂ ] → [ P₁ ⟶ P₃ ]
monotone-function (f ∘ω g) = monotone-function f ∘⊑ monotone-function g

ω-continuous (_∘ω_ {P₁ = P₁} {P₂ = P₂} {P₃ = P₃} f g) s =
  function f (function g (P₁.⨆ s))                             ≡⟨ cong (function f) (ω-continuous g s) ⟩
  function f (P₂.⨆ [ monotone-function g $ s ]-inc)            ≡⟨ ω-continuous f _ ⟩∎
  P₃.⨆ [ monotone-function f ∘⊑ monotone-function g $ s ]-inc  ∎
  where
  module P₁ = Partiality-algebra P₁
  module P₂ = Partiality-algebra P₂
  module P₃ = Partiality-algebra P₃

-- Equality characterisation lemma for ω-continuous functions.

equality-characterisation-continuous :
  ∀ {a₁ p₁ q₁} {A₁ : Type a₁} {P₁ : Partiality-algebra p₁ q₁ A₁}
    {a₂ p₂ q₂} {A₂ : Type a₂} {P₂ : Partiality-algebra p₂ q₂ A₂}
    {f g : [ P₁ ⟶ P₂ ]} →
  (∀ x → function f x ≡ function g x) ↔ f ≡ g
equality-characterisation-continuous {P₁ = P₁} {P₂ = P₂} {f} {g} =
  (∀ x → function f x ≡ function g x)        ↝⟨ equality-characterisation-monotone ⟩
  monotone-function f ≡ monotone-function g  ↝⟨ ignore-propositional-component
                                                  (Π-closure ext 1 λ _ →
                                                   P₂.T-is-set) ⟩
  _↔_.to rearrange f ≡ _↔_.to rearrange g    ↔⟨ Eq.≃-≡ (Eq.↔⇒≃ rearrange) ⟩□
  f ≡ g                                      □
  where
  module P₁ = Partiality-algebra P₁
  module P₂ = Partiality-algebra P₂

  rearrange :
    [ P₁ ⟶ P₂ ]
      ↔
    ∃ λ (h : [ P₁ ⟶ P₂ ]⊑) →
      ∀ s → [_⟶_]⊑.function h (P₁.⨆ s) ≡ P₂.⨆ [ h $ s ]-inc
  rearrange = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ f → monotone-function f , ω-continuous f
        ; from = uncurry λ f c → record { monotone-function = f
                                        ; ω-continuous      = c
                                        }
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ _ → refl
    }
    where
    open Partiality-algebra

-- Composition is associative.

∘ω-assoc :
  ∀ {a₁ p₁ q₁} {A₁ : Type a₁} {P₁ : Partiality-algebra p₁ q₁ A₁}
    {a₂ p₂ q₂} {A₂ : Type a₂} {P₂ : Partiality-algebra p₂ q₂ A₂}
    {a₃ p₃ q₃} {A₃ : Type a₃} {P₃ : Partiality-algebra p₃ q₃ A₃}
    {a₄ p₄ q₄} {A₄ : Type a₄} {P₄ : Partiality-algebra p₄ q₄ A₄}
  (f : [ P₃ ⟶ P₄ ]) (g : [ P₂ ⟶ P₃ ]) (h : [ P₁ ⟶ P₂ ]) →
  f ∘ω (g ∘ω h) ≡ (f ∘ω g) ∘ω h
∘ω-assoc _ _ _ =
  _↔_.to equality-characterisation-continuous λ _ → refl


module Common.Reflection where

open import Agda.Builtin.Reflection public renaming
  ( arg-info      to argInfo
  ; function      to funDef
  ; data-type     to dataDef
  ; record-type   to recordDef
  ; agda-sort     to sort
  ; name          to qname
  ; absurd-clause to absurdClause
  ; pat-lam       to extLam
  ; proj          to projP
  ; instance′      to inst
  ; Visibility    to Hiding
  ; Name          to QName)
open import Common.Level
open import Common.Prelude hiding (_>>=_)

pattern vArg x = arg (argInfo visible relevant) x
pattern hArg x = arg (argInfo hidden  relevant) x
pattern iArg x = arg (argInfo inst    relevant) x

Args = List (Arg Term)

data FunDef : Set where
  funDef : Type → List Clause → FunDef

Tactic = Term → TC ⊤

give : Term → Tactic
give v = λ hole → unify hole v

define : Arg QName → FunDef → TC ⊤
define (arg i f) (funDef a cs) =
  bindTC (declareDef (arg i f) a) λ _ →
  defineFun f cs

newMeta : Type → TC Term
newMeta a = checkType unknown a

numberOfParameters : QName → TC Nat
numberOfParameters d =
  bindTC (getDefinition d) λ
  { (dataDef n _) → returnTC n
  ; _ → typeError (strErr "Cannot get parameters of non-data type" ∷ nameErr d ∷ [])
  }

getConstructors : QName → TC (List QName)
getConstructors d =
  bindTC (getDefinition d) λ
  { (dataDef _ cs)  → returnTC cs
  ; (recordDef c _) → returnTC (c ∷ [])
  ; _ → typeError (strErr "Cannot get constructors of non-data or record type" ∷ nameErr d ∷ [])
  }

infixl 1 _>>=_
_>>=_ = bindTC


------------------------------------------------------------------------------
-- ABP Lemma 2
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see Lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2I where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Base.Loop
open import FOTC.Base.PropertiesI
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- Helper function for Lemma 2.
helper₂ : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
          Bit b →
          Fair os₁' →
          S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
          ∀ ft₂ os₂'' → F*T ft₂ → Fair os₂'' → os₂' ≡ ft₂ ++ os₂'' →
          ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
            Fair os₁''
            ∧ Fair os₂''
            ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
helper₂ {b} {i'} {is'} {os₁'} {os₂'} {as'} {bs'} {cs'} {ds'} {js'}
       Bb Fos₁' (as'S' , bs'S' , cs'S' , ds'S' , js'S')
       .(T ∷ []) os₂'' f*tnil Fos₂'' os₂'-eq =
       os₁' , os₂'' , as'' , bs'' , cs'' , ds''
       , Fos₁' , Fos₂''
       , as''-eq , bs''-eq ,  cs''-eq , refl , js'-eq
  where
  os₂'-eq-helper : os₂' ≡ T ∷ os₂''
  os₂'-eq-helper =
    os₂'              ≡⟨ os₂'-eq ⟩
    (T ∷ []) ++ os₂'' ≡⟨ ++-∷ T [] os₂'' ⟩
    T ∷ [] ++ os₂''   ≡⟨ ∷-rightCong (++-leftIdentity os₂'') ⟩
    T ∷ os₂''         ∎

  ds'' : D
  ds'' = corrupt os₂'' · cs'

  ds'-eq : ds' ≡ ok b ∷ ds''
  ds'-eq =
    ds' ≡⟨ ds'S' ⟩
    corrupt os₂' · (b ∷ cs')
      ≡⟨ ·-leftCong (corruptCong os₂'-eq-helper) ⟩
    corrupt (T ∷ os₂'') · (b ∷ cs')
      ≡⟨ corrupt-T os₂'' b cs' ⟩
    ok b ∷ corrupt os₂'' · cs'
       ≡⟨ refl ⟩
    ok b ∷ ds'' ∎

  as'' : D
  as'' = as'

  as''-eq : as'' ≡ send (not b) · is' · ds''
  as''-eq =
    as''                         ≡⟨ as'S' ⟩
    await b i' is' ds'           ≡⟨ awaitCong₄ ds'-eq ⟩
    await b i' is' (ok b ∷ ds'') ≡⟨ await-ok≡ b b i' is' ds'' refl ⟩
    send (not b) · is' · ds''    ∎

  bs'' : D
  bs'' = bs'

  bs''-eq : bs'' ≡ corrupt os₁' · as'
  bs''-eq = bs'S'

  cs'' : D
  cs'' = cs'

  cs''-eq : cs'' ≡ ack (not b) · bs'
  cs''-eq = cs'S'

  js'-eq : js' ≡ out (not b) · bs''
  js'-eq = js'S'

helper₂ {b} {i'} {is'} {os₁'} {os₂'} {as'} {bs'} {cs'} {ds'} {js'}
        Bb Fos₁' (as'S' , bs'S' , cs'S' , ds'S' , js'S')
        .(F ∷ ft₂) os₂'' (f*tcons {ft₂} FTft₂) Fos₂'' os₂'-eq =
        helper₂ Bb (tail-Fair Fos₁') ihS' ft₂ os₂'' FTft₂ Fos₂'' refl
  where
  os₁^ : D
  os₁^ = tail₁ os₁'

  os₂^ : D
  os₂^ = ft₂ ++ os₂''

  os₂'-eq-helper : os₂' ≡ F ∷ os₂^
  os₂'-eq-helper = os₂'               ≡⟨ os₂'-eq ⟩
                   (F ∷ ft₂) ++ os₂'' ≡⟨ ++-∷ _ _ _ ⟩
                   F ∷ ft₂ ++ os₂''   ≡⟨ refl ⟩
                   F ∷ os₂^           ∎

  ds^ : D
  ds^ = corrupt os₂^ · cs'

  ds'-eq : ds' ≡ error ∷ ds^
  ds'-eq =
    ds'
      ≡⟨ ds'S' ⟩
    corrupt os₂' · (b ∷ cs')
      ≡⟨ ·-leftCong (corruptCong os₂'-eq-helper) ⟩
    corrupt (F ∷ os₂^) · (b ∷ cs')
      ≡⟨ corrupt-F _ _ _ ⟩
    error ∷ corrupt os₂^ · cs'
      ≡⟨ refl ⟩
    error ∷ ds^ ∎

  as^ : D
  as^ = await b i' is' ds^

  as'-eq : as' ≡ < i' , b > ∷ as^
  as'-eq = as'                             ≡⟨ as'S' ⟩
           await b i' is' ds'              ≡⟨ awaitCong₄ ds'-eq ⟩
           await b i' is' (error ∷ ds^)    ≡⟨ await-error _ _ _ _ ⟩
           < i' , b > ∷ await b i' is' ds^ ≡⟨ refl ⟩
           < i' , b > ∷ as^                ∎

  bs^ : D
  bs^ = corrupt os₁^ · as^

  bs'-eq-helper₁ : os₁' ≡ T ∷ tail₁ os₁' → bs' ≡ ok < i' , b > ∷ bs^
  bs'-eq-helper₁ h =
    bs'
      ≡⟨ bs'S' ⟩
    corrupt os₁' · as'
      ≡⟨ subst₂ (λ t t' → corrupt os₁' · as' ≡ corrupt t · t')
                h
                as'-eq
                refl
      ⟩
    corrupt (T ∷ tail₁ os₁') · (< i' , b > ∷ as^)
      ≡⟨ corrupt-T _ _ _ ⟩
    ok < i' , b > ∷ corrupt (tail₁ os₁') · as^
       ≡⟨ refl ⟩
    ok < i' , b > ∷ bs^ ∎

  bs'-eq-helper₂ : os₁' ≡ F ∷ tail₁ os₁' → bs' ≡ error ∷ bs^
  bs'-eq-helper₂ h =
    bs'
      ≡⟨ bs'S' ⟩
    corrupt os₁' · as'
      ≡⟨ subst₂ (λ t t' → corrupt os₁' · as' ≡ corrupt t · t')
                h
                as'-eq
                refl
      ⟩
    corrupt (F ∷ tail₁ os₁') · (< i' , b > ∷ as^)
      ≡⟨ corrupt-F _ _ _ ⟩
    error ∷ corrupt (tail₁ os₁') · as^
      ≡⟨ refl ⟩
    error ∷ bs^ ∎

  bs'-eq : bs' ≡ ok < i' , b > ∷ bs^ ∨ bs' ≡ error ∷ bs^
  bs'-eq = case (λ h → inj₁ (bs'-eq-helper₁ h))
                (λ h → inj₂ (bs'-eq-helper₂ h))
                (head-tail-Fair Fos₁')

  cs^ : D
  cs^ = ack (not b) · bs^

  cs'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs^ → cs' ≡ b ∷ cs^
  cs'-eq-helper₁ h =
    cs'                                 ≡⟨ cs'S' ⟩
    ack (not b) · bs'                   ≡⟨ ·-rightCong h ⟩
    ack (not b) · (ok < i' , b > ∷ bs^) ≡⟨ ack-ok≢ _ _ _ _ (not-x≢x Bb) ⟩
    not (not b) ∷ ack (not b) · bs^     ≡⟨ ∷-leftCong (not-involutive Bb) ⟩
    b ∷ ack (not b) · bs^               ≡⟨ refl ⟩
    b ∷ cs^                             ∎

  cs'-eq-helper₂ : bs' ≡ error ∷ bs^ → cs' ≡ b ∷ cs^
  cs'-eq-helper₂ h =
    cs'                             ≡⟨ cs'S' ⟩
    ack (not b) · bs'               ≡⟨ ·-rightCong h ⟩
    ack (not b) · (error ∷ bs^)     ≡⟨ ack-error _ _ ⟩
    not (not b) ∷ ack (not b) · bs^ ≡⟨ ∷-leftCong (not-involutive Bb) ⟩
    b ∷ ack (not b) · bs^           ≡⟨ refl ⟩
    b ∷ cs^                         ∎

  cs'-eq : cs' ≡ b ∷ cs^
  cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

  js'-eq-helper₁ : bs' ≡ ok < i' , b > ∷ bs^ → js' ≡ out (not b) · bs^
  js'-eq-helper₁ h  =
    js'
      ≡⟨ js'S' ⟩
    out (not b) · bs'
      ≡⟨ ·-rightCong h ⟩
    out (not b) · (ok < i' , b > ∷ bs^)
      ≡⟨ out-ok≢ (not b) b i' bs^ (not-x≢x Bb) ⟩
    out (not b) · bs^ ∎

  js'-eq-helper₂ : bs' ≡ error ∷ bs^ → js' ≡ out (not b) · bs^
  js'-eq-helper₂ h  =
    js'                         ≡⟨ js'S' ⟩
    out (not b) · bs'           ≡⟨ ·-rightCong h ⟩
    out (not b) · (error ∷ bs^) ≡⟨ out-error (not b) bs^ ⟩
    out (not b) · bs^           ∎

  js'-eq : js' ≡ out (not b) · bs^
  js'-eq = case js'-eq-helper₁ js'-eq-helper₂ bs'-eq

  ds^-eq : ds^ ≡ corrupt os₂^ · (b ∷ cs^)
  ds^-eq = ·-rightCong cs'-eq

  ihS' : S' b i' is' os₁^ os₂^ as^ bs^ cs^ ds^ js'
  ihS' = refl , refl , refl , ds^-eq , js'-eq

-- From Dybjer and Sander's paper: From the assumption that
-- os₂' ∈ Fair and hence by unfolding Fair, we conclude that there are
-- ft₂ : F*T and os₂'' : Fair, such that os₂' = ft₂ ++ os₂''.
--
-- We proceed by induction on ft₂ : F*T using helper.

lemma₂ : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₁' →
         Fair os₂' →
         S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
         ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
         Fair os₁''
         ∧ Fair os₂''
         ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
lemma₂ {b} {is' = is'} {os₂' = os₂'} {js' = js'} Bb Fos₁' Fos₂' s' =
  helper₁ (Fair-out Fos₂')
  where
  helper₁ : (∃[ ft₂ ] ∃[ os₂'' ] F*T ft₂ ∧ os₂' ≡ ft₂ ++ os₂'' ∧ Fair os₂'') →
            ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
              Fair os₁''
              ∧ Fair os₂''
              ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
  helper₁ (ft₂ , os₂'' , FTft₂ , os₂'-eq , Fos₂'') =
    helper₂ Bb Fos₁' s' ft₂ os₂'' FTft₂ Fos₂'' os₂'-eq


-- Andreas, 2017-09-16, issue #2759
-- Allow empty declaration blocks in the parser.

open import Agda.Builtin.Nat

x0 = zero
mutual
x1 = suc x0
abstract
x2 = suc x1
private
x3 = suc x2
instance
x4 = suc x3
macro
x5 = suc x4
postulate
x6 = suc x5

-- Expected: 6 warnings about empty blocks

mutual
  postulate

-- Empty postulate block.

abstract private instance macro

-- Empty macro block.


------------------------------------------------------------------------------
-- All the FOTC modules
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

module FOTC.Everything where

open import FOTC.Base
open import FOTC.Base.Consistency.Axioms
open import FOTC.Base.Consistency.IfInjective
open import FOTC.Base.List
open import FOTC.Base.List.Consistency.Axioms
open import FOTC.Base.List.PropertiesATP
open import FOTC.Base.List.PropertiesI
open import FOTC.Base.Loop
open import FOTC.Base.PropertiesATP
open import FOTC.Base.PropertiesI

open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.Bool.Type

open import FOTC.Data.Colist
open import FOTC.Data.Colist.PropertiesATP
open import FOTC.Data.Colist.PropertiesI
open import FOTC.Data.Colist.Type
open import FOTC.Data.Colist.Type.Consistency.Axioms

open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality.Consistency.Axioms
open import FOTC.Data.Conat.Equality.PropertiesATP
open import FOTC.Data.Conat.Equality.PropertiesI
open import FOTC.Data.Conat.Equality.Type
open import FOTC.Data.Conat.PropertiesATP
open import FOTC.Data.Conat.PropertiesI
open import FOTC.Data.Conat.Type
open import FOTC.Data.Conat.Type.Consistency.Axioms

open import FOTC.Data.List
open import FOTC.Data.List.Consistency.Axioms
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesByInductionI
open import FOTC.Data.List.PropertiesByInductionATP
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.List.Type
open import FOTC.Data.List.WF-Relation.LT-Cons
open import FOTC.Data.List.WF-Relation.LT-Cons.Induction.Acc.WF-I
open import FOTC.Data.List.WF-Relation.LT-Cons.PropertiesI
open import FOTC.Data.List.WF-Relation.LT-Length
open import FOTC.Data.List.WF-Relation.LT-Length.Induction.Acc.WF-I
open import FOTC.Data.List.WF-Relation.LT-Length.PropertiesI

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Consistency.Axioms
open import FOTC.Data.Nat.Divisibility.By0
open import FOTC.Data.Nat.Divisibility.By0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.By0.PropertiesI
open import FOTC.Data.Nat.Divisibility.NotBy0
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesI
open import FOTC.Data.Nat.Induction.Acc.WF-ATP
open import FOTC.Data.Nat.Induction.Acc.WF-I
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicATP
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI
open import FOTC.Data.Nat.Induction.NonAcc.WF-ATP
open import FOTC.Data.Nat.Induction.NonAcc.WF-I
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.Consistency.Axioms
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesATP
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.List
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Data.Nat.Type
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityI

open import FOTC.Data.Stream
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Data.Stream.Equality.PropertiesI
open import FOTC.Data.Stream.PropertiesATP
open import FOTC.Data.Stream.PropertiesI
open import FOTC.Data.Stream.Type
open import FOTC.Data.Stream.Type.Consistency.Axioms

open import FOTC.Induction.WF

open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.ABP.Consistency.Axioms
open import FOTC.Program.ABP.CorrectnessProofATP
open import FOTC.Program.ABP.CorrectnessProofI
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.Consistency.Axioms
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Fair.PropertiesI
open import FOTC.Program.ABP.Lemma1ATP
open import FOTC.Program.ABP.Lemma1I
open import FOTC.Program.ABP.Lemma2ATP
open import FOTC.Program.ABP.Lemma2I
open import FOTC.Program.ABP.PropertiesI
open import FOTC.Program.ABP.Terms

open import FOTC.Program.Collatz.Collatz
open import FOTC.Program.Collatz.Collatz.Consistency.Axioms
open import FOTC.Program.Collatz.Data.Nat
open import FOTC.Program.Collatz.Data.Nat.Consistency.Axioms
open import FOTC.Program.Collatz.Data.Nat.PropertiesATP
open import FOTC.Program.Collatz.Data.Nat.PropertiesI
open import FOTC.Program.Collatz.PropertiesI
open import FOTC.Program.Collatz.PropertiesATP

open import FOTC.Program.Division.ConversionRulesATP
open import FOTC.Program.Division.ConversionRulesI
open import FOTC.Program.Division.CorrectnessProofATP
open import FOTC.Program.Division.CorrectnessProofI
open import FOTC.Program.Division.Division
open import FOTC.Program.Division.ResultATP
open import FOTC.Program.Division.ResultI
open import FOTC.Program.Division.Specification
open import FOTC.Program.Division.TotalityATP
open import FOTC.Program.Division.TotalityI

open import FOTC.Program.GCD.Partial.CommonDivisorATP
open import FOTC.Program.GCD.Partial.CommonDivisorI
open import FOTC.Program.GCD.Partial.ConversionRulesATP
open import FOTC.Program.GCD.Partial.ConversionRulesI
open import FOTC.Program.GCD.Partial.CorrectnessProofATP
open import FOTC.Program.GCD.Partial.CorrectnessProofI
open import FOTC.Program.GCD.Partial.Definitions
open import FOTC.Program.GCD.Partial.DivisibleATP
open import FOTC.Program.GCD.Partial.DivisibleI
open import FOTC.Program.GCD.Partial.GCD
open import FOTC.Program.GCD.Partial.GCD.Consistency.Axioms
open import FOTC.Program.GCD.Partial.GreatestAnyCommonDivisor
open import FOTC.Program.GCD.Partial.TotalityATP
open import FOTC.Program.GCD.Partial.TotalityI

open import FOTC.Program.GCD.Total.CommonDivisorATP
open import FOTC.Program.GCD.Total.CommonDivisorI
open import FOTC.Program.GCD.Total.ConversionRulesATP
open import FOTC.Program.GCD.Total.ConversionRulesI
open import FOTC.Program.GCD.Total.CorrectnessProofATP
open import FOTC.Program.GCD.Total.CorrectnessProofI
open import FOTC.Program.GCD.Total.Definitions
open import FOTC.Program.GCD.Total.DivisibleATP
open import FOTC.Program.GCD.Total.DivisibleI
open import FOTC.Program.GCD.Total.GCD
open import FOTC.Program.GCD.Total.GCD.Consistency.Axioms
open import FOTC.Program.GCD.Total.TotalityATP
open import FOTC.Program.GCD.Total.TotalityI

open import FOTC.Program.Iter0.Iter0
open import FOTC.Program.Iter0.PropertiesATP
open import FOTC.Program.Iter0.PropertiesI

open import FOTC.Program.MapIterate.MapIterateATP
open import FOTC.Program.MapIterate.MapIterateI

open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91.Consistency.Axioms
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.PropertiesATP
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.PropertiesATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

open import FOTC.Program.Mirror.Example
open import FOTC.Program.Mirror.Forest.PropertiesATP
open import FOTC.Program.Mirror.Forest.PropertiesI
open import FOTC.Program.Mirror.Forest.TotalityATP
open import FOTC.Program.Mirror.Forest.TotalityI
open import FOTC.Program.Mirror.Mirror.Consistency.Axioms
open import FOTC.Program.Mirror.Mirror
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI
open import FOTC.Program.Mirror.Tree.TotalityATP
open import FOTC.Program.Mirror.Tree.TotalityI
open import FOTC.Program.Mirror.Type

open import FOTC.Program.Nest.Nest
open import FOTC.Program.Nest.Nest.Consistency.Axioms
open import FOTC.Program.Nest.PropertiesATP

open import FOTC.Program.SortList.CorrectnessProofATP
open import FOTC.Program.SortList.CorrectnessProofI
open import FOTC.Program.SortList.Properties.MiscellaneousATP
open import FOTC.Program.SortList.Properties.MiscellaneousI
open import FOTC.Program.SortList.Properties.Totality.BoolATP
open import FOTC.Program.SortList.Properties.Totality.BoolI
open import FOTC.Program.SortList.Properties.Totality.ListN-ATP
open import FOTC.Program.SortList.Properties.Totality.ListN-I
open import FOTC.Program.SortList.Properties.Totality.OrdList.FlattenI
open import FOTC.Program.SortList.Properties.Totality.OrdList.FlattenATP
open import FOTC.Program.SortList.Properties.Totality.OrdListATP
open import FOTC.Program.SortList.Properties.Totality.OrdListI
open import FOTC.Program.SortList.Properties.Totality.OrdTreeATP
open import FOTC.Program.SortList.Properties.Totality.OrdTreeI
open import FOTC.Program.SortList.Properties.Totality.TreeATP
open import FOTC.Program.SortList.Properties.Totality.TreeI
open import FOTC.Program.SortList.PropertiesI
open import FOTC.Program.SortList.PropertiesATP
open import FOTC.Program.SortList.SortList
open import FOTC.Program.SortList.SortList.Consistency.Axioms

open import FOTC.Relation.Binary.Bisimilarity.Bisimulation
open import FOTC.Relation.Binary.Bisimilarity.Consistency.Axioms
open import FOTC.Relation.Binary.Bisimilarity.PropertiesATP
open import FOTC.Relation.Binary.Bisimilarity.PropertiesI
open import FOTC.Relation.Binary.Bisimilarity.Type


open import Prelude
open import Level using (Level) renaming (zero to lz; suc to ls)
open import Data.List.Properties as ListProps renaming (∷-injective to ∷-inj)
open import Data.String
open import Data.Nat as Nat using (decTotalOrder; _≤_; s≤s; z≤n)
open import Relation.Binary using (module DecTotalOrder)

module RW.Language.RTerm where

  open import Reflection renaming (Term to AgTerm; Type to AgType)
    public

  open DecTotalOrder Nat.decTotalOrder using (total)

  postulate
    unsuportedSyntax : ∀{a}{A : Set a} → String → A
    error            : ∀{a}{A : Set a} → String → A

  open Eq {{...}}

  -- We'll consider constructor and definitions
  -- as just names; we just need to know how to
  -- translate them back into a correct AgTerm.
  --
  -- Function type is represented with the impl constructor.
  data RTermName : Set where
    rcon : Name → RTermName
    rdef : Name → RTermName
    impl : RTermName

  showRTermName : RTermName → String
  showRTermName (rcon x) = showName x
  showRTermName (rdef x) = showName x
  showRTermName impl     = "→"

  ----------------------------------------
  -- Equalities associated with RTermNames

  rcon-inj : ∀{x y} → rcon x ≡ rcon y → x ≡ y
  rcon-inj refl = refl

  rdef-inj : ∀{x y} → rdef x ≡ rdef y → x ≡ y
  rdef-inj refl = refl

  _≟-RTermName_ : (n m : RTermName) → Dec (n ≡ m)
  rcon x ≟-RTermName rcon y with x ≟-Name y
  ...| yes x≡y = yes (cong rcon x≡y)
  ...| no  x≢y = no (x≢y ∘ rcon-inj)
  rdef x ≟-RTermName rdef y with x ≟-Name y
  ...| yes x≡y = yes (cong rdef x≡y)
  ...| no  x≢y = no (x≢y ∘ rdef-inj)
  impl ≟-RTermName impl     = yes refl
  rcon _ ≟-RTermName rdef _ = no (λ ())
  rcon _ ≟-RTermName impl   = no (λ ())
  rdef _ ≟-RTermName rcon _ = no (λ ())
  rdef _ ≟-RTermName impl   = no (λ ())
  impl ≟-RTermName rcon _   = no (λ ())
  impl ≟-RTermName rdef _   = no (λ ())

  -- Now we'll define a very handy term representation.
  -- We aim to reduce the amount of boilerplate code
  -- needed to handle Agda's complex term representation.
  --
  -- The phantom A will allow us to use multiple representations
  -- for unification variables and still prove termination
  -- by using a (Fin n), before unifying.
  data RTerm {a}(A : Set a) : Set a where
    -- Out-of-bound variables. We use a phantom type A
    -- to be able to (almost) seamless convert from
    -- ℕ to (Fin n).
    ovar : (x : A) → RTerm A

    -- Variables bound inside the term itself, from
    -- rlam's.
    ivar : (n : ℕ) → RTerm A

    -- Agda Literals
    rlit : (l : Literal) → RTerm A

    -- Lambda Abstraction
    rlam : RTerm A → RTerm A

    -- Applications
    rapp : (n : RTermName)(ts : List (RTerm A)) → RTerm A

  -- Equality Rules induced by RTerm's constructors

  ovar-inj : ∀{a}{A : Set a}{x y : A} → ovar {a} {A} x ≡ ovar {a} {A} y → x ≡ y
  ovar-inj refl = refl

  ivar-inj : ∀{a A x y} → ivar {a} {A} x ≡ ivar {a} {A} y → x ≡ y
  ivar-inj refl = refl

  rlit-inj : ∀{a A x y} → rlit {a} {A} x ≡ rlit {a} {A} y → x ≡ y
  rlit-inj refl = refl

  rlam-inj : ∀{a A x y} → rlam {a} {A} x ≡ rlam {a} {A} y → x ≡ y
  rlam-inj refl = refl

  rapp-inj : ∀{a A n₁ n₂ l₁ l₂}
           → rapp {a} {A} n₁ l₁ ≡ rapp {a} {A} n₂ l₂
           → n₁ ≡ n₂ × l₁ ≡ l₂
  rapp-inj refl = refl , refl

  --------------------------
  -- Generalized Comparison

  mutual
    compRTerm : ∀{A} ⦃ eqA : Eq A ⦄
              → (m n : RTerm A)
              → Dec (m ≡ n)
    compRTerm ⦃ eq f ⦄ (ovar x) (ovar y) with f x y
    ...| yes x≡y = yes (cong ovar x≡y)
    ...| no  x≢y = no (x≢y ∘ ovar-inj)
    compRTerm (ivar x) (ivar y) with x ≟-ℕ y
    ...| yes x≡y = yes (cong ivar x≡y)
    ...| no  x≢y = no (x≢y ∘ ivar-inj)
    compRTerm (rlit x) (rlit y) with x ≟-Lit y
    ...| yes x≡y = yes (cong rlit x≡y)
    ...| no  x≢y = no (x≢y ∘ rlit-inj)
    compRTerm (rlam x) (rlam y) with compRTerm x y
    ...| yes x≡y = yes (cong rlam x≡y)
    ...| no  x≢y = no (x≢y ∘ rlam-inj)
    compRTerm (rapp x ax) (rapp y ay) with x ≟-RTermName y
    ...| no  x≢y = no (x≢y ∘ p1 ∘ rapp-inj)
    ...| yes x≡y rewrite x≡y with compRTerm* ax ay
    ...| no  ax≢ay = no (ax≢ay ∘ p2 ∘ rapp-inj)
    ...| yes ax≡ay = yes (cong (rapp y) ax≡ay)
    compRTerm (ovar _) (ivar _)   = no (λ ())
    compRTerm (ovar _) (rlit _)   = no (λ ())
    compRTerm (ovar _) (rlam _)   = no (λ ())
    compRTerm (ovar _) (rapp _ _) = no (λ ())
    compRTerm (ivar _) (ovar _)   = no (λ ())
    compRTerm (ivar _) (rlit _)   = no (λ ())
    compRTerm (ivar _) (rlam _)   = no (λ ())
    compRTerm (ivar _) (rapp _ _) = no (λ ())
    compRTerm (rlit _) (ovar _)   = no (λ ())
    compRTerm (rlit _) (ivar _)   = no (λ ())
    compRTerm (rlit _) (rlam _)   = no (λ ())
    compRTerm (rlit _) (rapp _ _) = no (λ ())
    compRTerm (rlam _) (ovar _)   = no (λ ())
    compRTerm (rlam _) (ivar _)   = no (λ ())
    compRTerm (rlam _) (rlit _)   = no (λ ())
    compRTerm (rlam _) (rapp _ _) = no (λ ())
    compRTerm (rapp _ _) (ovar _) = no (λ ())
    compRTerm (rapp _ _) (ivar _) = no (λ ())
    compRTerm (rapp _ _) (rlit _) = no (λ ())
    compRTerm (rapp _ _) (rlam _) = no (λ ())

    compRTerm* : ∀{A} ⦃ eqA : Eq A ⦄
               → (x y : List (RTerm A))
               → Dec (x ≡ y)
    compRTerm* [] [] = yes refl
    compRTerm* (_ ∷ _) []  = no (λ ())
    compRTerm* [] (_ ∷ _)  = no (λ ())
    compRTerm* (x ∷ xs) (y ∷ ys)
      with compRTerm x y
    ...| no  x≢y = no (x≢y ∘ p1 ∘ ∷-inj)
    ...| yes x≡y rewrite x≡y with compRTerm* xs ys
    ...| no  xs≢ys = no (xs≢ys ∘ p2 ∘ ∷-inj)
    ...| yes xs≡ys = yes (cong (_∷_ y) xs≡ys)

  instance
    eq-RTerm : {A : Set}{{ eqA : Eq A }} → Eq (RTerm A)
    eq-RTerm = eq compRTerm

  -- Infix version

  _≟-RTerm_ : ∀{A} ⦃ eqA : Eq A ⦄ → (x y : RTerm A) → Dec (x ≡ y)
  _≟-RTerm_ = compRTerm

  ------------------------------
  -- Term Replacement Functions

  {-# TERMINATING #-}
  replace : ∀{a b}{A : Set a}{B : Set b}
          → (ovar-f : A → RTerm B)
          → (ivar-f : ℕ → RTerm B)
          → RTerm A → RTerm B
  replace f g (ovar x) = f x
  replace f g (ivar n) = g n
  replace _ _ (rlit l) = rlit l
  replace f g (rlam x) = rlam (replace f g x)
  replace f g (rapp n ts) = rapp n (map (replace f g) ts)

  -- This is basically fmap...
  replace-A : ∀{a b}{A : Set a}{B : Set b}
            → (A → RTerm B) → RTerm A → RTerm B
  replace-A f = replace f ivar

  -- equipped with a few usefull functor lemmas.
  lemma-replace-rlam : ∀{a b}{A : Set a}{B : Set b}{f : A → RTerm B}{t : RTerm A}
                     → replace-A f (rlam t) ≡ rlam (replace-A f t)
  lemma-replace-rlam = refl

  lemma-replace-rapp : ∀{a b}{A : Set a}{B : Set b}{f : A → RTerm B}{ts : List (RTerm A)}{n : RTermName}
                     → replace-A f (rapp n ts) ≡ rapp n (map (replace-A f) ts)
  lemma-replace-rapp = refl

  _◇-A_ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
        → (B → RTerm C) → (A → RTerm B)
        → A → RTerm C
  f ◇-A g = replace-A f ∘ g

  replace-ivar : ∀{a}{A : Set a}
               → (ℕ → RTerm A) → RTerm A → RTerm A
  replace-ivar f = replace ovar f

  ----------------------
  -- Counting utilities

  {-# TERMINATING #-}
  count : ∀{a}{A : Set a} → RTerm A → ℕ × ℕ
  count (ovar _) = 1 , 0
  count (ivar _) = 0 , 1
  count (rlit _) = 0 , 0
  count (rlam x) = count x
  count (rapp _ xs) = sum2 (map count xs)
    where
      sum2 : List (ℕ × ℕ) → ℕ × ℕ
      sum2 [] = 0 , 0
      sum2 ((a , b) ∷ xs) with sum2 xs
      ...| a' , b' = a + a' , b + b'

  #-A : ∀{a}{A : Set a} → RTerm A → ℕ
  #-A = p1 ∘ count

  #-ivar : ∀{a}{A : Set a} → RTerm A → ℕ
  #-ivar = p2 ∘ count

  -----------------------------------
  -- Conversion from AgTerm to RTerm

    -- compute the difference between two natural numbers, given an
  -- ordering between them.
  Δ_ : ∀ {m n} → m ≤ n → ℕ
  Δ z≤n {k} = k
  Δ s≤s  p  = Δ p

  -- correctness proof of the difference operator Δ.
  Δ-correct : ∀ {m n} (p : m ≤ n) → n ≡ m + Δ p
  Δ-correct  z≤n    = refl
  Δ-correct (s≤s p) = cong suc (Δ-correct p)

  _-Δ-_ : ∀{m}(n : ℕ)(p : m ≤ n) → ℕ
  n       -Δ- z≤n     = n
  (suc n) -Δ- s≤s prf = n -Δ- prf

  private
    convertℕ : ∀{a}{A : Set a} → ℕ → RTerm A
    convertℕ zero    = rapp (rcon (quote zero)) []
    convertℕ (suc n) = rapp (rcon (quote suc)) (convertℕ n ∷ [])

    mutual
      convert' : ℕ → AgTerm → RTerm ⊥
      convert' d (var x []) with total d x
      ...| i1 d≤x = ivar (x ∸ d)
      ...| i2 d>x = ivar x
      convert' d (lit (nat n)) = convertℕ n
      convert' d (con c args)
        = rapp (rcon c) (convertChildren d args)
      convert' d (def c args)
        = rapp (rdef c) (convertChildren d args)
      convert' d (pi (arg (arg-info visible _) (el _ t₁)) (abs _ (el _ t₂)))
        = rapp impl (convert' d t₁ ∷ convert' (suc d) t₂ ∷ [])
      convert' d (pi _ (abs _ (el _ t₂))) = convert' (suc d) t₂
      convert' d (lam _ (abs _ l))
        = rlam (convert' (suc d) l)
      convert' _ (pat-lam _ _)
        = unsuportedSyntax "Pattern-Matching lambdas."
      convert' _ (sort _)
        = unsuportedSyntax "Sorts."
      convert' _ unknown
        = unsuportedSyntax "Unknown."
      convert' _ (var _ (_ ∷ _))
        = unsuportedSyntax "Variables with arguments."
      convert' _ (lit _)
        = unsuportedSyntax "Non-ℕ literals."
      convert' _ (quote-goal _)
        = unsuportedSyntax "Reflection constructs not supported"
      convert' _ (quote-term _)
        = unsuportedSyntax "Reflection constructs not supported"
      convert' _ quote-context
        = unsuportedSyntax "Reflection constructs not supported"
      convert' _ (unquote-term _ _)
        = unsuportedSyntax "Reflection constructs not supported"

      convertChildren : ℕ → List (Arg AgTerm) → List (RTerm ⊥)
      convertChildren d [] = []
      convertChildren d (arg (arg-info visible _) x ∷ xs)
        = convert' d x ∷ convertChildren d xs
      convertChildren d (_ ∷ xs) = convertChildren d xs

  Ag2RTerm : AgTerm → RTerm ⊥
  Ag2RTerm a = convert' 0 a

  ------------------------------------------
  -- Handling Types

  Ag2RType : AgType → RTerm ⊥
  Ag2RType (el _ t) = Ag2RTerm t

  -----------------------------------------
  -- Converting Back to Agda

  open import RW.Utils.Monads using (MonadState; ST; get; inc) renaming (module Monad to MonadClass)
  open MonadClass {{...}}

  private
    mutual
      trevnoc' : RTerm ⊥ → AgTerm
      trevnoc' (ovar ())
      trevnoc' (ivar n) = var n []
      trevnoc' (rlit l) = lit l
      trevnoc' (rlam t) = lam visible (abs "_" (trevnoc' t))
      trevnoc' (rapp (rcon x) ts) = con x (trevnocChildren ts)
      trevnoc' (rapp (rdef x) ts) = def x (trevnocChildren ts)
      trevnoc' (rapp impl (t1 ∷ t2 ∷ [])) = pi (arg (arg-info visible relevant)
               (el unknown (trevnoc' t1)))
               (abs "_" (el unknown (trevnoc' t2)))
      trevnoc' (rapp impl _) = error "impl should have two arguments... always."

      trevnocChildren : List (RTerm ⊥) → List (Arg AgTerm)
      trevnocChildren []        = []
      trevnocChildren (x ∷ xs)  = arg (arg-info visible relevant) (trevnoc' x) ∷ trevnocChildren xs

  R2AgTerm : RTerm ⊥ → AgTerm
  R2AgTerm = trevnoc'


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

module Definition.Typed.Consequences.Equality where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Fundamental.Reducibility

open import Tools.Product
import Tools.PropositionalEquality as PE

U≡A′ : ∀ {A Γ l} ([U] : Γ ⊩⟨ l ⟩U)
    → Γ ⊩⟨ l ⟩ U ≡ A / (U-intr [U])
    → A PE.≡ U
U≡A′ (noemb [U]) [U≡A] = [U≡A]
U≡A′ (emb 0<1 [U]) [U≡A] = U≡A′ [U] [U≡A]

-- If A is judgmentally equal to U, then A is propositionally equal to U.
U≡A : ∀ {A Γ}
    → Γ ⊢ U ≡ A
    → A PE.≡ U
U≡A {A} U≡A with reducibleEq U≡A
U≡A {A} U≡A | [U] , [A] , [U≡A] =
  U≡A′ (U-elim [U]) (irrelevanceEq [U] (U-intr (U-elim [U])) [U≡A])

ℕ≡A′ : ∀ {A Γ l} ([ℕ] : Γ ⊩⟨ l ⟩ℕ ℕ)
    → Γ ⊩⟨ l ⟩ ℕ ≡ A / (ℕ-intr [ℕ])
    → Whnf A
    → A PE.≡ ℕ
ℕ≡A′ (noemb x) [ℕ≡A] whnfA = whnfRed* [ℕ≡A] whnfA
ℕ≡A′ (emb 0<1 [ℕ]) [ℕ≡A] whnfA = ℕ≡A′ [ℕ] [ℕ≡A] whnfA

-- If A in WHNF is judgmentally equal to ℕ, then A is propositionally equal to ℕ.
ℕ≡A : ∀ {A Γ}
    → Γ ⊢ ℕ ≡ A
    → Whnf A
    → A PE.≡ ℕ
ℕ≡A {A} ℕ≡A whnfA with reducibleEq ℕ≡A
ℕ≡A {A} ℕ≡A whnfA | [ℕ] , [A] , [ℕ≡A] =
  ℕ≡A′ (ℕ-elim [ℕ]) (irrelevanceEq [ℕ] (ℕ-intr (ℕ-elim [ℕ])) [ℕ≡A]) whnfA

-- If A in WHNF is judgmentally equal to Empty, then A is propositionally equal to Empty.
Empty≡A′ : ∀ {A Γ l} ([Empty] : Γ ⊩⟨ l ⟩Empty Empty)
    → Γ ⊩⟨ l ⟩ Empty ≡ A / (Empty-intr [Empty])
    → Whnf A
    → A PE.≡ Empty
Empty≡A′ (noemb x) [Empty≡A] whnfA = whnfRed* [Empty≡A] whnfA
Empty≡A′ (emb 0<1 [Empty]) [Empty≡A] whnfA = Empty≡A′ [Empty] [Empty≡A] whnfA

Empty≡A : ∀ {A Γ}
    → Γ ⊢ Empty ≡ A
    → Whnf A
    → A PE.≡ Empty
Empty≡A {A} Empty≡A whnfA with reducibleEq Empty≡A
Empty≡A {A} Empty≡A whnfA | [Empty] , [A] , [Empty≡A] =
  Empty≡A′ (Empty-elim [Empty]) (irrelevanceEq [Empty] (Empty-intr (Empty-elim [Empty])) [Empty≡A]) whnfA

Unit≡A′ : ∀ {A Γ l} ([Unit] : Γ ⊩⟨ l ⟩Unit Unit)
    → Γ ⊩⟨ l ⟩ Unit ≡ A / (Unit-intr [Unit])
    → Whnf A
    → A PE.≡ Unit
Unit≡A′ (noemb x) [Unit≡A] whnfA = whnfRed* [Unit≡A] whnfA
Unit≡A′ (emb 0<1 [Unit]) [Unit≡A] whnfA = Unit≡A′ [Unit] [Unit≡A] whnfA

Unit≡A : ∀ {A Γ}
    → Γ ⊢ Unit ≡ A
    → Whnf A
    → A PE.≡ Unit
Unit≡A {A} Unit≡A whnfA with reducibleEq Unit≡A
Unit≡A {A} Unit≡A whnfA | [Unit] , [A] , [Unit≡A] =
  Unit≡A′ (Unit-elim [Unit]) (irrelevanceEq [Unit] (Unit-intr (Unit-elim [Unit])) [Unit≡A]) whnfA

ne≡A′ : ∀ {A K Γ l}
     → ([K] : Γ ⊩⟨ l ⟩ne K)
     → Γ ⊩⟨ l ⟩ K ≡ A / (ne-intr [K])
     → Whnf A
     → ∃ λ M → Neutral M × A PE.≡ M
ne≡A′ (noemb [K]) (ne₌ M D′ neM K≡M) whnfA =
  M , neM , (whnfRed* (red D′) whnfA)
ne≡A′ (emb 0<1 [K]) [K≡A] whnfA = ne≡A′ [K] [K≡A] whnfA

-- If A in WHNF is judgmentally equal to K, then there exists a M such that
-- A is propositionally equal to M.
ne≡A : ∀ {A K Γ}
    → Neutral K
    → Γ ⊢ K ≡ A
    → Whnf A
    → ∃ λ M → Neutral M × A PE.≡ M
ne≡A {A} neK ne≡A whnfA with reducibleEq ne≡A
ne≡A {A} neK ne≡A whnfA | [ne] , [A] , [ne≡A] =
  ne≡A′ (ne-elim neK [ne])
        (irrelevanceEq [ne] (ne-intr (ne-elim neK [ne])) [ne≡A]) whnfA

B≡A′ : ∀ {A F G Γ l} W ([W] : Γ ⊩⟨ l ⟩B⟨ W ⟩ ⟦ W ⟧ F ▹ G)
    → Γ ⊩⟨ l ⟩ ⟦ W ⟧ F ▹ G ≡ A / (B-intr W [W])
    → Whnf A
    → ∃₂ λ H E → A PE.≡ ⟦ W ⟧ H ▹ E
B≡A′ W (noemb [W]) (B₌ F′ G′ D′ A≡B [F≡F′] [G≡G′]) whnfA =
  F′ , G′ , whnfRed* D′ whnfA
B≡A′ W (emb 0<1 [W]) [W≡A] whnfA = B≡A′ W [W] [W≡A] whnfA

Π≡A′ : ∀ {A F G Γ l} → _
Π≡A′ {A} {F} {G} {Γ} {l} = B≡A′ {A} {F} {G} {Γ} {l} BΠ
Σ≡A′ : ∀ {A F G Γ l} → _
Σ≡A′ {A} {F} {G} {Γ} {l} = B≡A′ {A} {F} {G} {Γ} {l} BΣ

-- If A is judgmentally equal to Π F ▹ G, then there exists H and E such that
-- A is propositionally equal to  Π H ▹ E.
B≡A : ∀ {A F G Γ} W
    → Γ ⊢ ⟦ W ⟧ F ▹ G ≡ A
    → Whnf A
    → ∃₂ λ H E → A PE.≡ ⟦ W ⟧ H ▹ E
B≡A {A} W W≡A whnfA with reducibleEq W≡A
B≡A {A} W W≡A whnfA | [W] , [A] , [W≡A] =
  B≡A′ W (B-elim W [W]) (irrelevanceEq [W] (B-intr W (B-elim W [W])) [W≡A]) whnfA

Π≡A : ∀ {A F G Γ} → _
Π≡A {A} {F} {G} {Γ} = B≡A {A} {F} {G} {Γ} BΠ
Σ≡A : ∀ {A F G Γ} → _
Σ≡A {A} {F} {G} {Γ} = B≡A {A} {F} {G} {Γ} BΣ


------------------------------------------------------------------------
-- Containers, including a definition of bag equivalence
------------------------------------------------------------------------

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

open import Equality

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

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude hiding (id; List)

open import Bag-equivalence eq using (Kind); open Kind
open import Bijection eq as Bijection using (_↔_; module _↔_)
open import Equivalence eq as Eq
  using (Is-equivalence; _≃_; ⟨_,_⟩; module _≃_)
open import Function-universe eq as Function-universe
  hiding (inverse; Kind) renaming (_∘_ to _⟨∘⟩_)
open import H-level eq
open import H-level.Closure eq
open import Surjection eq using (module _↠_)

------------------------------------------------------------------------
-- Containers

record Container c : Type (lsuc c) where
  constructor _▷_
  field
    Shape    : Type c
    Position : Shape → Type c

open Container public

-- Interpretation of containers.

⟦_⟧ : ∀ {c ℓ} → Container c → Type ℓ → Type _
⟦ S ▷ P ⟧ A = ∃ λ (s : S) → (P s → A)

------------------------------------------------------------------------
-- Some projections

-- The shape of something.

shape : ∀ {a c} {A : Type a} {C : Container c} → ⟦ C ⟧ A → Shape C
shape = proj₁

-- Finds the value at the given position.

index : ∀ {a c} {A : Type a} {C : Container c}
        (xs : ⟦ C ⟧ A) → Position C (shape xs) → A
index = proj₂

------------------------------------------------------------------------
-- Map

-- Containers are functors.

map : ∀ {c x y} {C : Container c} {X : Type x} {Y : Type y} →
      (X → Y) → ⟦ C ⟧ X → ⟦ C ⟧ Y
map f = Σ-map id (f ∘_)

module Map where

  identity : ∀ {c x} {C : Container c} {X : Type x}
             (xs : ⟦ C ⟧ X) → map id xs ≡ xs
  identity xs = refl _

  composition :
    ∀ {c x y z}
      {C : Container c} {X : Type x} {Y : Type y} {Z : Type z}
    (f : Y → Z) (g : X → Y) (xs : ⟦ C ⟧ X) →
    map f (map g xs) ≡ map (f ∘ g) xs
  composition f g xs = refl _

-- Naturality.

Natural : ∀ {c₁ c₂ a} {C₁ : Container c₁} {C₂ : Container c₂} →
          ({A : Type a} → ⟦ C₁ ⟧ A → ⟦ C₂ ⟧ A) → Type (c₁ ⊔ c₂ ⊔ lsuc a)
Natural function =
  ∀ {A B} (f : A → B) xs →
  map f (function xs) ≡ function (map f xs)

-- Natural transformations.

infixr 4 _[_]⟶_

record _[_]⟶_ {c₁ c₂} (C₁ : Container c₁) ℓ (C₂ : Container c₂) :
              Type (c₁ ⊔ c₂ ⊔ lsuc ℓ) where
  field
    function : {A : Type ℓ} → ⟦ C₁ ⟧ A → ⟦ C₂ ⟧ A
    natural  : Natural function

-- Natural isomorphisms.

record _[_]↔_ {c₁ c₂} (C₁ : Container c₁) ℓ (C₂ : Container c₂) :
              Type (c₁ ⊔ c₂ ⊔ lsuc ℓ) where
  field
    isomorphism : {A : Type ℓ} → ⟦ C₁ ⟧ A ↔ ⟦ C₂ ⟧ A
    natural     : Natural (_↔_.to isomorphism)

  -- Natural isomorphisms are natural transformations.

  natural-transformation : C₁ [ ℓ ]⟶ C₂
  natural-transformation = record
    { function = _↔_.to isomorphism
    ; natural  = natural
    }

  -- Natural isomorphisms can be inverted.

  inverse : C₂ [ ℓ ]↔ C₁
  inverse = record
    { isomorphism = Function-universe.inverse isomorphism
    ; natural     = λ f xs →
        map f (from xs)              ≡⟨ sym $ left-inverse-of _ ⟩
        from (to (map f (from xs)))  ≡⟨ sym $ cong from $ natural f (from xs) ⟩
        from (map f (to (from xs)))  ≡⟨ cong (from ∘ map f) $ right-inverse-of _ ⟩∎
        from (map f xs)              ∎
    }
    where open module I {A : Type ℓ} = _↔_ (isomorphism {A = A})

open Function-universe using (inverse)

------------------------------------------------------------------------
-- Any, _∈_, bag equivalence and similar relations

-- Definition of Any for containers.

Any : ∀ {a c p} {A : Type a} {C : Container c} →
      (A → Type p) → (⟦ C ⟧ A → Type (c ⊔ p))
Any {C = S ▷ P} Q (s , f) = ∃ λ (p : P s) → Q (f p)

-- Membership predicate.

infix 4 _∈_

_∈_ : ∀ {a c} {A : Type a} {C : Container c} → A → ⟦ C ⟧ A → Type _
x ∈ xs = Any (λ y → x ≡ y) xs

-- Bag equivalence etc. Note that the containers can be different as
-- long as the elements they contain have equal types.

infix 4 _∼[_]_

_∼[_]_ : ∀ {a c₁ c₂}
           {A : Type a} {C₁ : Container c₁} {C₂ : Container c₂} →
         ⟦ C₁ ⟧ A → Kind → ⟦ C₂ ⟧ A → Type _
xs ∼[ k ] ys = ∀ z → z ∈ xs ↝[ k ] z ∈ ys

-- Bag equivalence.

infix 4 _≈-bag_

_≈-bag_ : ∀ {a c₁ c₂}
            {A : Type a} {C₁ : Container c₁} {C₂ : Container c₂} →
          ⟦ C₁ ⟧ A → ⟦ C₂ ⟧ A → Type _
xs ≈-bag ys = xs ∼[ bag ] ys

------------------------------------------------------------------------
-- Various properties related to Any, _∈_ and _∼[_]_

-- Lemma relating Any to map.

Any-map : ∀ {a b c p} {A : Type a} {B : Type b} {C : Container c}
          (P : B → Type p) (f : A → B) (xs : ⟦ C ⟧ A) →
          Any P (map f xs) ↔ Any (P ∘ f) xs
Any-map P f xs = Any P (map f xs) □

-- Any can be expressed using _∈_.

Any-∈ : ∀ {a c p} {A : Type a} {C : Container c}
        (P : A → Type p) (xs : ⟦ C ⟧ A) →
        Any P xs ↔ ∃ λ x → P x × x ∈ xs
Any-∈ P (s , f) =
  (∃ λ p → P (f p))                ↔⟨ ∃-cong (λ p → ∃-intro P (f p)) ⟩
  (∃ λ p → ∃ λ x → P x × x ≡ f p)  ↔⟨ ∃-comm ⟩
  (∃ λ x → ∃ λ p → P x × x ≡ f p)  ↔⟨ ∃-cong (λ _ → ∃-comm) ⟩
  (∃ λ x → P x × ∃ λ p → x ≡ f p)  □

-- Using this property we can prove that Any and _⊎_ commute.

Any-⊎ : ∀ {a c p q} {A : Type a} {C : Container c}
        (P : A → Type p) (Q : A → Type q) (xs : ⟦ C ⟧ A) →
        Any (λ x → P x ⊎ Q x) xs ↔ Any P xs ⊎ Any Q xs
Any-⊎ P Q xs =
  Any (λ x → P x ⊎ Q x) xs                         ↔⟨ Any-∈ (λ x → P x ⊎ Q x) xs ⟩
  (∃ λ x → (P x ⊎ Q x) × x ∈ xs)                   ↔⟨ ∃-cong (λ x → ×-⊎-distrib-right) ⟩
  (∃ λ x → P x × x ∈ xs ⊎ Q x × x ∈ xs)            ↔⟨ ∃-⊎-distrib-left ⟩
  (∃ λ x → P x × x ∈ xs) ⊎ (∃ λ x → Q x × x ∈ xs)  ↔⟨ inverse $ Any-∈ P xs ⊎-cong Any-∈ Q xs ⟩
  Any P xs ⊎ Any Q xs                              □

-- Any preserves functions of various kinds and respects bag
-- equivalence and similar relations.

Any-cong : ∀ {k a c d p q}
             {A : Type a} {C : Container c} {D : Container d}
           (P : A → Type p) (Q : A → Type q)
           (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
           (∀ x → P x ↝[ k ] Q x) → xs ∼[ k ] ys →
           Any P xs ↝[ k ] Any Q ys
Any-cong P Q xs ys P↔Q xs∼ys =
  Any P xs                ↔⟨ Any-∈ P xs ⟩
  (∃ λ z → P z × z ∈ xs)  ↝⟨ ∃-cong (λ z → P↔Q z ×-cong xs∼ys z) ⟩
  (∃ λ z → Q z × z ∈ ys)  ↔⟨ inverse (Any-∈ Q ys) ⟩
  Any Q ys                □

-- Map preserves the relations.

map-cong :
  ∀ {k a b c d}
    {A : Type a} {B : Type b} {C : Container c} {D : Container d}
  (f : A → B)
  (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
  xs ∼[ k ] ys → map f xs ∼[ k ] map f ys
map-cong f xs ys xs∼ys = λ z →
  z ∈ map f xs            ↔⟨ Any-map (_≡_ z) f xs ⟩
  Any (λ x → z ≡ f x) xs  ↝⟨ Any-cong _ _ xs ys (λ x → z ≡ f x □) xs∼ys ⟩
  Any (λ x → z ≡ f x) ys  ↔⟨ inverse (Any-map (_≡_ z) f ys) ⟩
  z ∈ map f ys            □

-- Lemma relating Any to if_then_else_.

Any-if : ∀ {a c p} {A : Type a} {C : Container c}
         (P : A → Type p) (xs ys : ⟦ C ⟧ A) b →
         Any P (if b then xs else ys) ↔
         T b × Any P xs ⊎ T (not b) × Any P ys
Any-if P xs ys =
  inverse ∘ if-lemma (λ b → Any P (if b then xs else ys)) id id

-- One can reconstruct (up to natural isomorphism) the shape set and
-- the position predicate from the interpretation and the Any
-- predicate transformer.
--
-- (The following lemmas were suggested by an anonymous reviewer.)

Shape′ : ∀ {c} → (Type → Type c) → Type c
Shape′ F = F ⊤

Shape-⟦⟧ : ∀ {c} (C : Container c) →
           Shape C ↔ Shape′ ⟦ C ⟧
Shape-⟦⟧ C =
  Shape C                                 ↔⟨ inverse ×-right-identity ⟩
  Shape C × ⊤                             ↔⟨ ∃-cong (λ _ → inverse →-right-zero) ⟩
  (∃ λ (s : Shape C) → Position C s → ⊤)  □

Position′ : ∀ {c} (F : Type → Type c) →
            ({A : Type} → (A → Type) → (F A → Type c)) →
            Shape′ F → Type c
Position′ _ Any = Any (λ (_ : ⊤) → ⊤)

Position-Any : ∀ {c} {C : Container c} (s : Shape C) →
               Position C s ↔
               Position′ ⟦ C ⟧ Any (_↔_.to (Shape-⟦⟧ C) s)
Position-Any {C = C} s =
  Position C s      ↔⟨ inverse ×-right-identity ⟩
  Position C s × ⊤  □

expressed-in-terms-of-interpretation-and-Any :
  ∀ {c ℓ} (C : Container c) →
  C [ ℓ ]↔ (⟦ C ⟧ ⊤ ▷ Any (λ _ → ⊤))
expressed-in-terms-of-interpretation-and-Any C = record
  { isomorphism = λ {A} →
      (∃ λ (s : Shape C) → Position C s → A)                ↔⟨ Σ-cong (Shape-⟦⟧ C) (λ _ → lemma) ⟩
      (∃ λ (s : Shape′ ⟦ C ⟧) → Position′ ⟦ C ⟧ Any s → A)  □
  ; natural = λ _ _ → refl _
  }
  where
  -- If equality of functions had been extensional, then the following
  -- lemma could have been replaced by a congruence lemma applied to
  -- Position-Any.
  lemma : ∀ {a b} {A : Type a} {B : Type b} → (B → A) ↔ (B × ⊤ → A)
  lemma = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ { f (p , tt) → f p }
        ; from = λ f p → f (p , tt)
        }
      ; right-inverse-of = λ _ → refl _
      }
    ; left-inverse-of = λ _ → refl _
    }

------------------------------------------------------------------------
-- Alternative definition of bag equivalence

-- Two things are bag equivalent if there is a bijection (or
-- equivalence) between their positions that relates equal things.

infix 4 _≈[_]′_

_≈[_]′_ : ∀ {a c d} {A : Type a} {C : Container c} {D : Container d} →
          ⟦ C ⟧ A → Isomorphism-kind → ⟦ D ⟧ A → Type _
_≈[_]′_ {C = C} {D} (s , f) k (s′ , f′) =
  ∃ λ (P↔P : Position C s ↔[ k ] Position D s′) →
      (∀ p → f p ≡ f′ (to-implication P↔P p))

-- If the position sets are sets (have H-level two), then the two
-- instantiations of _≈[_]′_ are isomorphic (assuming extensionality).

≈′↔≈′ : ∀ {a c d} {A : Type a} {C : Container c} {D : Container d} →
        Extensionality (c ⊔ d) (c ⊔ d) →
        (∀ s → Is-set (Position C s)) →
        (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
        xs ≈[ bag ]′ ys ↔ xs ≈[ bag-with-equivalence ]′ ys
≈′↔≈′ ext P-set (s , f) (s′ , f′) =
  (∃ λ P↔P → ∀ p → f p ≡ f′ (to-implication P↔P p))  ↔⟨ Σ-cong (Eq.↔↔≃ ext (P-set s)) (λ _ → Bijection.id) ⟩
  (∃ λ P↔P → ∀ p → f p ≡ f′ (to-implication P↔P p))  □

-- The definition _≈[_]′_ is also logically equivalent to the one
-- given above. The proof is very similar to the one given in
-- Bag-equivalence.

-- Membership can be expressed as "there is an index which points to
-- the element". In fact, membership /is/ expressed in this way, so
-- this proof is unnecessary.

∈-index : ∀ {a c} {A : Type a} {C : Container c} {z}
          (xs : ⟦ C ⟧ A) → z ∈ xs ↔ ∃ λ p → z ≡ index xs p
∈-index {z = z} xs = z ∈ xs □

-- The index which points to the element (not used below).

index-of : ∀ {a c} {A : Type a} {C : Container c} {z}
           (xs : ⟦ C ⟧ A) → z ∈ xs → Position C (shape xs)
index-of xs = proj₁ ∘ to-implication (∈-index xs)

-- The positions for a given shape can be expressed in terms of the
-- membership predicate.

Position-shape :
  ∀ {a c} {A : Type a} {C : Container c} (xs : ⟦ C ⟧ A) →
  (∃ λ z → z ∈ xs) ↔ Position C (shape xs)
Position-shape {C = C} (s , f) =
  (∃ λ z → ∃ λ p → z ≡ f p)  ↔⟨ ∃-comm ⟩
  (∃ λ p → ∃ λ z → z ≡ f p)  ↔⟨⟩
  (∃ λ p → Singleton (f p))  ↔⟨ ∃-cong (λ _ → _⇔_.to contractible⇔↔⊤ (singleton-contractible _)) ⟩
  Position C s × ⊤           ↔⟨ ×-right-identity ⟩
  Position C s               □

-- Position _ ∘ shape respects the various relations.

Position-shape-cong :
  ∀ {k a c d} {A : Type a} {C : Container c} {D : Container d}
  (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
  xs ∼[ k ] ys → Position C (shape xs) ↝[ k ] Position D (shape ys)
Position-shape-cong {C = C} {D} xs ys xs∼ys =
  Position C (shape xs)  ↔⟨ inverse $ Position-shape xs ⟩
  ∃ (λ z → z ∈ xs)       ↝⟨ ∃-cong xs∼ys ⟩
  ∃ (λ z → z ∈ ys)       ↔⟨ Position-shape ys ⟩
  Position D (shape ys)  □

-- Furthermore Position-shape-cong relates equal elements.

Position-shape-cong-relates :
  ∀ {k a c d} {A : Type a} {C : Container c} {D : Container d}
  (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) (xs≈ys : xs ∼[ k ] ys) p →
  index xs p ≡
    index ys (to-implication (Position-shape-cong xs ys xs≈ys) p)
Position-shape-cong-relates {bag} xs ys xs≈ys p =
  index xs p                                                     ≡⟨ proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _) ⟩
  index ys (proj₁ $ to-implication (xs≈ys (index xs p))
                                   (p , refl _))                 ≡⟨⟩
  index ys (_↔_.to (Position-shape ys) $
            Σ-map id (λ {z} → to-implication (xs≈ys z)) $
            _↔_.from (Position-shape xs) $ p)                    ≡⟨⟩
  index ys (_↔_.to (Position-shape ys) $
            to-implication (∃-cong xs≈ys) $
            _↔_.from (Position-shape xs) $ p)                    ≡⟨⟩
  index ys (to-implication
              ((from-bijection (Position-shape ys) ⟨∘⟩
                ∃-cong xs≈ys) ⟨∘⟩
               from-bijection (inverse $ Position-shape xs))
              p)                                                 ≡⟨⟩
  index ys (to-implication (Position-shape-cong xs ys xs≈ys) p)  ∎

Position-shape-cong-relates {bag-with-equivalence} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)
Position-shape-cong-relates {bag-with-equivalenceᴱ} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)
Position-shape-cong-relates {subbag} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)
Position-shape-cong-relates {set} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)
Position-shape-cong-relates {subset} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)
Position-shape-cong-relates {embedding} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)
Position-shape-cong-relates {surjection} xs ys xs≈ys p =
  proj₂ $ to-implication (xs≈ys (index xs p)) (p , refl _)

-- We get that the two definitions of bag equivalence are logically
-- equivalent.

≈⇔≈′ : ∀ {k a c d} {A : Type a} {C : Container c} {D : Container d}
       (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
       xs ∼[ ⌊ k ⌋-iso ] ys ⇔ xs ≈[ k ]′ ys
≈⇔≈′ {k} xs ys = record
  { to   = λ xs≈ys → ( Position-shape-cong xs ys xs≈ys
                     , Position-shape-cong-relates xs ys xs≈ys
                     )
  ; from = from
  }
  where
  from : xs ≈[ k ]′ ys → xs ∼[ ⌊ k ⌋-iso ] ys
  from (P↔P , related) = λ z →
    z ∈ xs                    ↔⟨⟩
    ∃ (λ p → z ≡ index xs p)  ↔⟨ Σ-cong P↔P (λ p → _↠_.from (Π≡↔≡-↠-≡ k _ _) (related p) z) ⟩
    ∃ (λ p → z ≡ index ys p)  ↔⟨⟩
    z ∈ ys                    □

-- If equivalences are used, then the definitions are isomorphic
-- (assuming extensionality).
--
-- Thierry Coquand helped me with this proof: At first I wasn't sure
-- if it was true or not, but then I managed to prove it for singleton
-- lists, Thierry found a proof for lists of length two, I found one
-- for streams, and finally I could complete a proof of the statement
-- below.

≈↔≈′ : ∀ {a c d} {A : Type a} {C : Container c} {D : Container d} →
       Extensionality (a ⊔ c ⊔ d) (a ⊔ c ⊔ d) →
       (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
       xs ∼[ bag-with-equivalence ] ys ↔
       xs ≈[ bag-with-equivalence ]′ ys
≈↔≈′ {a} {c} {d} {C = C} {D} ext xs ys = record
  { surjection = record
    { logical-equivalence = equiv
    ; right-inverse-of    = λ { (⟨ f , f-eq ⟩ , related) →
      let
        P : (Position C (shape xs) → Position D (shape ys)) →
            Type (a ⊔ c)
        P f = ∀ p → index xs p ≡ index ys (f p)

        f-eq′ : Is-equivalence f
        f-eq′ = _

        irr : f-eq′ ≡ f-eq
        irr = proj₁ $ +⇒≡ $
          Eq.propositional (lower-extensionality a a ext) f

        f≡f : ⟨ f , f-eq′ ⟩ ≡ ⟨ f , f-eq ⟩
        f≡f = cong (⟨_,_⟩ f) irr

        cong-to-f≡f : cong _≃_.to f≡f ≡ refl f
        cong-to-f≡f =
          cong _≃_.to f≡f              ≡⟨ cong-∘ _≃_.to (⟨_,_⟩ f) irr ⟩
          cong (_≃_.to ∘ ⟨_,_⟩ f) irr  ≡⟨ cong-const irr ⟩∎
          refl _                       ∎
      in
      Σ-≡,≡→≡ f≡f
        (subst (P ∘ _≃_.to) f≡f (trans (refl _) ∘ related)  ≡⟨ cong (subst (P ∘ _≃_.to) f≡f)
                                                                    (apply-ext (lower-extensionality (a ⊔ d) (c ⊔ d) ext) λ _ → trans-reflˡ _) ⟩
         subst (P ∘ _≃_.to) f≡f related                     ≡⟨ subst-∘ P _≃_.to f≡f ⟩
         subst P (cong _≃_.to f≡f) related                  ≡⟨ cong (λ eq → subst P eq related) cong-to-f≡f ⟩
         subst P (refl _) related                           ≡⟨ subst-refl P related ⟩∎
         related                                            ∎) }
    }
  ; left-inverse-of = λ xs≈ys →
      apply-ext (lower-extensionality (c ⊔ d) a ext) λ z →
        Eq.lift-equality ext $
          apply-ext (lower-extensionality d c ext) λ { (p , z≡xs[p]) →

              let xs[p]≡ys[-] : ∃ λ p′ → index xs p ≡ index ys p′
                  xs[p]≡ys[-] = _≃_.to (xs≈ys (index xs p)) (p , refl _)
              in

            Σ-map id (trans z≡xs[p]) xs[p]≡ys[-]      ≡⟨ elim₁ (λ {z} z≡xs[p] → Σ-map id (trans z≡xs[p]) xs[p]≡ys[-] ≡
                                                                          _≃_.to (xs≈ys z) (p , z≡xs[p]))
              (Σ-map id (trans (refl _)) xs[p]≡ys[-]              ≡⟨ cong (_,_ _) (trans-reflˡ _) ⟩∎
               xs[p]≡ys[-]                                        ∎)
                                                               z≡xs[p] ⟩∎
            _≃_.to (xs≈ys z) (p , z≡xs[p])            ∎ }
  }
  where
  equiv = ≈⇔≈′ {k = equivalence} xs ys

  open _⇔_ equiv

------------------------------------------------------------------------
-- Another alternative definition of bag equivalence

-- A higher-order variant of _∼[_]_. Note that this definition is
-- large (due to the quantification over predicates).

infix 4 _∼[_]″_

_∼[_]″_ : ∀ {a c d} {A : Type a} {C : Container c} {D : Container d} →
          ⟦ C ⟧ A → Kind → ⟦ D ⟧ A → Type (lsuc a ⊔ c ⊔ d)
_∼[_]″_ {a} {A = A} xs k ys =
  (P : A → Type a) → Any P xs ↝[ k ] Any P ys

-- This definition is logically equivalent to _∼[_]_.

∼⇔∼″ : ∀ {k a c d} {A : Type a} {C : Container c} {D : Container d}
       (xs : ⟦ C ⟧ A) (ys : ⟦ D ⟧ A) →
       xs ∼[ k ] ys ⇔ xs ∼[ k ]″ ys
∼⇔∼″ xs ys = record
  { to   = λ xs∼ys P → Any-cong P P xs ys (λ _ → id) xs∼ys
  ; from = λ Any-xs↝Any-ys z → Any-xs↝Any-ys (λ x → z ≡ x)
  }

------------------------------------------------------------------------
-- The ⟦_⟧₂ operator

-- Lifts a family of binary relations from A to ⟦ C ⟧ A.

⟦_⟧₂ :
  ∀ {a c r} {A : Type a} (C : Container c) →
  (A → A → Type r) →
  ⟦ C ⟧ A → ⟦ C ⟧ A → Type (c ⊔ r)
⟦ C ⟧₂ R (s , f) (t , g) =
  ∃ λ (eq : s ≡ t) →
  (p : Position C s) →
  R (f p) (g (subst (Position C) eq p))
  where
  open Container

-- A map function for ⟦_⟧₂.

⟦⟧₂-map :
  ∀ {a b c r s} {A : Type a} {B : Type b} {C : Container c}
  (R : A → A → Type r) (S : B → B → Type s) (f : A → B) →
  (∀ x y → R x y → S (f x) (f y)) →
  (∀ x y → ⟦ C ⟧₂ R x y → ⟦ C ⟧₂ S (map f x) (map f y))
⟦⟧₂-map _ _ _ f _ _ = Σ-map id (f _ _ ∘_)

-- ⟦_⟧₂ preserves reflexivity.

⟦⟧₂-reflexive :
  ∀ {a c r} {A : Type a} {C : Container c}
  (R : A → A → Type r) →
  (∀ x → R x x) →
  (∀ x → ⟦ C ⟧₂ R x x)
⟦⟧₂-reflexive {C = C} R r (xs , f) =
    refl _
  , λ p →                                           $⟨ r _ ⟩
      R (f p) (f p)                                 ↝⟨ subst (R _ ∘ f) (sym $ subst-refl _ _) ⟩□
      R (f p) (f (subst (Position C) (refl xs) p))  □

-- ⟦_⟧₂ preserves symmetry.

⟦⟧₂-symmetric :
  ∀ {a c r} {A : Type a} {C : Container c}
  (R : A → A → Type r) →
  (∀ {x y} → R x y → R y x) →
  (∀ {x y} → ⟦ C ⟧₂ R x y → ⟦ C ⟧₂ R y x)
⟦⟧₂-symmetric {C = C} R r {_ , f} {_ , g} (eq , h) =
    sym eq
  , λ p →                                                            $⟨ h (subst (Position C) (sym eq) p) ⟩
      R (f (subst (Position C) (sym eq) p))
        (g (subst (Position C) eq (subst (Position C) (sym eq) p)))  ↝⟨ subst (R (f (subst (Position C) (sym eq) p)) ∘ g) $ subst-subst-sym _ _ _ ⟩

      R (f (subst (Position C) (sym eq) p)) (g p)                    ↝⟨ r ⟩□

      R (g p) (f (subst (Position C) (sym eq) p))                    □

-- ⟦_⟧₂ preserves transitivity.

⟦⟧₂-transitive :
  ∀ {a c r} {A : Type a} {C : Container c}
  (R : A → A → Type r) →
  (∀ {x y z} → R x y → R y z → R x z) →
  (∀ {x y z} → ⟦ C ⟧₂ R x y → ⟦ C ⟧₂ R y z → ⟦ C ⟧₂ R x z)
⟦⟧₂-transitive {C = C}
               R r {_ , f} {_ , g} {_ , h} (eq₁ , f₁) (eq₂ , f₂) =
    trans eq₁ eq₂
  , λ p →                                                             $⟨ f₂ _ ⟩
      R (g (subst (Position C) eq₁ p))
        (h (subst (Position C) eq₂ (subst (Position C) eq₁ p)))       ↝⟨ subst (R (g (subst (Position C) _ _)) ∘ h) $ subst-subst _ _ _ _ ⟩

      R (g (subst (Position C) eq₁ p))
        (h (subst (Position C) (trans eq₁ eq₂) p))                    ↝⟨ f₁ _ ,_ ⟩

      R (f p) (g (subst (Position C) eq₁ p)) ×
      R (g (subst (Position C) eq₁ p))
        (h (subst (Position C) (trans eq₁ eq₂) p))                    ↝⟨ uncurry r ⟩□

      R (f p) (h (subst (Position C) (trans eq₁ eq₂) p))              □


------------------------------------------------------------------------------
-- ABP Lemma 1
------------------------------------------------------------------------------

{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K                #-}

-- From Dybjer and Sander's paper: The first lemma states that given a
-- start state S of the ABP, we will arrive at a state S', where the
-- message has been received by the receiver, but where the
-- acknowledgement has not yet been received by the sender.

module FOT.FOTC.Program.ABP.Lemma1NoHelperATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP using ( x≢not-x )
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- 30 November 2013. If we don't have the following definitions
-- outside, the ATPs cannot prove the theorems.

as^ : ∀ b i' is' ds → D
as^ b i' is' ds = await b i' is' ds
{-# ATP definition as^ #-}

bs^ : D → D → D → D → D → D
bs^ b i' is' ds os₁^ = corrupt os₁^ · (as^ b i' is' ds)
{-# ATP definition bs^ #-}

cs^ : D → D → D → D → D → D
cs^ b i' is' ds os₁^ = ack b · (bs^ b i' is' ds os₁^)
{-# ATP definition cs^ #-}

ds^ : D → D → D → D → D → D → D
ds^ b i' is' ds os₁^ os₂^ = corrupt os₂^ · cs^ b i' is' ds os₁^
{-# ATP definition ds^ #-}

os₁^ : D → D → D
os₁^ os₁' ft₁^ = ft₁^ ++ os₁'
{-# ATP definition os₁^ #-}

os₂^ : D → D
os₂^ os₂ = tail₁ os₂
{-# ATP definition os₂^ #-}

------------------------------------------------------------------------------
-- From Dybjer and Sander's paper: From the assumption that os₁ ∈ Fair
-- and hence by unfolding Fair, we conclude that there are ft₁ :  F*T
-- and os₁' : Fair, such that os₁ = ft₁ ++ os₁'.
--
-- We proceed by induction on ft₁ : F*T using helper.

-- 26 January 2014. Pattern matching after a @with@ it is not accepted
-- by the termination checker. See Agda issue 59, comment 18.

{-# TERMINATING #-}
lemma₁ : ∀ b i' is' os₁ os₂ as bs cs ds js →
         Bit b →
         Fair os₁ →
         Fair os₂ →
         S b (i' ∷ is') os₁ os₂ as bs cs ds js →
         ∃[ os₁' ] ∃[ os₂' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
           Fair os₁'
           ∧ Fair os₂'
           ∧ S' b i' is' os₁' os₂' as' bs' cs' ds' js'
           ∧ js ≡ i' ∷ js'
lemma₁ b i' is' os₁ os₂ as bs cs ds js Bb Fos₁ Fos₂ s with Fair-out Fos₁
... | .(true ∷ []) , os₁' , f*tnil , os₁≡ft₁++os₁' , Fos₁' = prf
  where
  postulate
    prf : ∃[ os₁' ] ∃[ os₂' ] ∃[ as' ] ∃[ bs' ] ∃[ cs' ] ∃[ ds' ] ∃[ js' ]
            Fair os₁'
            ∧ Fair os₂'
            ∧ (as' ≡ await b i' is' ds'
              ∧ bs' ≡ corrupt os₁' · as'
              ∧ cs' ≡ ack (not b) · bs'
              ∧ ds' ≡ corrupt os₂' · (b ∷ cs')
              ∧ js' ≡ out (not b) · bs')
            ∧ js ≡ i' ∷ js'
  {-# ATP prove prf #-}

... | .(F ∷ ft₁^) , os₁' , f*tcons {ft₁^} FTft₁ , os₁≡ft₁++os₁' , Fos₁' =
  lemma₁ b i' is'
         (ft₁^ ++ os₁')
         (tail₁ os₂)
         (await b i' is' ds)
         (corrupt (ft₁^ ++ os₁') · await b i' is' ds)
         (ack b · (corrupt (ft₁^ ++ os₁') · await b i' is' ds))
         (corrupt (tail₁ os₂) ·
           (ack b · (corrupt (ft₁^ ++ os₁') · await b i' is' ds)))
         js Bb (Fair-in (ft₁^ , os₁' , FTft₁ , refl , Fos₁')) (tail-Fair Fos₂) ihS
     where
     postulate os₁-eq-helper : os₁ ≡ F ∷ os₁^ os₁' ft₁^
     {-# ATP prove os₁-eq-helper #-}

     postulate as-eq : as ≡ < i' , b > ∷ (as^ b i' is' ds)
     {-# ATP prove as-eq #-}

     postulate bs-eq : bs ≡ error ∷ (bs^ b i' is' ds (os₁^ os₁' ft₁^))
     {-# ATP prove bs-eq os₁-eq-helper as-eq #-}

     postulate cs-eq : cs ≡ not b ∷ cs^ b i' is' ds (os₁^ os₁' ft₁^)
     {-# ATP prove cs-eq bs-eq #-}

     postulate ds-eq : ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
                  ∨ ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove ds-eq head-tail-Fair cs-eq #-}

     postulate
       as^-eq-helper₁ :
         ds ≡ ok (not b) ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
         as^ b i' is' ds ≡
           send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove as^-eq-helper₁ x≢not-x #-}

     postulate
       as^-eq-helper₂ :
         ds ≡ error ∷ ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂) →
         as^ b i' is' ds ≡
           send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     {-# ATP prove as^-eq-helper₂ #-}

     as^-eq : as^ b i' is' ds ≡
              send b · (i' ∷ is') · ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂)
     as^-eq = case as^-eq-helper₁ as^-eq-helper₂ ds-eq

     postulate js-eq : js ≡ out b · bs^ b i' is' ds (os₁^ os₁' ft₁^)
     {-# ATP prove js-eq bs-eq #-}

     ihS : S b
             (i' ∷ is')
             (os₁^ os₁' ft₁^)
             (os₂^ os₂)
             (as^ b i' is' ds)
             (bs^ b i' is' ds (os₁^ os₁' ft₁^))
             (cs^ b i' is' ds (os₁^ os₁' ft₁^))
             (ds^ b i' is' ds (os₁^ os₁' ft₁^) (os₂^ os₂))
             js
     ihS = as^-eq , refl , refl , refl , js-eq