{-
The equivalent "goodness" of can w.r.t. the rmerge reduction.
The lemma proved in this file is

    can-irr : ∀ {BV} {FV} θ₁ θ₂ q →
      CorrectBinding q BV FV →
      (distinct' (proj₁ FV) (proj₁ (Dom θ₂))) →
       Can q θ₁ ≡ Can q (θ₁ ← θ₂)

That is, the result of the Can function will not change
provided that the program does not refer to any variables
in the new environment.

-}
module Esterel.Lang.CanFunction.MergePotentialRuleCan where

open import utility

open import Esterel.Lang
open import Esterel.Lang.Binding
open import Esterel.Lang.CanFunction
open import Esterel.Lang.CanFunction.Base
open import Esterel.Context
open import Esterel.Context.Properties
  using (plug ; unplug)
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)
open import Data.List.Properties
  using (map-id)
open import Data.List.Any
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties
  using ()
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; zero ; suc ; _≟_ ; _+_)
open import Data.Nat.Properties.Simple
  using (+-comm)
open import Data.Product
  using (Σ ; proj₁ ; proj₂ ; ∃ ; _,_ ; _,′_ ; _×_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function
  using (_∘_ ; _∋_ ; id)
open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; trans ; sym ; cong ; subst)

open 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-remove-mono-∈ ; set-remove-removed ; set-remove-not-removed)

can-new-irr : ∀ {BV} {FV} θ₁ θ₂ θo q →
  CorrectBinding q BV FV →
  (∀ S' → S' ∈ (proj₁ FV) → (S' ∉ proj₁ (Dom θ₂)) ⊎ (S' ∈ proj₁ (Dom θo))) →
  Can q (θ₁ ← θo) ≡ Can q ((θ₁ ← θ₂) ← θo)

