module Properties.Step where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Agda.Builtin.Float using (primFloatPlus; primFloatMinus; primFloatTimes; primFloatDiv)
open import FFI.Data.Maybe using (just; nothing)
open import Luau.Heap using (Heap; _[_]; alloc; ok; function_is_end)
open import Luau.Syntax using (Block; Expr; nil; var; addr; function_is_end; block_is_end; _$_; local_←_; return; done; _∙_; name; fun; arg; number; binexp; +)
open import Luau.OpSem using (_⊢_⟶ᴱ_⊣_; _⊢_⟶ᴮ_⊣_; app₁ ; app₂ ; beta; function; block; return; done; local; subst; binOpEval; evalBinOp; binOp₁; binOp₂)
open import Luau.RuntimeError using (RuntimeErrorᴱ; RuntimeErrorᴮ; TypeMismatch; UnboundVariable; SEGV; app₁; app₂; block; local; return; bin₁; bin₂)
open import Luau.RuntimeType using (function; number)
open import Luau.Substitution using (_[_/_]ᴮ)
open import Luau.Value using (nil; addr; val; number)
open import Properties.Remember using (remember; _,_)

data StepResultᴮ {a} (H : Heap a) (B : Block a) : Set
data StepResultᴱ {a} (H : Heap a) (M : Expr a) : Set

data StepResultᴮ H B where
  step : ∀ H′ B′ → (H ⊢ B ⟶ᴮ B′ ⊣ H′) → StepResultᴮ H B
  return : ∀ V {B′} → (B ≡ (return (val V) ∙ B′)) → StepResultᴮ H B
  done : (B ≡ done) → StepResultᴮ H B
  error : (RuntimeErrorᴮ H B) → StepResultᴮ H B

data StepResultᴱ H M where
  step : ∀ H′ M′ → (H ⊢ M ⟶ᴱ M′ ⊣ H′) → StepResultᴱ H M
  value : ∀ V → (M ≡ val V) → StepResultᴱ H M
  error : (RuntimeErrorᴱ H M) → StepResultᴱ H M

stepᴱ : ∀ {a} H M → StepResultᴱ {a} H M
stepᴮ : ∀ {a} H B → StepResultᴮ {a} H B

stepᴱ H nil = value nil refl
stepᴱ H (var x) = error (UnboundVariable x)
stepᴱ H (addr a) = value (addr a) refl
stepᴱ H (number x) = value (number x) refl
stepᴱ H (M $ N) with stepᴱ H M
stepᴱ H (M $ N) | step H′ M′ D = step H′ (M′ $ N) (app₁ D)
stepᴱ H (_ $ N) | value V refl with stepᴱ H N
stepᴱ H (_ $ N) | value V refl | step H′ N′ s = step H′ (val V $ N′) (app₂ s)
stepᴱ H (_ $ _) | value nil refl | value W refl = error (app₁ (TypeMismatch function nil λ()))
stepᴱ H (_ $ _) | value (number n) refl | value W refl = error (app₁ (TypeMismatch function (number n) λ()))
stepᴱ H (_ $ _) | value (addr a) refl | value W refl with remember (H [ a ])
stepᴱ H (_ $ _) | value (addr a) refl | value W refl  | (nothing , p) = error (app₁ (SEGV a p))
stepᴱ H (_ $ _) | value (addr a) refl | value W refl  | (just(function F is B end) , p) = step H (block fun F is B [ W / name (arg F) ]ᴮ end) (beta p)
stepᴱ H (M $ N) | value V p | error E = error (app₂ E)
stepᴱ H (M $ N) | error E = error (app₁ E)
stepᴱ H (block b is B end) with stepᴮ H B
stepᴱ H (block b is B end) | step H′ B′ D = step H′ (block b is B′ end) (block D)
stepᴱ H (block b is (return _ ∙ B′) end) | return V refl = step H (val V) return
stepᴱ H (block b is done end) | done refl = step H nil done
stepᴱ H (block b is B end) | error E = error (block b E)
stepᴱ H (function F is C end) with alloc H (function F is C end)
stepᴱ H function F is C end | ok a H′ p = step H′ (addr a) (function p)
stepᴱ H (binexp x op y) with stepᴱ H x
stepᴱ H (binexp x op y) | value x′ refl with stepᴱ H y
stepᴱ H (binexp x op y) | value (number x′) refl | value (number y′) refl = step H (number (evalBinOp x′ op y′)) binOpEval
stepᴱ H (binexp x op y) | value (number x′) refl | step H′ y′ s = step H′ (binexp (number x′) op y′) (binOp₂ s)
stepᴱ H (binexp x op y) | value (number x′) refl | error E = error (bin₂ E)
stepᴱ H (binexp x op y) | value nil refl | _ = error (bin₁ (TypeMismatch number nil λ()))
stepᴱ H (binexp x op y) | _ | value nil refl = error (bin₂ (TypeMismatch number nil λ()))
stepᴱ H (binexp x op y) | value (addr a) refl | _ = error (bin₁ (TypeMismatch number (addr a) λ()))
stepᴱ H (binexp x op y) | _ | value (addr a) refl = error (bin₂ (TypeMismatch number (addr a) λ()))
stepᴱ H (binexp x op y) | step H′ x′ s = step H′ (binexp x′ op y) (binOp₁ s)
stepᴱ H (binexp x op y) | error E = error (bin₁ E)

