module sn-calculus-confluence.helper where

open import Data.List.All
open import Function
  using (_∘_)
open import Data.List.Any using (Any ; here ; there)
open import Data.Nat using (_+_)
open import utility
open import Esterel.Lang
open import Esterel.Lang.Properties
open import Esterel.Environment as Env
open import Esterel.Context
open import Data.Product
open import Data.Sum
open import Data.Bool
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import sn-calculus
open import context-properties
open import Esterel.Lang.Binding
open import Data.List.Any.Properties
  renaming ( ++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ )

open import Data.FiniteMap
import Data.OrderedListMap as OMap
open import Data.Nat as Nat using (ℕ)
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

set-dist' : ∀{key value inject surject} → ∀{inject-injective : ∀{k1 : key} → ∀{k2 : key} → (inject k1) ≡ (inject k2) → k1 ≡ k2}
            → ∀{surject-inject : ∀{k} → inject (surject k) ≡ k}
            → ∀{A : Map {key} inject surject inject-injective surject-inject value} → ∀{B : Map {key} inject surject inject-injective surject-inject value}
            → distinct' (keys {key} inject surject inject-injective surject-inject {value} A) (keys {key} inject surject inject-injective surject-inject {value}  B)
            → (union {key} inject surject inject-injective surject-inject {value} A B) ≡ (union  {key} inject surject inject-injective surject-inject {value} B A)
set-dist'{key}{value}{inject}{surject}{inject-injective}{surject-inject}{A}{B} d = OMap.U-comm key inject value {A} {B} d

set-dist : ∀{θ θ'} → distinct (Dom θ) (Dom θ') → (θ ← θ') ≡ (θ' ← θ)
set-dist {Θ sig₁ shr₁ var₁} {Θ sig₂ shr₂ var₂} (a , b , c)
    rewrite  set-dist'{inject = _}{Signal.wrap}{inject-injective = Signal.unwrap-injective}{Signal.bijective}{sig₁}{sig₂} a
           | set-dist'{inject = _}{SharedVar.wrap}{inject-injective = SharedVar.unwrap-injective}{SharedVar.bijective}{shr₁}{shr₂} b
           | set-dist'{inject = _}{SeqVar.wrap}{inject-injective = SeqVar.unwrap-injective}{SeqVar.bijective}{var₁}{var₂} c = refl

done≠rho : ∀{p E θ q A} → done p → (p ≐ E ⟦ (ρ⟨ θ , A ⟩· q) ⟧e) → ⊥
done≠rho (dhalted hnothin) ()
done≠rho (dhalted (hexit n)) ()
done≠rho (dpaused p/paused) p≐E⟦ρθq⟧ with paused-⟦⟧e p/paused p≐E⟦ρθq⟧
... | ()

plug≡ : ∀{r q E w} → r ≐ E ⟦ w ⟧e → q ≐ E ⟦ w ⟧e  → r ≡ q
plug≡ r≐E⟦w⟧ q≐E⟦w⟧ = trans (sym (unplug r≐E⟦w⟧)) (unplug q≐E⟦w⟧)

RE-split : ∀{p θ p' E E' q A}
           → p ≐ E ⟦ ρ⟨ θ , A ⟩· p' ⟧e
           → p ≐ E' ⟦ q ⟧e
           → E a~ E'
           → ∃ (λ d → ∃ (λ Eout → d ≐ E ⟦ p' ⟧e × d ≐ Eout ⟦ q ⟧e × E' ~ Eout × Eout a~ E ))