canθ-new-irr : ∀ {BV} {FV} sigs S θ₁ θ₂ θo q →
  CorrectBinding q BV FV →
  (∀ S' → S' ∈ (proj₁ FV) →
    ((S' ∉ proj₁ (Dom θ₂)) ⊎ (S' ∈ proj₁ (Dom θo))) ⊎
    S' ∈ map (_+_ S) (SigMap.keys sigs)) →
  Canθ sigs S q (θ₁ ← θo) ≡ Canθ sigs S q ((θ₁ ← θ₂) ← θo)

can-new-irr θ₁ θ₂ θo nothin CBnothing S-prop = refl
can-new-irr θ₁ θ₂ θo pause CBpause S-prop = refl
can-new-irr θ₁ θ₂ θo (signl S q) (CBsig cbq) S-prop
  rewrite canθ-new-irr (Env.sig ([S]-env S)) 0 θ₁ θ₂ θo q cbq
            (λ S' S'∈FV →
              Data.Sum.map
                (S-prop S')
                (subst (S' ∈_) (sym (map-id (proj₁ (Dom ([S]-env S))))) ∘
                 (λ S'∈[S] →
                   subst (_∈ proj₁ (Dom ([S]-env S)))
                     (sym (∈:: S'∈[S]))
                     (Env.sig-∈-single S Signal.unknown)))
                (set-subtract-split {ys = Signal.unwrap S ∷ []} S'∈FV))
  = refl
can-new-irr θ₁ θ₂ θo (present S ∣⇒ p ∣⇒ q) (CBpresent {FVp = FVp} cbp cbq) S-prop
  with S-prop (Signal.unwrap S) (here refl)| Env.Sig∈ S (θ₁ ← θo) | Env.Sig∈ S ((θ₁ ← θ₂) ← θo)
... | inj₂ S∈Domθo | no  S∉domθ₁←θo | S∈domθ₁←θ₂←θo? =
  ⊥-elim (S∉domθ₁←θo (Env.sig-←-monoʳ S θo θ₁ S∈Domθo))
... | inj₂ S∈Domθo | yes S∈domθ₁←θo | no  S∉domθ₁←θ₂←θo =
  ⊥-elim (S∉domθ₁←θ₂←θo (Env.sig-←-monoʳ S θo (θ₁ ← θ₂) S∈Domθo))
... | inj₂ S∈Domθo | yes S∈domθ₁←θo | yes S∈domθ₁←θ₂←θo
  rewrite SigMap.∈-get-U-irr-m S (Env.sig θ₁) (Env.sig (θ₁ ← θ₂)) (Env.sig θo)
          S∈domθ₁←θo S∈domθ₁←θ₂←θo S∈Domθo
  with Env.sig-stats {S} ((θ₁ ← θ₂) ← θo) S∈domθ₁←θ₂←θo
... | Signal.present = can-new-irr θ₁ θ₂ θo p cbp
                         (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
... | Signal.absent  = can-new-irr θ₁ θ₂ θo q cbq
                         (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
... | Signal.unknown
  rewrite can-new-irr θ₁ θ₂ θo p cbp
            (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
        | can-new-irr θ₁ θ₂ θo q cbq
            (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
  = refl
can-new-irr θ₁ θ₂ θo (present S ∣⇒ p ∣⇒ q) (CBpresent {FVp = FVp} cbp cbq) S-prop
  | inj₁ S∉Domθ₂ | yes S∈domθ₁←θo | yes S∈domθ₁←θ₂←θo
  with Env.sig-←⁻ {θ₁} {θo} S S∈domθ₁←θo
... | inj₂ S∈Domθo
  rewrite SigMap.∈-get-U-irr-m S (Env.sig θ₁) (Env.sig (θ₁ ← θ₂)) (Env.sig θo)
          S∈domθ₁←θo S∈domθ₁←θ₂←θo S∈Domθo
  with Env.sig-stats {S} ((θ₁ ← θ₂) ← θo) S∈domθ₁←θ₂←θo
... | Signal.present = can-new-irr θ₁ θ₂ θo p cbp
                         (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
... | Signal.absent  = can-new-irr θ₁ θ₂ θo q cbq
                         (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
... | Signal.unknown
  rewrite can-new-irr θ₁ θ₂ θo p cbp
            (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
        | can-new-irr θ₁ θ₂ θo q cbq
            (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
  = refl
can-new-irr θ₁ θ₂ θo (present S ∣⇒ p ∣⇒ q) (CBpresent {FVp = FVp} cbp cbq) S-prop
  | inj₁ S∉Domθ₂ | yes S∈domθ₁←θo | yes S∈domθ₁←θ₂←θo
  | inj₁ S∈domθ₁ with Env.sig-←-irr-get {θ₁} {θ₂} {S} S∈domθ₁ S∉Domθ₂
... | a , b rewrite SigMap.get-U-both-irr-m S (Env.sig θ₁) (Env.sig (θ₁ ← θ₂)) (Env.sig θo) S∈domθ₁ a S∈domθ₁←θo S∈domθ₁←θ₂←θo b
  with Env.sig-stats {S} ((θ₁ ← θ₂) ← θo) S∈domθ₁←θ₂←θo
... | Signal.present = can-new-irr θ₁ θ₂ θo p cbp
                         (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
... | Signal.absent  = can-new-irr θ₁ θ₂ θo q cbq
                         (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
... | Signal.unknown
  rewrite can-new-irr θ₁ θ₂ θo p cbp
            (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
        | can-new-irr θ₁ θ₂ θo q cbq
            (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
  = refl
can-new-irr θ₁ θ₂ θo (present S ∣⇒ p ∣⇒ q) (CBpresent cbp cbq) S-prop
  | inj₁ S∉Domθ₂ | yes S∈domθ₁←θo | no  S∉domθ₁←θ₂←θo
  rewrite SigMap.keys-assoc-comm (Env.sig θ₁) (Env.sig θ₂) (Env.sig θo)
  = ⊥-elim (S∉domθ₁←θ₂←θo (SigMap.U-mono {m = Env.sig (θ₁ ← θo)} {k = S} S∈domθ₁←θo))
can-new-irr θ₁ θ₂ θo (present S ∣⇒ p ∣⇒ q) (CBpresent cbp cbq) S-prop
  | inj₁ S∉Domθ₂ | no  S∉domθ₁←θo | yes S∈domθ₁←θ₂←θo
  with Env.sig-←⁻ {θ₁ ← θo} {θ₂} S
                  (subst (Signal.unwrap S ∈_)
                    (SigMap.keys-assoc-comm (Env.sig θ₁) (Env.sig θ₂) (Env.sig θo))
                    S∈domθ₁←θ₂←θo)
... | (inj₁ S∈Domθ₁←θo) = ⊥-elim (S∉domθ₁←θo S∈Domθ₁←θo)
... | (inj₂ S∈Domθ₂) = ⊥-elim (S∉Domθ₂ S∈Domθ₂)
can-new-irr θ₁ θ₂ θo (present S ∣⇒ p ∣⇒ q) (CBpresent {FVp = FVp} cbp cbq) S-prop
  | inj₁ S∉Domθ₂ | no  S∉domθ₁←θo | no  S∉domθ₁←θ₂←θo
  rewrite can-new-irr θ₁ θ₂ θo p cbp
            (λ S' S'∈FVp → S-prop S' (++ʳ (Signal.unwrap S ∷ []) (++ˡ S'∈FVp)))
        | can-new-irr θ₁ θ₂ θo q cbq
            (λ S' S'∈FVq → S-prop S' (++ʳ (Signal.unwrap S ∷ proj₁ FVp) S'∈FVq))
  = refl
can-new-irr θ₁ θ₂ θo (emit S) CBemit S-prop = refl
can-new-irr θ₁ θ₂ θo (p ∥ q) (CBpar {FVp = FVp} cbp cbq BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) S-prop
  rewrite can-new-irr θ₁ θ₂ θo p cbp (λ S' S'∈FVp → S-prop S' (++ˡ S'∈FVp))
        | can-new-irr θ₁ θ₂ θo q cbq (λ S' S'∈FVq → S-prop S' (++ʳ (proj₁ FVp) S'∈FVq))
  = refl
can-new-irr θ₁ θ₂ θo (loop q) (CBloop cbq BV≠FV) S-prop =
  can-new-irr θ₁ θ₂ θo q cbq S-prop
can-new-irr θ₁ θ₂ θo (loopˢ p q) (CBloopˢ {BVp = BVp} {FVp = FVp} CBp CBq BVp≠FVq BVq≠FVq) S-prop
  rewrite can-new-irr θ₁ θ₂ θo p CBp (λ S' S'∈FVp → S-prop S' (++ˡ S'∈FVp))
        | can-new-irr θ₁ θ₂ θo q CBq (λ S' S'∈FVq → S-prop S' (++ʳ (proj₁ FVp) S'∈FVq))
 = refl
can-new-irr θ₁ θ₂ θo (p >> q) (CBseq {BVp = BVp} {FVp = FVp} cbp cbq BVp≠FVq) S-prop
  with can-new-irr θ₁ θ₂ θo p cbp (λ S' S'∈FVp → S-prop S' (++ˡ S'∈FVp))
... | can-p-θ₁←θo≡can-p-θ₁←θ₂←θo
  with any (Code._≟_ Code.nothin) (Canₖ p (θ₁ ← θo))
     | any (Code._≟_ Code.nothin) (Canₖ p ((θ₁ ← θ₂) ← θo))
... | yes nothin∈can-p-θ₁←θo | yes nothin∈can-p-θ₁←θ₂←θo
  rewrite can-p-θ₁←θo≡can-p-θ₁←θ₂←θo
        | can-new-irr θ₁ θ₂ θo q cbq (λ S' S'∈FVq → S-prop S' (++ʳ (proj₁ FVp) S'∈FVq))
  = refl
... | yes nothin∈can-p-θ₁←θo | no  nothin∉can-p-θ₁←θ₂←θo
  = ⊥-elim (nothin∉can-p-θ₁←θ₂←θo
            (subst (λ xs → Code.nothin ∈ proj₁ (proj₂ xs))
                   can-p-θ₁←θo≡can-p-θ₁←θ₂←θo
                   nothin∈can-p-θ₁←θo))
... | no  nothin∉can-p-θ₁←θo | yes nothin∈can-p-θ₁←θ₂←θo
  = ⊥-elim (nothin∉can-p-θ₁←θo
            (subst (λ xs → Code.nothin ∈ proj₁ (proj₂ xs))
                   (sym can-p-θ₁←θo≡can-p-θ₁←θ₂←θo)
                   nothin∈can-p-θ₁←θ₂←θo))
... | no  nothin∉can-p-θ₁←θo | no  nothin∉can-p-θ₁←θ₂←θo
  rewrite can-p-θ₁←θo≡can-p-θ₁←θ₂←θo = refl
can-new-irr θ₁ θ₂ θo (suspend q S) (CBsusp cbq [S]≠BVp) S-prop =
  can-new-irr θ₁ θ₂ θo q cbq (λ S' S'∈FV → S-prop S' (there S'∈FV))
can-new-irr θ₁ θ₂ θo (exit n) CBexit S-prop = refl
can-new-irr θ₁ θ₂ θo (trap q) (CBtrap cbq) S-prop
  rewrite can-new-irr θ₁ θ₂ θo q cbq S-prop
  = refl
can-new-irr θ₁ θ₂ θo (shared s ≔ e in: q) (CBshared {FV = FV} cbq) S-prop
  rewrite set-subtract-[] (proj₁ FV)
        | can-new-irr θ₁ θ₂ θo q cbq (λ S' S'∈FV → S-prop S' (++ʳ (proj₁ (FVₑ e)) S'∈FV))
  = refl
can-new-irr θ₁ θ₂ θo (s ⇐ e) CBsset S-prop = refl
can-new-irr θ₁ θ₂ θo (var x ≔ e in: q) (CBvar {FV = FV} cbq) S-prop
  rewrite set-subtract-[] (proj₁ FV)
  = can-new-irr θ₁ θ₂ θo q cbq (λ S' S'∈FV → S-prop S' (++ʳ (proj₁ (FVₑ e)) S'∈FV))
can-new-irr θ₁ θ₂ θo (x ≔ e) CBvset S-prop = refl
can-new-irr θ₁ θ₂ θo (if x ∣⇒ p ∣⇒ q) (CBif {FVp = FVp} cbp cbq) S-prop
  rewrite can-new-irr θ₁ θ₂ θo p cbp (λ S' S'∈FVp → S-prop S' (++ˡ S'∈FVp))
        | can-new-irr θ₁ θ₂ θo q cbq (λ S' S'∈FVq → S-prop S' (++ʳ (proj₁ FVp) S'∈FVq))
  = refl
can-new-irr θ₁ θ₂ θo (ρ⟨ θ , A ⟩· q) (CBρ {FV = FV} cbq) S-prop
  rewrite canθ-new-irr (Env.sig θ) 0 θ₁ θ₂ θo q cbq
            (λ S' S'∈FV →
              Data.Sum.map
                (S-prop S')
                (subst (S' ∈_) (sym (map-id (proj₁ (Dom θ)))))
                (set-subtract-split {ys = proj₁ (Dom θ)} S'∈FV))
  = refl

canθ-new-irr-S-prop-accumulate : ∀ {xs ys zs} S status θo →

  (∀ S' → S' ∈ xs →
    (S' ∉ ys ⊎ S' ∈ proj₁ (Dom θo)) ⊎
    S' ∈ (S + 0 ∷ map (_+_ S) (map suc zs))) →

  ∀ S' → S' ∈ xs →
    (S' ∉ ys ⊎ S' ∈ proj₁ (Dom (θo ← [ (S ₛ) ↦ status ]))) ⊎
    S' ∈ map (_+_ (suc S)) zs

canθ-new-irr-S-prop-accumulate {zs = zs} S status θo S-prop S' S'∈xs with S-prop S' S'∈xs
... | inj₁ (inj₁ S'∉ys) = inj₁ (inj₁ S'∉ys)
... | inj₁ (inj₂ S'∈Domθo) =
  inj₁ (inj₂ (Env.sig-←-monoˡ (S' ₛ) θo [ (S ₛ) ↦ status ]  S'∈Domθo))
... | inj₂ (here refl) rewrite +-comm S 0 =
  inj₁ (inj₂ (Env.sig-←-monoʳ (S ₛ) [ S ₛ ↦ status ] θo (Env.sig-∈-single (S ₛ) status)))
... | inj₂ (there S'∈map-+-S-suc-zs)
  rewrite map-+-compose-suc S zs
  = inj₂ S'∈map-+-S-suc-zs

canθ-new-irr {BV} {FV} [] S θ₁ θ₂ θo q cbq S-prop =
  can-new-irr θ₁ θ₂ θo q cbq S-prop'
  where
    S-prop' : ∀ S' → S' ∈ proj₁ FV → S' ∉ proj₁ (Dom θ₂) ⊎ S' ∈ proj₁ (Dom θo)
    S-prop' S' S'∈FV with S-prop S' S'∈FV
    ... | inj₁ S'∉Domθ₂⊎S'∈Domθo = S'∉Domθ₂⊎S'∈Domθo
    ... | inj₂ ()
canθ-new-irr (nothing ∷ sigs) S θ₁ θ₂ θo q cbq S-prop =
  canθ-new-irr sigs (suc S) θ₁ θ₂ θo q cbq
    (λ S' S'∈FV →
      Data.Sum.map id (subst (S' ∈_) (map-+-compose-suc S (SigMap.keys sigs)))
        (S-prop S' S'∈FV))
canθ-new-irr (just Signal.present ∷ sigs) S θ₁ θ₂ θo q cbq S-prop
  rewrite sym (Env.←-assoc θ₁ θo ([S]-env-present (S ₛ)))
        | sym (Env.←-assoc (θ₁ ← θ₂) θo ([S]-env-present (S ₛ)))
  = canθ-new-irr sigs (suc S) θ₁ θ₂ (θo ← [S]-env-present (S ₛ)) q cbq
      (canθ-new-irr-S-prop-accumulate S Signal.present θo S-prop)
canθ-new-irr (just Signal.absent ∷ sigs) S θ₁ θ₂ θo q cbq S-prop
  rewrite sym (Env.←-assoc θ₁ θo ([S]-env-absent (S ₛ)))
        | sym (Env.←-assoc (θ₁ ← θ₂) θo ([S]-env-absent (S ₛ)))
  = canθ-new-irr sigs (suc S) θ₁ θ₂ (θo ← [S]-env-absent (S ₛ)) q cbq
      (canθ-new-irr-S-prop-accumulate S Signal.absent θo S-prop)
canθ-new-irr (just Signal.unknown ∷ sigs) S θ₁ θ₂ θo q cbq S-prop
  with any (_≟_ S) (Canθₛ sigs (suc S) q ((θ₁ ← θo) ← [S]-env (S ₛ)))
     | any (_≟_ S) (Canθₛ sigs (suc S) q (((θ₁ ← θ₂) ← θo) ← [S]-env (S ₛ)))
... | yes S∈canθ-sigs-q-θ₁←θo←[S] | yes S∈canθ-sigs-q-θ₁←θ₂←θo←[S]
  rewrite sym (Env.←-assoc θ₁ θo ([S]-env (S ₛ)))
        | sym (Env.←-assoc (θ₁ ← θ₂) θo ([S]-env (S ₛ)))
  = canθ-new-irr sigs (suc S) θ₁ θ₂ (θo ← [S]-env (S ₛ)) q cbq
      (canθ-new-irr-S-prop-accumulate S Signal.unknown θo S-prop)
... | no  S∉canθ-sigs-q-θ₁←θo←[S] | no  S∉canθ-sigs-q-θ₁←θ₂←θo←[S]
  rewrite sym (Env.←-assoc θ₁ θo ([S]-env-absent (S ₛ)))
        | sym (Env.←-assoc (θ₁ ← θ₂) θo ([S]-env-absent (S ₛ)))
  = canθ-new-irr sigs (suc S) θ₁ θ₂ (θo ← [S]-env-absent (S ₛ)) q cbq
      (canθ-new-irr-S-prop-accumulate S Signal.absent θo S-prop)
... | yes S∈canθ-sigs-q-θ₁←θo←[S] | no  S∉canθ-sigs-q-θ₁←θ₂←θo←[S]
  rewrite sym (Env.←-assoc θ₁ θo ([S]-env (S ₛ)))
        | sym (Env.←-assoc (θ₁ ← θ₂) θo ([S]-env (S ₛ)))
        | canθ-new-irr sigs (suc S) θ₁ θ₂ (θo ← [S]-env (S ₛ)) q cbq
            (canθ-new-irr-S-prop-accumulate S Signal.unknown θo S-prop)
  = ⊥-elim
      (S∉canθ-sigs-q-θ₁←θ₂←θo←[S]
        S∈canθ-sigs-q-θ₁←θo←[S])
... | no  S∉canθ-sigs-q-θ₁←θo←[S] | yes S∈canθ-sigs-q-θ₁←θ₂←θo←[S]
  rewrite sym (Env.←-assoc θ₁ θo ([S]-env (S ₛ)))
        | sym (Env.←-assoc (θ₁ ← θ₂) θo ([S]-env (S ₛ)))
        | canθ-new-irr sigs (suc S) θ₁ θ₂ (θo ← [S]-env (S ₛ)) q cbq
            (canθ-new-irr-S-prop-accumulate S Signal.unknown θo S-prop)
  = ⊥-elim
      (S∉canθ-sigs-q-θ₁←θo←[S]
        S∈canθ-sigs-q-θ₁←θ₂←θo←[S])

can-irr : ∀ {BV} {FV} θ₁ θ₂ q →
  CorrectBinding q BV FV →
  (distinct' (proj₁ FV) (proj₁ (Dom θ₂))) →
  Can q θ₁ ≡ Can q (θ₁ ← θ₂)
can-irr θ₁ θ₂ q cbq FV≠Domθ₂
  with can-new-irr θ₁ θ₂ Env.[]env q cbq (λ S' S'∈FV → inj₁ (FV≠Domθ₂ S' S'∈FV))
... | eq rewrite cong (Can q) (Env.←-comm Env.[]env θ₁ distinct-empty-left)
               | cong (Can q) (Env.←-comm Env.[]env (θ₁ ← θ₂) distinct-empty-left)
         = eq


------------------------------------------------------------------------
-- Lemmas related to bisimilarity and CCS, implemented using the
-- coinductive definition of bisimilarity
------------------------------------------------------------------------

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

open import Prelude

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

open import Equality.Propositional
open import Prelude.Size

import Bisimilarity.Equational-reasoning-instances
import Bisimilarity.CCS.General
open import Equational-reasoning
open import Labelled-transition-system.CCS Name

open import Bisimilarity CCS
import Labelled-transition-system.Equational-reasoning-instances CCS
  as Dummy

------------------------------------------------------------------------
-- Congruence lemmas

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

module Cong-lemmas
  ({R} R′ : Proc ∞ → Proc ∞ → Type ℓ)
  ⦃ _ : Convertible R R′ ⦄
  ⦃ _ : Convertible R′ R′ ⦄
  ⦃ _ : Convertible _∼_ R′ ⦄
  ⦃ _ : Transitive R′ R′ ⦄
  (left-to-right :
   ∀ {P Q} → R P Q →
   ∀ {P′ μ} → P [ μ ]⟶ P′ → ∃ λ Q′ → Q [ μ ]⟶ Q′ × R′ P′ Q′)
  where

  private

    infix -2 R′:_

    R′:_ : ∀ {P Q} → R′ P Q → R′ P Q
    R′:_ = id

    infix -3 lr-result

    lr-result :
      ∀ {P′ Q Q′} μ → R′ P′ Q′ → Q [ μ ]⟶ Q′ →
      ∃ λ Q′ → Q [ μ ]⟶ Q′ × R′ P′ Q′
    lr-result _ P′∼′Q′ Q⟶Q′ = _ , Q⟶Q′ , P′∼′Q′

    syntax lr-result μ P′∼′Q′ Q⟶Q′ = P′∼′Q′ [ μ ]⟵ Q⟶Q′

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

  ⊕-cong :
    ∀ {P₁ P₁′ P₂ P₂′ S μ} →
    R P₁ P₁′ → R P₂ P₂′ → P₁ ⊕ P₂ [ μ ]⟶ S →
    ∃ λ S′ → P₁′ ⊕ P₂′ [ μ ]⟶ S′ × R′ S S′
  ⊕-cong {P₁} {P₁′} {P₂} {P₂′} {S} {μ} P₁∼P₁′ P₂∼P₂′ = λ where
    (sum-left P₁⟶S) → case left-to-right P₁∼P₁′ P₁⟶S of λ where
      (S′ , P₁′⟶S′ , S∼′S′) →
        S          ∼⟨ S∼′S′ ⟩■
        S′
          [ μ ]⟵   ←⟨ ⟶: sum-left P₁′⟶S′ ⟩■
        P₁′ ⊕ P₂′

    (sum-right P₂⟶S) → case left-to-right P₂∼P₂′ P₂⟶S of λ where
      (S′ , P₂′⟶S′ , S∼′S′) →
        S          ∼⟨ S∼′S′ ⟩■
        S′
          [ μ ]⟵   ←⟨ ⟶: sum-right P₂′⟶S′ ⟩■
        P₁′ ⊕ P₂′

  ·-cong :
    ∀ {P₁ P₂ Q₁ μ μ′} →
    R′ (force P₁) (force P₂) → μ · P₁ [ μ′ ]⟶ Q₁ →
    ∃ λ Q₂ → μ · P₂ [ μ′ ]⟶ Q₂ × R′ Q₁ Q₂
  ·-cong {P₁} {P₂} {μ = μ} P₁∼P₂ action =
    force P₁  ∼⟨ P₁∼P₂ ⟩■
    force P₂
      [ μ ]⟵  ←⟨ ⟶: action ⟩■
    μ · P₂

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

  !-cong :
    (∀ {μ P P₀} →
     ! P [ μ ]⟶ P₀ →
     (∃ λ P′ → P [ μ ]⟶ P′ × P₀ ∼ ! P ∣ P′)
       ⊎
     (μ ≡ τ × ∃ λ P′ → ∃ λ P″ → ∃ λ a →
      P [ name a ]⟶ P′ × P [ name (co a) ]⟶ P″ ×
      P₀ ∼ (! P ∣ P′) ∣ P″)) →
    (∀ {P P′ Q Q′} → R′ P P′ → R′ Q Q′ → R′ (P ∣ Q) (P′ ∣ Q′)) →
    (∀ {P P′} → R′ P P′ → R′ (! P) (! P′)) →
    ∀ {P P′ Q μ} →
    R P P′ → ! P [ μ ]⟶ Q →
    ∃ λ Q′ → ! P′ [ μ ]⟶ Q′ × R′ Q Q′
  !-cong 6-1-3-2 _∣-cong′_ !-cong′_ {P} {P′} {Q} {μ} P∼P′ !P⟶Q =
    case 6-1-3-2 !P⟶Q of λ where

      (inj₁ (P″ , P⟶P″ , Q∼!P∣P″)) →
        let Q′ , P′⟶Q′ , P″∼′Q′ = left-to-right P∼P′ P⟶P″
        in
        Q          ∼⟨ R′: convert Q∼!P∣P″ ⟩
        ! P  ∣ P″  ∼⟨ (!-cong′ convert P∼P′) ∣-cong′ P″∼′Q′ ⟩■
        ! P′ ∣ Q′
          [ μ ]⟵   ←⟨ ⟶: replication (par-right P′⟶Q′) ⟩■
        ! P′

      (inj₂ (refl , P″ , P‴ , a , P⟶P″ , P⟶P‴ , Q∼!P∣P″∣P‴)) →
        let Q′ , P′⟶Q′ , P″∼′Q′ = left-to-right P∼P′ P⟶P″
            Q″ , P′⟶Q″ , P‴∼′Q″ = left-to-right P∼P′ P⟶P‴
        in
        Q                 ∼⟨ R′: convert Q∼!P∣P″∣P‴ ⟩
        (! P ∣ P″) ∣ P‴   ∼⟨ ((!-cong′ convert P∼P′) ∣-cong′ P″∼′Q′) ∣-cong′ P‴∼′Q″ ⟩■
        (! P′ ∣ Q′) ∣ Q″
          [ τ ]⟵          ←⟨ ⟶: replication (par-τ (replication (par-right P′⟶Q′)) P′⟶Q″) ⟩■
        ! P′

private
  module CL {i} = Cong-lemmas [ i ]_∼′_ left-to-right

------------------------------------------------------------------------
-- Various lemmas related to _∣_

mutual

  -- _∣_ is commutative.

  ∣-comm : ∀ {P Q i} → [ i ] P ∣ Q ∼ Q ∣ P
  ∣-comm {i = i} = ⟨ lr , Σ-map id (Σ-map id symmetric) ∘ lr ⟩
    where
    lr : ∀ {P P′ Q μ} →
         P ∣ Q [ μ ]⟶ P′ →
         ∃ λ Q′ → Q ∣ P [ μ ]⟶ Q′ × [ i ] P′ ∼′ Q′
    lr (par-left tr)   = _ , par-right tr , ∣-comm′
    lr (par-right tr)  = _ , par-left tr , ∣-comm′
    lr (par-τ tr₁ tr₂) =
        _
      , par-τ tr₂ (subst (λ a → _ [ name a ]⟶ _)
                         (sym $ co-involutive _)
                         tr₁)
      , ∣-comm′

  ∣-comm′ : ∀ {P Q i} → [ i ] P ∣ Q ∼′ Q ∣ P
  force ∣-comm′ = ∣-comm

mutual

  -- _∣_ is associative.

  ∣-assoc : ∀ {P Q R i} → [ i ] P ∣ (Q ∣ R) ∼ (P ∣ Q) ∣ R
  ∣-assoc {i = i} = ⟨ lr , rl ⟩
    where
    lr : ∀ {P Q R P′ μ} →
         P ∣ (Q ∣ R) [ μ ]⟶ P′ →
         ∃ λ Q′ → (P ∣ Q) ∣ R [ μ ]⟶ Q′ × [ i ] P′ ∼′ Q′
    lr (par-left tr)               = _ , par-left (par-left tr)    , ∣-assoc′
    lr (par-right (par-left tr))   = _ , par-left (par-right tr)   , ∣-assoc′
    lr (par-right (par-right tr))  = _ , par-right tr              , ∣-assoc′
    lr (par-right (par-τ tr₁ tr₂)) = _ , par-τ (par-right tr₁) tr₂ , ∣-assoc′
    lr (par-τ tr₁ (par-left tr₂))  = _ , par-left (par-τ tr₁ tr₂)  , ∣-assoc′
    lr (par-τ tr₁ (par-right tr₂)) = _ , par-τ (par-left tr₁) tr₂  , ∣-assoc′

    rl : ∀ {P Q R Q′ μ} →
         (P ∣ Q) ∣ R [ μ ]⟶ Q′ →
         ∃ λ P′ → P ∣ (Q ∣ R) [ μ ]⟶ P′ × [ i ] P′ ∼′ Q′
    rl (par-left (par-left tr))    = _ , par-left tr               , ∣-assoc′
    rl (par-left (par-right tr))   = _ , par-right (par-left tr)   , ∣-assoc′
    rl (par-left (par-τ tr₁ tr₂))  = _ , par-τ tr₁ (par-left tr₂)  , ∣-assoc′
    rl (par-right tr)              = _ , par-right (par-right tr)  , ∣-assoc′
    rl (par-τ (par-left tr₁) tr₂)  = _ , par-τ tr₁ (par-right tr₂) , ∣-assoc′
    rl (par-τ (par-right tr₁) tr₂) = _ , par-right (par-τ tr₁ tr₂) , ∣-assoc′

  ∣-assoc′ : ∀ {P Q R i} → [ i ] P ∣ (Q ∣ R) ∼′ (P ∣ Q) ∣ R
  force ∣-assoc′ = ∣-assoc

-- ∅ is a left identity of _∣_.

∣-left-identity : ∀ {i P} → [ i ] ∅ ∣ P ∼ P
∣-left-identity =
  ⟨ (λ { (par-right tr) → (_ , tr , λ { .force → ∣-left-identity })
       ; (par-left ())
       ; (par-τ () _)
       })
  , (λ tr → (_ , par-right tr , λ { .force → ∣-left-identity }))
  ⟩

∣-left-identity′ : ∀ {P i} → [ i ] ∅ ∣ P ∼′ P
force ∣-left-identity′ = ∣-left-identity

-- ∅ is a right identity of _∣_.

∣-right-identity : ∀ {P} → P ∣ ∅ ∼ P
∣-right-identity {P} =
  P ∣ ∅  ∼⟨ ∣-comm ⟩
  ∅ ∣ P  ∼⟨ ∣-left-identity ⟩■
  P

mutual

  -- _∣_ preserves bisimilarity.

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

  _∣-cong_ : ∀ {i P P′ Q Q′} →
             [ i ] P ∼ Q → [ i ] P′ ∼ Q′ → [ i ] P ∣ P′ ∼ Q ∣ Q′
  P∼Q ∣-cong P′∼Q′ =
    ⟨ lr P∼Q P′∼Q′
    , Σ-map id (Σ-map id symmetric) ∘
      lr (symmetric P∼Q) (symmetric P′∼Q′)
    ⟩
    where
    lr = CL.∣-cong _∣-cong′_

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

-- An alternative proof that is closer to the one in the paper.

infix 6 _∣-congP_

_∣-congP_ : ∀ {i P P′ Q Q′} →
            [ i ] P ∼ Q → [ i ] P′ ∼ Q′ → [ i ] P ∣ P′ ∼ Q ∣ Q′
_∣-congP_ {i} = λ p q →
  ⟨ lr p q
  , Σ-map id (Σ-map id symmetric) ∘ lr (symmetric p) (symmetric q)
  ⟩
  where
  lr : ∀ {P P′ P″ Q Q′ μ} →
       [ i ] P ∼ Q → [ i ] P′ ∼ Q′ → P ∣ P′ [ μ ]⟶ P″ →
       ∃ λ Q″ → Q ∣ Q′ [ μ ]⟶ Q″ × [ i ] P″ ∼′ Q″
  lr p q (par-left tr) =
    let (_ , tr′          , p′) = left-to-right p tr
    in  (_ , par-left tr′ , λ { .force → force p′ ∣-congP q })

  lr p q (par-right tr) =
    let (_ , tr′           , q′) = left-to-right q tr
    in  (_ , par-right tr′ , λ { .force → p ∣-congP force q′ })

  lr p q (par-τ tr₁ tr₂) =
    let (_ , tr₁′            , p′) = left-to-right p tr₁
        (_ , tr₂′            , q′) = left-to-right q tr₂
    in  (_ , par-τ tr₁′ tr₂′ , λ { .force → force p′ ∣-congP force q′ })

------------------------------------------------------------------------
-- Exercise 6.1.2 from "Enhancements of the bisimulation proof method"
-- by Pous and Sangiorgi

private

  -- A compact proof.

  6-1-2-compact : ∀ {P i} → [ i ] ! P ∣ P ∼ ! P
  6-1-2-compact =
    ⟨ (λ tr → _ , replication tr , reflexive)
    , (λ { (replication tr) → _ , tr , reflexive })
    ⟩

-- A less compact proof.

6-1-2 : ∀ {P i} → [ i ] ! P ∣ P ∼ ! P
6-1-2 {P} =
  ⟨ (λ {P′} {μ} tr →
       P′   ∼⟨ ∼′: reflexive ⟩■
       P′   [ μ ]⟵⟨ replication tr ⟩
       ! P)
  , (λ { {q′ = P′} {μ = μ} (replication tr) →
         ! P ∣ P  [ μ ]⟶⟨ tr ⟩ʳˡ
         P′       ∼⟨ ∼′: reflexive ⟩■
         P′ })
  ⟩

------------------------------------------------------------------------
-- Exercise 6.1.3 (2) from "Enhancements of the bisimulation proof
-- method" by Pous and Sangiorgi, plus some rearrangement lemmas

private
  module 6-1-3-2 = Bisimilarity.CCS.General.6-1-3-2 (record
    { _∼_       = _∼_
    ; step-∼    = step-∼
    ; finally-∼ = Equational-reasoning.finally₂
    ; reflexive = reflexive
    ; symmetric = symmetric
    ; ∣-comm    = ∣-comm
    ; ∣-assoc   = ∣-assoc
    ; _∣-cong_  = _∣-cong_
    ; 6-1-2     = 6-1-2
    })

6-1-3-2 :
  ∀ {P μ R} →
  ! P [ μ ]⟶ R →
  (∃ λ P′ → P [ μ ]⟶ P′ × R ∼ ! P ∣ P′)
    ⊎
  (μ ≡ τ × ∃ λ P′ → ∃ λ P″ → ∃ λ a →
   P [ name a ]⟶ P′ × P [ name (co a) ]⟶ P″ × R ∼ (! P ∣ P′) ∣ P″)
6-1-3-2 = 6-1-3-2.6-1-3-2

swap-rightmost : ∀ {P Q R} → (P ∣ Q) ∣ R ∼ (P ∣ R) ∣ Q
swap-rightmost = 6-1-3-2.swap-rightmost

swap-in-the-middle : ∀ {P Q R S} →
                     (P ∣ Q) ∣ (R ∣ S) ∼ (P ∣ R) ∣ (Q ∣ S)
swap-in-the-middle {P} {Q} {R} {S} =
  (P ∣ Q) ∣ (R ∣ S)  ∼⟨ swap-rightmost ⟩
  (P ∣ (R ∣ S)) ∣ Q  ∼⟨ ∣-assoc ∣-cong reflexive ⟩
  ((P ∣ R) ∣ S) ∣ Q  ∼⟨ symmetric ∣-assoc ⟩
  (P ∣ R) ∣ (S ∣ Q)  ∼⟨ reflexive ∣-cong ∣-comm ⟩■
  (P ∣ R) ∣ (Q ∣ S)

------------------------------------------------------------------------
-- More preservation lemmas

-- _⊕_ preserves bisimilarity.

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

_⊕-cong_ : ∀ {i P P′ Q Q′} →
           [ i ] P ∼ P′ → [ i ] Q ∼ Q′ → [ i ] P ⊕ Q ∼ P′ ⊕ Q′
_⊕-cong_ {i} P∼P′ Q∼Q′ =
  ⟨ CL.⊕-cong P∼P′ Q∼Q′
  , Σ-map id (Σ-map id symmetric) ∘
    CL.⊕-cong {i = i} (symmetric P∼P′) (symmetric Q∼Q′)
  ⟩

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

-- _·_ preserves bisimilarity.

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

_·-cong_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ∼′ force P′ → [ i ] μ · P ∼ μ′ · P′
refl ·-cong P∼P′ =
  ⟨ CL.·-cong P∼P′
  , Σ-map id (Σ-map id symmetric) ∘ CL.·-cong (symmetric P∼P′)
  ⟩

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

-- An alternative proof that is closer to the one in the paper.

·-congP : ∀ {i μ P Q} → [ i ] force P ∼′ force Q → [ i ] μ · P ∼ μ · Q
·-congP p =
  ⟨ (λ { action → _ , action , p })
  , (λ { action → _ , action , p })
  ⟩

-- _∙_ preserves bisimilarity.

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

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

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

-- _∙ turns equality into bisimilarity.

infix 12 _∙-cong _∙-cong′

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

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

mutual

  -- !_ preserves bisimilarity.

  infix 10 !-cong_ !-cong′_

  !-cong_ : ∀ {i P P′} →
            [ i ] P ∼ P′ → [ i ] ! P ∼ ! P′
  !-cong P∼P′ =
    ⟨ lr P∼P′
    , Σ-map id (Σ-map id symmetric) ∘ lr (symmetric P∼P′)
    ⟩
    where
    lr = CL.!-cong 6-1-3-2 _∣-cong′_ !-cong′_

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

-- An alternative proof that is closer to the one in the paper.

!-congP : ∀ {i P Q} → [ i ] P ∼ Q → [ i ] ! P ∼ ! Q
!-congP {i} = λ p →
  ⟨ lr p
  , Σ-map id (Σ-map id symmetric) ∘ lr (symmetric p)
  ⟩
  where
  lr : ∀ {P Q R μ} →
       [ i ] P ∼ Q → ! P [ μ ]⟶ R →
       ∃ λ S → ! Q [ μ ]⟶ S × [ i ] R ∼′ S
  lr {P} {Q} {R} P∼Q !P⟶R with 6-1-3-2 !P⟶R
  ... | inj₁ (P′ , P⟶P′ , R∼!P∣P′) =
    let (Q′ , Q⟶Q′ , P′∼′Q′) = left-to-right P∼Q P⟶P′
    in
    ( ! Q ∣ Q′
    , replication (par-right Q⟶Q′)
    , (R         ∼⟨ R∼!P∣P′ ⟩
       ! P ∣ P′  ∼⟨ (λ { .force → !-congP P∼Q }) ∣-cong′ P′∼′Q′ ⟩
       ! Q ∣ Q′  ■
      )
    )
  ... | inj₂ (refl , P′ , P″ , a , P⟶P′ , P⟶P″ , R∼!P∣P′∣P″) =
    let (Q′ , Q⟶Q′ , P′∼′Q′) = left-to-right P∼Q P⟶P′
        (Q″ , Q⟶Q″ , P″∼′Q″) = left-to-right P∼Q P⟶P″
    in
    ( (! Q ∣ Q′) ∣ Q″
    , replication (par-τ (replication (par-right Q⟶Q′)) Q⟶Q″)
    , (R                ∼⟨ R∼!P∣P′∣P″ ⟩
       (! P ∣ P′) ∣ P″  ∼⟨ ((λ { .force → !-congP P∼Q }) ∣-cong′ P′∼′Q′)
                             ∣-cong′ P″∼′Q″ ⟩
       (! Q ∣ Q′) ∣ Q″  ■
      )
    )

mutual

  -- ⟨ν_⟩ preserves bisimilarity.

  ⟨ν_⟩-cong : ∀ {i a a′ P P′} →
              a ≡ a′ → [ i ] P ∼ P′ → [ i ] ⟨ν a ⟩ P ∼ ⟨ν a′ ⟩ P′
  ⟨ν refl ⟩-cong = λ P∼P′ →
    ⟨ lr P∼P′
    , Σ-map id (Σ-map id symmetric) ∘ lr (symmetric P∼P′)
    ⟩
    where
    lr = CL.⟨ν⟩-cong ⟨ν refl ⟩-cong′

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

-- _[_] preserves bisimilarity. (This result is related to Exercise
-- 6.2.10 in "Enhancements of the bisimulation proof method"
-- by Pous and Sangiorgi.)

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

_[_]-cong :
  ∀ {i n Ps Qs}
  (C : Context ∞ n) → (∀ x → [ i ] Ps x ∼ Qs x) →
  [ i ] C [ Ps ] ∼ C [ Qs ]
hole x   [ Ps∼Qs ]-cong = Ps∼Qs x
∅        [ Ps∼Qs ]-cong = reflexive
C₁ ∣ C₂  [ Ps∼Qs ]-cong = (C₁ [ Ps∼Qs ]-cong) ∣-cong (C₂ [ Ps∼Qs ]-cong)
C₁ ⊕ C₂  [ Ps∼Qs ]-cong = (C₁ [ Ps∼Qs ]-cong) ⊕-cong (C₂ [ Ps∼Qs ]-cong)
μ · C    [ Ps∼Qs ]-cong = refl ·-cong λ { .force → force C [ Ps∼Qs ]-cong }
⟨ν a ⟩ C [ Ps∼Qs ]-cong = ⟨ν refl ⟩-cong (C [ Ps∼Qs ]-cong)
! C      [ Ps∼Qs ]-cong = !-cong (C [ Ps∼Qs ]-cong)

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

-- The proof of _[_]-cong uses 6-1-3-2 (in !-cong_). The following
-- direct proof does not use 6-1-3-2 (but it does use
-- extensionality).

module _ (ext : Proc-extensionality) where

 mutual

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

  _[_]-cong₂ :
    ∀ {i n Ps Qs}
    (C : Context ∞ n) → (∀ x → [ i ] Ps x ∼ Qs x) →
    [ i ] C [ Ps ] ∼ C [ Qs ]
  _[_]-cong₂ {i} C Ps∼Qs =
    ⟨ lr C Ps∼Qs
    , Σ-map id (Σ-map id symmetric) ∘ lr C (symmetric ∘ Ps∼Qs)
    ⟩
    where

    infix 5 _[_][_]-cong₁ _[_][_]-cong₂

    _[_][_]-cong₁ :
      ∀ {n P Q Ps Qs} →
      (C : Context ∞ (suc n)) →
      [ i ] P ∼′ Q →
      (∀ x → [ i ] Ps x ∼ Qs x) →
      [ i ] C [ [ const P , Ps ] ] ∼′ C [ [ const Q , Qs ] ]
    force (C [ P∼′Q ][ Ps∼Qs ]-cong₁) =
      C [ [ const (force P∼′Q) , Ps∼Qs ] ]-cong₂

    _[_][_]-cong₂ :
      ∀ {P Q R S} →
      (C : Context ∞ 2) →
      [ i ] P ∼′ Q →
      [ i ] R ∼′ S →
      [ i ] C [ [ const P , [ const R , (λ ()) ] ] ] ∼′
            C [ [ const Q , [ const S , (λ ()) ] ] ]
    force (C [ P∼′Q ][ R∼′S ]-cong₂) =
      C [ [ const (force P∼′Q)
          , [ const (force R∼′S) , (λ ()) ]
          ] ]-cong₂

    lr : ∀ {n Ps Qs P′ μ} (C : Context ∞ n) →
         (∀ x → [ i ] Ps x ∼ Qs x) →
         C [ Ps ] [ μ ]⟶ P′ →
         ∃ λ Q′ → C [ Qs ] [ μ ]⟶ Q′ × [ i ] P′ ∼′ Q′
    lr (hole x)   Ps∼Qs tr                  = left-to-right (Ps∼Qs x) tr
    lr ∅          Ps∼Qs ()
    lr (C₁ ∣ C₂)  Ps∼Qs (par-left tr)       = Σ-map (_∣ _) (Σ-map par-left (λ b → subst (λ P → [ i ] _ ∼′ _ ∣ P) (ext $ weaken-[] C₂) $
                                                                                subst (λ P → [ i ] _ ∣ P ∼′ _) (ext $ weaken-[] C₂) $
                                                                                hole fzero ∣ weaken C₂ [ b ][ Ps∼Qs ]-cong₁)) (lr C₁ Ps∼Qs tr)
    lr (C₁ ∣ C₂)  Ps∼Qs (par-right tr)      = Σ-map (_ ∣_) (Σ-map par-right (λ b → subst (λ P → [ i ] _ ∼′ P ∣ _) (ext $ weaken-[] C₁) $
                                                                                subst (λ P → [ i ] P ∣ _ ∼′ _) (ext $ weaken-[] C₁) $
                                                                                weaken C₁ ∣ hole fzero [ b ][ Ps∼Qs ]-cong₁)) (lr C₂ Ps∼Qs tr)
    lr (C₁ ∣ C₂)  Ps∼Qs (par-τ tr₁ tr₂)     = Σ-zip _∣_ (Σ-zip par-τ (λ b₁ b₂ → hole fzero ∣ hole (fsuc fzero) [ b₁ ][ b₂ ]-cong₂))
                                                (lr C₁ Ps∼Qs tr₁) (lr C₂ Ps∼Qs tr₂)
    lr (C₁ ⊕ C₂)  Ps∼Qs (sum-left tr)       = Σ-map id (Σ-map sum-left id) (lr C₁ Ps∼Qs tr)
    lr (C₁ ⊕ C₂)  Ps∼Qs (sum-right tr)      = Σ-map id (Σ-map sum-right id) (lr C₂ Ps∼Qs tr)
    lr (μ · C)    Ps∼Qs action              = _ , action , λ { .force → force C [ Ps∼Qs ]-cong₂ }
    lr (⟨ν a ⟩ C) Ps∼Qs (restriction a∉ tr) = Σ-map ⟨ν a ⟩ (Σ-map (restriction a∉) (λ b → ⟨ν a ⟩ (hole fzero) [ b ][ Ps∼Qs ]-cong₁))
                                                (lr C Ps∼Qs tr)
    lr (! C)      Ps∼Qs (replication tr)    = Σ-map id (Σ-map replication id) (lr (! C ∣ C) Ps∼Qs tr)

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

-- A variant of _[_]-cong for weakly guarded contexts.
--
-- Note that the input uses the primed variant of bisimilarity.
--
-- I got the idea for this lemma from Lemma 23 in Schäfer and Smolka's
-- "Tower Induction and Up-to Techniques for CCS with Fixed Points".

infix 5 _[_]-cong-w

_[_]-cong-w :
  ∀ {i n Ps Qs} {C : Context ∞ n} →
  Weakly-guarded C → (∀ x → [ i ] Ps x ∼′ Qs x) →
  [ i ] C [ Ps ] ∼ C [ Qs ]
∅              [ Ps∼Qs ]-cong-w = reflexive
W₁ ∣ W₂        [ Ps∼Qs ]-cong-w = (W₁ [ Ps∼Qs ]-cong-w) ∣-cong
                                  (W₂ [ Ps∼Qs ]-cong-w)
action {C = C} [ Ps∼Qs ]-cong-w = refl ·-cong (force C [ Ps∼Qs ]-cong′)
⟨ν⟩ W          [ Ps∼Qs ]-cong-w = ⟨ν refl ⟩-cong (W [ Ps∼Qs ]-cong-w)
! W            [ Ps∼Qs ]-cong-w = !-cong (W [ Ps∼Qs ]-cong-w)
W₁ ⊕ W₂        [ Ps∼Qs ]-cong-w = (W₁ [ Ps∼Qs ]-cong-w) ⊕-cong
                                  (W₂ [ Ps∼Qs ]-cong-w)

-- Very strong bisimilarity is contained in bisimilarity.

mutual

  ≡→∼ : ∀ {i P Q} → Equal i P Q → [ i ] P ∼ Q
  ≡→∼ ∅              = reflexive
  ≡→∼ (eq₁ ∣ eq₂)    = ≡→∼ eq₁ ∣-cong ≡→∼ eq₂
  ≡→∼ (eq₁ ⊕ eq₂)    = ≡→∼ eq₁ ⊕-cong ≡→∼ eq₂
  ≡→∼ (refl · eq)    = refl ·-cong ≡→∼′ eq
  ≡→∼ (⟨ν refl ⟩ eq) = ⟨ν refl ⟩-cong (≡→∼ eq)
  ≡→∼ (! eq)         = !-cong ≡→∼ eq

  ≡→∼′ : ∀ {i P Q} → Equal′ i P Q → [ i ] P ∼′ Q
  force (≡→∼′ eq) = ≡→∼ (force eq)

------------------------------------------------------------------------
-- Unique solutions

-- If the set of equations corresponding (in a certain sense) to a
-- family of weakly guarded contexts has two families of solutions,
-- then those solutions are pairwise bisimilar.
--
-- This result is very similar to a proposition in Milner's
-- "Communication and Concurrency".

mutual

  unique-solutions :
    ∀ {i n} {Ps Qs : Fin n → Proc ∞} {C : Fin n → Context ∞ n} →
    (∀ x → Weakly-guarded (C x)) →
    (∀ x → [ i ] Ps x ∼ C x [ Ps ]) →
    (∀ x → [ i ] Qs x ∼ C x [ Qs ]) →
    ∀ x → [ i ] Ps x ∼ Qs x
  unique-solutions {i} {Ps = Ps} {Qs} {C} w ∼C[Ps] ∼C[Qs] x =
    Ps x        ∼⟨ ∼C[Ps] x ⟩
    C x [ Ps ]  ∼⟨ ∼: ⟨ lr ∼C[Ps] ∼C[Qs] , Σ-map id (Σ-map id symmetric) ∘ lr ∼C[Qs] ∼C[Ps] ⟩ ⟩
    C x [ Qs ]  ∼⟨ symmetric (∼C[Qs] x) ⟩■
    Qs x
    where
    lr :
      ∀ {Ps Qs μ P} →
      (∀ x → [ i ] Ps x ∼ C x [ Ps ]) →
      (∀ x → [ i ] Qs x ∼ C x [ Qs ]) →
      C x [ Ps ] [ μ ]⟶ P →
      ∃ λ Q → C x [ Qs ] [ μ ]⟶ Q × [ i ] P ∼′ Q
    lr {Ps} {Qs} {μ} ∼C[Ps] ∼C[Qs] ⟶P =
      case 6-2-15 (C x) (w x) ⟶P of λ where
        (C′ , refl , trs) →
          C′ [ Ps ]   ∼⟨ C′ [ unique-solutions′ w ∼C[Ps] ∼C[Qs] ]-cong′ ⟩■
          C′ [ Qs ]   [ μ ]⟵⟨ trs Qs ⟩
          C x [ Qs ]

  unique-solutions′ :
    ∀ {i n} {Ps Qs : Fin n → Proc ∞} {C : Fin n → Context ∞ n} →
    (∀ x → Weakly-guarded (C x)) →
    (∀ x → [ i ] Ps x ∼ C x [ Ps ]) →
    (∀ x → [ i ] Qs x ∼ C x [ Qs ]) →
    ∀ x → [ i ] Ps x ∼′ Qs x
  force (unique-solutions′ w ∼C[Ps] ∼C[Qs] x) = unique-solutions w ∼C[Ps] ∼C[Qs] x

-- For every family of weakly guarded contexts there is a family of
-- processes that satisfies the corresponding equations.

solutions-exist :
  ∀ {n} {C : Fin n → Context ∞ n} →
  (∀ x → Weakly-guarded (C x)) →
  ∃ λ Ps → ∀ x → Ps x ∼ C x [ Ps ]
solutions-exist {n} {C} w = Ps , Ps∼
  where

  mutual

    Ps : ∀ {i} → Fin n → Proc i
    Ps x = P₁ (w x)

    P₁ : ∀ {i} {C : Context ∞ n} → Weakly-guarded C → Proc i
    P₁ ∅                        = ∅
    P₁ (w₁ ∣ w₂)                = P₁ w₁ ∣ P₁ w₂
    P₁ (w₁ ⊕ w₂)                = P₁ w₁ ⊕ P₁ w₂
    P₁ (action {μ = μ} {C = C}) = μ · λ { .force → P₂ (force C) }
    P₁ (⟨ν⟩ {a = a} w)          = ⟨ν a ⟩ (P₁ w)
    P₁ (! w)                    = ! P₁ w

    P₂ : ∀ {i} → Context ∞ n → Proc i
    P₂ (hole x)   = Ps x
    P₂ ∅          = ∅
    P₂ (C₁ ∣ C₂)  = P₂ C₁ ∣ P₂ C₂
    P₂ (C₁ ⊕ C₂)  = P₂ C₁ ⊕ P₂ C₂
    P₂ (μ · C)    = μ · λ { .force → P₂ (force C) }
    P₂ (⟨ν a ⟩ C) = ⟨ν a ⟩ (P₂ C)
    P₂ (! C)      = ! P₂ C

  P₂∼ : ∀ {i} (C : Context ∞ n) → [ i ] P₂ C ∼ C [ Ps ]
  P₂∼ (hole x)   = reflexive
  P₂∼ ∅          = reflexive
  P₂∼ (C₁ ∣ C₂)  = P₂∼ C₁ ∣-cong P₂∼ C₂
  P₂∼ (C₁ ⊕ C₂)  = P₂∼ C₁ ⊕-cong P₂∼ C₂
  P₂∼ (μ · C)    = refl ·-cong λ { .force → P₂∼ (force C) }
  P₂∼ (⟨ν a ⟩ C) = ⟨ν refl ⟩-cong (P₂∼ C)
  P₂∼ (! C)      = !-cong P₂∼ C

  P₁∼ : {C : Context ∞ n} (w : Weakly-guarded C) → P₁ w ∼ C [ Ps ]
  P₁∼ ∅                = reflexive
  P₁∼ (w₁ ∣ w₂)        = P₁∼ w₁ ∣-cong P₁∼ w₂
  P₁∼ (w₁ ⊕ w₂)        = P₁∼ w₁ ⊕-cong P₁∼ w₂
  P₁∼ (action {C = C}) = refl ·-cong λ { .force → P₂∼ (force C) }
  P₁∼ (⟨ν⟩ {a = a} w)  = ⟨ν refl ⟩-cong (P₁∼ w)
  P₁∼ (! w)            = !-cong P₁∼ w

  Ps∼ : ∀ x → Ps x ∼ C x [ Ps ]
  Ps∼ x = P₁∼ (w x)

------------------------------------------------------------------------
-- Some lemmas related to _⊕_

-- _⊕_ is idempotent.

⊕-idempotent : ∀ {P} → P ⊕ P ∼ P
⊕-idempotent {P} =
  ⟨ lr
  , (λ {R} P⟶R →
       P ⊕ P  ⟶⟨ sum-left P⟶R ⟩ʳˡ
       R      ∼⟨ ∼′: reflexive ⟩■
       R)
  ⟩
  where
  lr : ∀ {Q μ} → P ⊕ P [ μ ]⟶ Q → ∃ λ R → P [ μ ]⟶ R × Q ∼′ R
  lr {Q} (sum-left P⟶Q) =
    Q  ∼⟨ ∼′: reflexive ⟩■
    Q  ⟵⟨ P⟶Q ⟩
    P

  lr {Q} (sum-right P⟶Q) =
    Q  ∼⟨ ∼′: reflexive ⟩■
    Q  ⟵⟨ P⟶Q ⟩
    P

⊕-idempotent′ : ∀ {P} → P ⊕ P ∼′ P
force ⊕-idempotent′ = ⊕-idempotent

-- _⊕_ is commutative.

⊕-comm : ∀ {P Q} → P ⊕ Q ∼ Q ⊕ P
⊕-comm = ⟨ lr , Σ-map id (Σ-map id symmetric) ∘ lr ⟩
  where
  lr : ∀ {P Q R μ} →
       P ⊕ Q [ μ ]⟶ R → ∃ λ R′ → Q ⊕ P [ μ ]⟶ R′ × R ∼′ R′
  lr {P} {Q} {R} = λ where
    (sum-left  P⟶R) →
      R      ■ ⟵⟨ sum-right P⟶R ⟩
      Q ⊕ P

    (sum-right Q⟶R) →
      R      ■ ⟵⟨ sum-left Q⟶R ⟩
      Q ⊕ P


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
import      LibraBFT.Concrete.Properties.Common        as Common
import      LibraBFT.Concrete.Properties.VotesOnce     as VO
open import LibraBFT.Impl.Consensus.Network            as Network
open import LibraBFT.Impl.Consensus.Network.Properties as NetworkProps
open import LibraBFT.Impl.Consensus.RoundManager
import      LibraBFT.Impl.Handle                       as Handle
open import LibraBFT.Impl.IO.OBM.InputOutputHandlers
open import LibraBFT.Impl.IO.OBM.Properties.InputOutputHandlers
open import LibraBFT.Impl.Handle.Properties
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

open Invariants
open RoundManagerTransProps

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId

open        ParamsWithInitAndHandlers Handle.InitHandler.initAndHandlers
open        PeerCanSignForPK

open import LibraBFT.ImplShared.Util.HashCollisions Handle.InitHandler.initAndHandlers

open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms
                      Handle.InitHandler.initAndHandlers
                      PeerCanSignForPK PeerCanSignForPK-stable
open import LibraBFT.Impl.Handle.InitProperties
open        initHandlerSpec

-- This module contains definitions and lemmas used by proofs of the
-- implementation obligations for VotesOnce and PreferredRoundRule.

module LibraBFT.Impl.Properties.Common where

postulate -- TODO-3: prove (note: advanced; waiting on: `handle`)
  -- This will require updates to the existing proofs for the peer handlers. We
  -- will need to show that honest peers sign things only for their only PK, and
  -- that they either resend messages signed before or if sending a new one,
  -- that signature hasn't been sent before
  impl-sps-avp : StepPeerState-AllValidParts

open Structural impl-sps-avp

-- We can prove this easily for the Agda model because (unlike the Haskell
-- prototype) it does not yet do epoch changes, so only the initial EC is
-- relevant. Later, this will require us to use the fact that epoch changes
-- require proof of committing an epoch-changing transaction.
availEpochsConsistent :
   ∀{pid pid' v v' pk}{st : SystemState}
   → (pkvpf  : PeerCanSignForPK st v  pid  pk)
   → (pkvpf' : PeerCanSignForPK st v' pid' pk)
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → pcs4𝓔 pkvpf ≡ pcs4𝓔 pkvpf'
availEpochsConsistent (mkPCS4PK _ (inBootstrapInfo refl) _) (mkPCS4PK _ (inBootstrapInfo refl) _) refl = refl

postulate -- TODO-1: Prove (waiting on: complete definition of `initRM`)
  uninitQcs∈Bootstrap
    : ∀ {pid qc vs}{st : SystemState}
      → ReachableSystemState st
      → initialised st pid ≡ uninitd
      → qc QCProps.∈RoundManager (peerStates st pid)
      → vs ∈ qcVotes qc
      → ∈BootstrapInfo-impl fakeBootstrapInfo (proj₂ vs)

module ∈BootstrapInfoProps where
  sameSig∉ : ∀ {pk} {v v' : Vote}
             → (sig : WithVerSig pk v) (sig' : WithVerSig pk v')
             → ¬ ∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig)
             → ver-signature sig' ≡ ver-signature sig
             → ¬ ∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig')
  sameSig∉ _ _ ¬bootstrap ≡sig rewrite ≡sig = ¬bootstrap

-- Lemmas for `PeerCanSignForPK`
module PeerCanSignForPKProps where
  msb4 -- NOTE: This proof requires updating when we model epoch changes.
    : ∀ {pid v pk}{pre post : SystemState}
      → ReachableSystemState pre
      → Step pre post
      → PeerCanSignForPK post v pid pk
      → Meta-Honest-PK pk → (sig : WithVerSig pk v)
      → MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
      → PeerCanSignForPK pre v pid pk
  msb4 preach step (mkPCS4PK 𝓔@._ (inBootstrapInfo refl) (mkPCS4PKin𝓔 𝓔id≡ mbr nid≡ pk≡)) hpk sig mws∈pool =
    mkPCS4PK 𝓔 (inBootstrapInfo refl) (mkPCS4PKin𝓔 𝓔id≡ mbr nid≡ pk≡)

  msb4-eid≡
    : ∀ {pre post : SystemState} {v v' pid pk}
      → ReachableSystemState pre
      → Step pre post
      → Meta-Honest-PK pk
      → PeerCanSignForPK post v pid pk
      → v ≡L v' at vEpoch
      → (sig' : WithVerSig pk v')
      → MsgWithSig∈ pk (ver-signature sig') (msgPool pre)
      → PeerCanSignForPK pre v pid pk
  msb4-eid≡ rss step hpk pcsfpk ≡eid sig' mws' =
    peerCanSignEp≡ (msb4 rss step (peerCanSignEp≡ pcsfpk ≡eid) hpk sig' mws') (sym ≡eid)

  pidInjective
    : ∀ {pid pid' pk v v'}{st : SystemState}
      → PeerCanSignForPK st v  pid  pk
      → PeerCanSignForPK st v' pid' pk
      → v ^∙ vEpoch ≡ v' ^∙ vEpoch
      → pid ≡ pid'
  pidInjective{pid}{pid'}{pk} pcsfpk₁ pcsfpk₂ ≡epoch = begin
    pid         ≡⟨ sym (nid≡ (pcs4in𝓔 pcsfpk₁)) ⟩
    pcsfpk₁∙pid ≡⟨ PK-inj-same-ECs{pcs4𝓔 pcsfpk₁}{pcs4𝓔 pcsfpk₂}
                     (availEpochsConsistent pcsfpk₁ pcsfpk₂ ≡epoch) pcsfpk∙pk≡ ⟩
    pcsfpk₂∙pid ≡⟨ nid≡ (pcs4in𝓔 pcsfpk₂) ⟩
    pid'        ∎
    where
    open ≡-Reasoning
    open PeerCanSignForPKinEpoch
    open PeerCanSignForPK

    pcsfpk₁∙pid  = EpochConfig.toNodeId  (pcs4𝓔 pcsfpk₁) (mbr (pcs4in𝓔 pcsfpk₁))
    pcsfpk₂∙pid  = EpochConfig.toNodeId  (pcs4𝓔 pcsfpk₂) (mbr (pcs4in𝓔 pcsfpk₂))
    pcsfpk₁∙pk   = EpochConfig.getPubKey (pcs4𝓔 pcsfpk₁) (mbr (pcs4in𝓔 pcsfpk₁))
    pcsfpk₂∙pk   = EpochConfig.getPubKey (pcs4𝓔 pcsfpk₂) (mbr (pcs4in𝓔 pcsfpk₂))

    pcsfpk∙pk≡ : pcsfpk₁∙pk ≡ pcsfpk₂∙pk
    pcsfpk∙pk≡ = begin
      pcsfpk₁∙pk ≡⟨ pk≡ (pcs4in𝓔 pcsfpk₁) ⟩
      pk         ≡⟨ sym (pk≡ (pcs4in𝓔 pcsfpk₂)) ⟩
      pcsfpk₂∙pk ∎

module ReachableSystemStateProps where
  mws∈pool⇒initd
    : ∀ {pid pk v}{st : SystemState}
    → ReachableSystemState st
    → PeerCanSignForPK st v pid pk
    → Meta-Honest-PK pk
    → (sig : WithVerSig pk v)
    → ¬ (∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig))
    → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
    → initialised st pid ≡ initd

  mws∈pool⇒initd{pk = pk}{v} (step-s{pre = pre} rss step@(step-peer sp@(step-cheat cmc))) pcsfpk hpk sig ¬bootstrap mws∈pool =
    peersRemainInitialized step (mws∈pool⇒initd rss (PeerCanSignForPKProps.msb4 rss step pcsfpk hpk sig mws∈poolPre) hpk sig ¬bootstrap mws∈poolPre)
    where
    ¬bootstrap' = ∈BootstrapInfoProps.sameSig∉ sig (msgSigned mws∈pool) ¬bootstrap (msgSameSig mws∈pool)

    mws∈poolPre : MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
    mws∈poolPre = ¬cheatForgeNew sp refl unit hpk mws∈pool ¬bootstrap'

  mws∈pool⇒initd{pid₁}{pk = pk} (step-s{pre = pre} rss step@(step-peer sp@(step-honest{pid₂} sps@(step-init {rm} rm×acts uni)))) pcsfpk hpk sig ¬bootstrap mws∈pool
     with pid₁ ≟ pid₂
  ...| yes refl = StepPeer-post-lemma2 {pre = pre} sps
  ...| no neq
     with newMsg⊎msgSentB4 rss sps hpk (msgSigned mws∈pool) ¬bootstrap' (msg⊆ mws∈pool) (msg∈pool mws∈pool)
     where
     ¬bootstrap' = ∈BootstrapInfoProps.sameSig∉ sig (msgSigned mws∈pool) ¬bootstrap (msgSameSig mws∈pool)
  ...| Right mws∈poolPre = peersRemainInitialized step (mws∈pool⇒initd rss (PeerCanSignForPKProps.msb4 rss step pcsfpk hpk sig mws∈poolPre') hpk sig ¬bootstrap mws∈poolPre')
     where
     mws∈poolPre' : MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
     mws∈poolPre' rewrite msgSameSig mws∈pool = mws∈poolPre
  ...| Left (send∈acts , _ , _)
     with initHandlerSpec.contract pid₂ fakeBootstrapInfo rm×acts
  ...| init-contract
     with msg⊆ mws∈pool
  ...| vote∈vm
     = ⊥-elim
       (P≢V (sym (proj₁ (proj₂ (initHandlerSpec.ContractOk.isInitPM init-contract send∈acts)))))
  ...| vote∈qc vs∈qc _ qc∈pm
     with initHandlerSpec.ContractOk.isInitPM init-contract send∈acts
  ...| (_ , refl , noSigs) = ⊥-elim (noSigs vs∈qc qc∈pm)

  mws∈pool⇒initd{pid₁}{pk}{v} (step-s{pre = pre} rss step@(step-peer{pid₂} sp@(step-honest sps@(step-msg _ ini)))) pcsfpk hpk sig ¬bootstrap mws∈pool
     with newMsg⊎msgSentB4 rss sps hpk (msgSigned mws∈pool) ¬bootstrap' (msg⊆ mws∈pool) (msg∈pool mws∈pool)
     where
     ¬bootstrap' = ∈BootstrapInfoProps.sameSig∉ sig (msgSigned mws∈pool) ¬bootstrap (msgSameSig mws∈pool)
  ...| Left (m∈outs , pcsfpk' , ¬msb4)
     with pid≡
     where
     vd₁≡vd₂ : v ≡L msgPart mws∈pool at vVoteData
     vd₁≡vd₂ = either (⊥-elim ∘ PerReachableState.meta-no-collision rss) id (sameSig⇒sameVoteData (msgSigned mws∈pool) sig (msgSameSig mws∈pool))

     pid≡ : pid₁ ≡ pid₂
     pid≡ = PeerCanSignForPKProps.pidInjective pcsfpk pcsfpk' (cong (_^∙ vdProposed ∙ biEpoch) vd₁≡vd₂)
  ...| refl rewrite StepPeer-post-lemma2{pid₂}{pre = pre} sps = refl

  mws∈pool⇒initd{pid₁}{pk}  (step-s{pre = pre} rss step@(step-peer{pid₂} sp@(step-honest sps@(step-msg _ ini)))) pcsfpk hpk sig ¬bootstrap mws∈pool | Right mws∈poolPre =
    peersRemainInitialized step (mws∈pool⇒initd rss (PeerCanSignForPKProps.msb4 rss step pcsfpk hpk sig mws∈poolPre') hpk sig ¬bootstrap mws∈poolPre')
    where
    mws∈poolPre' : MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
    mws∈poolPre' rewrite msgSameSig mws∈pool = mws∈poolPre

  mws∈pool⇒epoch≡
    : ∀ {pid v s' outs pk}{st : SystemState}
      → ReachableSystemState st
      → (sps : StepPeerState pid (msgPool st) (initialised st) (peerStates st pid) (s' , outs))
      → PeerCanSignForPK st v pid pk
      → Meta-Honest-PK pk → (sig : WithVerSig pk v)
      → ¬ (∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig))
      → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
      → s' ^∙ rmEpoch ≡ v ^∙ vEpoch
      → peerStates st pid ^∙ rmEpoch ≡ v ^∙ vEpoch
  mws∈pool⇒epoch≡ rss (step-init _ uni) pcsfpk hpk sig ¬bootstrap mws∈pool epoch≡ =
    absurd (uninitd ≡ initd) case (trans (sym uni) ini) of λ ()
    where
    ini = mws∈pool⇒initd rss pcsfpk hpk sig ¬bootstrap mws∈pool
  mws∈pool⇒epoch≡{pid}{v}{st = st} rss (step-msg{_ , P pm} m∈pool ini) pcsfpk hpk sig ¬bootstrap mws∈pool epoch≡ = begin
    hpPre ^∙ rmEpoch ≡⟨ noEpochChange ⟩
    hpPos ^∙ rmEpoch ≡⟨ epoch≡ ⟩
    v ^∙ vEpoch      ∎
    where
    hpPool = msgPool st
    hpPre  = peerStates st pid
    hpPos  = LBFT-post (handleProposal 0 pm) hpPre

    open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm hpPool hpPre)
    open ≡-Reasoning

  mws∈pool⇒epoch≡{pid}{v}{st = st} rss (step-msg{sndr , V vm} _ _) pcsfpk hpk sig ¬bootstrap mws∈pool epoch≡ = begin
    hvPre ^∙ rmEpoch ≡⟨ noEpochChange ⟩
    hvPos ^∙ rmEpoch ≡⟨ epoch≡ ⟩
    v ^∙ vEpoch      ∎
    where
    hvPre = peerStates st pid
    hvPos = LBFT-post (handleVote 0 vm) hvPre

    open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool st) hvPre)
    open ≡-Reasoning

  mws∈pool⇒epoch≡{pid}{v}{st = st} rss (step-msg{sndr , C cm} _ _) pcsfpk hpk sig ¬bootstrap mws∈pool epoch≡ = epoch≡


module Open1 where

module M where

  data ⊤
    : Set
    where

    tt
      : ⊤

module N where

  open M

  v
    : ⊤
  v
    = tt

open M
open N

module O where

  w
    : ⊤
  w
    = tt

  x
    : ⊤
  x
    = tt

module P where

  open O
    using (w)
    renaming (x to x')

  y
    : ⊤
  y
    = w

open P

module Q where

  open O
    hiding (w)
    renaming (x to x'')

  z
    : ⊤
  z
    = x''


{-# OPTIONS --no-positivity-check #-}

module STLC.Coquand.Completeness where

open import STLC.Coquand.Normalisation public
open import STLC.Coquand.Convertibility public

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

data CV : ∀ {Γ A} → Γ ⊢ A → Γ ⊩ A → Set
  where
    cv⎵ : ∀ {Γ} → {M : Γ ⊢ ⎵} {f : Γ ⊩ ⎵}
                → (h : ∀ {Γ′} → (η : Γ′ ∋⋆ Γ)
                               → sub ⌊ η ⌋ M ∼ ⟦g⟧⟨ η ⟩ f)
                → CV M f

    cv⊃ : ∀ {Γ A B} → {M : Γ ⊢ A ⇒ B} {f : Γ ⊩ A ⇒ B}
                    → (h : ∀ {Γ′ N a} → (η : Γ′ ∋⋆ Γ) → CV N a
                                       → CV (sub ⌊ η ⌋ M ∙ N) (f ⟦∙⟧⟨ η ⟩ a))
                    → CV M f

data CV⋆ : ∀ {Γ Ξ} → Γ ⊢⋆ Ξ → Γ ⊩⋆ Ξ → Set
  where
    ∅   : ∀ {Γ} → {σ : Γ ⊢⋆ ∅}
                → CV⋆ σ ∅

    _,_ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ , A} {ρ : Γ ⊩⋆ Ξ} {a : Γ ⊩ A}
                    → (κ : CV⋆ (σ ◐ wkᵣ {A} idᵣ) ρ) (k : CV (sub σ 0) a)
                    → CV⋆ σ (ρ , a)

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

postulate
  congCV : ∀ {Γ A} → {M₁ M₂ : Γ ⊢ A} {a : Γ ⊩ A}
                   → M₁ ∼ M₂ → CV M₁ a
                   → CV M₂ a

-- (cong↑⟨_⟩CV)
postulate
  accCV : ∀ {Γ Γ′ A} → {M : Γ ⊢ A} {a : Γ ⊩ A}
                     → (η : Γ′ ∋⋆ Γ) → CV M a
                     → CV (sub ⌊ η ⌋ M) (acc η a)

-- (conglookupCV)
postulate
  getCV : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                    → (i : Ξ ∋ A) → CV⋆ σ ρ
                    → CV (sub σ (𝓋 i)) (getᵥ ρ i)

-- (cong↑⟨_⟩CV⋆)
postulate
  accCV⋆ : ∀ {Γ Γ′ Ξ} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                      → (η : Γ′ ∋⋆ Γ) → CV⋆ σ ρ
                      → CV⋆ (η ◑ σ) (η ⬗ ρ)

-- (cong↓⟨_⟩CV⋆)
postulate
  getCV⋆ : ∀ {Γ Ξ Ξ′} → {σ : Γ ⊢⋆ Ξ′} {ρ : Γ ⊩⋆ Ξ′}
                      → (η : Ξ′ ∋⋆ Ξ) → CV⋆ σ ρ
                      → CV⋆ (σ ◐ η) (ρ ⬖ η)

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

-- Lemma 8.
postulate
  ⟦_⟧CV : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                    → (M : Ξ ⊢ A) → CV⋆ σ ρ
                    → CV (sub σ M) (⟦ M ⟧ ρ)

postulate
  ⟦_⟧CV⋆ : ∀ {Γ Ξ Φ} → {σ₁ : Γ ⊢⋆ Ξ} {ρ : Γ ⊩⋆ Ξ}
                     → (σ₂ : Ξ ⊢⋆ Φ) → CV⋆ σ₁ ρ
                     → CV⋆ (σ₁ ● σ₂) (⟦ σ₂ ⟧⋆ ρ)

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

-- Lemma 9.
mutual
  postulate
    lem₉ : ∀ {Γ A} → {M : Γ ⊢ A} {a : Γ ⊩ A}
                   → CV M a
                   → M ∼ reify a

  postulate
    aux₄₆₈ : ∀ {A Γ} → {M : Γ ⊢ A} {f : ∀ {Γ′} → Γ′ ∋⋆ Γ → Γ′ ⊢ A}
                     → (∀ {Γ′} → (η : Γ′ ∋⋆ Γ) → sub ⌊ η ⌋ M ∼ f η)
                     → CV M (⟪ f ⟫)

postulate
  ⌊_⌋CV⋆ : ∀ {Γ Γ′} → (η : Γ′ ∋⋆ Γ)
                   → CV⋆ ⌊ η ⌋ ⌊ η ⌋ᵥ

idCV⋆ : ∀ {Γ} → CV⋆ ⌊ idᵣ ⌋ (idᵥ {Γ})
idCV⋆ = ⌊ idᵣ ⌋CV⋆

postulate
  aux₄₆₉ : ∀ {Γ A} → (M : Γ ⊢ A)
                   → sub ⌊ idᵣ ⌋ M ∼ nf M

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

-- Theorem 2.
postulate
  thm₂ : ∀ {Γ A} → (M : Γ ⊢ A)
                 → M ∼ nf M

-- Theorem 3.
thm₃ : ∀ {Γ A} → (M₁ M₂ : Γ ⊢ A) → Eq (⟦ M₁ ⟧ idᵥ) (⟦ M₂ ⟧ idᵥ)
               → M₁ ∼ M₂
thm₃ M₁ M₂ e = thm₂ M₁
             ⦙ ≡→∼ (cor₁ M₁ M₂ e)
             ⦙ thm₂ M₂ ⁻¹

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


-- Basic intuitionistic modal logic S4, without ∨, ⊥, or ◇.
-- Translation between different formalisations of syntax.

module BasicIS4.Syntax.Translation where

open import BasicIS4.Syntax.Common public

import BasicIS4.Syntax.ClosedHilbertSequential as CHS
import BasicIS4.Syntax.ClosedHilbert as CH
import BasicIS4.Syntax.HilbertSequential as HS
import BasicIS4.Syntax.Hilbert as H
import BasicIS4.Syntax.Gentzen as G
import BasicIS4.Syntax.DyadicHilbertSequential as DHS
import BasicIS4.Syntax.DyadicHilbert as DH
import BasicIS4.Syntax.DyadicGentzen as DG
import BasicIS4.Syntax.LabelledGentzen as LG

open HS using () renaming (_⊦⊢_ to HS⟨_⊦⊢_⟩ ; _⊢_ to HS⟨_⊢_⟩) public
open H using () renaming (_⊢_ to H⟨_⊢_⟩ ; _⊢⋆_ to H⟨_⊢⋆_⟩) public
open G using () renaming (_⊢_ to G⟨_⊢_⟩ ; _⊢⋆_ to G⟨_⊢⋆_⟩) public
open DHS using () renaming (_⊦⊢_ to DHS⟨_⊦⊢_⟩ ; _⊢_ to DHS⟨_⊢_⟩) public
open DH using () renaming (_⊢_ to DH⟨_⊢_⟩) public
open DG using () renaming (_⊢_ to DG⟨_⊢_⟩ ; _⊢⋆_ to DG⟨_⊢⋆_⟩) public
open LG using (_↝_ ; _◎_ ; _◎⋆_) renaming (_⊢_ to LG⟨_⊢_⟩ ; _⊢⋆_ to LG⟨_⊢⋆_⟩) public

-- Available translations.
--
--       ┌─────┬─────┬─────┬─────┬─────┬─────┬─────┬─────┬─────┐
--       │ CHS │ CH  │ HS  │ H   │ G   │ DHS │ DH  │ DG  │ LG  │
-- ┌─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ CHS │     │ d   │ d   │ ∘   │ ∘   │ ∘   │ ∘   │ ∘   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ CH  │ d   │     │ ∘   │ d   │ ∘   │ ∘   │ ∘   │ ∘   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ HS  │ d   │ ∘   │     │ d   │ ∘   │ d   │ ∘   │ ∘   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ H   │ ∘   │ d   │ d   │     │ d   │ ∘   │ d   │ ∘   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ G   │ ∘   │ ∘   │ ∘   │ d   │     │ ∘   │ ∘   │ d   │ d   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ DHS │ ∘   │ ∘   │ d   │ ∘   │ ∘   │     │ d   │ ∘   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ DH  │ ∘   │ ∘   │ ∘   │ d   │ ∘   │ d   │     │ d   │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ DG  │ ∘   │ ∘   │ ∘   │ ∘   │ ∘!  │ ∘   │ d   │     │ ∘   │
-- ├─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┼─────┤
-- │ LG  │ ∘   │ ∘   │ ∘   │ WIP │ WIP │ ∘   │ ∘   │ ∘   │     │
-- └─────┴─────┴─────┴─────┴─────┴─────┴─────┴─────┴─────┴─────┘
--
-- d   : Direct translation.
-- ∘   : Composition of translations.
-- ∘!  : Composition; direct translation fails the termination check.
-- WIP : Work in progress.

-- Translation from closed Hilbert-style sequential to closed Hilbert-style.

chs→ch : ∀ {A} → CHS.⊢ A → CH.⊢ A
chs→ch (Ξ , ts) = chs⊦→ch ts top
  where
    chs⊦→ch : ∀ {A Ξ} → CHS.⊦⊢ Ξ → A ∈ Ξ → CH.⊢ A
    chs⊦→ch (CHS.mp i j ts) top     = CH.app (chs⊦→ch ts i) (chs⊦→ch ts j)
    chs⊦→ch (CHS.ci ts)     top     = CH.ci
    chs⊦→ch (CHS.ck ts)     top     = CH.ck
    chs⊦→ch (CHS.cs ts)     top     = CH.cs
    chs⊦→ch (CHS.nec ss ts) top     = CH.box (chs⊦→ch ss top)
    chs⊦→ch (CHS.cdist ts)  top     = CH.cdist
    chs⊦→ch (CHS.cup ts)    top     = CH.cup
    chs⊦→ch (CHS.cdown ts)  top     = CH.cdown
    chs⊦→ch (CHS.cpair ts)  top     = CH.cpair
    chs⊦→ch (CHS.cfst ts)   top     = CH.cfst
    chs⊦→ch (CHS.csnd ts)   top     = CH.csnd
    chs⊦→ch (CHS.unit ts)   top     = CH.unit
    chs⊦→ch (CHS.mp i j ts) (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ci ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ck ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cs ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.nec ss ts) (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cdist ts)  (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cup ts)    (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cdown ts)  (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cpair ts)  (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cfst ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.csnd ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.unit ts)   (pop k) = chs⊦→ch ts k

-- Translation from closed Hilbert-style to closed Hilbert-style sequential.

ch→chs : ∀ {A} → CH.⊢ A → CHS.⊢ A
ch→chs (CH.app t u) = CHS.app (ch→chs t) (ch→chs u)
ch→chs CH.ci        = ∅ , CHS.ci CHS.nil
ch→chs CH.ck        = ∅ , CHS.ck CHS.nil
ch→chs CH.cs        = ∅ , CHS.cs CHS.nil
ch→chs (CH.box t)   = CHS.box (ch→chs t)
ch→chs CH.cdist     = ∅ , CHS.cdist CHS.nil
ch→chs CH.cup       = ∅ , CHS.cup CHS.nil
ch→chs CH.cdown     = ∅ , CHS.cdown CHS.nil
ch→chs CH.cpair     = ∅ , CHS.cpair CHS.nil
ch→chs CH.cfst      = ∅ , CHS.cfst CHS.nil
ch→chs CH.csnd      = ∅ , CHS.csnd CHS.nil
ch→chs CH.unit      = ∅ , CHS.unit CHS.nil

-- Translation from Hilbert-style sequential to Hilbert-style.

hs→h : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
hs→h (Ξ , ts) = hs⊦→h ts top
  where
    hs⊦→h : ∀ {A Ξ Γ} → HS⟨ Γ ⊦⊢ Ξ ⟩ → A ∈ Ξ → H⟨ Γ ⊢ A ⟩
    hs⊦→h (HS.var i ts)  top     = H.var i
    hs⊦→h (HS.mp i j ts) top     = H.app (hs⊦→h ts i) (hs⊦→h ts j)
    hs⊦→h (HS.ci ts)     top     = H.ci
    hs⊦→h (HS.ck ts)     top     = H.ck
    hs⊦→h (HS.cs ts)     top     = H.cs
    hs⊦→h (HS.nec ss ts) top     = H.box (hs⊦→h ss top)
    hs⊦→h (HS.cdist ts)  top     = H.cdist
    hs⊦→h (HS.cup ts)    top     = H.cup
    hs⊦→h (HS.cdown ts)  top     = H.cdown
    hs⊦→h (HS.cpair ts)  top     = H.cpair
    hs⊦→h (HS.cfst ts)   top     = H.cfst
    hs⊦→h (HS.csnd ts)   top     = H.csnd
    hs⊦→h (HS.unit ts)   top     = H.unit
    hs⊦→h (HS.var i ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.mp i j ts) (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ci ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ck ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cs ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.nec ss ts) (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cdist ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cup ts)    (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cdown ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cpair ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cfst ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.csnd ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.unit ts)   (pop k) = hs⊦→h ts k

-- Translation from Hilbert-style to Hilbert-style sequential.

h→hs : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
h→hs (H.var i)   = ∅ , HS.var i HS.nil
h→hs (H.app t u) = HS.app (h→hs t) (h→hs u)
h→hs H.ci        = ∅ , HS.ci HS.nil
h→hs H.ck        = ∅ , HS.ck HS.nil
h→hs H.cs        = ∅ , HS.cs HS.nil
h→hs (H.box t)   = HS.box (h→hs t)
h→hs H.cdist     = ∅ , HS.cdist HS.nil
h→hs H.cup       = ∅ , HS.cup HS.nil
h→hs H.cdown     = ∅ , HS.cdown HS.nil
h→hs H.cpair     = ∅ , HS.cpair HS.nil
h→hs H.cfst      = ∅ , HS.cfst HS.nil
h→hs H.csnd      = ∅ , HS.csnd HS.nil
h→hs H.unit      = ∅ , HS.unit HS.nil

-- Translation from dyadic Hilbert-style sequential to dyadic Hilbert-style.

dhs→dh : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
dhs→dh (Ξ , ts) = dhs⊦→dh ts top
  where
    dhs⊦→dh : ∀ {A Ξ Γ Δ} → DHS⟨ Γ ⁏ Δ ⊦⊢ Ξ ⟩ → A ∈ Ξ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
    dhs⊦→dh (DHS.var i ts)  top     = DH.var i
    dhs⊦→dh (DHS.mp i j ts) top     = DH.app (dhs⊦→dh ts i) (dhs⊦→dh ts j)
    dhs⊦→dh (DHS.ci ts)     top     = DH.ci
    dhs⊦→dh (DHS.ck ts)     top     = DH.ck
    dhs⊦→dh (DHS.cs ts)     top     = DH.cs
    dhs⊦→dh (DHS.mvar i ts) top     = DH.mvar i
    dhs⊦→dh (DHS.nec ss ts) top     = DH.box (dhs⊦→dh ss top)
    dhs⊦→dh (DHS.cdist ts)  top     = DH.cdist
    dhs⊦→dh (DHS.cup ts)    top     = DH.cup
    dhs⊦→dh (DHS.cdown ts)  top     = DH.cdown
    dhs⊦→dh (DHS.cpair ts)  top     = DH.cpair
    dhs⊦→dh (DHS.cfst ts)   top     = DH.cfst
    dhs⊦→dh (DHS.csnd ts)   top     = DH.csnd
    dhs⊦→dh (DHS.unit ts)   top     = DH.unit
    dhs⊦→dh (DHS.var i ts)  (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.mp i j ts) (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.ci ts)     (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.ck ts)     (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.cs ts)     (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.mvar i ts) (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.nec ss ts) (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.cdist ts)  (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.cup ts)    (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.cdown ts)  (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.cpair ts)  (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.cfst ts)   (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.csnd ts)   (pop k) = dhs⊦→dh ts k
    dhs⊦→dh (DHS.unit ts)   (pop k) = dhs⊦→dh ts k

-- Translation from dyadic Hilbert-style to dyadic Hilbert-style sequential

dh→dhs : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
dh→dhs (DH.var i)   = ∅ , DHS.var i DHS.nil
dh→dhs (DH.app t u) = DHS.app (dh→dhs t) (dh→dhs u)
dh→dhs DH.ci        = ∅ , DHS.ci DHS.nil
dh→dhs DH.ck        = ∅ , DHS.ck DHS.nil
dh→dhs DH.cs        = ∅ , DHS.cs DHS.nil
dh→dhs (DH.mvar i)  = ∅ , DHS.mvar i DHS.nil
dh→dhs (DH.box t)   = DHS.box (dh→dhs t)
dh→dhs DH.cdist     = ∅ , DHS.cdist DHS.nil
dh→dhs DH.cup       = ∅ , DHS.cup DHS.nil
dh→dhs DH.cdown     = ∅ , DHS.cdown DHS.nil
dh→dhs DH.cpair     = ∅ , DHS.cpair DHS.nil
dh→dhs DH.cfst      = ∅ , DHS.cfst DHS.nil
dh→dhs DH.csnd      = ∅ , DHS.csnd DHS.nil
dh→dhs DH.unit      = ∅ , DHS.unit DHS.nil

-- Deduction and detachment theorems for Hilbert-style sequential.

hs-lam : ∀ {A B Γ} → HS⟨ Γ , A ⊢ B ⟩ → HS⟨ Γ ⊢ A ▻ B ⟩
hs-lam = h→hs ∘ H.lam ∘ hs→h

hs-lam⋆₀ : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → HS⟨ ∅ ⊢ Γ ▻⋯▻ A ⟩
hs-lam⋆₀ = h→hs ∘ H.lam⋆₀ ∘ hs→h

hs-det : ∀ {A B Γ} → HS⟨ Γ ⊢ A ▻ B ⟩ → HS⟨ Γ , A ⊢ B ⟩
hs-det = h→hs ∘ H.det ∘ hs→h

hs-det⋆₀ : ∀ {A Γ} → HS⟨ ∅ ⊢ Γ ▻⋯▻ A ⟩ → HS⟨ Γ ⊢ A ⟩
hs-det⋆₀ = h→hs ∘ H.det⋆₀ ∘ hs→h

-- Deduction and detachment theorems for dyadic Hilbert-style sequential.

dhs-lam : ∀ {A B Γ Δ} → DHS⟨ Γ , A ⁏ Δ ⊢ B ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ▻ B ⟩
dhs-lam = dh→dhs ∘ DH.lam ∘ dhs→dh

dhs-lam⋆₀ : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → DHS⟨ ∅ ⁏ Δ ⊢ Γ ▻⋯▻ A ⟩
dhs-lam⋆₀ = dh→dhs ∘ DH.lam⋆₀ ∘ dhs→dh

dhs-mlam : ∀ {A B Γ Δ} → DHS⟨ Γ ⁏ Δ , A ⊢ B ⟩ → DHS⟨ Γ ⁏ Δ ⊢ □ A ▻ B ⟩
dhs-mlam = dh→dhs ∘ DH.mlam ∘ dhs→dh

dhs-mlam⋆₀ : ∀ {Δ A Γ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → DHS⟨ Γ ⁏ ∅ ⊢ □⋆ Δ ▻⋯▻ A ⟩
dhs-mlam⋆₀ = dh→dhs ∘ DH.mlam⋆₀ ∘ dhs→dh

dhs-det : ∀ {A B Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ▻ B ⟩ → DHS⟨ Γ , A ⁏ Δ ⊢ B ⟩
dhs-det = dh→dhs ∘ DH.det ∘ dhs→dh

dhs-det⋆₀ : ∀ {A Γ Δ} → DHS⟨ ∅ ⁏ Δ ⊢ Γ ▻⋯▻ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
dhs-det⋆₀ = dh→dhs ∘ DH.det⋆₀ ∘ dhs→dh

dhs-mdet : ∀ {A B Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ □ A ▻ B ⟩ → DHS⟨ Γ ⁏ Δ , A ⊢ B ⟩
dhs-mdet = dh→dhs ∘ DH.mdet ∘ dhs→dh

dhs-mdet⋆₀ : ∀ {Δ A Γ} → DHS⟨ Γ ⁏ ∅ ⊢ □⋆ Δ ▻⋯▻ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
dhs-mdet⋆₀ = dh→dhs ∘ DH.mdet⋆₀ ∘ dhs→dh

-- Context manipulation for dyadic Hilbert-style sequential.

dhs-merge : ∀ {Δ A Γ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → DHS⟨ Γ ⧺ (□⋆ Δ) ⁏ ∅ ⊢ A ⟩
dhs-merge {Δ} = dh→dhs ∘ DH.merge ∘ dhs→dh

dhs-split : ∀ {Δ A Γ} → DHS⟨ Γ ⧺ (□⋆ Δ) ⁏ ∅ ⊢ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
dhs-split {Δ} = dh→dhs ∘ DH.split ∘ dhs→dh

-- Translation from closed Hilbert-style sequential to Hilbert-style sequential.

chs→hs₀ : ∀ {A} → CHS.⊢ A → HS⟨ ∅ ⊢ A ⟩
chs→hs₀ (Ξ , ts) = Ξ , chs⊦→hs⊦ ts
  where
    chs⊦→hs⊦ : ∀ {Ξ} → CHS.⊦⊢ Ξ → HS⟨ ∅ ⊦⊢ Ξ ⟩
    chs⊦→hs⊦ CHS.nil         = HS.nil
    chs⊦→hs⊦ (CHS.mp i j ts) = HS.mp i j (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.ci ts)     = HS.ci (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.ck ts)     = HS.ck (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.cs ts)     = HS.cs (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.cpair ts)  = HS.cpair (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.cfst ts)   = HS.cfst (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.csnd ts)   = HS.csnd (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.unit ts)   = HS.unit (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.nec ss ts) = HS.nec (chs⊦→hs⊦ ss) (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.cdist ts)  = HS.cdist (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.cup ts)    = HS.cup (chs⊦→hs⊦ ts)
    chs⊦→hs⊦ (CHS.cdown ts)  = HS.cdown (chs⊦→hs⊦ ts)

chs→hs : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → HS⟨ Γ ⊢ A ⟩
chs→hs t = hs-det⋆₀ (chs→hs₀ t)

-- Translation from Hilbert-style sequential to closed Hilbert-style sequential.

hs₀→chs : ∀ {A} → HS⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
hs₀→chs (Ξ , ts) = Ξ , hs₀⊦→chs⊦ ts
  where
    hs₀⊦→chs⊦ : ∀ {Ξ} → HS⟨ ∅ ⊦⊢ Ξ ⟩ → CHS.⊦⊢ Ξ
    hs₀⊦→chs⊦ HS.nil         = CHS.nil
    hs₀⊦→chs⊦ (HS.var () ts)
    hs₀⊦→chs⊦ (HS.mp i j ts) = CHS.mp i j (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ci ts)     = CHS.ci (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ck ts)     = CHS.ck (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cs ts)     = CHS.cs (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cpair ts)  = CHS.cpair (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cfst ts)   = CHS.cfst (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.csnd ts)   = CHS.csnd (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.unit ts)   = CHS.unit (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.nec ss ts) = CHS.nec (hs₀⊦→chs⊦ ss) (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cdist ts)  = CHS.cdist (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cup ts)    = CHS.cup (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cdown ts)  = CHS.cdown (hs₀⊦→chs⊦ ts)

hs→chs : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
hs→chs t = hs₀→chs (hs-lam⋆₀ t)

-- Translation from dyadic Hilbert-style sequential to Hilbert-style sequential.

dhs₀→hs : ∀ {A Γ} → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
dhs₀→hs (Ξ , ts) = Ξ , dhs₀⊦→hs⊦ ts
  where
    dhs₀⊦→hs⊦ : ∀ {Ξ Γ} → DHS⟨ Γ ⁏ ∅ ⊦⊢ Ξ ⟩ → HS⟨ Γ ⊦⊢ Ξ ⟩
    dhs₀⊦→hs⊦ DHS.nil          = HS.nil
    dhs₀⊦→hs⊦ (DHS.var i ts)   = HS.var i (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.mp i j ts)  = HS.mp i j (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.ci ts)      = HS.ci (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.ck ts)      = HS.ck (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.cs ts)      = HS.cs (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.mvar () ts)
    dhs₀⊦→hs⊦ (DHS.nec ss ts)  = HS.nec (dhs₀⊦→hs⊦ ss) (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.cdist ts)   = HS.cdist (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.cup ts)     = HS.cup (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.cdown ts)   = HS.cdown (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.cpair ts)   = HS.cpair (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.cfst ts)    = HS.cfst (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.csnd ts)    = HS.csnd (dhs₀⊦→hs⊦ ts)
    dhs₀⊦→hs⊦ (DHS.unit ts)    = HS.unit (dhs₀⊦→hs⊦ ts)

dhs→hs : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → HS⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dhs→hs = dhs₀→hs ∘ dhs-merge

-- Translation from Hilbert-style sequential to dyadic Hilbert-style sequential.

hs→dhs₀ : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩
hs→dhs₀ (Ξ , ts) = Ξ , hs⊦→dhs₀⊦ ts
  where
    hs⊦→dhs₀⊦ : ∀ {Ξ Γ} → HS⟨ Γ ⊦⊢ Ξ ⟩ → DHS⟨ Γ ⁏ ∅ ⊦⊢ Ξ ⟩
    hs⊦→dhs₀⊦ HS.nil         = DHS.nil
    hs⊦→dhs₀⊦ (HS.var i ts)  = DHS.var i (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.mp i j ts) = DHS.mp i j (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.ci ts)     = DHS.ci (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.ck ts)     = DHS.ck (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.cs ts)     = DHS.cs (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.nec ss ts) = DHS.nec (hs⊦→dhs₀⊦ ss) (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.cdist ts)  = DHS.cdist (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.cup ts)    = DHS.cup (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.cdown ts)  = DHS.cdown (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.cpair ts)  = DHS.cpair (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.cfst ts)   = DHS.cfst (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.csnd ts)   = DHS.csnd (hs⊦→dhs₀⊦ ts)
    hs⊦→dhs₀⊦ (HS.unit ts)   = DHS.unit (hs⊦→dhs₀⊦ ts)

hs→dhs : ∀ {A Γ Δ} → HS⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
hs→dhs = dhs-split ∘ hs→dhs₀

-- Translation from closed Hilbert-style to Hilbert-style.

ch→h₀ : ∀ {A} → CH.⊢ A → H⟨ ∅ ⊢ A ⟩
ch→h₀ (CH.app t u) = H.app (ch→h₀ t) (ch→h₀ u)
ch→h₀ CH.ci        = H.ci
ch→h₀ CH.ck        = H.ck
ch→h₀ CH.cs        = H.cs
ch→h₀ CH.cpair     = H.cpair
ch→h₀ CH.cfst      = H.cfst
ch→h₀ CH.csnd      = H.csnd
ch→h₀ CH.unit      = H.unit
ch→h₀ (CH.box t)   = H.box (ch→h₀ t)
ch→h₀ CH.cdist     = H.cdist
ch→h₀ CH.cup       = H.cup
ch→h₀ CH.cdown     = H.cdown

ch→h : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → H⟨ Γ ⊢ A ⟩
ch→h t = H.det⋆₀ (ch→h₀ t)

-- Translation from Hilbert-style to closed Hilbert-style.

h₀→ch : ∀ {A} → H⟨ ∅ ⊢ A ⟩ → CH.⊢ A
h₀→ch (H.var ())
h₀→ch (H.app t u) = CH.app (h₀→ch t) (h₀→ch u)
h₀→ch H.ci        = CH.ci
h₀→ch H.ck        = CH.ck
h₀→ch H.cs        = CH.cs
h₀→ch H.cpair     = CH.cpair
h₀→ch H.cfst      = CH.cfst
h₀→ch H.csnd      = CH.csnd
h₀→ch H.unit      = CH.unit
h₀→ch (H.box t)   = CH.box (h₀→ch t)
h₀→ch H.cdist     = CH.cdist
h₀→ch H.cup       = CH.cup
h₀→ch H.cdown     = CH.cdown

h→ch : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
h→ch t = h₀→ch (H.lam⋆₀ t)

-- Translation from dyadic Hilbert-style to Hilbert-style.

dh₀→h : ∀ {A Γ} → DH⟨ Γ ⁏ ∅ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
dh₀→h (DH.var i)   = H.var i
dh₀→h (DH.app t u) = H.app (dh₀→h t) (dh₀→h u)
dh₀→h DH.ci        = H.ci
dh₀→h DH.ck        = H.ck
dh₀→h DH.cs        = H.cs
dh₀→h (DH.mvar ())
dh₀→h (DH.box t)   = H.box (dh₀→h t)
dh₀→h DH.cdist     = H.cdist
dh₀→h DH.cup       = H.cup
dh₀→h DH.cdown     = H.cdown
dh₀→h DH.cpair     = H.cpair
dh₀→h DH.cfst      = H.cfst
dh₀→h DH.csnd      = H.csnd
dh₀→h DH.unit      = H.unit

dh→h : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → H⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dh→h = dh₀→h ∘ DH.merge

-- Translation from Hilbert-style to dyadic Hilbert-style.

h→dh₀ : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → DH⟨ Γ ⁏ ∅ ⊢ A ⟩
h→dh₀ (H.var i)   = DH.var i
h→dh₀ (H.app t u) = DH.app (h→dh₀ t) (h→dh₀ u)
h→dh₀ H.ci        = DH.ci
h→dh₀ H.ck        = DH.ck
h→dh₀ H.cs        = DH.cs
h→dh₀ (H.box t)   = DH.box (h→dh₀ t)
h→dh₀ H.cdist     = DH.cdist
h→dh₀ H.cup       = DH.cup
h→dh₀ H.cdown     = DH.cdown
h→dh₀ H.cpair     = DH.cpair
h→dh₀ H.cfst      = DH.cfst
h→dh₀ H.csnd      = DH.csnd
h→dh₀ H.unit      = DH.unit

h→dh : ∀ {A Γ Δ} → H⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
h→dh = DH.split ∘ h→dh₀

-- Translation from Hilbert-style to Gentzen-style.

h→g : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
h→g (H.var i)   = G.var i
h→g (H.app t u) = G.app (h→g t) (h→g u)
h→g H.ci        = G.ci
h→g H.ck        = G.ck
h→g H.cs        = G.cs
h→g (H.box t)   = G.box (h→g t)
h→g H.cdist     = G.cdist
h→g H.cup       = G.cup
h→g H.cdown     = G.cdown
h→g H.cpair     = G.cpair
h→g H.cfst      = G.cfst
h→g H.csnd      = G.csnd
h→g H.unit      = G.unit

-- Translation from Gentzen-style to Hilbert-style.

mutual
  g→h : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
  g→h (G.var i)         = H.var i
  g→h (G.lam t)         = H.lam (g→h t)
  g→h (G.app t u)       = H.app (g→h t) (g→h u)
  g→h (G.multibox ts u) = H.multibox (g→h⋆ ts) (g→h u)
  g→h (G.down t)        = H.down (g→h t)
  g→h (G.pair t u)      = H.pair (g→h t) (g→h u)
  g→h (G.fst t)         = H.fst (g→h t)
  g→h (G.snd t)         = H.snd (g→h t)
  g→h G.unit            = H.unit

  g→h⋆ : ∀ {Ξ Γ} → G⟨ Γ ⊢⋆ Ξ ⟩ → H⟨ Γ ⊢⋆ Ξ ⟩
  g→h⋆ {∅}     ∙        = ∙
  g→h⋆ {Ξ , A} (ts , t) = g→h⋆ ts , g→h t

-- Translation from dyadic Hilbert-style to dyadic Gentzen-style.

dh→dg : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → DG⟨ Γ ⁏ Δ ⊢ A ⟩
dh→dg (DH.var i)   = DG.var i
dh→dg (DH.app t u) = DG.app (dh→dg t) (dh→dg u)
dh→dg DH.ci        = DG.ci
dh→dg DH.ck        = DG.ck
dh→dg DH.cs        = DG.cs
dh→dg (DH.mvar i)  = DG.mvar i
dh→dg (DH.box t)   = DG.box (dh→dg t)
dh→dg DH.cdist     = DG.cdist
dh→dg DH.cup       = DG.cup
dh→dg DH.cdown     = DG.cdown
dh→dg DH.cpair     = DG.cpair
dh→dg DH.cfst      = DG.cfst
dh→dg DH.csnd      = DG.csnd
dh→dg DH.unit      = DG.unit

-- Translation from dyadic Gentzen-style to dyadic Hilbert-style.

dg→dh : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
dg→dh (DG.var i)     = DH.var i
dg→dh (DG.lam t)     = DH.lam (dg→dh t)
dg→dh (DG.app t u)   = DH.app (dg→dh t) (dg→dh u)
dg→dh (DG.mvar i)    = DH.mvar i
dg→dh (DG.box t)     = DH.box (dg→dh t)
dg→dh (DG.unbox t u) = DH.unbox (dg→dh t) (dg→dh u)
dg→dh (DG.pair t u)  = DH.pair (dg→dh t) (dg→dh u)
dg→dh (DG.fst t)     = DH.fst (dg→dh t)
dg→dh (DG.snd t)     = DH.snd (dg→dh t)
dg→dh DG.unit        = DH.unit

-- Translation from Gentzen-style to dyadic Gentzen-style.

mutual
  g→dg₀ : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → DG⟨ Γ ⁏ ∅ ⊢ A ⟩
  g→dg₀ (G.var i)         = DG.var i
  g→dg₀ (G.lam t)         = DG.lam (g→dg₀ t)
  g→dg₀ (G.app t u)       = DG.app (g→dg₀ t) (g→dg₀ u)
  g→dg₀ (G.multibox ts u) = DG.multibox (g→dg₀⋆ ts) (g→dg₀ u)
  g→dg₀ (G.down t)        = DG.down (g→dg₀ t)
  g→dg₀ (G.pair t u)      = DG.pair (g→dg₀ t) (g→dg₀ u)
  g→dg₀ (G.fst t)         = DG.fst (g→dg₀ t)
  g→dg₀ (G.snd t)         = DG.snd (g→dg₀ t)
  g→dg₀ G.unit            = DG.unit

  g→dg₀⋆ : ∀ {Ξ Γ} → G⟨ Γ ⊢⋆ Ξ ⟩ → DG⟨ Γ ⁏ ∅ ⊢⋆ Ξ ⟩
  g→dg₀⋆ {∅}     ∙        = ∙
  g→dg₀⋆ {Ξ , A} (ts , t) = g→dg₀⋆ ts , g→dg₀ t

g→dg : ∀ {A Γ Δ} → G⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DG⟨ Γ ⁏ Δ ⊢ A ⟩
g→dg = DG.split ∘ g→dg₀

-- Translation from Hilbert-style to labelled Gentzen-style.

h→lg : ∀ {x A Γ Λ} → H⟨ Γ ⊢ A ⟩ → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
h→lg (H.var i)   = LG.var i
h→lg (H.app t u) = LG.app (h→lg t) (h→lg u)
h→lg H.ci        = LG.ci
h→lg H.ck        = LG.ck
h→lg H.cs        = LG.cs
h→lg (H.box t)   = LG.box (h→lg t)
h→lg H.cdist     = LG.cdist
h→lg H.cup       = LG.cup
h→lg H.cdown     = LG.cdown
h→lg H.cpair     = LG.cpair
h→lg H.cfst      = LG.cfst
h→lg H.csnd      = LG.csnd
h→lg H.unit      = LG.unit

-- Translation from labelled Gentzen-style to Hilbert-style.

-- FIXME: Stronger hypothesis?
postulate
  h-oops : ∀ {x A Γ Λ} → (∀ {y} → LG⟨ Γ ⁏ Λ , x ↝ y ⊢ A ◎ y ⟩) → H⟨ Γ ⊢ □ A ⟩

lg→h : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → H⟨ Γ ⊢ A ⟩
lg→h (LG.var i)    = H.var i
lg→h (LG.lam t)    = H.lam (lg→h t)
lg→h (LG.app t u)  = H.app (lg→h t) (lg→h u)
lg→h (LG.scan t)   = h-oops t
lg→h (LG.move t u) = H.down (lg→h t)
lg→h (LG.pair t u) = H.pair (lg→h t) (lg→h u)
lg→h (LG.fst t)    = H.fst (lg→h t)
lg→h (LG.snd t)    = H.snd (lg→h t)
lg→h LG.unit       = H.unit

-- Translation from Gentzen-style to labelled Gentzen-style.

mutual
  g→lg : ∀ {x A Γ Λ} → G⟨ Γ ⊢ A ⟩ → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
  g→lg (G.var i)         = LG.var i
  g→lg (G.lam t)         = LG.lam (g→lg t)
  g→lg (G.app t u)       = LG.app (g→lg t) (g→lg u)
  g→lg (G.multibox ts u) = LG.multibox (g→lg⋆ ts) (g→lg u)
  g→lg (G.down t)        = LG.move (g→lg t) LG.rrefl
  g→lg (G.pair t u)      = LG.pair (g→lg t) (g→lg u)
  g→lg (G.fst t)         = LG.fst (g→lg t)
  g→lg (G.snd t)         = LG.snd (g→lg t)
  g→lg G.unit            = LG.unit

  g→lg⋆ : ∀ {x Ξ Γ Λ} → G⟨ Γ ⊢⋆ Ξ ⟩ → LG⟨ Γ ⁏ Λ ⊢⋆ Ξ ◎⋆ x ⟩
  g→lg⋆ {x} {∅}     ∙        = ∙
  g→lg⋆ {x} {Ξ , A} (ts , t) = g→lg⋆ ts , g→lg t

-- Translation from labelled Gentzen-style to Gentzen-style.

-- FIXME: Stronger hypothesis?
postulate
  g-oops : ∀ {x A Γ Λ} → (∀ {y} → LG⟨ Γ ⁏ Λ , x ↝ y ⊢ A ◎ y ⟩) → G⟨ Γ ⊢ □ A ⟩

lg→g : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → G⟨ Γ ⊢ A ⟩
lg→g (LG.var i)    = G.var i
lg→g (LG.lam t)    = G.lam (lg→g t)
lg→g (LG.app t u)  = G.app (lg→g t) (lg→g u)
lg→g (LG.scan t)   = g-oops t
lg→g (LG.move t u) = G.down (lg→g t)
lg→g (LG.pair t u) = G.pair (lg→g t) (lg→g u)
lg→g (LG.fst t)    = G.fst (lg→g t)
lg→g (LG.snd t)    = G.snd (lg→g t)
lg→g LG.unit       = G.unit

-- Additional translations from closed Hilbert-style sequential.

chs→h₀ : ∀ {A} → CHS.⊢ A → H⟨ ∅ ⊢ A ⟩
chs→h₀ = ch→h₀ ∘ chs→ch

chs→h : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → H⟨ Γ ⊢ A ⟩
chs→h = ch→h ∘ chs→ch

chs→g₀ : ∀ {A} → CHS.⊢ A → G⟨ ∅ ⊢ A ⟩
chs→g₀ = h→g ∘ chs→h₀

chs→g : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → G⟨ Γ ⊢ A ⟩
chs→g = h→g ∘ chs→h

chs→dhs₀₀ : ∀ {A} → CHS.⊢ A → DHS⟨ ∅ ⁏ ∅ ⊢ A ⟩
chs→dhs₀₀ = hs→dhs₀ ∘ chs→hs₀

chs→dhs₀ : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩
chs→dhs₀ = hs→dhs₀ ∘ chs→hs

chs→dhs : ∀ {A Γ Δ} → CHS.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
chs→dhs = hs→dhs ∘ chs→hs

chs→dh₀₀ : ∀ {A} → CHS.⊢ A → DH⟨ ∅ ⁏ ∅ ⊢ A ⟩
chs→dh₀₀ = h→dh₀ ∘ chs→h₀

chs→dh₀ : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → DH⟨ Γ ⁏ ∅ ⊢ A ⟩
chs→dh₀ = h→dh₀ ∘ chs→h

chs→dh : ∀ {A Γ Δ} → CHS.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A → DH⟨ Γ ⁏ Δ ⊢ A ⟩
chs→dh = h→dh ∘ chs→h

chs→dg₀₀ : ∀ {A} → CHS.⊢ A → DG⟨ ∅ ⁏ ∅ ⊢ A ⟩
chs→dg₀₀ = g→dg₀ ∘ chs→g₀

chs→dg₀ : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → DG⟨ Γ ⁏ ∅ ⊢ A ⟩
chs→dg₀ = g→dg₀ ∘ chs→g

chs→dg : ∀ {A Γ Δ} → CHS.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A → DG⟨ Γ ⁏ Δ ⊢ A ⟩
chs→dg = g→dg ∘ chs→g

chs→lg₀ : ∀ {x A Λ} → CHS.⊢ A → LG⟨ ∅ ⁏ Λ ⊢ A ◎ x ⟩
chs→lg₀ = g→lg ∘ chs→g₀

chs→lg : ∀ {x A Γ Λ} → CHS.⊢ Γ ▻⋯▻ A → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
chs→lg = g→lg ∘ chs→g

-- Additional translations from closed Hilbert-style.

ch→hs₀ : ∀ {A} → CH.⊢ A → HS⟨ ∅ ⊢ A ⟩
ch→hs₀ = chs→hs ∘ ch→chs

ch→hs : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → HS⟨ Γ ⊢ A ⟩
ch→hs = chs→hs ∘ ch→chs

ch→g₀ : ∀ {A} → CH.⊢ A → G⟨ ∅ ⊢ A ⟩
ch→g₀ = h→g ∘ ch→h₀

ch→g : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → G⟨ Γ ⊢ A ⟩
ch→g = h→g ∘ ch→h

ch→dhs₀₀ : ∀ {A} → CH.⊢ A → DHS⟨ ∅ ⁏ ∅ ⊢ A ⟩
ch→dhs₀₀ = hs→dhs₀ ∘ ch→hs₀

ch→dhs₀ : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩
ch→dhs₀ = hs→dhs₀ ∘ ch→hs

ch→dhs : ∀ {A Γ Δ} → CH.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
ch→dhs = hs→dhs ∘ ch→hs

ch→dh₀₀ : ∀ {A} → CH.⊢ A → DH⟨ ∅ ⁏ ∅ ⊢ A ⟩
ch→dh₀₀ = h→dh₀ ∘ ch→h₀

ch→dh₀ : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → DH⟨ Γ ⁏ ∅ ⊢ A ⟩
ch→dh₀ = h→dh₀ ∘ ch→h

ch→dh : ∀ {A Γ Δ} → CH.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A → DH⟨ Γ ⁏ Δ ⊢ A ⟩
ch→dh = h→dh ∘ ch→h

ch→dg₀₀ : ∀ {A} → CH.⊢ A → DG⟨ ∅ ⁏ ∅ ⊢ A ⟩
ch→dg₀₀ = g→dg₀ ∘ ch→g₀

ch→dg₀ : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → DG⟨ Γ ⁏ ∅ ⊢ A ⟩
ch→dg₀ = g→dg₀ ∘ ch→g

ch→dg : ∀ {A Γ Δ} → CH.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A → DG⟨ Γ ⁏ Δ ⊢ A ⟩
ch→dg = g→dg ∘ ch→g

ch→lg₀ : ∀ {x A Λ} → CH.⊢ A → LG⟨ ∅ ⁏ Λ ⊢ A ◎ x ⟩
ch→lg₀ = g→lg ∘ ch→g₀

ch→lg : ∀ {x A Γ Λ} → CH.⊢ Γ ▻⋯▻ A → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
ch→lg = g→lg ∘ ch→g

-- Additional translations from Hilbert-style sequential.

hs₀→ch : ∀ {A} → HS⟨ ∅ ⊢ A ⟩ → CH.⊢ A
hs₀→ch = chs→ch ∘ hs₀→chs

hs→ch : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
hs→ch = chs→ch ∘ hs→chs

hs→g : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
hs→g = h→g ∘ hs→h

hs→dh₀ : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → DH⟨ Γ ⁏ ∅ ⊢ A ⟩
hs→dh₀ = h→dh₀ ∘ hs→h

hs→dh : ∀ {A Γ Δ} → HS⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
hs→dh = h→dh ∘ hs→h

hs→dg₀ : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → DG⟨ Γ ⁏ ∅ ⊢ A ⟩
hs→dg₀ = dh→dg ∘ hs→dh₀

hs→dg : ∀ {A Γ Δ} → HS⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DG⟨ Γ ⁏ Δ ⊢ A ⟩
hs→dg = dh→dg ∘ hs→dh

hs→lg : ∀ {x A Γ Λ} → HS⟨ Γ ⊢ A ⟩ → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
hs→lg = h→lg ∘ hs→h

-- Additional translations from Hilbert-style.

h₀→chs : ∀ {A} → H⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
h₀→chs = ch→chs ∘ h₀→ch

h→chs : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
h→chs = ch→chs ∘ h→ch

h→dhs₀ : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩
h→dhs₀ = hs→dhs₀ ∘ h→hs

h→dhs : ∀ {A Γ Δ} → H⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
h→dhs = hs→dhs ∘ h→hs

h→dg₀ : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → DG⟨ Γ ⁏ ∅ ⊢ A ⟩
h→dg₀ = dh→dg ∘ h→dh₀

h→dg : ∀ {A Γ Δ} → H⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DG⟨ Γ ⁏ Δ ⊢ A ⟩
h→dg = dh→dg ∘ h→dh

-- Additional translations from Gentzen-style.

g₀→chs : ∀ {A} → G⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
g₀→chs = h₀→chs ∘ g→h

g→chs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
g→chs = h→chs ∘ g→h

g₀→ch : ∀ {A} → G⟨ ∅ ⊢ A ⟩ → CH.⊢ A
g₀→ch = h₀→ch ∘ g→h

g→ch : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
g→ch = h→ch ∘ g→h

g→hs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
g→hs = h→hs ∘ g→h

g→dhs₀ : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩
g→dhs₀ = h→dhs₀ ∘ g→h

g→dhs : ∀ {A Γ Δ} → G⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
g→dhs = h→dhs ∘ g→h

g→dh₀ : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → DH⟨ Γ ⁏ ∅ ⊢ A ⟩
g→dh₀ = h→dh₀ ∘ g→h

g→dh : ∀ {A Γ Δ} → G⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
g→dh = h→dh ∘ g→h

-- Additional translations from dyadic Hilbert-style sequential.

dhs₀₀→chs : ∀ {A} → DHS⟨ ∅ ⁏ ∅ ⊢ A ⟩ → CHS.⊢ A
dhs₀₀→chs = hs₀→chs ∘ dhs₀→hs

dhs₀→chs : ∀ {A Γ} → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
dhs₀→chs = hs→chs ∘ dhs₀→hs

dhs→chs : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → CHS.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A
dhs→chs = hs→chs ∘ dhs→hs

dhs₀₀→ch : ∀ {A} → DHS⟨ ∅ ⁏ ∅ ⊢ A ⟩ → CH.⊢ A
dhs₀₀→ch = hs₀→ch ∘ dhs₀→hs

dhs₀→ch : ∀ {A Γ} → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
dhs₀→ch = hs→ch ∘ dhs₀→hs

dhs→ch : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → CH.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A
dhs→ch = hs→ch ∘ dhs→hs

dhs₀→h : ∀ {A Γ} → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
dhs₀→h = hs→h ∘ dhs₀→hs

dhs→h : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → H⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dhs→h = hs→h ∘ dhs→hs

dhs₀→g : ∀ {A Γ} → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
dhs₀→g = hs→g ∘ dhs₀→hs

dhs→g : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → G⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dhs→g = hs→g ∘ dhs→hs

dhs→dg : ∀ {A Γ Δ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → DG⟨ Γ ⁏ Δ ⊢ A ⟩
dhs→dg = dh→dg ∘ dhs→dh

dhs₀→lg : ∀ {x A Γ Λ} → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩ → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
dhs₀→lg = hs→lg ∘ dhs₀→hs

dhs→lg : ∀ {x A Γ Δ Λ} → DHS⟨ Γ ⁏ Δ ⊢ A ⟩ → LG⟨ Γ ⧺ (□⋆ Δ) ⁏ Λ ⊢ A ◎ x ⟩
dhs→lg = hs→lg ∘ dhs→hs

-- Additional translations from dyadic Hilbert-style.

dh₀₀→chs : ∀ {A} → DH⟨ ∅ ⁏ ∅ ⊢ A ⟩ → CHS.⊢ A
dh₀₀→chs = h₀→chs ∘ dh₀→h

dh₀→chs : ∀ {A Γ} → DH⟨ Γ ⁏ ∅ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
dh₀→chs = h→chs ∘ dh₀→h

dh→chs : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → CHS.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A
dh→chs = h→chs ∘ dh→h

dh₀₀→ch : ∀ {A} → DH⟨ ∅ ⁏ ∅ ⊢ A ⟩ → CH.⊢ A
dh₀₀→ch = h₀→ch ∘ dh₀→h

dh₀→ch : ∀ {A Γ} → DH⟨ Γ ⁏ ∅ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
dh₀→ch = h→ch ∘ dh₀→h

dh→ch : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → CH.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A
dh→ch = h→ch ∘ dh→h

dh₀→hs : ∀ {A Γ} → DH⟨ Γ ⁏ ∅ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
dh₀→hs = h→hs ∘ dh₀→h

dh→hs : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → HS⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dh→hs = h→hs ∘ dh→h

dh₀→g : ∀ {A Γ} → DH⟨ Γ ⁏ ∅ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
dh₀→g = h→g ∘ dh₀→h

dh→g : ∀ {A Γ Δ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → G⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dh→g = h→g ∘ dh→h

dh₀→lg : ∀ {x A Γ Λ} → DH⟨ Γ ⁏ ∅ ⊢ A ⟩ → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
dh₀→lg = h→lg ∘ dh₀→h

dh→lg : ∀ {x A Γ Δ Λ} → DH⟨ Γ ⁏ Δ ⊢ A ⟩ → LG⟨ Γ ⧺ (□⋆ Δ) ⁏ Λ ⊢ A ◎ x ⟩
dh→lg = h→lg ∘ dh→h

-- Additional translations from dyadic Gentzen-style.

dg₀₀→chs : ∀ {A} → DG⟨ ∅ ⁏ ∅ ⊢ A ⟩ → CHS.⊢ A
dg₀₀→chs = dh₀→chs ∘ dg→dh

dg₀→chs : ∀ {A Γ} → DG⟨ Γ ⁏ ∅ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
dg₀→chs = dh→chs ∘ dg→dh

dg→chs : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → CHS.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A
dg→chs = dh→chs ∘ dg→dh

dg₀₀→ch : ∀ {A} → DG⟨ ∅ ⁏ ∅ ⊢ A ⟩ → CH.⊢ A
dg₀₀→ch = dh₀→ch ∘ dg→dh

dg₀→ch : ∀ {A Γ} → DG⟨ Γ ⁏ ∅ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
dg₀→ch = dh→ch ∘ dg→dh

dg→ch : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → CH.⊢ Γ ⧺ (□⋆ Δ) ▻⋯▻ A
dg→ch = dh→ch ∘ dg→dh

dg₀→hs : ∀ {A Γ} → DG⟨ Γ ⁏ ∅ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
dg₀→hs = dh₀→hs ∘ dg→dh

dg→hs : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → HS⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dg→hs = dh→hs ∘ dg→dh

dg₀→h : ∀ {A Γ} → DG⟨ Γ ⁏ ∅ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
dg₀→h = dh₀→h ∘ dg→dh

dg→h : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → H⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dg→h = dh→h ∘ dg→dh

-- NOTE: Direct translation fails the termination check.
dg₀→g : ∀ {A Γ} → DG⟨ Γ ⁏ ∅ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
dg₀→g = h→g ∘ dg₀→h

dg→g : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → G⟨ Γ ⧺ (□⋆ Δ) ⊢ A ⟩
dg→g = h→g ∘ dg→h

dg→dhs : ∀ {A Γ Δ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
dg→dhs = dh→dhs ∘ dg→dh

dg₀→lg : ∀ {x A Γ Λ} → DG⟨ Γ ⁏ ∅ ⊢ A ⟩ → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩
dg₀→lg = g→lg ∘ dg₀→g

dg→lg : ∀ {x A Γ Δ Λ} → DG⟨ Γ ⁏ Δ ⊢ A ⟩ → LG⟨ Γ ⧺ (□⋆ Δ) ⁏ Λ ⊢ A ◎ x ⟩
dg→lg = g→lg ∘ dg→g

-- Additional translations from labelled Gentzen-style.

lg₀→chs : ∀ {x A Λ} → LG⟨ ∅ ⁏ Λ ⊢ A ◎ x ⟩ → CHS.⊢ A
lg₀→chs = h₀→chs ∘ lg→h

lg→chs : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → CHS.⊢ Γ ▻⋯▻ A
lg→chs = h→chs ∘ lg→h

lg₀→ch : ∀ {x A Λ} → LG⟨ ∅ ⁏ Λ ⊢ A ◎ x ⟩ → CH.⊢ A
lg₀→ch = h₀→ch ∘ lg→h

lg→ch : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → CH.⊢ Γ ▻⋯▻ A
lg→ch = h→ch ∘ lg→h

lg→hs : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → HS⟨ Γ ⊢ A ⟩
lg→hs = h→hs ∘ lg→h

lg→dhs₀ : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → DHS⟨ Γ ⁏ ∅ ⊢ A ⟩
lg→dhs₀ = h→dhs₀ ∘ lg→h

lg→dhs : ∀ {x A Γ Δ Λ} → LG⟨ Γ ⧺ (□⋆ Δ) ⁏ Λ ⊢ A ◎ x ⟩ → DHS⟨ Γ ⁏ Δ ⊢ A ⟩
lg→dhs = h→dhs ∘ lg→h

lg→dh₀ : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → DH⟨ Γ ⁏ ∅ ⊢ A ⟩
lg→dh₀ = h→dh₀ ∘ lg→h

lg→dh : ∀ {x A Γ Δ Λ} → LG⟨ Γ ⧺ (□⋆ Δ) ⁏ Λ ⊢ A ◎ x ⟩ → DH⟨ Γ ⁏ Δ ⊢ A ⟩
lg→dh = h→dh ∘ lg→h

lg→dg₀ : ∀ {x A Γ Λ} → LG⟨ Γ ⁏ Λ ⊢ A ◎ x ⟩ → DG⟨ Γ ⁏ ∅ ⊢ A ⟩
lg→dg₀ = h→dg₀ ∘ lg→h

lg→dg : ∀ {x A Γ Δ Λ} → LG⟨ Γ ⧺ (□⋆ Δ) ⁏ Λ ⊢ A ◎ x ⟩ → DG⟨ Γ ⁏ Δ ⊢ A ⟩
lg→dg = h→dg ∘ lg→h


module _ where

postulate D : Set

module A where

  infixr 5 _∷_

  postulate
    _∷_ : Set₁ → D → D

module B where

  infix 5 _∷_

  postulate
    _∷_ : Set₁ → Set₁ → D

open A
open B

foo : D
foo = Set ∷ Set

-- Expected error:
--
-- <preciseErrorLocation>
-- Ambiguous name _∷_. It could refer to any one of
--   A._∷_ bound at ...
--   B._∷_ bound at ...


module Structure.Function.Multi where

open import Data
open import Data.Boolean
open import Data.Tuple.Raise
import      Data.Tuple.Raiseᵣ.Functions as Raise
open import Data.Tuple.RaiseTypeᵣ
import      Data.Tuple.RaiseTypeᵣ.Functions as RaiseType
open import Function.DomainRaise as DomainRaise using (_→̂_)
import      Function.Equals.Multi as Multi
open import Function.Multi
import      Function.Multi.Functions as Multi
open import Functional
open import Lang.Instance
open import Logic
open import Logic.Propositional
open import Logic.Predicate
import      Lvl
import      Lvl.MultiFunctions as Lvl
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Structure.Setoid.Uniqueness
open import Structure.Setoid
open import Syntax.Number
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ ℓₗ : Lvl.Level
private variable n : ℕ

module Names where
  module _ {X : Type{ℓ₁}} {Y : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(Y) ⦄ where
    -- Definition of the relation between a function and an operation that says:
    -- The function preserves the operation.
    -- Often used when defining homomorphisms.
    -- Examples:
    --   Preserving(1) (f)(g₁)(g₂)
    --   = (∀{x} → (f ∘₁ g₁)(x) ≡ (g₂ on₁ f)(x))
    --   = (∀{x} → (f(g₁(x)) ≡ g₂(f(x)))
    --   Preserving(2) (f)(g₁)(g₂)
    --   = (∀{x y} → (f ∘₂ g₁)(x)(y) ≡ (g₂ on₂ f)(x)(y))
    --   = (∀{x y} → (f(g₁ x y) ≡ g₂ (f(x)) (f(y)))
    --   Preserving(3) (f)(g₁)(g₂)
    --   = (∀{x y z} → (f ∘₃ g₁)(x)(y)(z) ≡ (g₂ on₃ f)(x)(y)(z))
    --   = (∀{x y z} → (f(g₁ x y z) ≡ g₂ (f(x)) (f(y)) (f(z))))
    -- Alternative implementation:
    --   Preserving(n) (f)(g₁)(g₂) = Multi.Names.⊜₊(n) ([→̂]-to-[⇉] n (f DomainRaise.∘ g₁)) ([→̂]-to-[⇉] n (g₂ DomainRaise.on f))
    Preserving : (n : ℕ) → (f : X → Y) → (X →̂ X)(n) → (Y →̂ Y)(n) → Stmt{if positive?(n) then (ℓ₁ Lvl.⊔ ℓₑ₂) else ℓₑ₂}
    Preserving(𝟎)       (f)(g₁)(g₂) = (f(g₁) ≡ g₂)
    Preserving(𝐒(𝟎))    (f)(g₁)(g₂) = (∀{x} → f(g₁(x)) ≡ g₂(f(x)))
    Preserving(𝐒(𝐒(n))) (f)(g₁)(g₂) = (∀{x} → Preserving(𝐒(n)) (f) (g₁(x)) (g₂(f(x))))

    Preserving₀ = Preserving(0)
    Preserving₁ = Preserving(1)
    Preserving₂ = Preserving(2)
    Preserving₃ = Preserving(3)
    Preserving₄ = Preserving(4)
    Preserving₅ = Preserving(5)
    Preserving₆ = Preserving(6)
    Preserving₇ = Preserving(7)
    Preserving₈ = Preserving(8)
    Preserving₉ = Preserving(9)

  module _ where
    RelationReplacement : ∀{B : Type{ℓ}} → (B → B → Type{ℓₑ}) → (n : ℕ) → ∀{ℓ𝓈 ℓ𝓈ₑ}{As : Types{n}(ℓ𝓈)} → (RaiseType.mapWithLvls(\A ℓₑ → Equiv{ℓₑ}(A)) As ℓ𝓈ₑ) ⇉ᵢₙₛₜ ((As ⇉ B) → (As ⇉ B) → Stmt{Lvl.⨆(ℓ𝓈) Lvl.⊔ ℓₑ Lvl.⊔ Lvl.⨆(ℓ𝓈ₑ)})
    RelationReplacement(_▫_) 0         f g = f ▫ g
    RelationReplacement(_▫_) 1         f g = ∀{x y} → (x ≡ y) → (f(x) ▫ g(y))
    RelationReplacement(_▫_) (𝐒(𝐒(n)))     = Multi.expl-to-inst(𝐒(n)) (Multi.compose(𝐒(n)) (\R f g → ∀{x y} → (x ≡ y) → R (f(x)) (g(y))) (Multi.inst-to-expl(𝐒(n)) (RelationReplacement(_▫_) (𝐒(n)))))

    FunctionReplacement : (n : ℕ) → ∀{ℓ𝓈 ℓ𝓈ₑ}{As : Types{n}(ℓ𝓈)}{B : Type{ℓ}} → (RaiseType.mapWithLvls(\A ℓₑ → Equiv{ℓₑ}(A)) As ℓ𝓈ₑ) ⇉ᵢₙₛₜ (⦃ equiv-B : Equiv{ℓₑ}(B) ⦄ → (As ⇉ B) → (As ⇉ B) → Stmt{Lvl.⨆(ℓ𝓈) Lvl.⊔ ℓₑ Lvl.⊔ Lvl.⨆(ℓ𝓈ₑ)})
    FunctionReplacement 0         f g = f ≡ g
    FunctionReplacement 1         f g = ∀{x y} → (x ≡ y) → (f(x) ≡ g(y))
    FunctionReplacement (𝐒(𝐒(n)))     = Multi.expl-to-inst(𝐒(n)) (Multi.compose(𝐒(n)) (\R ⦃ equiv-B ⦄ f g → ∀{x y} → (x ≡ y) → R ⦃ equiv-B ⦄ (f(x)) (g(y))) (Multi.inst-to-expl(𝐒(n)) (FunctionReplacement (𝐒(n)))))

    -- Generalization of `Structure.Function.Function` for nested function types (or normally known as: functions of any number of arguments (n-ary functions)).
    -- Examples:
    --   Function(0) f g = f ≡ g
    --   Function(1) f g = ∀{x y} → (x ≡ y) → (f(x) ≡ g(y))
    --   Function(2) f g = ∀{x y} → (x ≡ y) → ∀{x₁ y₁} → (x₁ ≡ y₁) → (f(x)(x₁) ≡ g(y)(y₁))
    --   Function(3) f g = ∀{x y} → (x ≡ y) → ∀{x₁ y₁} → (x₁ ≡ y₁) → ∀{x₂ y₂} → (x₂ ≡ y₂) → (f(x)(x₁)(x₂) ≡ g(y)(y₁)(y₂))
    Function : (n : ℕ) → ∀{ℓ𝓈 ℓ𝓈ₑ}{As : Types{n}(ℓ𝓈)}{B : Type{ℓ}} → (RaiseType.mapWithLvls(\A ℓₑ → Equiv{ℓₑ}(A)) As ℓ𝓈ₑ) ⇉ᵢₙₛₜ (⦃ equiv-B : Equiv{ℓₑ}(B) ⦄ → (As ⇉ B) → Stmt)
    Function(n) = Multi.expl-to-inst(n) (Multi.compose(n) (\R ⦃ equiv-B ⦄ → R ⦃ equiv-B ⦄ $₂_) (Multi.inst-to-expl(n) (FunctionReplacement(n))))

  module _ where
    CompatibleReplacement : (n : ℕ) → ∀{ℓ𝓈 ℓ𝓈ₗ}{As : Types{n}(ℓ𝓈)}{B : Type{ℓ}} → (RaiseType.mapWithLvls(\A ℓₗ → A → A → Type{ℓₗ}) As ℓ𝓈ₗ) ⇉ ((B → B → Stmt{ℓₗ}) → (As ⇉ B) → (As ⇉ B) → Stmt{ℓₗ Lvl.⊔ Lvl.⨆(ℓ𝓈) Lvl.⊔ Lvl.⨆(ℓ𝓈ₗ)})
    CompatibleReplacement 0               (_▫_) f g = f ▫ g
    CompatibleReplacement 1         (_▫₀_)(_▫_) f g = ∀{x y} → (x ▫₀ y) → (f(x) ▫ g(y))
    CompatibleReplacement (𝐒(𝐒(n))) (_▫₀_)          = Multi.compose(𝐒(n)) (R ↦ _▫_ ↦ f ↦ g ↦ ∀{x y} → (x ▫₀ y) → R(_▫_) (f(x)) (g(y))) (CompatibleReplacement(𝐒(n)))

    Compatible : (n : ℕ) → ∀{ℓ𝓈 ℓ𝓈ₗ}{As : Types{n}(ℓ𝓈)}{B : Type{ℓ}} → (RaiseType.mapWithLvls(\A ℓₗ → A → A → Type{ℓₗ}) As ℓ𝓈ₗ) ⇉ ((B → B → Stmt{ℓₗ}) → (As ⇉ B) → Stmt)
    Compatible(n) = Multi.compose(n) ((_$₂_) ∘_) (CompatibleReplacement(n))

  module _ {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ where
    -- Definition of the relation between a function and an operation that says:
    -- The function preserves the operation.
    -- This is a special case of the (_preserves_)-relation that has the same operator inside and outside.
    -- Special cases:
    --   Additive function (Operator is a conventional _+_)
    --   Multiplicative function (Operator is a conventional _*_)
    -- ∀{x y} → (f(x ▫ y) ≡ f(x) ▫ f(y))
    _preserves_ : (T → T) → (T → T → T) → Stmt
    f preserves (_▫_) = Preserving(2) f (_▫_)(_▫_) --

module _ {X : Type{ℓ₁}} {Y : Type{ℓ₂}} ⦃ _ : Equiv{ℓₑ₂}(Y) ⦄ where
  module _ (n : ℕ) (f : X → Y) (g₁ : (X →̂ X)(n)) (g₂ : (Y →̂ Y)(n)) where
    record Preserving : Stmt{if positive?(n) then (ℓ₁ Lvl.⊔ ℓₑ₂) else ℓₑ₂} where -- TODO: Is it possible to prove for levels that an if-expression is less if both are less?
      constructor intro
      field proof : Names.Preserving(n) (f)(g₁)(g₂)
    preserving = inst-fn Preserving.proof

  Preserving₀ = Preserving(0)
  Preserving₁ = Preserving(1)
  Preserving₂ = Preserving(2)
  Preserving₃ = Preserving(3)
  Preserving₄ = Preserving(4)
  Preserving₅ = Preserving(5)
  Preserving₆ = Preserving(6)
  Preserving₇ = Preserving(7)
  Preserving₈ = Preserving(8)
  Preserving₉ = Preserving(9)

  preserving₀ = preserving(0)
  preserving₁ = preserving(1)
  preserving₂ = preserving(2)
  preserving₃ = preserving(3)
  preserving₄ = preserving(4)
  preserving₅ = preserving(5)
  preserving₆ = preserving(6)
  preserving₇ = preserving(7)
  preserving₈ = preserving(8)
  preserving₉ = preserving(9)

module _ {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ (n : ℕ) (f : T → T) (_▫_ : T → T → T) where
  _preserves_ = Preserving(2) (f)(_▫_)(_▫_)

{-
module _ {T : Type{ℓ}} where
  module _ (n : ℕ) {ℓₗ} (_▫_ : T → T → Stmt{ℓₗ}) (f : RaiseType.repeat n T ⇉ T) where
    record Compatible : Stmt{ℓₗ Lvl.⊔ (if positive?(n) then ℓ else Lvl.𝟎)} where
      constructor intro
      field proof : Names.Compatible(n) (_▫_)(f)
    compatible = inst-fn Compatible.proof

  Compatible₀ = Compatible(0)
  Compatible₁ = Compatible(1)
  Compatible₂ = Compatible(2)
  Compatible₃ = Compatible(3)
  Compatible₄ = Compatible(4)
  Compatible₅ = Compatible(5)
  Compatible₆ = Compatible(6)
  Compatible₇ = Compatible(7)
  Compatible₈ = Compatible(8)
  Compatible₉ = Compatible(9)

  compatible₀ = compatible(0)
  compatible₁ = compatible(1)
  compatible₂ = compatible(2)
  compatible₃ = compatible(3)
  compatible₄ = compatible(4)
  compatible₅ = compatible(5)
  compatible₆ = compatible(6)
  compatible₇ = compatible(7)
  compatible₈ = compatible(8)
  compatible₉ = compatible(9)
-}


------------------------------------------------------------------------
-- Specialised eliminators
------------------------------------------------------------------------

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

module Partiality-monad.Inductive.Eliminators where

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

open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import Nat equality-with-J as Nat

open import Partiality-monad.Inductive

------------------------------------------------------------------------
-- Non-dependent eliminators

Inc-nd : ∀ {a p q}
         (A : Type a) (P : Type p)
         (Q : P → P → Type q) → Type (p ⊔ q)
Inc-nd A P Q = ∃ λ (p : ℕ → P) → ∀ n → Q (p n) (p (suc n))

record Arguments-nd {a} p q (A : Type a) : Type (a ⊔ lsuc (p ⊔ q)) where
  field
    P  : Type p
    Q  : P → P → Type q
    pe : P
    po : (x : A) → P
    pl : (s : Increasing-sequence A) (pq : Inc-nd A P Q) → P
    pa : (p₁ p₂ : P) (q₁ : Q p₁ p₂) (q₂ : Q p₂ p₁) → p₁ ≡ p₂
    ps : Is-set P
    qr : (x : A ⊥) (p : P) → Q p p
    qt : {x y z : A ⊥} → x ⊑ y → y ⊑ z →
         (px py pz : P) → Q px py → Q py pz → Q px pz
    qe : (x : A ⊥) (p : P) → Q pe p
    qu : (s : Increasing-sequence A) (pq : Inc-nd A P Q) (n : ℕ) →
         Q (proj₁ pq n) (pl s pq)
    ql : ∀ s (ub : A ⊥) (is-ub : Is-upper-bound s ub) pq (pu : P)
         (qu : ∀ n → Q (proj₁ pq n) pu) →
         Q (pl s pq) pu
    qp : (p₁ p₂ : P) → Is-proposition (Q p₁ p₂)

module _ {a p q} {A : Type a} (args : Arguments-nd p q A) where

  open Arguments-nd args

  private

    args′ : Arguments p q A
    args′ = record
      { P  = λ _ → P
      ; Q  = λ p-x p-y _ → Q p-x p-y
      ; pe = pe
      ; po = po
      ; pl = pl
      ; pa = λ x⊑y x⊒y p₁ p₂ q₁ q₂ →
               subst (const P) (antisymmetry x⊑y x⊒y) p₁  ≡⟨ subst-const (antisymmetry x⊑y x⊒y) ⟩
               p₁                                         ≡⟨ pa p₁ p₂ q₁ q₂ ⟩∎
               p₂                                         ∎
      ; pp = ps
      ; qr = qr
      ; qt = qt
      ; qe = qe
      ; qu = qu
      ; ql = ql
      ; qp = λ p-x p-y _ → qp p-x p-y
      }

  ⊥-rec-nd : A ⊥ → P
  ⊥-rec-nd = ⊥-rec args′

  ⊑-rec-nd : ∀ {x y} → x ⊑ y → Q (⊥-rec-nd x) (⊥-rec-nd y)
  ⊑-rec-nd = ⊑-rec args′

  inc-rec-nd : Increasing-sequence A → Inc-nd A P Q
  inc-rec-nd = inc-rec args′

  ⊥-rec-nd-never : ⊥-rec-nd never ≡ pe
  ⊥-rec-nd-never = ⊥-rec-never _

  ⊥-rec-nd-now : ∀ x → ⊥-rec-nd (now x) ≡ po x
  ⊥-rec-nd-now = ⊥-rec-now _

  ⊥-rec-nd-⨆ : ∀ s → ⊥-rec-nd (⨆ s) ≡ pl s (inc-rec-nd s)
  ⊥-rec-nd-⨆ = ⊥-rec-⨆ _

------------------------------------------------------------------------
-- Eliminators which are trivial for _⊑_

record Arguments-⊥ {a} p (A : Type a) : Type (a ⊔ lsuc p) where
  field
    P  : A ⊥ → Type p
    pe : P never
    po : ∀ x → P (now x)
    pl : ∀ s (p : ∀ n → P (s [ n ])) → P (⨆ s)
    pp : ∀ x → Is-proposition (P x)

module _ {a p} {A : Type a} (args : Arguments-⊥ p A) where

  open Arguments-⊥ args

  ⊥-rec-⊥ : (x : A ⊥) → P x
  ⊥-rec-⊥ = ⊥-rec (record
    { Q  = λ _ _ _ → ⊤
    ; pe = pe
    ; po = po
    ; pl = λ s pq → pl s (proj₁ pq)
    ; pa = λ _ _ _ _ _ _ → pp _ _ _
    ; pp = mono₁ 1 (pp _)
    ; qp = λ _ _ _ _ _ → refl
    })

  inc-rec-⊥ : (s : ℕ → A ⊥) → ∀ n → P (s n)
  inc-rec-⊥ s = ⊥-rec-⊥ ∘ s

  ⊥-rec-⊥-never : ⊥-rec-⊥ never ≡ pe
  ⊥-rec-⊥-never = ⊥-rec-never _

  ⊥-rec-⊥-now : ∀ x → ⊥-rec-⊥ (now x) ≡ po x
  ⊥-rec-⊥-now = ⊥-rec-now _

  ⊥-rec-⊥-⨆ : ∀ s → ⊥-rec-⊥ (⨆ s) ≡ pl s (λ n → ⊥-rec-⊥ (s [ n ]))
  ⊥-rec-⊥-⨆ = ⊥-rec-⨆ _

------------------------------------------------------------------------
-- Eliminators which are trivial for _⊥

record Arguments-⊑ {a} q (A : Type a) : Type (a ⊔ lsuc q) where
  field
    Q  : {x y : A ⊥} → x ⊑ y → Type q
    qr : ∀ x → Q (⊑-refl x)
    qt : ∀ {x y z} (x⊑y : x ⊑ y) (y⊑z : y ⊑ z) →
         Q x⊑y → Q y⊑z → Q (⊑-trans x⊑y y⊑z)
    qe : ∀ x → Q (never⊑ x)
    qu : ∀ s (q : ∀ n → Q (increasing s n)) n →
         Q (upper-bound s n)
    ql : ∀ s ub is-ub (q : ∀ n → Q (increasing s n))
         (qu : ∀ n → Q (is-ub n)) →
         Q (least-upper-bound s ub is-ub)
    qp : ∀ {x y} (x⊑y : x ⊑ y) →
         Is-proposition (Q x⊑y)

module _ {a q} {A : Type a} (args : Arguments-⊑ q A) where

  open Arguments-⊑ args

  ⊑-rec-⊑ : ∀ {x y} (x⊑y : x ⊑ y) → Q x⊑y
  ⊑-rec-⊑ = ⊑-rec (record
    { P  = λ _ → ⊤
    ; Q  = λ _ _ → Q
    ; pa = λ _ _ _ _ _ _ → refl
    ; pp = mono (Nat.zero≤ 2) ⊤-contractible
    ; qr = λ x _ → qr x
    ; qt = λ x⊑y y⊑z _ _ _ → qt x⊑y y⊑z
    ; qe = λ x _ → qe x
    ; qu = λ s pq → qu s (proj₂ pq)
    ; ql = λ s ub is-ub pq _ → ql s ub is-ub (proj₂ pq)
    ; qp = λ _ _ → qp
    })

  inc-rec-⊑ : (s : Increasing-sequence A) → ∀ n → Q (increasing s n)
  inc-rec-⊑ (_ , inc) = ⊑-rec-⊑ ∘ inc


-- Andreas, 2021-05-07, issue #5358 reported by ecavallo
-- Do not expand clauses with tactics attached to the target type!

open import Agda.Builtin.Unit
open import Agda.Builtin.Bool
open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)

defaultTo : {A : Set} (x : A) → Term → TC ⊤
defaultTo x goal = do
  `x ← quoteTC x
  unify goal `x

record Class : Set where
  constructor con
  field
    x : Bool → Bool
    @(tactic defaultTo x) {y} : Bool → Bool
open Class

{- Correctly succeeds -}
testA : Class
testA = con (λ b → b)

{-
  WAS: Incorrectly fails with:
  Bool → Bool !=< Bool
  when checking that the inferred type of an application
    Bool → Bool
  matches the expected type
    Bool

What is happening here?

  - The coverage checker detects a missing clause
    testB .y : @(tactic defaultTo x) {Bool → Bool}.

  - It expands this to testB .y b : @(tactic defaultTo x) {Bool},
    eliminating the function type.

  - It then runs the tactic at the wrong type.

A fix is to not expand the clause if there is a tactic attached to the projections.
-}

testB : Class
testB .x = λ b → b

-- Should succeed