stepᴮ H (function F is C end ∙ B) with alloc H (function F is C end)
stepᴮ H (function F is C end ∙ B) | ok a H′ p = step H′ (B [ addr a / fun F ]ᴮ) (function p)
stepᴮ H (local x ← M ∙ B) with stepᴱ H M
stepᴮ H (local x ← M ∙ B) | step H′ M′ D = step H′ (local x ← M′ ∙ B) (local D)
stepᴮ H (local x ← _ ∙ B) | value V refl = step H (B [ V / name x ]ᴮ) subst
stepᴮ H (local x ← M ∙ B) | error E = error (local x E)
stepᴮ H (return M ∙ B) with stepᴱ H M
stepᴮ H (return M ∙ B) | step H′ M′ D = step H′ (return M′ ∙ B) (return D)
stepᴮ H (return _ ∙ B) | value V refl = return V refl
stepᴮ H (return M ∙ B) | error E = error (return E)
stepᴮ H done = done refl


{- 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
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
import      LibraBFT.Impl.Consensus.ConsensusTypes.Properties.QuorumCert as QC
import      LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert            as QuorumCert
open import LibraBFT.Impl.Consensus.ConsensusTypes.SyncInfo as SI
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.Impl.Types.BlockInfo as BI
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Prelude
open import Yasm.System ℓ-RoundManager ℓ-VSFP ConcSysParms

open Invariants
open RoundManagerTransProps

module LibraBFT.Impl.Consensus.ConsensusTypes.Properties.SyncInfo where

module verifyMSpec (self : SyncInfo) (validator : ValidatorVerifier) where

  epoch = self ^∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biEpoch

  record SIVerifyProps (pre : RoundManager) : Set where
    field
      sivpEp≡       : epoch ≡ self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biEpoch
      sivpTcEp≡     : maybeS (self ^∙ siHighestTimeoutCert) Unit $ λ tc -> epoch ≡ tc ^∙ tcEpoch
      sivpHqc≥Hcc   : (self ^∙ siHighestQuorumCert) [ _≥_ ]L self ^∙ siHighestCommitCert at qcCertifiedBlock ∙ biRound
      sivpHqc≢empty : self ^∙ siHighestCommitCert ∙ qcCommitInfo ≢ BI.empty
      sivpHqcVer    : QC.Contract (self ^∙ siHighestQuorumCert) validator
      sivpHccVer    : maybeS (self ^∙ sixxxHighestCommitCert) Unit $ λ qc → QC.Contract qc validator
      -- Waiting on TimeoutCertificate Contract : sivpHtcVer    : maybeS (self ^∙ siHighestTimeoutCert  ) Unit $ λ tc → {!!}

  module _ (pre : RoundManager) where

   record Contract (r : Either ErrLog Unit) (post : RoundManager) (outs : List Output) : Set where
     constructor mkContract
     field
       -- General properties / invariants
       rmInv         : Preserves RoundManagerInv pre post
       noStateChange : pre ≡ post
       -- Output
       noMsgOuts     : OutputProps.NoMsgs outs
       -- Syncing
       syncResCorr   : r ≡ Right unit → SIVerifyProps pre
       -- NOTE: Since the output contains no messages and the state does not
       -- change, nothing needs to be said about the quorum certificats in the
       -- output and post state

   verifyCorrect : SI.verify self validator ≡ Right unit → SIVerifyProps pre
   verifyCorrect verify≡
      with epoch ≟ self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biEpoch
   ...| no  ep≢ = absurd (Left _ ≡ Right _) case verify≡ of λ ()
   ...| yes sivpEp≡
      with sivpTcEp≡ verify≡
      where
      sivpTcEp≡ : SI.verify.step₁ self validator ≡ Right unit
                  → maybeS (self ^∙ siHighestTimeoutCert) Unit (\tc -> epoch ≡ tc ^∙ tcEpoch)
                    × SI.verify.step₂ self validator ≡ Right unit
      sivpTcEp≡ verify≡₁
         with self ^∙ siHighestTimeoutCert
      ...| nothing = unit , verify≡₁
      ...| just tc
         with epoch ≟ tc ^∙ tcEpoch
      ...| yes tce≡ = tce≡ , verify≡₁
      ...| no  tce≢ = absurd (Left _ ≡ Right _) case verify≡₁ of λ ()
   ...| sivpTcEp≡ , verify≡₂
      with sivpHqc≥Hcc verify≡₂
      where
      sivpHqc≥Hcc : (SI.verify.step₂ self validator ≡ Right unit)
                    → (self ^∙ siHighestQuorumCert) [ _≥_ ]L self ^∙ siHighestCommitCert at qcCertifiedBlock ∙ biRound
                      × SI.verify.step₃ self validator ≡ Right unit
      sivpHqc≥Hcc verify≡₂
         with    self ^∙ siHighestQuorumCert ∙ qcCertifiedBlock ∙ biRound
              ≥? self ^∙ siHighestCommitCert ∙ qcCertifiedBlock ∙ biRound
      ...| yes hqc≥hcc = hqc≥hcc , verify≡₂
      ...| no  hqc<hcc = absurd Left _ ≡ Right _ case verify≡₂ of λ ()
   ...| sivpHqc≥Hcc , verify≡₃
      with sivpHqc≢empty verify≡₃
      where
      sivpHqc≢empty : (SI.verify.step₃ self validator ≡ Right unit)
                      → self ^∙ siHighestCommitCert ∙ qcCommitInfo ≢ BI.empty
                        × SI.verify.step₄ self validator ≡ Right unit
      sivpHqc≢empty verify≡₃
         with self ^∙ siHighestCommitCert ∙ qcCommitInfo ≟ BI.empty
      ...| no  ≢empty = ≢empty , verify≡₃
      ...| yes ≡empty = absurd Left _ ≡ Right _ case verify≡₃ of λ ()
   ...| sivpHqc≢empty , verify≡₄
      with sivpHqcVer verify≡₄
      where
      sivpHqcVer : (SI.verify.step₄ self validator ≡ Right unit)
                   → QC.Contract (self ^∙ siHighestQuorumCert) validator
                     × SI.verify.step₅ self validator ≡ Right unit
      sivpHqcVer verify≡₄
         with  QuorumCert.verify (self ^∙ siHighestQuorumCert)  validator | inspect
              (QuorumCert.verify (self ^∙ siHighestQuorumCert)) validator
      ...| Left  _    | _ = absurd Left _ ≡ Right _ case verify≡₄ of λ ()
      ...| Right unit | [ R ]
         with QC.contract (self ^∙ siHighestQuorumCert) validator (Right unit) refl R
      ...| qcCon = qcCon , verify≡₄
   ...| sivpHqcVer , verify≡₅
      with sivpHccVer verify≡₅
      where
      sivpHccVer : (SI.verify.step₅ self validator ≡ Right unit)
                   → (maybeS (self ^∙ sixxxHighestCommitCert) Unit $ λ qc → QC.Contract qc validator)
                     × SI.verify.step₆ self validator ≡ Right unit
      sivpHccVer verify≡₅
         with self ^∙ sixxxHighestCommitCert
      ...| nothing = unit , verify≡₅
      ...| just qc
         with QuorumCert.verify  qc  validator | inspect
              (QuorumCert.verify qc) validator
      ...| Left _ | _ = absurd Left _ ≡ Right _ case verify≡₅ of λ ()
      ...| Right unit | [ R ] = QC.contract qc validator (Right unit) refl R , verify≡₅
   ...| sivpHccVer , verify≡₆ =
   -- TODO: continue case analysis for remaining fields
     record
     { sivpEp≡       = sivpEp≡
     ; sivpTcEp≡     = sivpTcEp≡
     ; sivpHqc≥Hcc   = sivpHqc≥Hcc
     ; sivpHqc≢empty = sivpHqc≢empty
     ; sivpHqcVer    = sivpHqcVer
     ; sivpHccVer    = sivpHccVer
     -- ; sivpHtcVer =
     }

   contract : ∀ Q → (RWS-Post-⇒ Contract Q) → LBFT-weakestPre (SI.verifyM self validator) Q pre
   contract Q pf = LBFT-⇒ (SI.verifyM self validator) pre (mkContract id refl refl verifyCorrect) pf


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

   Copyright (c) 2020, 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.ImplShared.Base.Types

open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open import LibraBFT.Concrete.Records as LCR
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Util.Crypto
open import Optics.All
open import Util.KVMap
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude
open import Yasm.Base

open        EpochConfig

-- This module contains placeholders for the future analog of the
-- corresponding VotesOnce property.  Defining the implementation
-- obligation and proving that it is an invariant of an implementation
-- is a substantial undertaking.  We are working first on proving the
-- simpler VotesOnce property to settle down the structural aspects
-- before tackling the harder semantic issues.
module LibraBFT.Concrete.Properties.PreferredRound (iiah : SystemInitAndHandlers ℓ-RoundManager ConcSysParms) (𝓔 : EpochConfig) where
 open        LibraBFT.ImplShared.Consensus.Types.EpochDep.WithEC
 import      LibraBFT.Abstract.Records         UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Abs
 import      LibraBFT.Abstract.Records.Extends UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔) as Ext
 open import LibraBFT.Abstract.RecordChain     UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔)
 open import LibraBFT.Abstract.System          UID _≟UID_ NodeId 𝓔 (ConcreteVoteEvidence 𝓔)
 open import LibraBFT.Concrete.Intermediate                      𝓔 (ConcreteVoteEvidence 𝓔)
 open import LibraBFT.Concrete.Obligations.PreferredRound        𝓔 (ConcreteVoteEvidence 𝓔)
 open        SystemTypeParameters ConcSysParms
 open        SystemInitAndHandlers iiah
 open        ParamsWithInitAndHandlers iiah
 open import LibraBFT.ImplShared.Util.HashCollisions iiah
 open import LibraBFT.Concrete.Properties.Common iiah 𝓔
 open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms iiah PeerCanSignForPK PeerCanSignForPK-stable

 open PerEpoch    𝓔
 open WithAbsVote 𝓔
 open LCR.WithEC  𝓔
 open PerState
 open PerReachableState
 open IntermediateSystemState
 open All-InSys-props

 Block-RC-AllInSys : Abs.Vote → SystemState → Set
 Block-RC-AllInSys vabs st = ∃[ b ] ( Abs.bId b ≡ abs-vBlockUID vabs
                                    × Σ (RecordChain (Abs.B b)) (All-InSys (InSys (intSystemState st))))

 ImplObligation-RC : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation-RC =
   ∀{pid s' outs pk}{pre : SystemState}
   → ReachableSystemState pre
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → ∀{v m} → Meta-Honest-PK pk
   -- For signed every vote v of every outputted message
   → v ⊂Msg m → send m ∈ outs
   → (sig : WithVerSig pk v)
   → 0 < v ^∙ vRound
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre))
   → let post = StepPeer-post {pre = pre} (step-honest sps)
     in (pcs4 : PeerCanSignForPK post v pid pk)
        → ∃[ mbr ] ( getPubKey 𝓔 mbr ≡ pk
                   × Block-RC-AllInSys (α-ValidVote 𝓔 v mbr) post)

 -- For PreferredRound, we have two implementation obligations, one for when v is sent by the
 -- step and v' has been sent before, and one for when both are sent by the step.
 ImplObligation₁ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₁ =
   ∀{pid pid' s' outs pk}{pre : SystemState}
   → (r : ReachableSystemState pre)
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → let post = StepPeer-post {pre = pre} (step-honest sps) in
     ∀{mbr v vabs m v' v'abs m'}
   → Meta-Honest-PK pk
   -- For signed every vote v of every outputted message
   → v'  ⊂Msg m'  → send m' ∈ outs
   → (sig' : WithVerSig pk v') → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig'))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig') (msgPool pre))
   → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v' pid pk
   -- And if there exists another v' that has been sent before
   → v ⊂Msg m → (pid' , m) ∈ (msgPool pre)
   → (sig : WithVerSig pk v) → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig))
   -- If v and v' share the same epoch
   → v ^∙  vEpoch ≡ v' ^∙ vEpoch
   -- and v is for a smaller round
   → v ^∙ vRound < v' ^∙ vRound
   -- and vabs* are the abstract Votes for v and v'
   → α-ValidVote 𝓔 v  mbr ≡ vabs
   → α-ValidVote 𝓔 v' mbr ≡ v'abs
   → (c2 : Cand-3-chain-vote (intSystemState post) vabs)
   -- then the round of the block that v' votes for is at least the round of
   -- the grandparent of the block that v votes for (i.e., the preferred round rule)
   → Σ (VoteParentData (intSystemState post) v'abs)
           (λ vp → Cand-3-chain-head-round (intSystemState post) c2 ≤ Abs.round (vpParent vp))
     ⊎ (VoteForRound∈ pk (v' ^∙ vRound) (v' ^∙ vEpoch) (v' ^∙ vProposedId) (msgPool pre))

 -- Similarly in case the same step sends both v and v'
 ImplObligation₂ : Set (ℓ+1 ℓ-RoundManager)
 ImplObligation₂ =
   ∀{pid s' outs pk}{pre : SystemState}
   → (r  : ReachableSystemState pre)
   -- For any honest call to /handle/ or /init/,
   → (sps : StepPeerState pid (msgPool pre) (initialised pre) (peerStates pre pid) (s' , outs))
   → let post = StepPeer-post {pre = pre} (step-honest sps) in
     ∀{mbr v vabs m v' v'abs m'}
   → Meta-Honest-PK pk
   -- For every vote v represented in a message output by the call
   → v  ⊂Msg m  → send m ∈ outs
   → (sig : WithVerSig pk v) → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig))
   -- If v is really new and valid
   → ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool pre))
   → PeerCanSignForPK post v pid pk
   -- And if there exists another v' that is also new and valid
   → v' ⊂Msg m'  → send m' ∈ outs
   → (sig' : WithVerSig pk v') → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature sig'))
   → ¬ (MsgWithSig∈ pk (ver-signature sig') (msgPool pre))
   → PeerCanSignForPK (StepPeer-post {pre = pre} (step-honest sps)) v' pid pk
   -- If v and v' share the same epoch and round
   → v ^∙ vEpoch ≡ v' ^∙ vEpoch
   → v ^∙ vRound < v' ^∙ vRound
   → α-ValidVote 𝓔 v  mbr ≡ vabs
   → α-ValidVote 𝓔 v' mbr ≡ v'abs
   → (c2 : Cand-3-chain-vote (intSystemState post) vabs)
   → Σ (VoteParentData (intSystemState post) v'abs)
           (λ vp → Cand-3-chain-head-round (intSystemState post) c2 ≤ Abs.round (vpParent vp))

 module _ where
   open InSys iiah

   stepPreservesVoteParentData : ∀ {st0 st1 v}
     → Step st0 st1
     → (vpd : VoteParentData (intSystemState st0) v)
     → Σ (VoteParentData (intSystemState st1) v)
         λ vpd' → vpParent vpd' ≡ vpParent vpd
   stepPreservesVoteParentData {st0} {st1} theStep vpd
      with vpd
   ...| (record { vpV4B        = vpV4B
                ; vpBlock∈sys  = vpBlock∈sys
                ; vpParent     = vpParent
                ; vpParent∈sys = vpParent∈sys
                ; vpExt        = vpExt
                ; vpMaybeBlock = vpMaybeBlock
                }) = (record
                     { vpV4B        = vpV4B
                     ; vpBlock∈sys  = stable theStep vpBlock∈sys
                     ; vpParent     = vpParent
                     ; vpParent∈sys = stable theStep vpParent∈sys
                     ; vpExt        = vpExt
                     ; vpMaybeBlock = transp-vpmb vpMaybeBlock
                     }) , refl
     where transp-vpmb : ∀ {r}
                         → VoteParentData-BlockExt (intSystemState st0) r
                         → VoteParentData-BlockExt (intSystemState st1) r
           transp-vpmb vpParent≡I = vpParent≡I
           transp-vpmb (vpParent≡Q x x₁) = vpParent≡Q x (stable theStep x₁)

 module Proof
   (sps-corr   : StepPeerState-AllValidParts)   -- Bring in newMsg⊎msgSentB4
   (Impl-bsvr  : ImplObl-bootstrapVotesRound≡0)
   (Impl-nvr≢0 : ImplObl-NewVoteRound≢0)
   (Impl-∈BI?  : (sig : Signature) → Dec (∈BootstrapInfo bootstrapInfo sig))
   (Impl-RC    : ImplObligation-RC)
   (Impl-IRO   : IncreasingRoundObligation)
   (Impl-PR1   : ImplObligation₁)
   (Impl-PR2   : ImplObligation₂)
    where
  module _ {st : SystemState}(r : ReachableSystemState st) (𝓔-∈sys : EpochConfig∈Sys st 𝓔) where
   open        Structural sps-corr
   open        ConcreteCommonProperties st r sps-corr Impl-bsvr Impl-nvr≢0

   α-ValidVote-trans : ∀ {pk mbr vabs pool} (v : Vote)
                     → α-ValidVote 𝓔 v mbr ≡ vabs
                     → (vfr : VoteForRound∈ pk (v ^∙ vRound) (v ^∙ vEpoch)
                                            (v ^∙ vProposedId) pool)
                     → α-ValidVote 𝓔 (msgVote vfr) mbr ≡ vabs
   α-ValidVote-trans v₁ refl vfr
     with msgRound≡ vfr | msgEpoch≡ vfr | msgBId≡ vfr
   ...| refl | refl | refl = refl

   0<rnd⇒¬BootStrap : ∀ {pk rnd bid pool}
                      → (v4r : VoteForRound∈ pk rnd (epoch 𝓔) bid pool)
                      → 0 < rnd
                      → ¬ (∈BootstrapInfo bootstrapInfo (ver-signature $ msgSigned v4r))
   0<rnd⇒¬BootStrap v4r 0<r rewrite sym (msgRound≡ v4r) = ⊥-elim ∘ (<⇒≢ 0<r) ∘ sym ∘ Impl-bsvr (msgSigned v4r)

   -- To prove this, we observe that cheaters can't introduce a VoteForRound∈ for an honest PK.  We
   -- will also require an additional implementation obligation.  It may simply be that Votes sent
   -- satisy IsValidVote, but the question is where do we maintain evidence that such a RecordChain
   -- exists for any Block we may vote for?
   voteForRound-RC : ∀ {pk vabs}{st : SystemState}
                     → Meta-Honest-PK pk
                     → ReachableSystemState st
                     → (v4r : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool st))
                     → 0 < abs-vRound vabs
                     → Block-RC-AllInSys vabs st

   voteForRound-RC-mws : ∀ {pk vabs pre pid st' outs}
                       → Meta-Honest-PK pk
                       → ReachableSystemState pre
                       → (sp : StepPeer pre pid st' outs)
                       → (v4r : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool $ StepPeer-post sp))
                       → MsgWithSig∈ pk (ver-signature $ msgSigned v4r) (msgPool pre)
                       → 0 < abs-vRound vabs
                       → Block-RC-AllInSys vabs (StepPeer-post sp)
   voteForRound-RC-mws {pk} {vabs} {pre} hpk preReach sps v4r mwsb4 0<r
      with sameSig⇒sameVoteData (msgSigned mwsb4) (msgSigned v4r) (msgSameSig mwsb4)
   ...| inj₁ hb = ⊥-elim $ meta-no-collision preReach hb -- TODO-2: refine sameSig⇒samevotedata to
                                                         -- enable tying collision to specific state
                                                         -- so we can use meta-no-collision-in-sys
   ...| inj₂ svd
      with msgSentB4⇒VoteRound∈ (msgSigned v4r) mwsb4'
         where
           mwsb4' : _
           mwsb4' rewrite
                    trans (cong (_^∙ vdProposed ∙ biEpoch) $ sym svd) (msgEpoch≡ v4r) |
                    msgBId≡ v4r |
                    msgSameSig mwsb4 = mwsb4
   ...| v4r' , refl
      with voteForRound-RC {pk} {vabs} hpk preReach v4r'' 0<r
         where
           v4r'' : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool pre)
           v4r'' rewrite sym (msgEpoch≡ v4r) | sym (msgRound≡ v4r) | sym (msgBId≡ v4r) = v4r'
   ...| b , refl , rc , ais = b , refl , rc , InSys.ais-stable iiah (step-peer sps) rc ais

   voteForRound-RC {pk} {vabs} {st} hpk (step-s preReach (step-peer (step-honest sps))) v4r 0<r
      with newMsg⊎msgSentB4 {sndr = msgSender v4r} preReach sps hpk (msgSigned v4r)
                            (0<rnd⇒¬BootStrap v4r 0<r)
                            (msg⊆ v4r)
                            (msg∈pool v4r)
   ...| inj₂ mwsb4 = voteForRound-RC-mws {vabs = vabs} hpk preReach (step-honest sps) v4r mwsb4 0<r
   ...| inj₁ (send∈outs , pcs4 , ¬sentb4) rewrite sym (msgRound≡ v4r)
      with Impl-RC preReach sps hpk (msg⊆ v4r) send∈outs (msgSigned v4r) 0<r ¬sentb4 pcs4
   ...| mbr , refl , b , bid≡ , rc∈sys  = b , (trans bid≡ $ msgBId≡ v4r) , rc∈sys
   voteForRound-RC {pk} {vabs} {st} hpk (step-s {pre = pre} preReach (step-peer (step-cheat {pid} x))) v4r 0<r
      with VoteRound∈⇒msgSent v4r
   ...| msgb4 , refl , refl
      with ¬cheatForgeNew {st = pre} (step-cheat x) refl unit hpk msgb4
                          (0<rnd⇒¬BootStrap v4r 0<r)
   ...| mwsb4 = voteForRound-RC-mws {vabs = vabs} hpk preReach (step-cheat x) v4r mwsb4 0<r

   open _α-Sent_
   open _BlockDataInjectivityProps_

   Abs2ImplCollision : ∀ {ab1 ab2 : Abs.Block}{post}
                     → (rPost : ReachableSystemState post)
                     → InSys (intSystemState post) (Abs.B ab1)
                     → InSys (intSystemState post) (Abs.B ab2)
                     → ab1 ≢ ab2
                     → Abs.bId ab1 ≡ Abs.bId ab2
                     → HashCollisionFound rPost
   Abs2ImplCollision rPost (ws ep≡1 m1∈pool (b∈NM {cb1} {pm1} refl refl bidcorr1))
                           (ws ep≡2 m2∈pool (b∈NM {cb2} {pm2} refl refl bidcorr2)) neq absIds≡ =
     msgmsgHC {r = rPost} (inP m1∈pool (inPM (inB {b = cb1}))) (inP m2∈pool (inPM (inB {b = cb2}))) hashes≡ bsls≢
     where
       -- TODO-2: Some of the properties should be factored out for reuse, maybe into Common?
       bIds≡ : _
       bIds≡ = trans (trans (α-Block-bid≡ cb1) absIds≡) (sym (α-Block-bid≡ cb2))

       hashes≡ : _
       hashes≡ = trans (trans bidcorr1 bIds≡) (sym bidcorr2)

       rnds≡ : ∀ {cb1 cb2} → (cb1 ^∙ bBlockData) BlockDataInjectivityProps (cb2 ^∙ bBlockData)
               → Abs.bRound (α-Block cb1) ≡ Abs.bRound (α-Block cb2)
       rnds≡ {cb1} {cb2} injprops = trans (sym (α-Block-rnd≡ cb1)) (trans (bdInjRound injprops) (α-Block-rnd≡ cb2))

       propBlock : ∀ {cb pm} → pm ^∙ pmProposal ≡ cb
                   → cb ^∙ bId ≡ pm ^∙ pmProposal ∙ bId
       propBlock refl = refl

       prevQCs≡ : ∀ {cb1 cb2}
                  → (cb1 ^∙ bBlockData) BlockDataInjectivityProps (cb2 ^∙ bBlockData)
                  → Abs.bPrevQC (α-Block cb1) ≡ Abs.bPrevQC (α-Block cb2)
       prevQCs≡ {cb1} {cb2} injprops
          with cb1 ^∙ bBlockData ∙ bdBlockType | inspect
               (cb1 ^∙_) (bBlockData ∙ bdBlockType)
       ...| Genesis      | [ R ] rewrite R                    = sym (α-Block-prevqc≡-Gen  {cb2} (bdInjBTGen injprops R))
       ...| Proposal _ _ | [ R ] rewrite R | bdInjVD injprops = sym (α-Block-prevqc≡-Prop {cb2} (trans (sym $ bdInjBTProp injprops R) R))
       ...| NilBlock     | [ R ] rewrite R | bdInjBTNil injprops R | bdInjVD injprops = refl

       bsls≢ : _
       bsls≢ _
          with hashBD-inj hashes≡
       ...| injprops = neq (Abs.Block-η
                              (rnds≡ {cb1} {cb2} injprops)
                              absIds≡
                              (prevQCs≡ {cb1} {cb2} injprops))

   Cand-3-chain-vote-b4 : ∀ {pk vabs}{pre : SystemState}{pid st' outs sp}
                          → Meta-Honest-PK pk
                          → ReachableSystemState pre
                          → let post = StepPeer-post {pid}{st'}{outs}{pre} sp in
                            (c2 : Cand-3-chain-vote (intSystemState post) vabs)
                            → (v4r : VoteForRound∈ pk (abs-vRound vabs) (epoch 𝓔) (abs-vBlockUID vabs) (msgPool pre))
                            → Σ (Cand-3-chain-vote (intSystemState pre) vabs)
                                 λ c2' → Cand-3-chain-head-round (intSystemState post) c2
                                       ≡ Cand-3-chain-head-round (intSystemState pre ) c2'
   Cand-3-chain-vote-b4 {pk} {vabs} {pre} {pid} {st'} {outs} {sp} pkH r
                        c3@(mkCand3chainvote (mkVE veBlock refl refl) c3Blk∈sys₁ qc₁ qc←b₁ rc₁ rc∈sys₁ n₁ is-2chain₁) v4r
      with v-cand-3-chain⇒0<roundv  (intSystemState $ StepPeer-post {pid}{st'}{outs}{pre} sp)
   ...| 0<r
      with voteForRound-RC {vabs = vabs} pkH r v4r (0<r c3)
   ...| b , refl , rcb , ais
      with veBlock Abs.≟Block b
   ...| no   neq = ⊥-elim (meta-no-collision-in-sys postR hcf)
        where
          post    = StepPeer-post sp
          theStep = step-peer sp
          postR   = step-s r theStep
          hcf = Abs2ImplCollision postR c3Blk∈sys₁ (InSys.stable iiah theStep (ais here)) neq refl
   ...| yes refl
      with RecordChain-irrelevant rcb (step rc₁ qc←b₁)
   ...| inj₁ (((b1 , b2) , neq , absIds≡) , b1∈rcb , b2∈rc1ext) = ⊥-elim (meta-no-collision-in-sys postR (hcf b2∈rc1ext))
      where
         post    = StepPeer-post sp
         theStep = step-peer sp
         postR   = step-s r theStep

         inSys1  = InSys.stable iiah theStep $ ais b1∈rcb
         inSys2 : _ → _
         inSys2 here = c3Blk∈sys₁
         inSys2 (there .qc←b₁ b2∈rc1ext) = rc∈sys₁ b2∈rc1ext

         hcf : _ → _
         hcf b2∈rc1ext = Abs2ImplCollision postR inSys1 (inSys2 b2∈rc1ext) neq absIds≡
   ...| inj₂ (eq-step {r₀ = .(Abs.B b)} {r₁ = .(Abs.B b)} rc0 rc1 b≈b
                      ext0@(Ext.I←B _ prevNothing)
                      ext1@(Ext.Q←B _ prevJust)
                      rcrest≈) = absurd just _ ≡ nothing case trans prevJust prevNothing of λ ()
   ...| inj₂ (eq-step {r₀ = .(Abs.B b)} {r₁ = .(Abs.B b)} rc0 rc1 b≈b
                      ext0@(Ext.Q←B {qc0} {.b} _ _)
                      ext1@(Ext.Q←B {qc1} {.b} _ _) rcrest≈) = newc3 , rnds≡
          where

            newc3 = mkCand3chainvote (mkVE b refl refl)
                                     (ais here)
                                     qc0
                                     ext0
                                     rc0
                                     (ais ∘ (_∈RC-simple_.there ext0))
                                     n₁
                                     (transp-𝕂-chain (≈RC-sym rcrest≈) is-2chain₁)
            rnds≡ = cong Abs.bRound $ kchainBlock-≈RC is-2chain₁ (suc zero) (≈RC-sym rcrest≈)

   PreferredRoundProof :
      ∀ {pk round₁ round₂ bId₁ bId₂ v₁abs v₂abs mbr} {st : SystemState}
      → ReachableSystemState st
      → Meta-Honest-PK pk
      → (v₁ : VoteForRound∈ pk round₁ (epoch 𝓔) bId₁ (msgPool st))
      → (v₂ : VoteForRound∈ pk round₂ (epoch 𝓔) bId₂ (msgPool st))
      → round₁ < round₂
      → α-ValidVote 𝓔 (msgVote v₁) mbr ≡ v₁abs
      → α-ValidVote 𝓔 (msgVote v₂) mbr ≡ v₂abs
      → (c3 : Cand-3-chain-vote (intSystemState st) v₁abs)
      → Σ (VoteParentData (intSystemState st) v₂abs)
            (λ vp → Cand-3-chain-head-round (intSystemState st) c3 ≤ Abs.round (vpParent vp))
   PreferredRoundProof {pk}{round₁}{round₂}{bId₁}{bId₂}{v₁abs}{v₂abs}{mbr}{st = post}
                       step@(step-s {pre = pre} r theStep) pkH v₁ v₂ r₁<r₂ refl refl c3
      with msgRound≡ v₁ | msgEpoch≡ v₁ | msgBId≡ v₁
         | msgRound≡ v₂ | msgEpoch≡ v₂ | msgBId≡ v₂
   ...| refl | refl | refl | refl | refl | refl
      with Impl-∈BI? (_vSignature (msgVote v₁)) | Impl-∈BI? (_vSignature (msgVote v₂))
   ...| yes init₁  | yes init₂  = let r₁≡0 = Impl-bsvr (msgSigned v₁) init₁
                                      r₂≡0 = Impl-bsvr (msgSigned v₂) init₂
                                  in ⊥-elim (<⇒≢ r₁<r₂ (trans r₁≡0 (sym r₂≡0)))
   ...| yes init₁  | no  ¬init₂ = let 0≡rv = sym (Impl-bsvr (msgSigned v₁) init₁)
                                      0<rv = v-cand-3-chain⇒0<roundv (intSystemState post) c3
                                  in ⊥-elim (<⇒≢ 0<rv 0≡rv)
   ...| no  ¬init₁ | yes init₂  = let 0≡r₂ = sym (Impl-bsvr (msgSigned v₂) init₂)
                                      r₁   = msgVote v₁ ^∙ vRound
                                  in ⊥-elim (<⇒≱ r₁<r₂ (subst (r₁ ≥_) 0≡r₂ z≤n))
   ...| no  ¬init₁ | no ¬init₂
      with theStep
   ...| step-peer {pid} {st'} {outs} cheat@(step-cheat c) = vpdPres
      where
              m₁sb4 = ¬cheatForgeNewSig r cheat unit pkH (msgSigned v₁) (msg⊆ v₁) (msg∈pool v₁) ¬init₁
              m₂sb4 = ¬cheatForgeNewSig r cheat unit pkH (msgSigned v₂) (msg⊆ v₂) (msg∈pool v₂) ¬init₂
              v₁sb4 = msgSentB4⇒VoteRound∈ (msgSigned v₁) m₁sb4
              v₂sb4 = msgSentB4⇒VoteRound∈ (msgSigned v₂) m₂sb4
              v₁abs' = α-ValidVote-trans {pk} {mbr} {pool = msgPool pre} (msgVote v₁) refl (proj₁ v₁sb4)
              v₂abs' = α-ValidVote-trans {pk} {mbr} {pool = msgPool pre} (msgVote v₂) refl (proj₁ v₂sb4)

              vpdPres : Σ (VoteParentData (intSystemState post) v₂abs)
                          (λ vp → Cand-3-chain-head-round (intSystemState post) c3 ≤ Abs.round (vpParent vp))
              vpdPres
                 with Cand-3-chain-vote-b4 {sp = step-cheat c} pkH r c3 (proj₁ v₁sb4)
              ...| c2' , c2'rnd≡
                 with PreferredRoundProof r pkH (proj₁ v₁sb4) (proj₁ v₂sb4) r₁<r₂ v₁abs' v₂abs' c2'
              ...| vpd , rnd≤
                 with stepPreservesVoteParentData theStep vpd
              ...| res , rnds≡ rewrite sym rnds≡ = res , ≤-trans (≤-reflexive c2'rnd≡) rnd≤
   ...| step-peer (step-honest stP)
      with ⊎-map₂ (msgSentB4⇒VoteRound∈ (msgSigned v₁))
                  (newMsg⊎msgSentB4 r stP pkH (msgSigned v₁) ¬init₁  (msg⊆ v₁) (msg∈pool v₁))
         | ⊎-map₂ (msgSentB4⇒VoteRound∈ (msgSigned v₂))
                  (newMsg⊎msgSentB4 r stP pkH (msgSigned v₂) ¬init₂ (msg⊆ v₂) (msg∈pool v₂))
   ...| inj₂ (v₁sb4 , refl) | inj₂ (v₂sb4 , refl)
        = vpdPres
          where
            v₁abs' = α-ValidVote-trans (msgVote v₁) refl v₁sb4
            v₂abs' = α-ValidVote-trans (msgVote v₂) refl v₂sb4

            vpdPres : _
            vpdPres
               with Cand-3-chain-vote-b4 {sp = step-honest stP} pkH r c3 v₁sb4
            ...| c2' , c2'rnd≡
               with PreferredRoundProof r pkH v₁sb4 v₂sb4 r₁<r₂ v₁abs' v₂abs' c2'
            ...| vpd , rnd≤
               with stepPreservesVoteParentData theStep vpd
            ...| res , pars≡ rewrite sym pars≡ =  res , ≤-trans (≤-reflexive c2'rnd≡) rnd≤
   ...| inj₁ (m₁∈outs , v₁pk , newV₁) | inj₁ (m₂∈outs , v₂pk , newV₂) =
              Impl-PR2 r stP pkH (msg⊆ v₁) m₁∈outs (msgSigned v₁) ¬init₁ newV₁ v₁pk (msg⊆ v₂)
                                           m₂∈outs (msgSigned v₂) ¬init₂ newV₂ v₂pk refl r₁<r₂ refl refl c3

   ...| inj₁ (m₁∈outs , v₁pk , v₁New) | inj₂ (v₂sb4 , refl) = help
        where
          round≡ = trans (msgRound≡ v₂sb4) (msgRound≡ v₂)
          ¬bootstrapV₂ = ¬Bootstrap∧Round≡⇒¬Bootstrap step pkH v₂ ¬init₂ (msgSigned v₂sb4) round≡
          epoch≡ = sym (msgEpoch≡ v₂sb4)

          implir0 : _
          implir0 = Impl-IRO r stP pkH (msg⊆ v₁) m₁∈outs (msgSigned v₁) ¬init₁ v₁New v₁pk (msg⊆ v₂sb4)
                                       (msg∈pool v₂sb4)  (msgSigned v₂sb4) ¬bootstrapV₂ epoch≡

          help : _
          help = either (λ r₂<r₁ → ⊥-elim (<⇒≯ r₁<r₂ (<-transʳ (≡⇒≤ (sym round≡)) r₂<r₁)))
                        (λ v₁sb4 → let v₁abs = α-ValidVote-trans (msgVote v₁) refl v₁sb4
                                       v₂abs = α-ValidVote-trans (msgVote v₂) refl v₂sb4
                                       c2'p  = Cand-3-chain-vote-b4 {sp = step-honest stP} pkH r c3 v₁sb4
                                       prp   = PreferredRoundProof r pkH v₁sb4 v₂sb4 r₁<r₂ v₁abs v₂abs (proj₁ c2'p)
                                       vpd'  = stepPreservesVoteParentData theStep (proj₁ prp)
                                   in (proj₁ vpd') , (≤-trans (≤-reflexive (proj₂ c2'p)) (proj₂ prp)))
                        implir0
   ...| inj₂ (v₁sb4 , refl)           | inj₁ (m₂∈outs , v₂pk , v₂New) = help
        where
          rv₁<r₂ = <-transʳ (≡⇒≤ (msgRound≡ v₁sb4)) r₁<r₂
          round≡ = trans (msgRound≡ v₁sb4) (msgRound≡ v₁)
          ¬bootstrapV₁ = ¬Bootstrap∧Round≡⇒¬Bootstrap step pkH v₁ ¬init₁ (msgSigned v₁sb4) round≡
          v₁abs' = α-ValidVote-trans (msgVote v₁) refl v₁sb4

          c2'p   = Cand-3-chain-vote-b4 {sp = step-honest stP} pkH r c3 v₁sb4

          implir1 : _
          implir1 = Impl-PR1 r stP pkH (msg⊆ v₂) m₂∈outs (msgSigned v₂) ¬init₂ v₂New v₂pk
                                   (msg⊆ v₁sb4) (msg∈pool v₁sb4) (msgSigned v₁sb4) ¬bootstrapV₁
                                   (msgEpoch≡ v₁sb4) rv₁<r₂ v₁abs' refl c3

          help : _
          help = either id
                        (λ v₂sb4 → let v₂abs' = α-ValidVote-trans (msgVote v₂) refl v₂sb4
                                       prp    = PreferredRoundProof r pkH v₁sb4 v₂sb4 r₁<r₂ v₁abs' v₂abs' (proj₁ c2'p)
                                       vpd'   = stepPreservesVoteParentData theStep (proj₁ prp)
                                   in (proj₁ vpd') , (≤-trans (≤-reflexive (proj₂ c2'p)) (proj₂ prp)))
                        implir1

   prr : Type (intSystemState st)
   prr honα refl sv refl sv' c2 round<
     with vmsg≈v (vmFor sv) | vmsg≈v (vmFor sv')
   ...| refl | refl
       = let v₁ = mkVoteForRound∈ (nm (vmFor sv)) (cv ((vmFor sv))) (cv∈nm (vmFor sv))
                                  (vmSender sv) (nmSentByAuth sv) (vmsgSigned (vmFor sv))
                                  (vmsgEpoch (vmFor sv)) refl refl
             v₂ = mkVoteForRound∈ (nm (vmFor sv')) (cv (vmFor sv')) (cv∈nm (vmFor sv'))
                                  (vmSender sv') (nmSentByAuth sv') (vmsgSigned (vmFor sv'))
                                  (vmsgEpoch (vmFor sv')) refl refl
         in PreferredRoundProof r honα v₁ v₂ round< refl refl c2


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)