RE-split {.(ρ⟨ _ , _ ⟩· _)} dehole dehole ()
RE-split {.(_ ∥ _)} (depar₁ eq1) dehole ()
RE-split {.(_ >> _)} (deseq eq1) dehole ()
RE-split {.(trap _)} (detrap eq1) dehole ()
RE-split {.(_ ∥ _)} (depar₂ eq1) dehole ()
RE-split {.(suspend _ _)} (desuspend eq1) dehole ()
RE-split {(pin ∥ qin)}{θ}{p'}{((epar₁ _) ∷ E)}{(epar₂ _) ∷ E'} (depar₁ eq1) (depar₂ eq2) par2
   = (t ∥ qin) , (epar₂ t) ∷ E' , (depar₁ (plug refl) , depar₂ eq2 , parl (~ref E') , par) where t = (E ⟦ p' ⟧e)
RE-split {(pin ∥ qin)}{θ}{p'}{((epar₂ _) ∷ E)}{(epar₁ _) ∷ E'} (depar₂ eq1) (depar₁ eq2) par
   = (pin ∥ t) , ((epar₁ t) ∷ E' , (depar₂ (plug refl) , depar₁ eq2 , parr (~ref E') , par2)) where t = (E ⟦ p' ⟧e)
RE-split {(pin ∥ qin)} (depar₁ eq1) (depar₁ eq2) (parr neg) with RE-split eq1 eq2 neg
... | (d , Eout , (eqd , eqo , ~ , a~)) = d ∥ qin , (epar₁ qin) ∷ Eout , (depar₁ eqd , depar₁ eqo , parr ~ , parr a~)
RE-split {(pin ∥ qin)} (depar₂ eq1) (depar₂ eq2) (parl neg) with RE-split eq1 eq2 neg
... | (d , Eout , (eqd , eqo , ~ , a~)) = pin ∥ d , (epar₂ pin) ∷ Eout , (depar₂ eqd , depar₂ eqo , parl ~ , parl a~)
RE-split {(loopˢ _ q)} (deloopˢ eq1) (deloopˢ eq2) (loopˢ neg) with RE-split eq1 eq2 neg
... | (d , Eout , (eqd , eqo , ~ , a~)) = (loopˢ d q) , (eloopˢ q) ∷ Eout , (deloopˢ eqd , deloopˢ eqo , loopˢ ~ , loopˢ a~)
RE-split {(._ >> q)} (deseq eq1) (deseq eq2) (seq neg) with RE-split eq1 eq2 neg
... | (d , Eout , (eqd , eqo , ~ , a~)) = (d >> q) , (eseq q) ∷ Eout , (deseq eqd , deseq eqo , seq ~ , seq a~)
RE-split {(suspend ._ S)} (desuspend eq1) (desuspend eq2) (susp neg) with RE-split eq1 eq2 neg
... | (d , Eout , (eqd , eqo , ~ , a~)) = (suspend d S) , ((esuspend S) ∷ Eout) , (desuspend eqd , desuspend eqo , susp ~ , susp a~)
RE-split {.(trap _)} (detrap eq1) (detrap eq2) (trp neg) with RE-split eq1 eq2 neg
... | (d , Eout , (eqd , eqo , ~ , a~)) = (trap d) , (etrap ∷ Eout) , (detrap eqd , detrap eqo , trp ~ , trp a~)

ready-maint : ∀{θ e} → (S : Signal) → (S∈ : (Env.isSig∈ S θ)) → (stat : Signal.Status) → all-ready e θ
                     → all-ready e (Env.set-sig{S} θ S∈ stat)
ready-maint {θ} {.(plus [])} S S∈ stat (aplus []) = aplus []
ready-maint {θ} {.(plus (num _ ∷ _))} S S∈ stat (aplus (brnum ∷ x₁)) with ready-maint S S∈ stat (aplus x₁)
... | (aplus r) = aplus (brnum ∷ r)
ready-maint {θ} {.(plus (seq-ref _ ∷ _))} S S∈ stat (aplus (brseq x₁ ∷ x₂)) with ready-maint S S∈ stat (aplus x₂)
... | (aplus r) = aplus (brseq x₁ ∷ r)
ready-maint {θ} {.(plus (shr-ref _ ∷ _))} S S∈ stat (aplus (brshr s∈ x ∷ x₁)) with ready-maint S S∈ stat (aplus x₁)
... | (aplus r) = aplus (brshr s∈ x ∷ r)

ready-irr : ∀{θ e} → (S : Signal) → (S∈ : (Env.isSig∈ S θ)) → (stat : Signal.Status)
                   → (e' : all-ready e θ)
                   → (e'' : all-ready e (Env.set-sig{S} θ S∈ stat))
                   → δ e' ≡ δ e''

ready-irr {θ} {.(plus [])} S S∈ stat (aplus []) (aplus []) = refl
ready-irr {θ} {.(plus (num _ ∷ _))} S S∈ stat (aplus (brnum ∷ x₁)) (aplus (brnum ∷ x₂))
 rewrite ready-irr S S∈ stat (aplus x₁) (aplus x₂) = refl
ready-irr {θ@(Θ Ss ss xs)} {.(plus (seq-ref _ ∷ _))} S S∈ stat (aplus (brseq{_}{x} x₁ ∷ x₂)) (aplus (brseq x₃ ∷ x₄))
 rewrite ready-irr S S∈ stat (aplus x₂) (aplus x₄) | seq∈-eq'{x}{xs} x₁ x₃ = refl
ready-irr {θ@(Θ Ss ss xs)} {.(plus (shr-ref _ ∷ _))} S S∈ stat (aplus (brshr{_}{s} s∈ x ∷ x₁)) (aplus (brshr s∈₁ x₂ ∷ x₃))
 rewrite ready-irr S S∈ stat (aplus x₁) (aplus x₃) | shr∈-eq'{s}{ss} s∈ s∈₁ = refl

ready-maint/irr : ∀{θ e} → (S : Signal) → (S∈ : (Env.isSig∈ S θ)) → (stat : Signal.Status)
                         → (e' : all-ready e θ)
                         → Σ[ e'' ∈ all-ready e (Env.set-sig{S} θ S∈ stat) ] δ e' ≡ δ e''
ready-maint/irr {θ}{e} S S∈ stat e' with ready-maint{θ}{e} S S∈ stat e'
... | e'' = e'' , (ready-irr{θ}{e} S S∈ stat e' e'')

ready-maint/x : ∀{θ e} → (x : SeqVar) → (x∈ : (Env.isVar∈ x θ)) → (n : ℕ) → all-ready e θ
                       → all-ready e (Env.set-var{x} θ x∈ n)
ready-maint/x {θ} {.(plus [])} x x∈ n (aplus []) = aplus []
ready-maint/x {θ} {.(plus (num _ ∷ _))} x₁ x∈ n (aplus (brnum ∷ x₂)) with ready-maint/x x₁ x∈ n (aplus x₂)
... | (aplus r) = aplus (brnum ∷ r)
ready-maint/x {θ} {.(plus (seq-ref _ ∷ _))} x₁ x∈ n (aplus (brseq{x = x2} x₂ ∷ x₃)) with ready-maint/x x₁ x∈ n (aplus x₃)
... | (aplus r) = aplus ((brseq (seq-set-mono'{x2}{x₁}{θ}{n}{x∈} x₂)) ∷ r)
ready-maint/x {θ} {.(plus (shr-ref _ ∷ _))} x₁ x∈ n (aplus (brshr s∈ x ∷ x₂))  with ready-maint/x x₁ x∈ n (aplus x₂)
... | (aplus r) = aplus (brshr s∈ x ∷ r)

ready-maint-s : ∀{θ e} → (s : SharedVar) → (n : ℕ) → (s∈ : Env.isShr∈ s θ) → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready) → (e' : all-ready e θ)
                       → all-ready e (Env.set-shr{s = s} θ s∈ SharedVar.new n)
ready-maint-s {e = .(plus [])} s n s∈ ¬≡ (aplus []) = aplus []
ready-maint-s {e = .(plus (num _ ∷ _))} s n₁ s∈ ¬≡ (aplus (brnum ∷ x₁)) with ready-maint-s s n₁ s∈ ¬≡ (aplus x₁)
... | aplus rec  = aplus (brnum ∷ rec)
ready-maint-s {e = .(plus (seq-ref _ ∷ _))} s n s∈ ¬≡ (aplus (brseq x₁ ∷ x₂)) with ready-maint-s s n s∈ ¬≡ (aplus x₂)
... | aplus rec = aplus (brseq x₁ ∷ rec)
ready-maint-s{θ} {e = (plus (shr-ref s ∷ ._))} s₁ n s∈ ¬≡ (aplus (brshr s∈₁ x ∷ x₁)) with ready-maint-s s₁ n s∈ ¬≡ (aplus x₁) | s SharedVar.≟ s₁
... | aplus rec | yes refl with shr-stats-∈-irr{s}{θ} s∈ s∈₁
... | eq rewrite eq = ⊥-elim (¬≡ x)
ready-maint-s{θ = θ} {e = (plus (shr-ref s ∷ ._))} s₁ n s∈ ¬≡ (aplus (brshr s∈₁ x ∷ x₁)) | aplus rec | no ¬s≡s₁
 with shr-putputget{θ = θ}{v2l = SharedVar.new}{n} ¬s≡s₁ s∈₁ s∈ (shr-set-mono'{s}{s₁}{θ}{n = n}{s∈} s∈₁) x refl
... | (eq1 , eq2) = aplus (brshr ((shr-set-mono'{s}{s₁}{θ}{n = n}{s∈} s∈₁)) eq1 ∷ rec)

ready-irr-on-irr-s-helper : ∀{θ e} → (s : SharedVar) → (n : ℕ) → (s∈ : Env.isShr∈ s θ) → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready) → (e' : all-ready e θ)
                            → (e'' : all-ready e (Env.set-shr{s = s} θ s∈ SharedVar.new n)) →  δ e' ≡ δ e''
ready-irr-on-irr-s-helper {θ} {.(plus [])} s n s∈ ¬≡ (aplus []) (aplus []) = refl
ready-irr-on-irr-s-helper {θ} {.(plus (num _ ∷ _))} s n s∈ ¬≡ (aplus (brnum ∷ x₁)) (aplus (brnum ∷ x'))
  rewrite ready-irr-on-irr-s-helper s n s∈ ¬≡ (aplus x₁) (aplus x') = refl
ready-irr-on-irr-s-helper {θ@(Θ Ss ss xs)} {(plus (seq-ref x ∷ _))} s n s∈ ¬≡ (aplus (brseq x₁ ∷ x₂)) (aplus (brseq x₃ ∷ x'))
  rewrite ready-irr-on-irr-s-helper s n s∈ ¬≡ (aplus x₂) (aplus x') | seq∈-eq'{x}{xs} x₁ x₃ = refl
ready-irr-on-irr-s-helper {θ@(Θ Ss ss xs)} {(plus (shr-ref sₑ ∷ _))} s n s∈ ¬≡ (aplus (brshr s∈₁ x ∷ x₁)) (aplus (brshr s∈₂ x₂ ∷ x'))
  with sₑ SharedVar.≟ s
... | yes sₑ≡s rewrite sₑ≡s | shr∈-eq'{s}{ss} s∈ s∈₁ = ⊥-elim (¬≡ x)
... | no ¬sₑ≡s with shr-putputget{θ = θ}{v2l = SharedVar.new}{n} ¬sₑ≡s s∈₁ s∈ s∈₂ x refl
... | (eq1 , eq2) rewrite ready-irr-on-irr-s-helper s n s∈ ¬≡ (aplus x₁) (aplus x') | eq2 = refl

ready-irr-on-irr-s : ∀{θ e} → (s : SharedVar) → (n : ℕ) → (s∈ : Env.isShr∈ s θ) → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready) → (e' : all-ready e θ)
                     → Σ[ e'' ∈ all-ready e (Env.set-shr{s = s} θ s∈ SharedVar.new n) ] δ e' ≡ δ e''
ready-irr-on-irr-s s n s∈ ¬≡ e' = e'' , (ready-irr-on-irr-s-helper s n s∈ ¬≡ e' e'')
  where e'' = ready-maint-s s n s∈ ¬≡ e'

-- copied and pasted form above
-- TODO: maybe someday abstract over SharedVar.new/SharedVar.ready to sharedvar-status
ready-maint-s/ready : ∀{θ e} → (s : SharedVar) → (n : ℕ) → (s∈ : Env.isShr∈ s θ) → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready) → (e' : all-ready e θ)
                       → all-ready e (Env.set-shr{s = s} θ s∈ SharedVar.ready n)
ready-maint-s/ready {e = .(plus [])} s n s∈ ¬≡ (aplus []) = aplus []
ready-maint-s/ready {e = .(plus (num _ ∷ _))} s n₁ s∈ ¬≡ (aplus (brnum ∷ x₁)) with ready-maint-s/ready s n₁ s∈ ¬≡ (aplus x₁)
... | aplus rec  = aplus (brnum ∷ rec)
ready-maint-s/ready {e = .(plus (seq-ref _ ∷ _))} s n s∈ ¬≡ (aplus (brseq x₁ ∷ x₂)) with ready-maint-s/ready s n s∈ ¬≡ (aplus x₂)
... | aplus rec = aplus (brseq x₁ ∷ rec)
ready-maint-s/ready{θ} {e = (plus (shr-ref s ∷ ._))} s₁ n s∈ ¬≡ (aplus (brshr s∈₁ x ∷ x₁)) with ready-maint-s/ready s₁ n s∈ ¬≡ (aplus x₁) | s SharedVar.≟ s₁
... | aplus rec | yes refl with shr-stats-∈-irr{s}{θ} s∈ s∈₁
... | eq rewrite eq = ⊥-elim (¬≡ x)
ready-maint-s/ready{θ = θ} {e = (plus (shr-ref s ∷ ._))} s₁ n s∈ ¬≡ (aplus (brshr s∈₁ x ∷ x₁)) | aplus rec | no ¬s≡s₁
 with shr-putputget{θ = θ}{v2l = SharedVar.ready}{n} ¬s≡s₁ s∈₁ s∈ (shr-set-mono'{s}{s₁}{θ}{n = n}{s∈} s∈₁) x refl
... | (eq1 , eq2) = aplus (brshr ((shr-set-mono'{s}{s₁}{θ}{n = n}{s∈} s∈₁)) eq1 ∷ rec)

ready-irr-on-irr-s-helper/ready : ∀{θ e} → (s : SharedVar) → (n : ℕ) → (s∈ : Env.isShr∈ s θ) → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready) → (e' : all-ready e θ)
                            → (e'' : all-ready e (Env.set-shr{s = s} θ s∈ SharedVar.ready n)) →  δ e' ≡ δ e''
ready-irr-on-irr-s-helper/ready {θ} {.(plus [])} s n s∈ ¬≡ (aplus []) (aplus []) = refl
ready-irr-on-irr-s-helper/ready {θ} {.(plus (num _ ∷ _))} s n s∈ ¬≡ (aplus (brnum ∷ x₁)) (aplus (brnum ∷ x'))
  rewrite ready-irr-on-irr-s-helper/ready s n s∈ ¬≡ (aplus x₁) (aplus x') = refl
ready-irr-on-irr-s-helper/ready {θ@(Θ Ss ss xs)} {(plus (seq-ref x ∷ _))} s n s∈ ¬≡ (aplus (brseq x₁ ∷ x₂)) (aplus (brseq x₃ ∷ x'))
  rewrite ready-irr-on-irr-s-helper/ready s n s∈ ¬≡ (aplus x₂) (aplus x') | seq∈-eq'{x}{xs} x₁ x₃ = refl
ready-irr-on-irr-s-helper/ready {θ@(Θ Ss ss xs)} {(plus (shr-ref sₑ ∷ _))} s n s∈ ¬≡ (aplus (brshr s∈₁ x ∷ x₁)) (aplus (brshr s∈₂ x₂ ∷ x'))
  with sₑ SharedVar.≟ s
... | yes sₑ≡s rewrite sₑ≡s | shr∈-eq'{s}{ss} s∈ s∈₁ = ⊥-elim (¬≡ x)
... | no ¬sₑ≡s with shr-putputget{θ = θ}{v2l = SharedVar.ready}{n} ¬sₑ≡s s∈₁ s∈ s∈₂ x refl
... | (eq1 , eq2) rewrite ready-irr-on-irr-s-helper/ready s n s∈ ¬≡ (aplus x₁) (aplus x') | eq2 = refl

ready-irr-on-irr-s/ready : ∀{θ e} → (s : SharedVar) → (n : ℕ) → (s∈ : Env.isShr∈ s θ) → ¬ (Env.shr-stats {s} θ s∈ ≡ SharedVar.ready) → (e' : all-ready e θ)
                     → Σ[ e'' ∈ all-ready e (Env.set-shr{s = s} θ s∈ SharedVar.ready n) ] δ e' ≡ δ e''
ready-irr-on-irr-s/ready s n s∈ ¬≡ e' = e'' , (ready-irr-on-irr-s-helper/ready s n s∈ ¬≡ e' e'')
  where e'' = ready-maint-s/ready s n s∈ ¬≡ e'

ready-irr-on-irr-x-help : ∀{θ e} x n → (x∈ : Env.isVar∈ x θ) → (e' : all-ready e θ) → (SeqVar.unwrap x) ∉ (Xs (FVₑ e))
                          → (e'' : all-ready e (Env.set-var{x = x} θ x∈ n))
                          →  δ e' ≡ δ e''
ready-irr-on-irr-x-help x n x∈ (aplus []) x∉FV (aplus []) = refl
ready-irr-on-irr-x-help x₁ n x∈ (aplus (brnum ∷ a)) x∉FV (aplus (brnum ∷ b)) rewrite ready-irr-on-irr-x-help x₁ n x∈ (aplus a) x∉FV (aplus b) = refl
ready-irr-on-irr-x-help{θ}{e} x₁ n x∈ (aplus (brseq{x = x} x₂ ∷ a)) x∉FV (aplus (brseq x₃ ∷ b))
    with x SeqVar.≟ x₁
... | yes refl = ⊥-elim (x∉FV (here refl))
... | no  ¬x≡x₁ rewrite seq-putputget{θ = θ} ¬x≡x₁ x₂ x∈ x₃ refl
                      | ready-irr-on-irr-x-help x₁ n x∈ (aplus a) (λ x → x∉FV (there x)) (aplus b) = refl
ready-irr-on-irr-x-help{θ} x₁ n x∈ (aplus (brshr{s = s} s∈ x ∷ a)) x∉FV (aplus (brshr s∈₁ x₂ ∷ b))
  rewrite ready-irr-on-irr-x-help x₁ n x∈ (aplus a) x∉FV (aplus b)
        | shr∈-eq'{s = s}{θ = (shr θ)} s∈ s∈₁
  = refl

ready-maint-x : ∀{θ e} x n → (x∈ : Env.isVar∈ x θ) → (e' : all-ready e θ) → (SeqVar.unwrap x) ∉ (Xs (FVₑ e))
                → all-ready e (Env.set-var{x = x} θ x∈ n)
ready-maint-x x n x∈ (aplus []) x∉FV = aplus []
ready-maint-x x₁ n₁ x∈ (aplus (brnum ∷ a)) x∉FV with ready-maint-x x₁ n₁ x∈ (aplus a) x∉FV
... | (aplus r) = aplus (brnum ∷ r)
ready-maint-x{θ} x₁ n x∈ (aplus (brseq{x = x} x₂ ∷ a)) x∉FV with ready-maint-x x₁ n x∈ (aplus a) (λ x₃ → x∉FV (there x₃))
... | (aplus r) = aplus ((brseq ((seq-set-mono'{x}{x₁}{θ}{n}{x∈} x₂))) ∷ r)
ready-maint-x x₁ n x∈ (aplus (brshr s∈ x ∷ a)) x∉FV  with ready-maint-x x₁ n x∈ (aplus a) x∉FV
... | (aplus r) = aplus ((brshr s∈ x) ∷ r)

ready-irr-on-irr-x : ∀{θ e} x n → (x∈ : Env.isVar∈ x θ) → (e' : all-ready e θ) → (SeqVar.unwrap x) ∉ (Xs (FVₑ e))
                     → Σ[ e'' ∈ all-ready e (Env.set-var{x = x} θ x∈ n) ] δ e' ≡ δ e''
ready-irr-on-irr-x x n x∈ e' x∉FV = _ , ready-irr-on-irr-x-help x n x∈ e' x∉FV (ready-maint-x x n x∈ e' x∉FV)

ready-maint-θˡ : ∀{θ e} θ' → (e' : all-ready e θ) → (distinct (Dom θ') (FVₑ e)) → (all-ready e (θ ← θ'))
ready-maint-θˡ θ' (aplus []) Domθ'≠FVe = aplus []
ready-maint-θˡ θ' (aplus (brnum ∷ x₁)) Domθ'≠FVe with ready-maint-θˡ θ' (aplus x₁) Domθ'≠FVe
... | (aplus f) = (aplus (brnum ∷ f))
ready-maint-θˡ{θ} θ' (aplus (brseq{x = x} x₁ ∷ x₂)) Domθ'≠FVe  with ready-maint-θˡ θ' (aplus x₂) ((proj₁ Domθ'≠FVe) , (proj₁ (proj₂ Domθ'≠FVe)) , dist':: (proj₂ (proj₂ Domθ'≠FVe)))
... | (aplus f) = aplus (brseq (Env.seq-←-monoˡ x θ θ' x₁) ∷ f)
ready-maint-θˡ{θ} θ' (aplus (brshr{s = s} s∈ s≡ ∷ x₁)) Domθ'≠FVe  with ready-maint-θˡ θ' (aplus x₁) (((proj₁ Domθ'≠FVe) ,  dist':: (proj₁ (proj₂ Domθ'≠FVe)) , (proj₂ (proj₂ Domθ'≠FVe))))
    | shr-←-irr-get{θ}{θ'}{s} s∈ (λ x → (proj₁ (proj₂ Domθ'≠FVe)) _ x (here refl))
... | (aplus f) | (s∈2 , eq) rewrite eq = aplus ((brshr s∈2 s≡) ∷ f)
ready-irr-on-irr-θˡ-help : ∀{θ e} θ' → (e' : all-ready e θ) → (distinct (Dom θ') (FVₑ e))
                     → (e'' : (all-ready e (θ ← θ'))) → δ e' ≡ δ e''
ready-irr-on-irr-θˡ-help θ' (aplus []) Domθ'≠FVe (aplus []) = refl
ready-irr-on-irr-θˡ-help θ' (aplus (brnum ∷ x₁)) Domθ'≠FVe (aplus (brnum ∷ x₂))
   rewrite ready-irr-on-irr-θˡ-help θ' (aplus x₁) Domθ'≠FVe (aplus x₂)
   = refl
ready-irr-on-irr-θˡ-help{θ} θ' (aplus (brseq{x = x} x₁ ∷ x₂)) Domθ'≠FVe (aplus (brseq x₃ ∷ x₄))
   rewrite ready-irr-on-irr-θˡ-help θ' (aplus x₂) ((proj₁ Domθ'≠FVe) , (proj₁ (proj₂ Domθ'≠FVe)) , dist':: (proj₂ (proj₂ Domθ'≠FVe))) (aplus x₄)
         | seq-←-irr-get'{θ}{θ'}{x} x₁ (λ x → (proj₂ (proj₂ Domθ'≠FVe)) _ x (here refl)) x₃
   = refl
ready-irr-on-irr-θˡ-help{θ} θ' (aplus (brshr{s = s} s∈ x ∷ x₁)) Domθ'≠FVe (aplus (brshr s∈₁ x₂ ∷ x₃))
    rewrite ready-irr-on-irr-θˡ-help θ' (aplus x₁) ((proj₁ Domθ'≠FVe) , dist':: (proj₁ (proj₂ Domθ'≠FVe)) , (proj₂ (proj₂ Domθ'≠FVe))) (aplus x₃)
          | shr-←-irr-get/vals'{θ}{θ'}{s} s∈ (λ x → (proj₁ (proj₂ Domθ'≠FVe)) _ x (here refl)) s∈₁
    = refl

ready-irr-on-irr-θˡ : ∀{θ e} θ' → (e' : all-ready e θ) → (distinct (Dom θ') (FVₑ e))
                     → Σ[ e'' ∈ (all-ready e (θ ← θ')) ] δ e' ≡ δ e''
ready-irr-on-irr-θˡ θ' e' Domθ'≠FVe = _ , ready-irr-on-irr-θˡ-help θ' e' Domθ'≠FVe (ready-maint-θˡ θ' e' Domθ'≠FVe)

ready-maint-θʳ : ∀ {θ' e} θ → (e' : all-ready e θ') → all-ready e (θ ← θ')
ready-maint-θʳ θ (aplus []) = aplus []
ready-maint-θʳ θ (aplus (brnum ∷ bound-readys))
  with ready-maint-θʳ θ (aplus bound-readys)
... | aplus bound-readys' = aplus (brnum ∷ bound-readys')
ready-maint-θʳ {θ'} θ (aplus (brseq {x = x} x∈Domθ' ∷ bound-readys))
  with ready-maint-θʳ θ (aplus bound-readys)
... | aplus bound-readys' = aplus (brseq (seq-←-monoʳ x θ' θ x∈Domθ') ∷ bound-readys')
ready-maint-θʳ {θ'} θ (aplus (brshr {s = s} s∈Domθ' θ's≡ready ∷ bound-readys))
  with ready-maint-θʳ θ (aplus bound-readys)
... | aplus bound-readys' =
  aplus (brshr (shr-←-monoʳ s θ' θ s∈Domθ')
               (trans
                 (shr-stats-←-right-irr' s θ θ' s∈Domθ'
                   (shr-←-monoʳ s θ' θ s∈Domθ'))
                 θ's≡ready) ∷
         bound-readys')

ready-irr-on-irr-θʳ-help : ∀ {θ' e} θ →
  (e' : all-ready e θ') →
  (e'' : all-ready e (θ ← θ')) →
  δ e' ≡ δ e''
ready-irr-on-irr-θʳ-help {θ'} θ (aplus []) (aplus []) = refl
ready-irr-on-irr-θʳ-help {θ'} θ (aplus (brnum ∷ bound-readys')) (aplus (brnum ∷ bound-readys''))
  with ready-irr-on-irr-θʳ-help θ (aplus bound-readys') (aplus bound-readys'')
... | δe'≡δe'' rewrite δe'≡δe'' = refl
ready-irr-on-irr-θʳ-help {θ'} θ
  (aplus (brseq {x = x}  x∈Domθ' ∷ bound-readys'))
  (aplus (brseq {x = .x} x∈Domθ←θ' ∷ bound-readys''))
  with ready-irr-on-irr-θʳ-help θ (aplus bound-readys') (aplus bound-readys'')
... | δe'≡δe'' rewrite δe'≡δe'' | var-vals-←-right-irr' x θ θ' x∈Domθ' x∈Domθ←θ' = refl
ready-irr-on-irr-θʳ-help {θ'} θ
  (aplus (brshr {s = s}  s∈Domθ'   θ's≡ready     ∷ bound-readys'))
  (aplus (brshr {s = .s} s∈Domθ←θ' ⟨θ←θ'⟩s≡ready ∷ bound-readys''))
  with ready-irr-on-irr-θʳ-help θ (aplus bound-readys') (aplus bound-readys'')
... | δe'≡δe'' rewrite δe'≡δe'' | shr-vals-←-right-irr' s θ θ' s∈Domθ' s∈Domθ←θ' = refl

ready-irr-on-irr-θʳ : ∀ {θ' e} θ →
  (e' : all-ready e θ') →
  Σ[ e'' ∈ all-ready e (θ ← θ') ] δ e' ≡ δ e''
ready-irr-on-irr-θʳ θ e' = _ , ready-irr-on-irr-θʳ-help θ e' (ready-maint-θʳ θ e')

CBE⟦p⟧=>CBp : ∀{BV FV E p} → CorrectBinding (E ⟦ p ⟧e) BV FV → ∃ (λ BV → ∃ (λ FV → (CorrectBinding p BV FV)))
CBE⟦p⟧=>CBp{BV}{FV} {E = []} CB = BV , FV , CB
CBE⟦p⟧=>CBp {E = epar₁ q ∷ E} (CBpar CB CB₁ x x₁ x₂ x₃) = CBE⟦p⟧=>CBp{E = E} CB
CBE⟦p⟧=>CBp {E = epar₂ p ∷ E} (CBpar CB CB₁ x x₁ x₂ x₃) = CBE⟦p⟧=>CBp{E = E} CB₁
CBE⟦p⟧=>CBp {E = eloopˢ q ∷ E} (CBloopˢ CB CB₁ x _) = CBE⟦p⟧=>CBp{E = E} CB
CBE⟦p⟧=>CBp {E = eseq q ∷ E} (CBseq CB CB₁ x) = CBE⟦p⟧=>CBp{E = E} CB
CBE⟦p⟧=>CBp {E = esuspend S ∷ E} (CBsusp CB x) = CBE⟦p⟧=>CBp{E = E} CB
CBE⟦p⟧=>CBp {E = etrap ∷ E} (CBtrap CB) = CBE⟦p⟧=>CBp{E = E} CB

CBE⟦p⟧=>CBp' : ∀{BV FV E p p'} → p ≐ E ⟦ p' ⟧e →  CorrectBinding (p) BV FV → ∃ (λ BV → ∃ (λ FV → (CorrectBinding p' BV FV)))
CBE⟦p⟧=>CBp'{E = E}{p' = p'} peq cb = CBE⟦p⟧=>CBp{E = E}{p = p'} (subst (λ x → CorrectBinding x _ _) (sym (unplug peq)) cb)
-- , (BV⊆S , BV⊆s , BV⊆x)

CBp⊆CBE⟦p⟧ : ∀{BVp FVp BVE FVE} → (E : EvaluationContext ) → (p : Term) → CorrectBinding p BVp FVp → CorrectBinding (E ⟦ p ⟧e) BVE FVE → (FVp ⊆ FVE × BVp ⊆ BVE)

CBp⊆CBE⟦p⟧ [] p CBp CBE with binding-is-function CBp CBE
... | (e1 , e2) rewrite e1 | e2 = (((λ x z → z) , (λ x z → z) , (λ x z → z))) , (((λ x z → z) , (λ x z → z) , (λ x z → z)))
CBp⊆CBE⟦p⟧ (epar₁ q ∷ E) p CBp (CBpar CBE CBE₁ x x₁ x₂ x₃) with CBp⊆CBE⟦p⟧ E p CBp CBE
... | (FV⊆S , FV⊆s , FV⊆x) , (BV⊆S , BV⊆s , BV⊆x) = ((λ x y → ++ˡ (FV⊆S x y)) , ((λ x y → ++ˡ (FV⊆s x y))) , ((λ x y → ++ˡ (FV⊆x x y)))) , (((λ x y → ++ˡ (BV⊆S x y))) , ((λ x y → ++ˡ (BV⊆s x y))) , ((λ x y → ++ˡ (BV⊆x x y))))

CBp⊆CBE⟦p⟧ (epar₂ p ∷ E) p₁ CBp (CBpar{BVp = BVp}{FVp = FVp} CBE CBE₁ x x₁ x₂ x₃) with CBp⊆CBE⟦p⟧ E p₁ CBp CBE₁
... | (FV⊆S , FV⊆s , FV⊆x) , (BV⊆S , BV⊆s , BV⊆x)
   = ((λ x z → ++ʳ (proj₁ FVp) (FV⊆S x z)) , (λ x → (++ʳ (proj₁ (proj₂ FVp))) ∘ (FV⊆s x)) , ((λ x → (++ʳ (proj₂ (proj₂ FVp))) ∘ (FV⊆x x))))
   , ((λ x z → ++ʳ (proj₁ BVp) (BV⊆S x z)) , (λ x → (++ʳ (proj₁ (proj₂ BVp))) ∘ (BV⊆s x)) , ((λ x → (++ʳ (proj₂ (proj₂ BVp))) ∘ (BV⊆x x))))
CBp⊆CBE⟦p⟧ (eloopˢ q ∷ E) p CBp (CBloopˢ CBE CBE₁ x _) with CBp⊆CBE⟦p⟧ E p CBp CBE
... | (FV⊆S , FV⊆s , FV⊆x) , (BV⊆S , BV⊆s , BV⊆x) = ((λ x y → ++ˡ (FV⊆S x y)) , ((λ x → ++ˡ ∘ (FV⊆s x)) ) , get FV⊆x) , (get BV⊆S , get BV⊆s , get BV⊆x)
   where
   get : ∀{a b c} → a ⊆¹ b → a ⊆¹ (b ++ c)
   get f = λ x y → ++ˡ (f x y)
CBp⊆CBE⟦p⟧ (eseq q ∷ E) p CBp (CBseq CBE CBE₁ x) with CBp⊆CBE⟦p⟧ E p CBp CBE
... | (FV⊆S , FV⊆s , FV⊆x) , (BV⊆S , BV⊆s , BV⊆x) = ((λ x y → ++ˡ (FV⊆S x y)) , ((λ x → ++ˡ ∘ (FV⊆s x)) ) , get FV⊆x) , (get BV⊆S , get BV⊆s , get BV⊆x)
   where
   get : ∀{a b c} → a ⊆¹ b → a ⊆¹ (b ++ c)
   get f = λ x y → ++ˡ (f x y)
   --(λ x₁ x₂ → {!there x₂!})
CBp⊆CBE⟦p⟧ (esuspend S ∷ E) p CBp (CBsusp CBE x) with CBp⊆CBE⟦p⟧ E p CBp CBE
... | (FV⊆S , FV⊆s , FV⊆x) , BV⊆ = (((λ x y → there (FV⊆S x y)) , FV⊆s , FV⊆x)) , BV⊆
CBp⊆CBE⟦p⟧ (etrap ∷ E) p CBp (CBtrap CBE) = CBp⊆CBE⟦p⟧ E p CBp CBE

CBp⊆CBE⟦p⟧' : ∀{BVp FVp BVE FVE} E p p' → p ≐ E ⟦ p' ⟧e → CorrectBinding p' BVp FVp → CorrectBinding p BVE FVE → (FVp ⊆ FVE × BVp ⊆ BVE)
CBp⊆CBE⟦p⟧' E p p' peq cbp' cbp = CBp⊆CBE⟦p⟧ E p' cbp' (subst (λ x → CorrectBinding x _ _) (sym (unplug peq)) cbp)

inspecting-cb-distinct-double-unplug : ∀{p q Ep Eq p' q' BV FV} → CorrectBinding (p ∥ q) BV FV
                            → p ≐ Ep ⟦ p' ⟧e → q ≐ Eq ⟦ q' ⟧e
                            →
                            Σ (Term × VarList × VarList)
                              λ {(o , BVo , FVo)
                                → CorrectBinding o BVo FVo
                                × o ≡ (p' ∥ q')}
inspecting-cb-distinct-double-unplug{p' = p'}{q'} (CBpar CBp CBq BVp≠BVq FVp≠BVq BVp≠FVq Xp≠Xq) p=Ep⟦p'⟧ q=Eq⟦q'⟧
     with CBE⟦p⟧=>CBp' p=Ep⟦p'⟧ CBp | CBE⟦p⟧=>CBp' q=Eq⟦q'⟧ CBq
... | (BVp' , FVp' , CBp') | (BVq' , FVq' , CBq')
   with CBp⊆CBE⟦p⟧' _ _ _ p=Ep⟦p'⟧ CBp' CBp | CBp⊆CBE⟦p⟧' _ _ _ q=Eq⟦q'⟧ CBq' CBq
... | (FVp'⊆FVp , BVp'⊆BVp) | (FVq'⊆FVq , BVq'⊆BVq)
  = (_ , _ , _) , CBpar CBp' CBq' (⊆-rep-dist-both BVp'⊆BVp BVq'⊆BVq BVp≠BVq) (⊆-rep-dist-both FVp'⊆FVp BVq'⊆BVq FVp≠BVq) (⊆-rep-dist-both BVp'⊆BVp FVq'⊆FVq BVp≠FVq) (⊆¹-rep-dist-both (proj₂ (proj₂ FVp'⊆FVp)) (proj₂ (proj₂ FVq'⊆FVq)) Xp≠Xq) , refl
  where
    ⊆¹-rep-dist-both : ∀{a b c d} → a ⊆¹ b →  c ⊆¹ d → distinct' b d → distinct' a c
    ⊆¹-rep-dist-both sub1 sub2 dist = λ z z₁ z₂ → dist z (sub1 z z₁) (sub2 z z₂)
    ⊆-rep-dist-both : ∀{a b c d} → a ⊆ b →  c ⊆ d → distinct b d → distinct a c
    ⊆-rep-dist-both a b c = (⊆¹-rep-dist-both , ⊆¹-rep-dist-both , ⊆¹-rep-dist-both) # a # b # c


{- 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.Records
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.Handle.Properties
open import LibraBFT.Impl.IO.OBM.InputOutputHandlers
open import LibraBFT.Impl.IO.OBM.Properties.InputOutputHandlers
open import LibraBFT.Impl.Properties.Common
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        ReachableSystemStateProps
open import LibraBFT.Impl.Properties.Util
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 import LibraBFT.ImplShared.Util.HashCollisions Handle.InitHandler.initAndHandlers

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

-- This module proves the two "VotesOnce" proof obligations for our handler.

module LibraBFT.Impl.Properties.VotesOnce (𝓔 : EpochConfig) where

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

newVote⇒lv≡
  : ∀ {pre : SystemState}{pid s' acts v m pk}
  → ReachableSystemState pre
  → StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , acts)
  → v ⊂Msg m
  → send m ∈ acts
  → (sig : WithVerSig pk v)
  → Meta-Honest-PK pk
  → ¬ (∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig))
  → ¬ MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
  → LastVoteIs s' v

newVote⇒lv≡ {pid = pid} preach (step-init rm×acts uni) v⊂m send∈acts sig hpk ¬bootstrap ¬mws∈pool
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  with initHandlerSpec.ContractOk.isInitPM init-contract send∈acts
...| (_ , refl , noSigs)
  with v⊂m
...| vote∈qc vs∈qc v≈rbld qc∈pm = ⊥-elim (noSigs vs∈qc qc∈pm)

newVote⇒lv≡{pre}{pid}{s'}{v = v}{m}{pk} preach sps@(step-msg{sndr , nm} m∈pool ini) (vote∈qc{vs}{qc} vs∈qc v≈rbld qc∈m) m∈acts sig hpk ¬bootstrap ¬msb4
   with cong _vSignature v≈rbld
...| refl = ⊥-elim ∘′ ¬msb4 $ qcVoteSigsSentB4-handle pid preach sps m∈acts qc∈m sig vs∈qc v≈rbld ¬bootstrap

newVote⇒lv≡{pre}{pid}{v = v} preach (step-msg{sndr , P pm} m∈pool ini) vote∈vm m∈acts sig hpk ¬bootstrap ¬msb4
  with handleProposalSpec.contract! 0 pm (msgPool pre) (peerStates pre pid)
...| handleProposalSpec.mkContract _ invalidProposal _ vac _ _
   -- TODO-2: DRY fail.  This pattern arises several times in this file, where we need to know that
   -- the proposal being processed is valid, and to use handleProposalSpec to derive a contradiction
   -- if is not.  Some are identical, some are not.
   with BlockId-correct? (pm ^∙ pmProposal)
...| no  ¬validProposal = ⊥-elim (sendVote∉actions {outs = handleOuts} {st = handlePre}
                                    (sym (proj₂ $ invalidProposal ¬validProposal)) m∈acts)
  where
  handlePre  = peerStates pre pid
  handleOuts = LBFT-outs (handle pid (P pm) 0) (peerStates pre pid)

...| yes refl
   with vac refl (nohc preach m∈pool pid ini (invariantsCorrect pid pre ini preach) refl refl)
...| Voting.mkVoteAttemptCorrectWithEpochReq (inj₁ (_ , voteUnsent)) sdEpoch≡? =
  ⊥-elim (¬voteUnsent voteUnsent)
  where
  handleOuts = LBFT-outs (handle pid (P pm) 0) (peerStates pre pid)

  ¬voteUnsent : ¬ Voting.VoteUnsentCorrect (peerStates pre pid) _ _ _ _
  ¬voteUnsent (Voting.mkVoteUnsentCorrect noVoteMsgOuts _) =
    sendVote∉actions{outs = handleOuts}{st = peerStates pre pid}
      (sym noVoteMsgOuts) m∈acts
...| Voting.mkVoteAttemptCorrectWithEpochReq (inj₂ (Voting.mkVoteSentCorrect (VoteMsg∙new v' _) rcvr voteMsgOuts vgCorrect)) sdEpoch≡? =
  sentVoteIsPostLV
  where
  handlePost = LBFT-post (handle pid (P pm) 0) (peerStates pre pid)
  handleOuts = LBFT-outs (handle pid (P pm) 0) (peerStates pre pid)

  sentVoteIsPostLV : LastVoteIs handlePost v
  sentVoteIsPostLV
    with Voting.VoteGeneratedCorrect.state vgCorrect
  ...| RoundManagerTransProps.mkVoteGenerated lv≡v _
    rewrite sym lv≡v
    = cong (just ∘ _^∙ vmVote) (sendVote∈actions{outs = handleOuts}{st = peerStates pre pid} (sym voteMsgOuts) m∈acts)

newVote⇒lv≡{pre}{pid}{s' = s'}{v = v} preach (step-msg{sndr , V vm} m∈pool ini) vote∈vm m∈outs sig hpk ¬bootstrap ¬msb4 =
  ⊥-elim (sendVote∉actions{outs = hvOut}{st = hvPre} (sym noVotes) m∈outs)
  where
  hvPre = peerStates pre pid
  hvOut = LBFT-outs (handleVote 0 vm) hvPre
  open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)

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

oldVoteRound≤lvr
  : ∀ {pid pk v}{pre : SystemState}
  → (r : ReachableSystemState pre)
  → Meta-Honest-PK pk
  → (sig : WithVerSig pk v)
  → ¬ (∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig))
  → MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
  → PeerCanSignForPK pre v pid pk
  → (peerStates pre pid) ^∙ rmEpoch ≡ (v ^∙ vEpoch)
  → v ^∙ vRound ≤ Meta.getLastVoteRound ((peerStates pre pid) ^∙ pssSafetyData-rm)

oldVoteRound≤lvr{pid} (step-s preach step@(step-peer{pid'} sp@(step-cheat  cmc))) hpk sig ¬bootstrap mws∈pool pcsfpk epoch≡
  -- `pid`'s state is untouched by this step
  rewrite cheatStepDNMPeerStates₁{pid = pid'}{pid' = pid} sp unit
  = oldVoteRound≤lvr preach hpk sig ¬bootstrap mws∈prePool pcsfpkPre epoch≡
  where
  -- The cheat step could not have been where the signed message was introduced,
  -- so there must be a signed message in the pool prior to this
  mws∈prePool = ¬cheatForgeNew sp refl unit hpk mws∈pool (¬subst ¬bootstrap (msgSameSig mws∈pool))
  -- `pid` can sign for the message in the previous system state
  pcsfpkPre   = PeerCanSignForPKProps.msb4 preach step pcsfpk hpk sig mws∈prePool

oldVoteRound≤lvr{pid}{v = v} step*@(step-s{pre = pre}{post = post@._} preach step@(step-peer{pid'} sp@(step-honest{st = ppost}{outs} sps))) hpk sig ¬bootstrap mws∈pool pcsfpk epoch≡
   with msgSameSig mws∈pool
...| refl
   with newMsg⊎msgSentB4 preach sps hpk (msgSigned mws∈pool) ¬bootstrap (msg⊆ mws∈pool) (msg∈pool mws∈pool)
...| Right msb4 = helpSentB4
   where
   pcsfpkPre : PeerCanSignForPK pre v pid _
   pcsfpkPre = PeerCanSignForPKProps.msb4 preach step pcsfpk hpk sig msb4

   ovrHyp : peerStates pre pid ^∙ rmEpoch ≡ v ^∙ vEpoch → v ^∙ vRound ≤ Meta.getLastVoteRound ((peerStates pre pid) ^∙ pssSafetyData-rm)
   ovrHyp ep≡ = oldVoteRound≤lvr{pre = pre} preach hpk sig ¬bootstrap msb4 pcsfpkPre ep≡

   helpSentB4 : v ^∙ vRound ≤ Meta.getLastVoteRound ((peerStates post pid) ^∙ pssSafetyData-rm)
   helpSentB4
      with pid ≟ pid'
   -- A step by `pid'` step cannot affect `pid`'s state
   ...| no  pid≢
      rewrite sym (pids≢StepDNMPeerStates{pre = pre} sps pid≢)
      = ovrHyp epoch≡
   ...| yes refl = ≤-trans (ovrHyp epochPre≡) lvr≤
     where
     -- If a vote signed by a peer exists in the past, and that vote has an
     -- epoch id associated to it that is the same as the peer's post-state
     -- epoch, then the peer has that same epoch id in its immediately preceding
     -- pre-state.
     epochPre≡ : peerStates pre pid ^∙ rmEpoch ≡ v ^∙ vEpoch
     epochPre≡ =
       ReachableSystemStateProps.mws∈pool⇒epoch≡{v = v}{ppost}{outs} preach sps
         pcsfpkPre hpk sig ¬bootstrap msb4 epoch≡'
       where
       open ≡-Reasoning
       epoch≡' : ppost ^∙ rmEpoch ≡ v ^∙ vEpoch
       epoch≡' = begin
         ppost                                         ^∙ rmEpoch ≡⟨ cong (_^∙ rmEpoch) (StepPeer-post-lemma sp) ⟩
         peerStates (StepPeer-post{pre = pre} sp) pid' ^∙ rmEpoch ≡⟨ epoch≡ ⟩
         v ^∙ vEpoch                                              ∎

     ini : initialised pre pid' ≡ initd
     ini = ReachableSystemStateProps.mws∈pool⇒initd preach pcsfpkPre hpk sig ¬bootstrap msb4

     lvr≤ : Meta.getLastVoteRound ((peerStates pre pid) ^∙ pssSafetyData-rm) ≤ Meta.getLastVoteRound ((peerStates post pid) ^∙ pssSafetyData-rm)
     lvr≤
       rewrite sym (StepPeer-post-lemma{pre = pre} sp)
       = lastVotedRound-mono pid' pre preach ini sps
           (trans epochPre≡ (sym epoch≡))
-- The vote was newly sent this round
...| Left (m∈outs , pcsfpkPost , ¬msb4)
-- ... and it really is the same vote, because there has not been a hash collision
   with sameSig⇒sameVoteData (msgSigned mws∈pool) sig (msgSameSig mws∈pool)
...| Left nonInjSHA256 = ⊥-elim (PerReachableState.meta-no-collision step* nonInjSHA256)
...| Right refl
   with PeerCanSignForPKProps.pidInjective pcsfpk pcsfpkPost refl
...| refl = ≡⇒≤ vr≡lvrPost
  where
    vr≡lvrPost : v ^∙ vRound ≡ Meta.getLastVoteRound ((peerStates (StepPeer-post sp) pid) ^∙ pssSafetyData-rm)
    vr≡lvrPost
      rewrite sym (StepPeer-post-lemma sp)
      with newVote⇒lv≡{pre = pre}{pid = pid} preach sps (msg⊆ mws∈pool) m∈outs (msgSigned mws∈pool) hpk ¬bootstrap ¬msb4
    ...| lastVoteIsJust
       with ppost ^∙ pssSafetyData-rm ∙ sdLastVote
    ...| nothing = absurd (just _ ≡ nothing) case lastVoteIsJust of λ ()
    ...| just _ rewrite just-injective (sym lastVoteIsJust) = refl

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

sameERasLV⇒sameId-lem₁ :
  ∀ {pid pid' pk s acts}{pre : SystemState}
  → ReachableSystemState pre
  → (sp : StepPeer pre pid' s acts)
  → ∀ {v v'} → Meta-Honest-PK pk
  → PeerCanSignForPK (StepPeer-post sp) v pid pk
  → (sig' : WithVerSig pk v') → ¬ (∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig'))
  → (mws : MsgWithSig∈ pk (ver-signature sig') (msgPool pre))
  → v ≡L v' at vEpoch → v ≡L v' at vRound
  → Σ[ mws ∈ MsgWithSig∈ pk (ver-signature sig') (msgPool pre) ]
      (¬ ∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature ∘ msgSigned $ mws)
       × PeerCanSignForPK pre v pid pk
       × v  ≡L msgPart mws at vEpoch
       × v  ≡L msgPart mws at vRound
       × msgPart mws ≡L v' at vProposedId)

sameERasLV⇒sameId-lem₁{pid}{pid'}{pk}{pre = pre} rss sp {v}{v'} hpk pcsfpk sig' ¬bootstrap mws ≡epoch ≡round =
  mws , ¬bootstrap' , pcsfpkPre
  , trans ≡epoch (cong (_^∙ vdProposed ∙ biEpoch) (sym ≡voteData))
  , trans ≡round (cong (_^∙ vdProposed ∙ biRound) (sym ≡voteData))
  ,               cong (_^∙ vdProposed ∙ biId)    (    ≡voteData)
  where
  -- That message has the same signature as `v'`, so it has the same vote data
  -- (unless there was a collision, which we currently assume does not occur).
  ≡voteData : msgPart mws ≡L v' at vVoteData
  ≡voteData = ⊎-elimˡ (PerReachableState.meta-no-collision rss) (sameSig⇒sameVoteData sig' (msgSigned mws) (sym ∘ msgSameSig $ mws))

  ¬bootstrap' : ¬ ∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature ∘ msgSigned $ mws)
  ¬bootstrap' rewrite msgSameSig mws = ¬bootstrap

  -- The peer can sign for `v` now, so it can sign for `v` in the preceeding
  -- step, because there is an honestly signed message part for the peer's pubkey in the
  -- current epoch already in the pool.
  pcsfpkPre : PeerCanSignForPK pre v pid pk
  pcsfpkPre = PeerCanSignForPKProps.msb4-eid≡ rss (step-peer sp) hpk pcsfpk ≡epoch sig' mws

sameERasLV⇒sameId
  : ∀ {pid pid' pk}{st : SystemState}
    → ReachableSystemState st
    → ∀{v v' m'} → Meta-Honest-PK pk
    → just v ≡ peerStates st pid ^∙ pssSafetyData-rm ∙ sdLastVote
    → PeerCanSignForPK st v pid pk
    → v' ⊂Msg m' → (pid' , m') ∈ (msgPool st)
    → (sig' : WithVerSig pk v') → ¬ (∈BootstrapInfo-impl fakeBootstrapInfo (ver-signature sig'))
    → v ≡L v' at vEpoch → v ≡L v' at vRound
    → v ≡L v' at vProposedId
-- Cheat steps cannot be where an honestly signed message originated.
sameERasLV⇒sameId{pid}{pid'}{pk} (step-s{pre = pre} rss (step-peer sp@(step-cheat cmc))) {v}{v'}{m'} hpk ≡pidLV pcsfpk v'⊂m' m'∈pool sig' ¬bootstrap ≡epoch ≡round
   with sameERasLV⇒sameId-lem₁ rss sp hpk pcsfpk sig' ¬bootstrap mws ≡epoch ≡round
   where
   -- Track down the honestly signed message which existed before.
   mws : MsgWithSig∈ pk (ver-signature sig') (msgPool pre)
   mws = ¬cheatForgeNew sp refl unit hpk (mkMsgWithSig∈ m' v' v'⊂m' pid' m'∈pool sig' refl) ¬bootstrap
...| mws , ¬bootstrap' , pcsfpkPre , ≡epoch' , ≡round' , v'id≡ =
   trans (sameERasLV⇒sameId rss hpk ≡pidLVPre pcsfpkPre (msg⊆ mws) (msg∈pool mws) (msgSigned mws) ¬bootstrap' ≡epoch' ≡round') v'id≡
   where
   -- The state of `pid` is unchanged
   ≡pidLVPre : just v ≡ peerStates pre pid ^∙ pssSafetyData-rm ∙ sdLastVote
   ≡pidLVPre = trans ≡pidLV (cong (_^∙ pssSafetyData-rm ∙ sdLastVote) (cheatStepDNMPeerStates₁ sp unit))

-- Initialization steps cannot be where an honestly signed message originated
sameERasLV⇒sameId {pid} {pid'} {pk}
                  (step-s rss step@(step-peer{pre = pre} sp@(step-honest{pid“} sps@(step-init {rm} rm×acts uni))))
                  {v} {v'} {m'} hpk ≡pidLV pcsfpk v'⊂m' m'∈pool sig' ¬bootstrap ≡epoch ≡round
   with pid ≟ pid“
   -- If this isn't `pid`, the step does not affect `pid`'s state
...| no  pid≢
   rewrite sym $ pids≢StepDNMPeerStates{pre = pre} sps pid≢
   = sameERasLV⇒sameId rss hpk ≡pidLV pcsfpkPre v'⊂m' (m'∈poolb4 v'⊂m') sig' ¬bootstrap ≡epoch ≡round
   where

   m'∈poolb4 : v' ⊂Msg m' → (pid' , m') ∈ (msgPool pre)
   m'∈poolb4 v'⊂m'
     with Any-++⁻ _ m'∈pool
   ...| inj₂ x = x
   ...| inj₁ x
      with initHandlerSpec.contract pid“ fakeBootstrapInfo rm×acts
   ...| init-contract
      with initHandlerSpec.ContractOk.isInitPM init-contract (proj₁ (senderMsgPair∈⇒send∈ _ x))
   ...| (pm , refl , noSigs)
      with v'⊂m'
   ...| vote∈qc vs∈qc v≈rbld qc∈nm
      = ⊥-elim (noSigs vs∈qc qc∈nm)

   mws : MsgWithSig∈ pk (ver-signature sig') (msgPool pre)
   mws = mkMsgWithSig∈ _ _ v'⊂m' _ (m'∈poolb4 v'⊂m') sig' refl

   pcsfpkPre : PeerCanSignForPK pre v pid pk
   pcsfpkPre = PeerCanSignForPKProps.msb4-eid≡ rss step hpk pcsfpk ≡epoch sig' mws
   -- If this is `pid`, the last vote cannot be a `just`!
...| yes refl
   rewrite sym (StepPeer-post-lemma sp)
   with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
   with initHandlerSpec.ContractOk.sdLVnothing init-contract
...| lv≡nothing
   = absurd just v ≡ nothing case trans ≡pidLV lv≡nothing of λ ()

sameERasLV⇒sameId{pid}{pid'}{pk} (step-s rss (step-peer{pre = pre} sp@(step-honest{pid“} sps@(step-msg{sndr , m} m∈pool ini)))) {v}{v'} hpk ≡pidLV pcsfpk v'⊂m' m'∈pool sig' ¬bootstrap ≡epoch ≡round
   with newMsg⊎msgSentB4 rss sps hpk sig' ¬bootstrap v'⊂m' m'∈pool
-- The message has been sent before
...| Right mws'
   with sameERasLV⇒sameId-lem₁ rss sp hpk pcsfpk sig' ¬bootstrap mws' ≡epoch ≡round
...| mws , ¬bootstrap' , pcsfpkPre , ≡epoch' , ≡round' , v'id≡
   with pid ≟ pid“
   -- If this isn't `pid`, the step does not affect `pid`'s state
...| no  pid≢
   rewrite sym $ pids≢StepDNMPeerStates{pre = pre} sps pid≢
   = trans (sameERasLV⇒sameId rss hpk ≡pidLV pcsfpkPre (msg⊆ mws) (msg∈pool mws) (msgSigned mws) ¬bootstrap' ≡epoch' ≡round') v'id≡
   -- This is `pid`, so we need to know what message it was processing
...| yes refl
   rewrite sym $ StepPeer-post-lemma{pre = pre} sp
   = trans (sameERasLV⇒sameId rss hpk (≡pidLVPre m m∈pool ≡pidLV) pcsfpkPre (msg⊆ mws) (msg∈pool mws) (msgSigned mws) ¬bootstrap' ≡epoch' ≡round') v'id≡
   where
   ≡pidLVPre : (m : NetworkMsg) → (sndr , m) ∈ msgPool pre  → just v ≡ LBFT-post (handle pid m 0) (peerStates pre pid) ^∙ pssSafetyData-rm ∙ sdLastVote → just v ≡ peerStates pre pid ^∙ pssSafetyData-rm ∙ sdLastVote
   -- Last vote doesn't change when processing a vote message
   ≡pidLVPre (V vm) m∈pool ≡pidLV = begin
      just v                                 ≡⟨ ≡pidLV ⟩
      hvPos ^∙ pssSafetyData-rm ∙ sdLastVote ≡⟨ cong (_^∙ sdLastVote) (sym noSDChange) ⟩
      hvPre ^∙ pssSafetyData-rm ∙ sdLastVote ∎
      where
      open ≡-Reasoning

      hvPre = peerStates pre pid
      hvPos = LBFT-post (handleVote 0 vm) hvPre
      hvOut = LBFT-outs (handleVote 0 vm) hvPre

      open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)

   -- Commit messages are only for reasoning about correctness
   ≡pidLVPre (C cm) m∈pool ≡pidLV = ≡pidLV

   ≡pidLVPre (P pm) m∈pool ≡pidLV = analyzeVoteAttempt
      where
      hpPre  = peerStates pre pid“
      hpPos  = LBFT-post (handleProposal 0 pm) hpPre

      open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm (msgPool pre) hpPre)
        renaming (rmInv to rmInvP)
      open Invariants.RoundManagerInv (invariantsCorrect pid“ pre ini rss)

      -- when the last vote is the same in pre and post states
      module OldVote (lv≡ : hpPre ≡L hpPos at pssSafetyData-rm ∙ sdLastVote) where
        open ≡-Reasoning
        ≡pidLVPre₁ : just v ≡ hpPre ^∙ pssSafetyData-rm ∙ sdLastVote
        ≡pidLVPre₁ = begin
          just v                                 ≡⟨ ≡pidLV ⟩
          hpPos ^∙ pssSafetyData-rm ∙ sdLastVote ≡⟨ sym lv≡ ⟩
          hpPre ^∙ pssSafetyData-rm ∙ sdLastVote ∎

      -- When a new vote is generated, its round is strictly greater than that of the previous vote we attempted to send.
      module NewVote
        (vote : Vote) (lv≡v : just vote ≡ hpPos ^∙ pssSafetyData-rm ∙ sdLastVote)
        (lvr< : hpPre [ _<_ ]L hpPos at pssSafetyData-rm ∙ sdLastVotedRound)
        (lvr≡ : vote ^∙ vRound ≡ hpPos ^∙ pssSafetyData-rm ∙ sdLastVotedRound)
        (sdEpoch≡ : hpPre ^∙ pssSafetyData-rm ∙ sdEpoch ≡ pm ^∙ pmProposal ∙ bEpoch)
        (blockTriggered : Voting.VoteMadeFromBlock vote (pm ^∙ pmProposal))
        where

        -- `vote` comes from the peer handler contract
        v≡vote : v ≡ vote
        v≡vote = just-injective $ begin
          just v                                 ≡⟨ ≡pidLV ⟩
          hpPos ^∙ pssSafetyData-rm ∙ sdLastVote ≡⟨ sym lv≡v ⟩
          just vote                              ∎
          where open ≡-Reasoning

        -- The round of `v'` must be less than the round of the vote stored in `sdLastVote`
        rv'≤lvrPre : v' ^∙ vRound ≤ Meta.getLastVoteRound (hpPre ^∙ pssSafetyData-rm)
        rv'≤lvrPre = oldVoteRound≤lvr rss hpk sig' ¬bootstrap mws pcsfpkPre'
                       (ReachableSystemStateProps.mws∈pool⇒epoch≡ rss (step-msg m∈pool ini)
                         pcsfpkPre' hpk sig' ¬bootstrap mws ≡epoch“)
          where
          pcsfpkPre' = peerCanSignEp≡ pcsfpkPre ≡epoch

          open ≡-Reasoning
          ≡epoch“ : hpPos ^∙ rmEpoch ≡ v' ^∙ vEpoch
          ≡epoch“ = begin
            hpPos ^∙ rmEpoch                    ≡⟨ sym noEpochChange ⟩
            hpPre ^∙ rmEpoch                    ≡⟨ rmEpochsMatch ⟩
            hpPre ^∙ pssSafetyData-rm ∙ sdEpoch ≡⟨ sdEpoch≡ ⟩
            pm    ^∙ pmProposal ∙ bEpoch        ≡⟨ sym $ Voting.VoteMadeFromBlock.epoch≡ blockTriggered ⟩
            vote  ^∙ vEpoch                     ≡⟨ cong (_^∙ vEpoch) (sym v≡vote) ⟩
            v     ^∙ vEpoch                     ≡⟨ ≡epoch ⟩
            v'    ^∙ vEpoch                     ∎

        rv'<rv : v' [ _<_ ]L v at vRound
        rv'<rv = begin
          (suc $ v' ^∙ vRound)                                      ≤⟨ s≤s rv'≤lvrPre ⟩
          (suc $ Meta.getLastVoteRound (hpPre ^∙ pssSafetyData-rm)) ≤⟨ s≤s lvRound≤ ⟩
          (suc $ hpPre ^∙ pssSafetyData-rm ∙ sdLastVotedRound)      ≤⟨ lvr< ⟩
          hpPos ^∙ pssSafetyData-rm ∙ sdLastVotedRound              ≡⟨ sym lvr≡ ⟩
          vote  ^∙ vRound                                           ≡⟨ sym (cong (_^∙ vRound) v≡vote) ⟩
          v     ^∙ vRound                                           ∎
          where
          open ≤-Reasoning
          open SafetyDataInv (SafetyRulesInv.sdInv rmSafetyRulesInv)

      analyzeVoteAttempt : just v ≡ peerStates pre pid ^∙ pssSafetyData-rm ∙ sdLastVote
      analyzeVoteAttempt
         with BlockId-correct? (pm ^∙ pmProposal)
      ...| no ¬validProposal rewrite sym (proj₁ (invalidProposal ¬validProposal)) = ≡pidLV
      ...| yes refl
         with voteAttemptCorrect refl (nohc rss m∈pool pid ini (invariantsCorrect pid pre ini rss) refl refl)
      ...| Voting.mkVoteAttemptCorrectWithEpochReq (Left (_ , Voting.mkVoteUnsentCorrect noVoteMsgOuts nvg⊎vgusc)) sdEpoch≡?
         with nvg⊎vgusc
      ...| Left (mkVoteNotGenerated lv≡ lvr≤) = OldVote.≡pidLVPre₁ lv≡
      ...| Right (Voting.mkVoteGeneratedUnsavedCorrect vote (Voting.mkVoteGeneratedCorrect (mkVoteGenerated lv≡v voteSrc) blockTriggered))
         with voteSrc
      ...| Left (mkVoteOldGenerated lvr≡ lv≡) = OldVote.≡pidLVPre₁ lv≡
      ...| Right (mkVoteNewGenerated lvr< lvr≡) =
         ⊥-elim (<⇒≢ (NewVote.rv'<rv vote lv≡v lvr< lvr≡ sdEpoch≡? blockTriggered) (sym ≡round))
      analyzeVoteAttempt | yes refl | Voting.mkVoteAttemptCorrectWithEpochReq (Right (Voting.mkVoteSentCorrect vm pid voteMsgOuts vgCorrect)) sdEpoch≡?
         with vgCorrect
      ...| Voting.mkVoteGeneratedCorrect (mkVoteGenerated lv≡v voteSrc) blockTriggered
         with voteSrc
      ...| Left (mkVoteOldGenerated lvr≡ lv≡) = OldVote.≡pidLVPre₁ lv≡
      ...| Right (mkVoteNewGenerated lvr< lvr≡) =
         ⊥-elim (<⇒≢ (NewVote.rv'<rv (vm ^∙ vmVote) lv≡v lvr< lvr≡ sdEpoch≡? blockTriggered) (sym ≡round))

-- This is the origin of the message
sameERasLV⇒sameId{pid}{pid'}{pk} (step-s rss (step-peer{pre = pre} sp@(step-honest{pid“} sps@(step-msg{sndr , m} m∈pool ini)))) {v}{v'} hpk ≡pidLV pcsfpk v'⊂m' m'∈pool sig' ¬bootstrap ≡epoch ≡round
   | Left (m'∈acts , pcsfpk' , ¬msb4)
   -- So `pid“` must be `pid`
   with PeerCanSignForPKProps.pidInjective pcsfpk pcsfpk' ≡epoch
...| refl
   with v'⊂m'
   -- QC vote signatures have been sent before
...| vote∈qc{qc = qc} vs∈qc v≈ qc∈m'
   rewrite cong _vSignature v≈
   = ⊥-elim ∘′ ¬msb4 $ qcVoteSigsSentB4-handle pid rss sps m'∈acts qc∈m' sig' vs∈qc v≈ ¬bootstrap
...| vote∈vm
   rewrite sym $ StepPeer-post-lemma{pre = pre} sp
   = sameId m m∈pool m'∈acts ≡pidLV
   where

   handlePre = peerStates pre pid

   handleOuts : NetworkMsg → List Output
   handleOuts m = LBFT-outs (handle sndr m 0) handlePre

   handlePst : NetworkMsg → RoundManager
   handlePst m = LBFT-post (handle sndr m 0) handlePre

   sameId : ∀ {sndr} m → (sndr , m) ∈ msgPool pre
          → send (V (VoteMsg∙new v' _)) ∈ outputsToActions{State = handlePre} (handleOuts m)
          → just v ≡ handlePst m ^∙ pssSafetyData-rm ∙ sdLastVote → v ≡L v' at vProposedId
   sameId (P pm) m∈pool m'∈acts ≡pidLV = analyzeVoteAttempt
     where
     open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm (msgPool pre) handlePre)

     analyzeVoteAttempt : v ≡L v' at vProposedId
     analyzeVoteAttempt
        with BlockId-correct? (pm ^∙ pmProposal)
     ...| no ¬validProposal = ⊥-elim (sendVote∉actions {outs = handleOuts (P pm)} {st = handlePre}
                                      (sym (proj₂ $ invalidProposal ¬validProposal)) m'∈acts)
     ...| yes refl
        with voteAttemptCorrect refl (nohc rss m∈pool pid ini (invariantsCorrect pid pre ini rss) refl refl)
     ...| Voting.mkVoteAttemptCorrectWithEpochReq (Left (_ , vuc)) sdEpoch≡? =
        ⊥-elim (sendVote∉actions {outs = handleOuts (P pm)} {st = handlePre} (sym $ Voting.VoteUnsentCorrect.noVoteMsgOuts vuc) m'∈acts)
     ...| Voting.mkVoteAttemptCorrectWithEpochReq (Right (Voting.mkVoteSentCorrect vm pid voteMsgOuts vgCorrect)) sdEpoch≡?
        with vgCorrect
     ...| Voting.mkVoteGeneratedCorrect (mkVoteGenerated lv≡v voteSrc) blockTriggered = cong (_^∙ vProposedId) v≡v'
        where
        open ≡-Reasoning

        v≡v' : v ≡ v'
        v≡v' = just-injective $ begin
          just v
            ≡⟨ ≡pidLV ⟩
          (handlePst (P pm)                              ^∙ pssSafetyData-rm ∙ sdLastVote)
            ≡⟨ sym lv≡v ⟩
          just (vm ^∙ vmVote)
            ≡⟨ cong (just ∘ _^∙ vmVote) (sym $ sendVote∈actions{outs = handleOuts (P pm)}{st = handlePre} (sym voteMsgOuts) m'∈acts) ⟩
          just v' ∎

   sameId (V vm) _ m'∈acts ≡pidLV =
     ⊥-elim (sendVote∉actions {outs = hvOuts} {st = peerStates pre pid} (sym noVotes) m'∈acts)
     where
     hvOuts = LBFT-outs (handleVote 0 vm) (peerStates pre pid)

     open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) handlePre)
   sameId (C x) _ ()

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

votesOnce₁ : Common.IncreasingRoundObligation Handle.InitHandler.initAndHandlers 𝓔

votesOnce₁ {pid = pid} {pid'} {pk = pk} {pre = pre} preach
           (step-init {rm} rm×acts uni)
           {v} {m} {v'} {m'} hpk v⊂MsgPpm m∈acts sig ¬bootstrap ¬msb pcspkv v'⊂m' m'∈pool sig' ¬bootstrap' eid≡
  with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
  with initHandlerSpec.ContractOk.isInitPM init-contract m∈acts
...| (_ , _ , noSigs)
  with v⊂MsgPpm
...| vote∈qc vs∈qc v≈rbld qc∈nm
  = ⊥-elim (noSigs vs∈qc qc∈nm)

votesOnce₁ {pid = pid} {pid'} {pk = pk} {pre = pre} preach sps@(step-msg {sndr , P pm} m∈pool ini) {v} {m} {v'} {m'} hpk (vote∈qc {vs} {qc} vs∈qc v≈rbld qc∈m) m∈acts sig ¬bootstrap ¬msb pcspkv v'⊂m' m'∈pool sig' ¬bootstrap' eid≡
   with cong _vSignature v≈rbld
...| refl = ⊥-elim ∘′ ¬msb $ qcVoteSigsSentB4-handle pid preach sps m∈acts qc∈m sig vs∈qc v≈rbld ¬bootstrap

votesOnce₁ {pid = pid} {pid'} {pk = pk} {pre = pre} preach sps@(step-msg {sndr , P pm} m∈pool ini) {v} {.(V (VoteMsg∙new v _))} {v'} {m'} hpk vote∈vm m∈acts sig ¬bootstrap ¬msb pcspkv v'⊂m' m'∈pool sig' ¬bootstrap' eid≡
  with handleProposalSpec.contract! 0 pm (msgPool pre) (peerStates pre pid)
...| handleProposalSpec.mkContract _ invProp noEpochChange vac _ _
   with BlockId-correct? (pm ^∙ pmProposal)
...| no ¬validProposal = ⊥-elim (sendVote∉actions {outs = hpOut} {st = hpPre} (sym (proj₂ $ invProp ¬validProposal)) m∈acts )
   where
   hpPre  = peerStates pre pid
   hpOut  = LBFT-outs (handleProposal 0 pm) hpPre
...| yes refl
   with vac refl (nohc preach m∈pool pid ini (invariantsCorrect pid pre ini preach) refl refl)
...| Voting.mkVoteAttemptCorrectWithEpochReq (inj₁ (_ , Voting.mkVoteUnsentCorrect noVoteMsgOuts nvg⊎vgusc)) sdEpoch≡? =
     ⊥-elim (sendVote∉actions{outs = LBFT-outs (handleProposal 0 pm) (peerStates pre pid)}{st = peerStates pre pid} (sym noVoteMsgOuts) m∈acts)
...| Voting.mkVoteAttemptCorrectWithEpochReq (inj₂ (Voting.mkVoteSentCorrect vm pid₁ voteMsgOuts vgCorrect)) sdEpoch≡?
  with sendVote∈actions{outs = LBFT-outs (handleProposal 0 pm) (peerStates pre pid)}{st = peerStates pre pid} (sym voteMsgOuts) m∈acts
...| refl = ret
  where
  -- Some definitions
  step = step-peer (step-honest sps)
  rmPre  = peerStates pre pid
  rmPost = peerStates (StepPeer-post{pre = pre} (step-honest sps)) pid

  -- State invariants
  rmInvs      = invariantsCorrect pid pre ini preach
  open RoundManagerInv rmInvs

  -- Properties of `handleProposal`
  postLV≡ : just v ≡ (rmPost ^∙ pssSafetyData-rm ∙ sdLastVote)
  postLV≡ =
    trans (RoundManagerTransProps.VoteGenerated.lv≡v ∘ Voting.VoteGeneratedCorrect.state $ vgCorrect)
      (cong (_^∙ pssSafetyData-rm ∙ sdLastVote) (StepPeer-post-lemma (step-honest sps)))

  -- The proof
  m'mwsb : MsgWithSig∈ pk (ver-signature sig') (msgPool pre)
  m'mwsb = mkMsgWithSig∈ m' v' v'⊂m' pid' m'∈pool sig' refl

  pcspkv'-pre : PeerCanSignForPK pre v' pid pk
  pcspkv'-pre = PeerCanSignForPKProps.msb4 preach step (peerCanSignEp≡{v' = v'} pcspkv eid≡) hpk sig' m'mwsb

  rv'≤rv : v' ^∙ vRound ≤ v ^∙ vRound
  rv'≤rv =
    ≤-trans
      (oldVoteRound≤lvr preach hpk sig' ¬bootstrap' m'mwsb pcspkv'-pre (trans rmPreEsEpoch≡ eid≡))
      realLVR≤rv
    where
    open ≡-Reasoning
    -- TODO-1 : `rmPreSdEpoch≡` can be factored out into a lemma.
    -- Something like: for any reachable state where a peer sends a vote, the
    -- epoch for that vote is the peer's sdEpoch / esEpoch.
    rmPreSdEpoch≡ : rmPre ^∙ pssSafetyData-rm ∙ sdEpoch ≡ v ^∙ vEpoch
    rmPreSdEpoch≡
       with Voting.VoteGeneratedCorrect.state vgCorrect
       |    Voting.VoteGeneratedCorrect.blockTriggered vgCorrect
    ...| RoundManagerTransProps.mkVoteGenerated lv≡v (Left (RoundManagerTransProps.mkVoteOldGenerated lvr≡ lv≡)) | _
       with SafetyDataInv.lvEpoch≡ ∘ SafetyRulesInv.sdInv $ rmSafetyRulesInv
    ...| sdEpochInv rewrite trans lv≡ (sym lv≡v) = sym sdEpochInv
    rmPreSdEpoch≡
       | RoundManagerTransProps.mkVoteGenerated lv≡v (Right (RoundManagerTransProps.mkVoteNewGenerated lvr< lvr≡)) | bt =
      trans sdEpoch≡? (sym ∘ proj₁ ∘ Voting.VoteMadeFromBlock⇒VoteEpochRoundIs $ bt)

    rmPreEsEpoch≡ : rmPre ^∙ rmEpochState ∙ esEpoch ≡ v ^∙ vEpoch
    rmPreEsEpoch≡ =
      begin rmPre ^∙ rmEpochState ∙ esEpoch ≡⟨ rmEpochsMatch   ⟩
            rmPre ^∙ pssSafetyData-rm  ∙ sdEpoch ≡⟨ rmPreSdEpoch≡ ⟩
            v     ^∙ vEpoch                 ∎

    realLVR≤rv : Meta.getLastVoteRound (rmPre ^∙ pssSafetyData-rm) ≤ v ^∙ vRound
    realLVR≤rv
      with Voting.VoteGeneratedCorrect.state vgCorrect
    ...| RoundManagerTransProps.mkVoteGenerated lv≡v (inj₁ (RoundManagerTransProps.mkVoteOldGenerated lvr≡ lv≡))
      rewrite trans lv≡ (sym lv≡v)
        = ≤-refl
    ...| RoundManagerTransProps.mkVoteGenerated lv≡v (inj₂ (RoundManagerTransProps.mkVoteNewGenerated lvr< lvr≡))
       with rmPre ^∙ pssSafetyData-rm ∙ sdLastVote
       |    SafetyDataInv.lvRound≤ ∘ SafetyRulesInv.sdInv $ rmSafetyRulesInv
    ...| nothing | _ = z≤n
    ...| just lv | round≤ = ≤-trans (≤-trans round≤ (<⇒≤ lvr<)) (≡⇒≤ (sym lvr≡))

  ret : v' [ _<_ ]L v at vRound ⊎ Common.VoteForRound∈ Handle.InitHandler.initAndHandlers 𝓔 pk (v ^∙ vRound) (v ^∙ vEpoch) (v ^∙ vProposedId) (msgPool pre)
  ret
    with <-cmp (v' ^∙ vRound) (v ^∙ vRound)
  ...| tri< rv'<rv _ _ = Left rv'<rv
  ...| tri≈ _ rv'≡rv _
    = Right (Common.mkVoteForRound∈ _ v' v'⊂m' pid' m'∈pool sig' (sym eid≡) rv'≡rv
        (sym (sameERasLV⇒sameId (step-s preach step) hpk postLV≡ pcspkv v'⊂m' (Any-++ʳ _ m'∈pool) sig' ¬bootstrap' eid≡ (sym rv'≡rv) )))
  ...| tri> _ _ rv'>rv = ⊥-elim (≤⇒≯ rv'≤rv rv'>rv)

votesOnce₁{pid = pid}{pid'}{pk = pk}{pre = pre} preach sps@(step-msg{sndr , V vm} m∈pool ini){v}{m}{v'}{m'} hpk v⊂m m∈acts sig ¬bootstrap ¬msb vspk v'⊂m' m'∈pool sig' ¬bootstrap' eid≡
  with v⊂m
...| vote∈qc vs∈qc v≈rbld qc∈m rewrite cong _vSignature v≈rbld =
       ⊥-elim ∘′ ¬msb $ qcVoteSigsSentB4-handle pid preach sps m∈acts qc∈m sig vs∈qc v≈rbld ¬bootstrap
...| vote∈vm =
  ⊥-elim (sendVote∉actions{outs = hvOut}{st = hvPre} (sym noVotes) m∈acts)
  where
  hvPre = peerStates pre pid
  hvOut = LBFT-outs (handleVote 0 vm) hvPre
  open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)

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

votesOnce₂ : VO.ImplObligation₂ Handle.InitHandler.initAndHandlers 𝓔

votesOnce₂ {pid} {pk = pk} {pre} rss
           (step-init {rm} rm×acts uni)
           hpk v⊂m m∈acts sig ¬bootstrap ¬msb4 pcsfpk v'⊂m' m'∈acts sig' ¬bootstrap' ¬msb4' pcsfpk' ≡epoch ≡round
   with initHandlerSpec.contract pid fakeBootstrapInfo rm×acts
...| init-contract
   with initHandlerSpec.ContractOk.isInitPM init-contract m∈acts
...| (_ , refl , noSigs)
  with v⊂m
...| vote∈qc vs∈qc v≈rbld qc∈pm = ⊥-elim (noSigs vs∈qc qc∈pm)

votesOnce₂{pid}{pk = pk}{pre} rss (step-msg{sndr , m“} m“∈pool ini){v}{v' = v'} hpk v⊂m m∈acts sig ¬bootstrap ¬msb4 pcsfpk v'⊂m' m'∈acts sig' ¬bootstrap' ¬msb4' pcsfpk' ≡epoch ≡round
   with v⊂m
...| vote∈qc vs∈qc v≈rbld qc∈m rewrite cong _vSignature v≈rbld =
       ⊥-elim ∘′ ¬msb4 $ qcVoteSigsSentB4-handle pid rss (step-msg m“∈pool ini) m∈acts qc∈m sig vs∈qc v≈rbld ¬bootstrap
...| vote∈vm
  with v'⊂m'
...| vote∈qc vs∈qc' v≈rbld' qc∈m' rewrite cong _vSignature v≈rbld' =
       ⊥-elim ∘′ ¬msb4' $ qcVoteSigsSentB4-handle pid rss (step-msg m“∈pool ini) m'∈acts qc∈m' sig' vs∈qc' v≈rbld' ¬bootstrap'
...| vote∈vm
  with m“
...| P pm = cong (_^∙ vProposedId) v≡v'
  where
  hpPool = msgPool pre
  hpPre  = peerStates pre pid
  hpOut  = LBFT-outs (handleProposal 0 pm) hpPre
  open handleProposalSpec.Contract (handleProposalSpec.contract! 0 pm hpPool hpPre)

  v≡v' : v ≡ v'
  v≡v'
    with BlockId-correct? (pm ^∙ pmProposal)
  ...| no ¬validProposal = ⊥-elim (sendVote∉actions {outs = hpOut} {st = hpPre} (sym (proj₂ $ invalidProposal ¬validProposal)) m∈acts)
  ...| yes refl
    with voteAttemptCorrect refl (nohc rss m“∈pool pid ini (invariantsCorrect pid pre ini rss) refl refl   )
  ...| Voting.mkVoteAttemptCorrectWithEpochReq (Left (_ , Voting.mkVoteUnsentCorrect noVoteMsgOuts _)) _ =
    ⊥-elim (sendVote∉actions{outs = hpOut}{st = hpPre} (sym noVoteMsgOuts) m∈acts)
  ...| Voting.mkVoteAttemptCorrectWithEpochReq (Right (Voting.mkVoteSentCorrect vm pid voteMsgOuts _)) _ = begin
    v            ≡⟨        cong (_^∙ vmVote) (sendVote∈actions{outs = hpOut}{st = hpPre} (sym voteMsgOuts) m∈acts) ⟩
    vm ^∙ vmVote ≡⟨ (sym $ cong (_^∙ vmVote) (sendVote∈actions{outs = hpOut}{st = hpPre} (sym voteMsgOuts) m'∈acts)) ⟩
    v'           ∎
    where
    open ≡-Reasoning
...| V vm = ⊥-elim (sendVote∉actions{outs = hvOut}{st = hvPre} (sym noVotes) m∈acts)
  where
  hvPre = peerStates pre pid
  hvOut = LBFT-outs (handle pid (V vm) 0) hvPre
  open handleVoteSpec.Contract (handleVoteSpec.contract! 0 vm (msgPool pre) hvPre)


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

module Definition.Conversion.Transitivity where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.RedSteps
open import Definition.Conversion
open import Definition.Conversion.Soundness
open import Definition.Conversion.Stability
open import Definition.Conversion.Whnf
open import Definition.Conversion.Conversion
open import Definition.Conversion.Reduction
open import Definition.Conversion.Lift
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Injectivity
import Definition.Typed.Consequences.Inequality as WF
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution
open import Definition.Typed.Consequences.NeTypeEq
open import Definition.Typed.Consequences.SucCong
open import Definition.Typed.Consequences.Inversion
open import Definition.Typed.Consequences.Reduction

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

mutual
  -- Transitivity of algorithmic equality of neutrals.
  trans~↑ : ∀ {t u v A B Γ}
         → Γ ⊢ t ~ u ↑ A
         → Γ ⊢ u ~ v ↑ B
         → Γ ⊢ t ~ v ↑ A
         × Γ ⊢ A ≡ B
  trans~↑ (var-refl x₁ x≡y) (var-refl x₂ x≡y₁) =
    var-refl x₁ (PE.trans x≡y x≡y₁)
    , neTypeEq (var _) x₁
               (PE.subst (λ x → _ ⊢ var x ∷ _) (PE.sym x≡y)
                         x₂)
  trans~↑ (app-cong t~u a<>b) (app-cong u~v b<>c) =
    let t~v , ΠFG≡ΠF′G′ = trans~↓ t~u u~v
        F≡F₁ , G≡G₁ = injectivity ΠFG≡ΠF′G′
        a<>c = transConv↑Term F≡F₁ a<>b b<>c
    in  app-cong t~v a<>c , substTypeEq G≡G₁ (soundnessConv↑Term a<>b)
  trans~↑ (fst-cong t~u) (fst-cong u~v) =
    let t~v , ΣFG≡ΣF′G′ = trans~↓ t~u u~v
        F≡F′ , _ = Σ-injectivity ΣFG≡ΣF′G′
    in  fst-cong t~v , F≡F′
  trans~↑ (snd-cong t~u) (snd-cong u~v) =
    let t~v , ΣFG≡ΣF′G′ = trans~↓ t~u u~v
        F≡F′ , G≡G′ = Σ-injectivity ΣFG≡ΣF′G′
    in  snd-cong t~v , substTypeEq G≡G′ (soundness~↑ (fst-cong t~u))
  trans~↑ (natrec-cong A<>B a₀<>b₀ aₛ<>bₛ t~u) (natrec-cong B<>C b₀<>c₀ bₛ<>cₛ u~v) =
    let ⊢Γ = wf (proj₁ (syntacticEqTerm (soundness~↓ t~u)))
        A≡B = soundnessConv↑ A<>B
        F[0]≡F₁[0] = substTypeEq A≡B (refl (zeroⱼ ⊢Γ))
        ΠℕFs≡ΠℕF₁s = sucCong A≡B
        A<>C = transConv↑ A<>B B<>C
        a₀<>c₀ = transConv↑Term F[0]≡F₁[0] a₀<>b₀ b₀<>c₀
        aₛ<>cₛ = transConv↑Term ΠℕFs≡ΠℕF₁s aₛ<>bₛ bₛ<>cₛ
        t~v , _ = trans~↓ t~u u~v
    in  natrec-cong A<>C a₀<>c₀ aₛ<>cₛ t~v
    ,   substTypeEq A≡B (soundness~↓ t~u)
  trans~↑ (Emptyrec-cong A<>B t~u) (Emptyrec-cong B<>C u~v) =
    let A≡B = soundnessConv↑ A<>B
        A<>C = transConv↑ A<>B B<>C
        t~v , _ = trans~↓  t~u u~v
    in  Emptyrec-cong A<>C t~v , A≡B

  -- Transitivity of algorithmic equality of neutrals with types in WHNF.
  trans~↓ : ∀ {t u v A B Γ}
          → Γ ⊢ t ~ u ↓ A
          → Γ ⊢ u ~ v ↓ B
          → Γ ⊢ t ~ v ↓ A
          × Γ ⊢ A ≡ B
  trans~↓ ([~] A₁ D whnfA k~l) ([~] A₂ D₁ whnfA₁ k~l₁) =
    let t~v , A≡B = trans~↑ k~l k~l₁
    in  [~] A₁ D whnfA t~v
    ,   trans (sym (subset* D))
              (trans A≡B
                     (subset* D₁))

  -- Transitivity of algorithmic equality of types.
  transConv↑ : ∀ {A B C Γ}
            → Γ ⊢ A [conv↑] B
            → Γ ⊢ B [conv↑] C
            → Γ ⊢ A [conv↑] C
  transConv↑ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′)
             ([↑] A″ B″ D₁ D″ whnfA″ whnfB″ A′<>B″) =
    [↑] A′ B″ D D″ whnfA′ whnfB″
        (transConv↓ A′<>B′
                    (PE.subst (λ x → _ ⊢ x [conv↓] B″)
                              (whrDet* (D₁ , whnfA″)
                                        (D′ , whnfB′))
                              A′<>B″))
  transConv↑′ : ∀ {A B C Γ Δ}
              → ⊢ Γ ≡ Δ
              → Γ ⊢ A [conv↑] B
              → Δ ⊢ B [conv↑] C
              → Γ ⊢ A [conv↑] C
  transConv↑′ Γ≡Δ aConvB bConvC =
    transConv↑ aConvB (stabilityConv↑ (symConEq Γ≡Δ) bConvC)

  -- Transitivity of algorithmic equality of types in WHNF.
  transConv↓ : ∀ {A B C Γ}
            → Γ ⊢ A [conv↓] B
            → Γ ⊢ B [conv↓] C
            → Γ ⊢ A [conv↓] C
  transConv↓ (U-refl x) (U-refl x₁) = U-refl x
  transConv↓ (ℕ-refl x) (ℕ-refl x₁) = ℕ-refl x
  transConv↓ (Empty-refl x) (Empty-refl x₁) = Empty-refl x
  transConv↓ (Unit-refl x) (Unit-refl x₁) = Unit-refl x
  transConv↓ (ne x) (ne x₁) =
    let A~C , U≡U = trans~↓ x x₁
    in  ne A~C
  transConv↓ (Π-cong x x₁ x₂) (Π-cong x₃ x₄ x₅) =
    Π-cong x (transConv↑ x₁ x₄) (transConv↑′ (reflConEq (wf x) ∙ soundnessConv↑ x₁) x₂ x₅)
  transConv↓ (Σ-cong x x₁ x₂) (Σ-cong x₃ x₄ x₅) =
    Σ-cong x (transConv↑ x₁ x₄) (transConv↑′ (reflConEq (wf x) ∙ soundnessConv↑ x₁) x₂ x₅)
  -- Refutable cases
  transConv↓ (U-refl x) (ne ([~] A D whnfB ()))
  transConv↓ (ℕ-refl x) (ne ([~] A D whnfB ()))
  transConv↓ (Empty-refl x) (ne ([~] A D whnfB ()))
  transConv↓ (Π-cong x x₁ x₂) (ne ([~] A D whnfB ()))
  transConv↓ (Σ-cong x x₁ x₂) (ne ([~] A D whnfB ()))
  transConv↓ (ne ([~] A₁ D whnfB ())) (U-refl x₁)
  transConv↓ (ne ([~] A₁ D whnfB ())) (ℕ-refl x₁)
  transConv↓ (ne ([~] A₁ D whnfB ())) (Empty-refl x₁)
  transConv↓ (ne ([~] A₁ D whnfB ())) (Π-cong x₁ x₂ x₃)
  transConv↓ (ne ([~] A₁ D whnfB ())) (Σ-cong x₁ x₂ x₃)

  -- Transitivity of algorithmic equality of terms.
  transConv↑Term : ∀ {t u v A B Γ}
                → Γ ⊢ A ≡ B
                → Γ ⊢ t [conv↑] u ∷ A
                → Γ ⊢ u [conv↑] v ∷ B
                → Γ ⊢ t [conv↑] v ∷ A
  transConv↑Term A≡B ([↑]ₜ B₁ t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u)
                 ([↑]ₜ B₂ t″ u″ D₁ d₁ d″ whnfB₁ whnft″ whnfu″ t<>u₁) =
    let B₁≡B₂ = trans (sym (subset* D))
                      (trans A≡B
                             (subset* D₁))
        d₁″ = conv* d″ (sym B₁≡B₂)
        d₁′  = conv* d′ B₁≡B₂
    in  [↑]ₜ B₁ t′ u″ D d d₁″ whnfB whnft′ whnfu″
             (transConv↓Term B₁≡B₂ t<>u
                             (PE.subst (λ x → _ ⊢ x [conv↓] u″ ∷ B₂)
                                       (whrDet*Term (d₁ , whnft″)
                                                    (d₁′ , whnfu′))
                                       t<>u₁))

  transConv↑Term′ : ∀ {t u v A B Γ Δ}
                  → ⊢ Γ ≡ Δ
                  → Γ ⊢ A ≡ B
                  → Γ ⊢ t [conv↑] u ∷ A
                  → Δ ⊢ u [conv↑] v ∷ B
                  → Γ ⊢ t [conv↑] v ∷ A
  transConv↑Term′ Γ≡Δ A≡B tConvU uConvV =
    transConv↑Term A≡B tConvU (stabilityConv↑Term (symConEq Γ≡Δ) uConvV)

  -- Transitivity of algorithmic equality of terms in WHNF.
  transConv↓Term : ∀ {t u v A B Γ}
                → Γ ⊢ A ≡ B
                → Γ ⊢ t [conv↓] u ∷ A
                → Γ ⊢ u [conv↓] v ∷ B
                → Γ ⊢ t [conv↓] v ∷ A
  transConv↓Term A≡B (ℕ-ins x) (ℕ-ins x₁) =
    ℕ-ins (proj₁ (trans~↓ x x₁))
  transConv↓Term A≡B (Empty-ins x) (Empty-ins x₁) =
    Empty-ins (proj₁ (trans~↓ x x₁))
  transConv↓Term A≡B (Unit-ins t~u) uConvV =
    let _ , [t] , _ = syntacticEqTerm (soundness~↓ t~u)
        _ , tNe , _ = ne~↓ t~u
        _ , _ , [v] = syntacticEqTerm (soundnessConv↓Term uConvV)
        [v] = conv [v] (sym A≡B)
        _ , _ , vWhnf = whnfConv↓Term uConvV
    in  η-unit [t] [v] (ne tNe) vWhnf
  transConv↓Term A≡B (ne-ins t u x x₁) (ne-ins t′ u′ x₂ x₃) =
    ne-ins t (conv u′ (sym A≡B)) x
           (proj₁ (trans~↓ x₁ x₃))
  transConv↓Term A≡B (univ x x₁ x₂) (univ x₃ x₄ x₅) =
    univ x x₄ (transConv↓ x₂ x₅)
  transConv↓Term A≡B (zero-refl x) conv↓ =
    convConv↓Term (reflConEq x) (sym A≡B) ℕₙ conv↓
  transConv↓Term A≡B conv↓ (zero-refl _) = conv↓
  transConv↓Term A≡B (suc-cong x) (suc-cong x₁) =
    suc-cong (transConv↑Term A≡B x x₁)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (η-eq x₅ x₆ y₂ y₃ x₇) =
    let F₁≡F , G₁≡G = injectivity A≡B
    in  η-eq x₁ (conv x₆ (sym A≡B))
             y y₃ (transConv↑Term′ (reflConEq (wfEq F₁≡F) ∙ F₁≡F) G₁≡G x₃ x₇)
  transConv↓Term A≡B (Σ-η ⊢p ⊢r pProd rProd fstConv sndConv)
                     (Σ-η ⊢r′ ⊢q _ qProd fstConv′ sndConv′) =
    let F≡ , G≡ = Σ-injectivity A≡B
        Gfst≡ = substTypeEq G≡ (soundnessConv↑Term fstConv)
    in  Σ-η ⊢p (conv ⊢q (sym A≡B)) pProd qProd
            (transConv↑Term F≡ fstConv fstConv′)
            (transConv↑Term Gfst≡ sndConv sndConv′)
  transConv↓Term A≡B (η-unit [t] [u] tUnit uUnit) uConvV =
    let _ , _ , [v] = syntacticEqTerm (soundnessConv↓Term uConvV)
        [v] = conv [v] (sym A≡B)
        _ , _ , vWhnf = whnfConv↓Term uConvV
    in  η-unit [t] [v] tUnit vWhnf

  -- Refutable cases
  transConv↓Term A≡B (ℕ-ins x) (ne-ins t u x₂ x₃) = ⊥-elim (WF.ℕ≢ne x₂ A≡B)
  transConv↓Term A≡B (ℕ-ins x) (univ x₂ x₃ x₄) = ⊥-elim (WF.U≢ℕ (sym A≡B))
  transConv↓Term A≡B (ℕ-ins x) (Empty-ins x₁) = ⊥-elim (WF.ℕ≢Emptyⱼ A≡B)
  transConv↓Term A≡B (ℕ-ins x) (Unit-ins x₁) = ⊥-elim (WF.ℕ≢Unitⱼ A≡B)
  transConv↓Term A≡B (ℕ-ins ([~] A D whnfB ())) (suc-cong x₂)
  transConv↓Term A≡B (ℕ-ins x) (η-eq x₃ x₄ y y₁ x₅) = ⊥-elim (WF.ℕ≢Π A≡B)
  transConv↓Term A≡B (ℕ-ins x₁) (Σ-η x₂ x₃ x₄ x₅ x₆ x₇) = ⊥-elim (WF.ℕ≢Σ A≡B)
  transConv↓Term A≡B (ℕ-ins x) (η-unit _ _ _ _) = ⊥-elim (WF.ℕ≢Unitⱼ A≡B)
  transConv↓Term A≡B (Empty-ins x) (ne-ins t u x₂ x₃) = ⊥-elim (WF.Empty≢neⱼ x₂ A≡B)
  transConv↓Term A≡B (Empty-ins x) (univ x₂ x₃ x₄) = ⊥-elim (WF.U≢Emptyⱼ (sym A≡B))
  transConv↓Term A≡B (Empty-ins x₁) (ℕ-ins x) = ⊥-elim (WF.ℕ≢Emptyⱼ (sym A≡B))
  transConv↓Term A≡B (Empty-ins x₁) (Unit-ins x) = ⊥-elim (WF.Empty≢Unitⱼ A≡B)
  transConv↓Term A≡B (Empty-ins ([~] A D whnfB ())) (suc-cong x₂)
  transConv↓Term A≡B (Empty-ins x) (η-eq x₃ x₄ y y₁ x₅) = ⊥-elim (WF.Empty≢Πⱼ A≡B)
  transConv↓Term A≡B (Empty-ins x₁) (Σ-η x₂ x₃ x₄ x₅ x₆ x₇) = ⊥-elim (WF.Empty≢Σⱼ A≡B)
  transConv↓Term A≡B (Empty-ins x₁) (η-unit _ _ _ _) = ⊥-elim (WF.Empty≢Unitⱼ A≡B)
  transConv↓Term A≡B (ne-ins t u x x₁) (ℕ-ins x₂) = ⊥-elim (WF.ℕ≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (Empty-ins x₂) = ⊥-elim (WF.Empty≢neⱼ x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (Unit-ins x₂) = ⊥-elim (WF.Unit≢neⱼ x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (univ x₃ x₄ x₅) = ⊥-elim (WF.U≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x ([~] A D whnfB ())) (suc-cong x₃)
  transConv↓Term A≡B (ne-ins t u x x₁) (η-eq x₄ x₅ y y₁ x₆) = ⊥-elim (WF.Π≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (Σ-η x₅ x₆ x₇ x₈ x₉ x₁₀) = ⊥-elim (WF.Σ≢ne x (sym A≡B))
  transConv↓Term A≡B (ne-ins t u x x₁) (η-unit _ _ _ _) = ⊥-elim (WF.Unit≢neⱼ x (sym A≡B))
  transConv↓Term A≡B (univ x x₁ x₂) (ℕ-ins x₃) = ⊥-elim (WF.U≢ℕ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (Empty-ins x₃) = ⊥-elim (WF.U≢Emptyⱼ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (Unit-ins x₃) = ⊥-elim (WF.U≢Unitⱼ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (ne-ins t u x₃ x₄) = ⊥-elim (WF.U≢ne x₃ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (suc-cong x₃) = ⊥-elim (WF.U≢ℕ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (η-eq x₄ x₅ y y₁ x₆) = ⊥-elim (WF.U≢Π A≡B)
  transConv↓Term A≡B (univ x₁ x₂ x₃) (Σ-η x₄ x₅ x₆ x₇ x₈ x₉) = ⊥-elim (WF.U≢Σ A≡B)
  transConv↓Term A≡B (univ x x₁ x₂) (η-unit _ _ _ _) = ⊥-elim (WF.U≢Unitⱼ A≡B)
  transConv↓Term A≡B (suc-cong x) (ℕ-ins ([~] A D whnfB ()))
  transConv↓Term A≡B (suc-cong x) (Empty-ins ([~] A D whnfB ()))
  transConv↓Term A≡B (suc-cong x) (ne-ins t u x₁ ([~] A D whnfB ()))
  transConv↓Term A≡B (suc-cong x) (univ x₁ x₂ x₃) = ⊥-elim (WF.U≢ℕ (sym A≡B))
  transConv↓Term A≡B (suc-cong x) (η-eq x₂ x₃ y y₁ x₄) = ⊥-elim (WF.ℕ≢Π A≡B)
  transConv↓Term A≡B (suc-cong x₁) (Σ-η x₂ x₃ x₄ x₅ x₆ x₇) = ⊥-elim (WF.ℕ≢Σ A≡B)
  transConv↓Term A≡B (suc-cong x) (η-unit _ _ _ _) = ⊥-elim (WF.ℕ≢Unitⱼ A≡B)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (ℕ-ins x₄) = ⊥-elim (WF.ℕ≢Π (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (Empty-ins x₄) = ⊥-elim (WF.Empty≢Πⱼ (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (Unit-ins _) = ⊥-elim (WF.Unit≢Πⱼ (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (ne-ins t u x₄ x₅) = ⊥-elim (WF.Π≢ne x₄ A≡B)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (univ x₄ x₅ x₆) = ⊥-elim (WF.U≢Π (sym A≡B))
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (suc-cong x₄) = ⊥-elim (WF.ℕ≢Π (sym A≡B))
  transConv↓Term A≡B (η-eq x₂ x₃ x₄ x₅ x₆) (Σ-η x₇ x₈ x₉ x₁₀ x₁₁ x₁₂) = ⊥-elim (WF.Π≢Σ A≡B)
  transConv↓Term A≡B (η-eq x₁ x₂ y y₁ x₃) (η-unit _ _ _ _) = ⊥-elim (WF.Unit≢Πⱼ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (ℕ-ins x₇) = ⊥-elim (WF.ℕ≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (Empty-ins x₇) = ⊥-elim (WF.Empty≢Σⱼ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (Unit-ins x₇) = ⊥-elim (WF.Unit≢Σⱼ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (ne-ins x₇ x₈ x₉ x₁₀) = ⊥-elim (WF.Σ≢ne x₉ A≡B)
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (univ x₇ x₈ x₉) = ⊥-elim (WF.U≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (suc-cong x₇) = ⊥-elim (WF.ℕ≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (η-eq x₈ x₉ x₁₀ x₁₁ x₁₂) = ⊥-elim (WF.Π≢Σ (sym A≡B))
  transConv↓Term A≡B (Σ-η x₁ x₂ x₃ x₄ x₅ x₆) (η-unit x₇ x₈ x₉ x₁₀) = ⊥-elim (WF.Unit≢Σⱼ (sym A≡B))

-- Transitivity of algorithmic equality of types of the same context.
transConv : ∀ {A B C Γ}
          → Γ ⊢ A [conv↑] B
          → Γ ⊢ B [conv↑] C
          → Γ ⊢ A [conv↑] C
transConv A<>B B<>C = transConv↑ A<>B B<>C

-- Transitivity of algorithmic equality of terms of the same context.
transConvTerm : ∀ {t u v A Γ}
              → Γ ⊢ t [conv↑] u ∷ A
              → Γ ⊢ u [conv↑] v ∷ A
              → Γ ⊢ t [conv↑] v ∷ A
transConvTerm t<>u u<>v =
  let t≡u = soundnessConv↑Term t<>u
      ⊢A , _ , _ = syntacticEqTerm t≡u
  in  transConv↑Term (refl ⊢A) t<>u u<>v


{- 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.Base.Types
import      LibraBFT.Impl.Consensus.Network      as Network
import      LibraBFT.Impl.Consensus.RoundManager as RoundManager
open import LibraBFT.Impl.OBM.Logging.Logging
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude

-- This module defines the handler for our implementation.  For most message types, it does some
-- initial validation before passing the message on to the proper handlers.

module LibraBFT.Impl.IO.OBM.InputOutputHandlers where

epvv : LBFT (Epoch × ValidatorVerifier)
epvv = _,_ <$> gets (_^∙ rmSafetyRules ∙ srPersistentStorage ∙ pssSafetyData ∙ sdEpoch)
           <*> gets (_^∙ rmEpochState ∙ esVerifier)

module handleProposal (now : Instant) (pm : ProposalMsg) where
  step₀ : LBFT Unit
  step₁ : Epoch → ValidatorVerifier → LBFT Unit

  step₀ = do
    (myEpoch , vv) ← epvv
    step₁ myEpoch vv

  step₁ myEpoch vv = do
    case⊎D Network.processProposal {- {!!} -} pm myEpoch vv of λ where
      (Left (Left e))  → logErr e
      (Left (Right i)) → logInfo i
      (Right _)        → RoundManager.processProposalMsgM now pm

handleProposal : Instant → ProposalMsg → LBFT Unit
handleProposal = handleProposal.step₀

module handleVote (now : Instant) (vm : VoteMsg) where
  step₀ : LBFT Unit
  step₁ : Epoch → ValidatorVerifier → LBFT Unit

  step₀ = do
    (myEpoch , vv) ← epvv
    step₁ myEpoch vv

  step₁ myEpoch vv = do
    case Network.processVote vm myEpoch vv of λ where
      (Left (Left e))  → logErr e
      (Left (Right i)) → logInfo i
      (Right _)        → RoundManager.processVoteMsgM now vm

abstract
  handleVote = handleVote.step₀

  handleVote≡ : handleVote ≡ handleVote.step₀
  handleVote≡ = refl

handle : NodeId → NetworkMsg → Instant → LBFT Unit
handle _self msg now =
  case msg of λ where
    (P pm) → handleProposal now pm
    (V vm) → handleVote     now vm
    (C cm) → pure unit    -- We don't do anything with commit messages, they are just for defining Correctness.