{- 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.Parameters
import      LibraBFT.Impl.Consensus.ConsensusTypes.Block      as Block
import      LibraBFT.Impl.Consensus.ConsensusTypes.Properties.QuorumCert as QuorumCertProps
import      LibraBFT.Impl.Consensus.ConsensusTypes.Properties.VoteData as VoteDataProps
import      LibraBFT.Impl.Consensus.ConsensusTypes.QuorumCert as QuorumCert
import      LibraBFT.Impl.Consensus.ConsensusTypes.Vote       as Vote
import      LibraBFT.Impl.Consensus.ConsensusTypes.VoteData   as VoteData
open import LibraBFT.Impl.Consensus.SafetyRules.SafetyRules
import      LibraBFT.Impl.Handle                              as Handle
open import LibraBFT.Impl.Properties.Util
open import LibraBFT.Impl.OBM.Crypto                          as Crypto
open import LibraBFT.Impl.OBM.Logging.Logging
import      LibraBFT.Impl.Types.LedgerInfoWithSignatures      as LedgerInfoWithSignatures
open import LibraBFT.Impl.Types.ValidatorSigner               as ValidatorSigner
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Interface.Output
import      LibraBFT.ImplShared.Util.Crypto                   as Crypto
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.Hash
open import Util.KVMap                                        as Map
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

open        ParamsWithInitAndHandlers Handle.InitHandler.initAndHandlers
open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms
                      Handle.InitHandler.initAndHandlers
                      PeerCanSignForPK PeerCanSignForPK-stable
open Invariants
open RoundManagerTransProps

module LibraBFT.Impl.Consensus.SafetyRules.Properties.SafetyRules where

module verifyAndUpdatePreferredRoundDefs (quorumCert : QuorumCert) (safetyData : SafetyData) where
  preferredRound = safetyData ^∙ sdPreferredRound
  oneChainRound  = quorumCert ^∙ qcCertifiedBlock ∙ biRound
  twoChainRound  = quorumCert ^∙ qcParentBlock ∙ biRound

  C₁ = oneChainRound < preferredRound
  C₂ = twoChainRound > preferredRound
  C₃ = twoChainRound < preferredRound
  C₄ = twoChainRound ≡ preferredRound

  safetyData' = safetyData & sdPreferredRound ∙~ twoChainRound

module verifyAndUpdatePreferredRoundMSpec (quorumCert : QuorumCert) (safetyData : SafetyData) where
  open verifyAndUpdatePreferredRoundDefs quorumCert safetyData

  module _ (pre : RoundManager) where
    record setPR (sd : SafetyData) : Set where
      field
        cond  : C₂
        eff   : sd ≡ safetyData'

    record noChanges (sd : SafetyData) : Set where
      field
        noUpd : sd ≡ safetyData

    record ConditionCorrectR (sd : SafetyData) : Set where
      field
        ep≡    : sd ≡L safetyData at sdEpoch
        qcr≤pr : quorumCert ^∙ qcParentBlock ∙ biRound ≤ sd ^∙ sdPreferredRound
        conds  : noChanges sd ⊎ setPR sd
    open ConditionCorrectR public

    ConditionCorrect : Either ErrLog SafetyData → Set
    ConditionCorrect (Left _)   = ⊤
    ConditionCorrect (Right sd) = ConditionCorrectR sd

    record Contract (r : Either ErrLog SafetyData) (post : RoundManager) (outs : List Output) : Set where
      constructor mkContract
      field
        noOuts        : OutputProps.NoMsgs outs
        noEff         : post ≡ pre
        condCorr      : ConditionCorrect r

  contract
      : ∀ pre
        → LBFT-weakestPre (verifyAndUpdatePreferredRoundM quorumCert safetyData)
                          (Contract pre) pre
  proj₁ (contract pre) _ = mkContract refl refl tt
  proj₂ (contract pre) x rewrite x
     with <-cmp twoChainRound preferredRound
  ...| tri< lt _   _  = λ where ._ refl ._ refl → mkContract refl refl
                                                    (record { ep≡ = refl
                                                            ; qcr≤pr = <⇒≤ lt
                                                            ; conds = inj₁ (record { noUpd = refl }) })
  ...| tri≈ _ refl _  = λ where ._ refl         → mkContract refl refl
                                                    (record { ep≡ = refl
                                                            ; qcr≤pr = ≤-refl
                                                            ; conds = inj₁ (record { noUpd = refl }) })
  ...| tri> _ _    gt = λ where ._ refl ._ refl → mkContract refl refl
                                                    (record { ep≡ = refl
                                                            ; qcr≤pr = ≤-refl
                                                            ; conds = inj₂ (record { cond = gt ; eff = refl }) })

module extensionCheckSpec (voteProposal : VoteProposal) where
  proposedBlock = voteProposal ^∙ vpBlock
  obmAEP        = voteProposal ^∙ vpAccumulatorExtensionProof

  voteData      =
     (VoteData.new
       (Block.genBlockInfo
         proposedBlock
         -- OBM-LBFT-DIFF: completely different
         (Crypto.obmHashVersion (obmAEP ^∙ aepObmNumLeaves))
         (obmAEP ^∙ aepObmNumLeaves)
         (voteProposal ^∙ vpNextEpochState))
       (proposedBlock ^∙ bQuorumCert ∙ qcCertifiedBlock))

  contract -- TODO-1: refine (waiting on: extensionCheckM)
    : ∀ {ℓ} (Post : Either ErrLog VoteData → Set ℓ)
      → (∀ e → Post (Left e))
      → (Post (pure voteData))
      → Post (extensionCheck voteProposal)
  contract Post pfBail pfOk = pfOk

module constructLedgerInfoMSpec (proposedBlock : Block) (consensusDataHash : HashValue) where
  -- This is a place-holder contract that requires refinement once
  -- `constructLedgerInfoM is implemented.
  postulate -- TODO-1: refine and prove
    contract
      : ∀ P pre
        → P (inj₁ fakeErr) pre []
        → (∀ ledgerInfo → P (inj₂ ledgerInfo) pre [])
        → LBFT-weakestPre (constructLedgerInfoM proposedBlock consensusDataHash) P pre

-- TUTORIAL: Weakest preconditions generated from conditionals, translating a
-- boolean equality test to proofs of (in)equality.
module verifyEpochMSpec (epoch : Epoch) (safetyData : SafetyData) where
  -- The body of `verifyEpochM` is:
  -- > ifM not ⌊ epoch ≟ℕ safetyData ^∙ sdEpoch ⌋
  -- >   then bail fakeErr -- log: error: incorrect epoch
  -- >   else ok unit
  contract
    : ∀ P pre
      → (epoch ≢ safetyData ^∙ sdEpoch → P (inj₁ fakeErr) pre [])
      → (epoch ≡ safetyData ^∙ sdEpoch → P (inj₂ unit) pre [])
      → LBFT-weakestPre (verifyEpochM epoch safetyData) P pre
  -- The outermost node of the AST of `verifyEpochM` is `ifM_then_else_ ...`, so
  -- our goal is to return a product: one proof corresponding to the "then" case
  -- one and one proof corresponding to the "else" case.
  --
  -- 1. In the "then" case, we recieve a proof `e≢` that
  --    > toBool (not ⌊ epoch ≟ℕ safetyData ^∙ sdEpoch ⌋) ≡ true
  proj₁ (contract Post pre pfBail pfOk) e≢
  --    - abstract over the expression that prevents us from analyzing this evidence
     with epoch ≟ℕ safetyData ^∙ sdEpoch
  --    - Agda can tell that `yes pf` is not an option, since e≢ would have type
  --      `false ≡ true` in that case
  ...| no  pf = pfBail pf
  -- 2. In the "else" case, we receive a proof `e≡` that
  --    > toBool (not ⌊ epoch ≟ℕ safetyData ^∙ sdEpoch ⌋) ≡ false
  proj₂ (contract Post pre pfBail pfOk) e≡
  --    - perform the same `with` abstraction as the previous case
     with epoch ≟ℕ safetyData ^∙ sdEpoch
  --    - Agda can tell that `no pf` is not an option
  ...| yes pf = pfOk pf

-- TUTORIAL: Translating boolean comparison tests to proofs.
module verifyAndUpdateLastVoteRoundMSpec (round : Round) (safetyData : SafetyData) where
  safetyData' = safetyData & sdLastVotedRound ∙~ round
  -- This example shows that we could have further simplified the proof of the
  -- contract for `verifyEpochM`. In `Util.Prelude`, we define lemmas
  -- > toWitnessT : ∀{ℓ}{P : Set ℓ}{d : Dec P} → ⌊ d ⌋ ≡ true → P
  -- > toWitnessF : ∀{ℓ}{P : Set ℓ}{d : Dec P} → ⌊ d ⌋ ≡ false → ¬ P
  -- which extract the underlying proof used to construct `d` given evidence
  -- that "lowering" `d` to a boolean produces `true` or `false`.
  contract
    : ∀ P pre
      → ((r>lvr : round > safetyData ^∙ sdLastVotedRound) → P (Right safetyData') pre [])
      → ((r≤lvr : ¬ (round > safetyData ^∙ sdLastVotedRound)) → P (Left fakeErr) pre [])
      → LBFT-weakestPre (verifyAndUpdateLastVoteRoundM round safetyData) P pre
  proj₁ (contract Post pre pfOk pfBail) r>lvr = pfOk (toWitnessT r>lvr)
  proj₂ (contract Post pre pfOk pfBail) ¬r>lvr = pfBail (toWitnessF ¬r>lvr)

module verifyQcMSpec (self : QuorumCert) where
  getVv : RoundManager → ValidatorVerifier
  getVv = _^∙ (rmEpochState ∙ esVerifier)

  -- See comment on contract below to understand the motivation for stating and proving the property
  -- this way.

  Contract : RoundManager → RWS-Post Output RoundManager (Either ErrLog Unit)
  Contract pre (Left _)  post outs = post ≡ pre × outs ≡ []
  Contract pre (Right _) post outs = post ≡ pre × outs ≡ []
                                   × QuorumCertProps.Contract self (getVv pre)

  contract' : ∀ pre → RWS-weakestPre (verifyQcM self) (Contract pre) unit pre
  contract' _ _ _ (Left x₂) _ = refl , refl
  contract' pre vv refl (Right unit) x₁ = refl , refl , QuorumCertProps.contract self vv (Right unit) refl (sym x₁)

  -- Suppose verifyQcM runs from prestate pre, and we wish to ensure that postcondition Post holds
  -- afterwards.  If P holds provided verifyQcM does not modify the state and does not produce any
  -- Outputs, and, if verifyQcM succeeds (returns Right unit), P holds provided
  -- QuorumCertProps.Contract holds for the given QuorumCert and the ValidatorVerifier of the
  -- prestate, then verifyQcM ensures P holds.  Proving this directly is painful because it's
  -- difficult to construct a QuorumCertProps.Contract self (getVv pre) that Agda understands allows
  -- us to invoke the rPrf (condition on P in case verifyQcM succeeds).  Therefore, we restate the
  -- conditions on P (as P', above) and prove that P' implies P, and then use LBFT-⇒ to achieve
  -- the desired result.
  contract
    : ∀ P pre
    → (∀ {e} → P (Left e) pre [])  -- verifyQcM does not emit any outputs, it just propagates a Left ErrLog, hence []
    → (QuorumCertProps.Contract self (getVv pre) → P (Right unit) pre [])
    → RWS-weakestPre (verifyQcM self) P unit pre
  contract Post pre lPrf rPrf = LBFT-⇒ (verifyQcM self) pre
                                       (contract' pre)
                                       (λ { (Left x₁) st outs (refl , refl)          → lPrf
                                          ; (Right unit) st outs (refl , refl , prf) → rPrf prf })

module constructAndSignVoteMSpec where

  VoteResultCorrect : (pre post : RoundManager) (block : Block) (lvr≡? : Bool) (r : Either ErrLog Vote) → Set
  VoteResultCorrect pre post block lvr≡? (Left e) = VoteNotGenerated pre post lvr≡?
  VoteResultCorrect pre post block lvr≡? (Right vote) = Voting.VoteGeneratedCorrect pre post vote block

  record Contract (pre : RoundManager) (block : Block) (r : Either ErrLog Vote) (post : RoundManager) (outs : List Output) : Set where
    constructor mkContract
    field
      -- General properties / invariants
      rmInv          : Preserves RoundManagerInv pre post
      noEpochChange  : NoEpochChange pre post
      noMsgOuts      : OutputProps.NoMsgs outs
      -- Voting
      lvr≡?          : Bool
      voteResCorrect : VoteResultCorrect pre post block lvr≡? r

  private
    contractBail : ∀ {pre block e} outs → OutputProps.NoMsgs outs → Contract pre block (Left e) pre outs
    contractBail{pre} outs noMsgs =
      mkContract
        reflPreservesRoundManagerInv
        (reflNoEpochChange{pre})
        noMsgs
        true reflVoteNotGenerated

  module continue2
    (voteProposal : VoteProposal) (validatorSigner : ValidatorSigner)
    (proposedBlock : Block)       (safetyData : SafetyData) where

    open constructAndSignVoteM-continue2 voteProposal validatorSigner proposedBlock safetyData

    record Requirements (pre : RoundManager) : Set where
      constructor mkRequirements
      field
        es≡₁  : (pre ^∙ pssSafetyData-rm) ≡L safetyData at sdEpoch
        es≡₂  : voteProposal ^∙ vpBlock ∙ bEpoch ≡ safetyData ^∙ sdEpoch
        lv≡  : (pre ^∙ pssSafetyData-rm) ≡L safetyData at sdLastVote
        lvr≡ : (pre ^∙ pssSafetyData-rm) ≡L safetyData at sdLastVotedRound
        vp≡pb : proposedBlock ≡ voteProposal ^∙ vpBlock

    contract'
      : ∀ pre
        → Requirements pre
        → LBFT-weakestPre
            (constructAndSignVoteM-continue2 voteProposal validatorSigner proposedBlock safetyData)
            (Contract pre proposedBlock) pre
    contract' pre reqs =
      verifyAndUpdateLastVoteRoundMSpec.contract (proposedBlock ^∙ bRound) safetyData
        (RWS-weakestPre-ebindPost unit step₁ (Contract pre proposedBlock)) pre
        contract-step₁
        (λ r≤lvr → contractBail _ refl)
      where
      module _ (r>lvr : proposedBlock ^∙ bRound > safetyData ^∙ sdLastVotedRound) where
        -- Shared definitions
        module _ where
          safetyData1 = verifyAndUpdateLastVoteRoundMSpec.safetyData' (proposedBlock ^∙ bRound) safetyData
          preUpdatedSD = pre & pssSafetyData-rm ∙~ safetyData1
          author = validatorSigner ^∙ vsAuthor

        -- State invariants
        module _ where
          bsip₁ : Preserves BlockStoreInv (rm→BlockStore-EC pre) (rm→BlockStore-EC preUpdatedSD)
          bsip₁ = id

          emP : Preserves EpochsMatch pre preUpdatedSD
          emP eq = trans eq (Requirements.es≡₁ reqs)

          srPre  = pre ^∙ lSafetyRules
          srPost = preUpdatedSD ^∙ lSafetyRules

          srP : Preserves SafetyRulesInv srPre srPost
          srP = mkPreservesSafetyRulesInv λ where (mkSafetyDataInv epoch≡ round≤) →
                                                    mkSafetyDataInv (epoch≡P epoch≡) (round≤P round≤)
            where
            epoch≡P : Preserves (λ sd → Meta.getLastVoteEpoch sd ≡ sd ^∙ sdEpoch)
                                (srPre ^∙ (srPersistentStorage ∙ pssSafetyData))
                                (srPost ^∙ (srPersistentStorage ∙ pssSafetyData))
            epoch≡P epoch≡
              rewrite sym (Requirements.lv≡  reqs)
              |       sym (Requirements.es≡₁ reqs)
              = epoch≡
            round≤P : Preserves (λ sd → Meta.getLastVoteRound sd ≤ sd ^∙ sdLastVotedRound)
                                (srPre ^∙ (srPersistentStorage ∙ pssSafetyData))
                                (srPost ^∙ (srPersistentStorage ∙ pssSafetyData))
            round≤P round≤
               with pre ^∙ pssSafetyData-rm ∙ sdLastVote
               |    inspect (_^∙ pssSafetyData-rm ∙ sdLastVote) pre
            ...| nothing | [ lv≡ ] rewrite (trans (sym (Requirements.lv≡ reqs)) lv≡) = z≤n
            ...| just x  | [ lv≡ ] rewrite (trans (sym (Requirements.lv≡ reqs)) lv≡) =
              ≤-trans round≤ (≤-trans (≡⇒≤ (Requirements.lvr≡ reqs)) (<⇒≤ r>lvr))

          invP₁ : Preserves RoundManagerInv pre preUpdatedSD
          invP₁ = mkPreservesRoundManagerInv id emP bsip₁ srP

        -- Some lemmas
        module _ where
          lvr<pbr : pre ^∙ pssSafetyData-rm ∙ sdLastVotedRound < proposedBlock ^∙ bRound
          lvr<pbr rewrite (Requirements.lvr≡ reqs) = r>lvr

          vpr≡pbr : (voteProposal ^∙ vpBlock) ≡L proposedBlock at bRound
          vpr≡pbr rewrite Requirements.vp≡pb reqs = refl

        bailAfterSetSafetyData : ∀ e → Contract pre proposedBlock (Left e) preUpdatedSD []
        bailAfterSetSafetyData e =
          mkContract invP₁ refl refl false (mkVoteNotGenerated (Requirements.lv≡ reqs) lvr<pbr)

        contract-step₁ : RWS-weakestPre-ebindPost unit step₁ (Contract pre proposedBlock) (Right _) pre []
        contract-step₂ : RWS-weakestPre-ebindPost unit (step₂ safetyData1) (Contract pre proposedBlock) (Right _) preUpdatedSD []

        contract-step₁ ._ refl ._ refl .unit refl =
          extensionCheckSpec.contract voteProposal
            (λ r → RWS-weakestPre-ebindPost unit (step₂ safetyData1) (Contract pre proposedBlock) r preUpdatedSD [])
            bailAfterSetSafetyData contract-step₂

        contract-step₂ voteData@._ refl =
          constructLedgerInfoMSpec.contract proposedBlock (hashVD voteData)
            (RWS-weakestPre-∙^∙Post unit (withErrCtx ("" ∷ []))
              (RWS-weakestPre-ebindPost unit (step₃ safetyData1 voteData author) (Contract pre proposedBlock))) preUpdatedSD
              (λ where .(Left fakeErr) refl → bailAfterSetSafetyData fakeErr)
              contract-step₃
          where
          contract-step₃
            : ∀ ledgerInfo
              → RWS-weakestPre-∙^∙Post unit (withErrCtx ("" ∷ []))
                  (RWS-weakestPre-ebindPost unit (step₃ safetyData1 _ author) (Contract pre proposedBlock))
                  (Right ledgerInfo) preUpdatedSD []
          contract-step₃ ledgerInfo ._ refl ._ refl ._ refl .unit refl unit refl =
            mkContract invP₂ refl refl false
              (Voting.mkVoteGeneratedCorrect
                (mkVoteGenerated refl
                  (inj₂ (mkVoteNewGenerated lvr<pbr vpr≡pbr)))
              voteFromBlock)
            where
            vote = Vote.newWithSignature voteData author ledgerInfo (ValidatorSigner.sign validatorSigner ledgerInfo)
            preUpdatedSD₂ = preUpdatedSD & pssSafetyData-rm ∙~ (safetyData1 & sdLastVote ?~ vote)

            pb≡vpb = sym (Requirements.vp≡pb reqs)

            voteFromBlock : Voting.VoteMadeFromBlock vote proposedBlock
            voteFromBlock =
              Voting.mkVoteMadeFromBlock
                (cong (_^∙ bEpoch) pb≡vpb) (cong (_^∙ bRound) pb≡vpb) (cong (_^∙ bId) pb≡vpb)

            -- State invariants
            module _ where
              bsiP₂ : Preserves BlockStoreInv (rm→BlockStore-EC pre) (rm→BlockStore-EC preUpdatedSD₂)
              bsiP₂ = id

              srP₂ : Preserves SafetyRulesInv (pre ^∙ lSafetyRules) (preUpdatedSD₂ ^∙ lSafetyRules)
              srP₂ = mkPreservesSafetyRulesInv
                       (const $ mkSafetyDataInv (Requirements.es≡₂ reqs) (≡⇒≤ (cong (_^∙ bRound) pb≡vpb)))

              invP₂ : Preserves RoundManagerInv pre preUpdatedSD₂
              invP₂ = mkPreservesRoundManagerInv id emP bsiP₂ srP₂

    contract
      : ∀ pre Post
        → Requirements pre
        → RWS-Post-⇒ (Contract pre proposedBlock) Post
        → LBFT-weakestPre
            (constructAndSignVoteM-continue2 voteProposal validatorSigner proposedBlock safetyData)
            Post pre
    contract pre Post reqs pf =
      LBFT-⇒ (constructAndSignVoteM-continue2 voteProposal validatorSigner proposedBlock safetyData)
             pre (contract' pre reqs) pf

  module continue1
    (voteProposal  : VoteProposal) (validatorSigner : ValidatorSigner)
    (proposedBlock : Block)        (safetyData0     : SafetyData) where

    open constructAndSignVoteM-continue1 voteProposal validatorSigner proposedBlock safetyData0

    record Requirements (pre : RoundManager) : Set where
      constructor mkRequirements
      field
        sd≡   : pre ^∙ pssSafetyData-rm ≡ safetyData0
        es≡   : voteProposal ^∙ vpBlock ∙ bEpoch ≡ safetyData0 ^∙ sdEpoch
        vp≡pb : proposedBlock ≡ voteProposal ^∙ vpBlock

    contract
      : ∀ pre → Requirements pre
        → LBFT-weakestPre (constructAndSignVoteM-continue1 voteProposal validatorSigner proposedBlock safetyData0)
            (Contract pre proposedBlock) pre
    contract pre reqs =
      verifyQcMSpec.contract (proposedBlock ^∙ bQuorumCert)
        (RWS-weakestPre-ebindPost unit (λ _ → step₁) (Contract pre proposedBlock)) pre
        (contractBail _ refl)
        contract-step₁
      where
      contract-step₁ : QuorumCertProps.Contract _ _ → RWS-weakestPre-ebindPost unit (const step₁) (Contract pre proposedBlock) (Right unit) pre []
      contract-step₁ qcCon ._ refl validatorVerifier@._ refl
        with Block.validateSignature proposedBlock validatorVerifier
      ... | Left e = contractBail _ refl
      ... | Right unit = λ where ._ refl → contract-step₃
        where
        contract-step₃ : RWS-weakestPre step₃ (Contract pre proposedBlock) unit pre
        contract-step₃ =
          LBFT-⇒ (verifyAndUpdatePreferredRoundM (proposedBlock ^∙ bQuorumCert) safetyData0) pre
            (verifyAndUpdatePreferredRoundMSpec.contract (proposedBlock ^∙ bQuorumCert) safetyData0 pre) pf-step₃
          -- verifyAndUpdatePreferredRoundMSpec.contract (proposedBlock ^∙ bQuorumCert) safetyData0
          --   Pred pre (λ r≤pr → contractBail _ refl) cases
            where
            VAUPContract = verifyAndUpdatePreferredRoundMSpec.Contract (proposedBlock ^∙ bQuorumCert) safetyData0
            Pred = RWS-weakestPre-ebindPost unit
                     (constructAndSignVoteM-continue2 voteProposal validatorSigner proposedBlock)
                     (Contract pre proposedBlock)

            reqs₁ : continue2.Requirements voteProposal validatorSigner proposedBlock safetyData0 pre
            reqs₁
              with Requirements.sd≡ reqs
            ...| refl = continue2.mkRequirements refl (Requirements.es≡ reqs) refl refl (Requirements.vp≡pb reqs)

            reqs₂ : continue2.Requirements voteProposal validatorSigner proposedBlock
                      (verifyAndUpdatePreferredRoundDefs.safetyData' (proposedBlock ^∙ bQuorumCert) safetyData0)
                      pre
            reqs₂
              with Requirements.sd≡ reqs
            ...| refl = continue2.mkRequirements refl (Requirements.es≡ reqs) refl refl (Requirements.vp≡pb reqs)

            pf-step₃ : ∀ r st outs → VAUPContract pre r st outs → Pred r st outs
            pf-step₃ r st outs (verifyAndUpdatePreferredRoundMSpec.mkContract noOuts refl condCorr) = pf r condCorr
              where
              pf-Con++outs : RWS-Post-⇒ (Contract pre proposedBlock) (RWS-Post++ (Contract pre proposedBlock) outs)
              pf-Con++outs r' st' outs' (mkContract rmInv noEpochChange noMsgOuts lvr≡? voteResCorrect) =
                mkContract rmInv noEpochChange (OutputProps.++-NoMsgs outs outs' noOuts noMsgOuts) lvr≡? voteResCorrect

              pf : (r : Either ErrLog SafetyData) (cc : verifyAndUpdatePreferredRoundMSpec.ConditionCorrect _ _ pre r) → Pred r st outs
              pf (Left e) tt = contractBail outs noOuts
              pf (Right .safetyData0) record { ep≡ = ep≡ ; qcr≤pr = qcr≤pr ; conds = (Left record { noUpd = refl }) } ._ refl =
                continue2.contract voteProposal validatorSigner proposedBlock safetyData0 pre
                  (RWS-Post++ (Contract pre proposedBlock) outs) reqs₁
                  pf-Con++outs
              pf (Right safetyData1@._) record { ep≡ = ep≡ ; qcr≤pr = qcr≤pr ; conds = (Right record { eff = refl }) } ._ refl =
                continue2.contract voteProposal validatorSigner proposedBlock safetyData1 pre
                  (RWS-Post++ (Contract pre proposedBlock) outs)
                  reqs₂ pf-Con++outs

  module continue0
    (voteProposal  : VoteProposal) (validatorSigner : ValidatorSigner) where

    open constructAndSignVoteM-continue0 voteProposal validatorSigner

    contract
      : ∀ pre
        → LBFT-weakestPre
            (constructAndSignVoteM-continue0 voteProposal validatorSigner) (Contract pre proposedBlock) pre
    contract pre safetyData0@._ refl =
      -- NOTE: There is a redundant check for this (that the proposal epoch
      -- matches the safety data epoch) in `LibraBFT.Impl.Consensus.Network`
      verifyEpochMSpec.contract (proposedBlock ^∙ bEpoch) safetyData0
        (RWS-weakestPre-ebindPost unit (const (step₁ safetyData0)) (Contract pre proposedBlock)) pre
        (λ e≢sde → contractBail _ refl)
        contract-step₁
      where
      module _ (e≡sde : proposedBlock ^∙ bEpoch ≡ pre ^∙ pssSafetyData-rm ∙ sdEpoch) where
        contract-step₁
          : RWS-weakestPre-ebindPost unit (const (step₁ safetyData0)) (Contract pre proposedBlock) (Right unit) pre []
        proj₁ (contract-step₁ .unit refl) ≡nothing =
          continue1.contract voteProposal validatorSigner proposedBlock safetyData0 pre
            (continue1.mkRequirements refl e≡sde refl)
        proj₁ (proj₂ (contract-step₁ .unit refl) vote vote≡) lvr≡pbr =
          mkContract reflPreservesRoundManagerInv (reflNoEpochChange{pre}) refl
            true (Voting.mkVoteGeneratedCorrect
                   (mkVoteGenerated (sym vote≡)
                     (inj₁ reflVoteOldGenerated))
                   (toWitnessT lvr≡pbr))
        proj₂ (proj₂ (contract-step₁ .unit refl) vote vote≡) lvr≢pbr =
          continue1.contract voteProposal validatorSigner proposedBlock safetyData0 pre
            (continue1.mkRequirements refl e≡sde refl)

  module _ (maybeSignedVoteProposal : MaybeSignedVoteProposal) where

    voteProposal  = maybeSignedVoteProposal ^∙ msvpVoteProposal
    proposedBlock = voteProposal ^∙ vpBlock

    contract'
      : ∀ pre
        → LBFT-weakestPre (constructAndSignVoteM maybeSignedVoteProposal) (Contract pre proposedBlock) pre
    contract' pre nothing vs≡ =
      mkContract
        reflPreservesRoundManagerInv (reflNoEpochChange{pre})
        refl true reflVoteNotGenerated
    contract' pre (just validatorSigner) vs≡ = continue0.contract voteProposal validatorSigner pre

    contract
      : ∀ pre Post → RWS-Post-⇒ (Contract pre proposedBlock) Post
        → LBFT-weakestPre (constructAndSignVoteM maybeSignedVoteProposal) Post pre
    contract pre Post pf =
      RWS-⇒ (constructAndSignVoteM maybeSignedVoteProposal) unit pre (contract' pre) pf

private
  module Tutorial
    (voteProposal : VoteProposal) (validatorSigner : ValidatorSigner)
    (proposedBlock : Block)       (safetyData : SafetyData) where

    -- After some experience with these proofs, it (allegedly)
    -- becomes fairly straightforward to let Agda do a lot of the
    -- work, and unfold the proof as we go.  However, it is
    -- important to understand what's going on under the hood to be
    -- able to reliably do this.  For the proof below, we do it in
    -- excruciating detail "by hand" in comments as an example to
    -- help ourselves understand.

    -- For this example, we will prove that `step₃` of (and old version of)
    -- `constructAndSignVoteM-continue2` produces no output.

    Contract : LBFT-Post (Either ErrLog Vote)
    Contract x post outs = outs ≡ []

    step₃ : SafetyData → VoteData → Author → LedgerInfo → LBFT (Either ErrLog Vote)
    step₃ safetyData1 voteData author ledgerInfo = do
      let signature = ValidatorSigner.sign validatorSigner ledgerInfo
          vote      = Vote.newWithSignature voteData author ledgerInfo signature
      pssSafetyData-rm ∙= (safetyData1 & sdLastVote ?~ vote)
      ok vote

    step₃-contract
      : ∀ pre safetyData1 voteData author ledgerInfo
        → LBFT-weakestPre
            (step₃ safetyData1 voteData author ledgerInfo)
            Contract pre
    step₃-contract pre safetyData1 voteData author ledgerInfo
    {-
    The proof can be as simple as this:

       = λ _ _ _ _ → refl

    Easy, right?!  Oh, you want a little more detail?  Sure here you go:

       = λ where .pre refl →
                  λ where .unit refl →
                           refl   -- Indenting important for parsing

    Still not crystal clear?  OK, let's explore in a little more detail.

    The initial goal looks like this:

    RWS-weakestPre-bindPost unit
      (λ st →
         RWS-put
         (LibraBFT.ImplShared.Consensus.Types.s st
          ((λ { F rf f (SafetyRules∙new v vv vvv)
                  → (rf Category.Functor.RawFunctor.<$>
                     (λ y' → SafetyRules∙new y' vv vvv))
                    (f v)
              })
           (λ x → x) Optics.Functorial.if
           ((λ { F rf f (PersistentSafetyStorage∙new v vv)
                   → (rf Category.Functor.RawFunctor.<$>
                      (λ y' → PersistentSafetyStorage∙new y' vv))
                     (f v)
               })
            (λ x → x) Optics.Functorial.if
            (λ _ →
               safetyData1 &
               sdLastVote ?~
               Vote.newWithSignature voteData author ledgerInfo
               (ValidatorSigner.sign validatorSigner ledgerInfo)))
           (LibraBFT.ImplShared.Consensus.Types.g st))))
      (RWS-weakestPre-bindPost unit
       (λ _ →
          RWS-return
          (inj₂
           (Vote.newWithSignature voteData author ledgerInfo
            (ValidatorSigner.sign validatorSigner ledgerInfo))))
       Contract)
      pre pre []

   It looks a bit ugly, but if we use C-u C-c C-, we get a more
   readable version that is exactly what we expect:

     LBFT-weakestPre (step₃ safetyData1 voteData author ledgerInfo)
                     Contract
                     pre

   Let's start refining by hand to understand.

   By desugaring the definition of "step₃ safetyData voteData author
   ledgerInfo" a bit, we can see that it is (using some shorthand in
   "quotes" to keep it concise at the expense of accuracy):

      (RWS-bind
         (RWS-bind
            (RWS-gets id)                                                                -- Fetch the state.
            (λ st → RWS-put (st & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote")))-- Modify the state returned by RWS-get.
         (λ _ → RWS-return (inj₂ "vote"))                                                -- The Unit returned by RWS-bind
                                                                                -- via RWS-put is ignored

      Note that "vote" is: Vote.newWithSignature voteData author ledgerInfo
                             (ValidatorSigner.sign validatorSigner ledgerInfo)

   Rewriting our goal with this yields (the annotations on the right
   show how we instantiate the rules in the next step):

     RWS-weakestPre
      (RWS-bind
         (RWS-bind                                                              = m
            (RWS-gets id)
            (λ st → RWS-put (st & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote")))
         (λ _ → RWS-return (inj₂ "vote"))                                       = f
      Contract                                                                   = P
      unit                                                                       = ev
      pre                                                                        = st

   Applying the definition of RWS-weakestPre (RWS-bind...), we need:

     RWS-weakestPre
       (RWS-bind
            (RWS-gets id)                                                                 = m
            (λ st → RWS-put (st & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))) = f
       (RWS-weakestPre-bindPost unit                                                      = P
         (λ _ → RWS-return (inj₂ vote))
         Contract)
       unit                                                                                = ev
       pre                                                                                = pre

   Applying the definition of RWS-weakestPre (RWS-bind...) again, we have:

     RWS-weakestPre
       (RWS-gets id)
       (RWS-weakestPre-bindPost unit                                            = P
         (λ st → RWS-put (st & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote")))
         (RWS-weakestPre-bindPost unit
           (λ _ → RWS-return (inj₂ vote))
           Contract))
       unit                                                                      = ev
       pre                                                                       = pre

   Now applying the definition of RWS-weakestPre RWS-gets, we want:

     (RWS-weakestPre-bindPost
         unit                                                                           = ev
         (λ st → RWS-put (st & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))) = f
         (RWS-weakestPre-bindPost unit                                                 = Post
           (λ _ → RWS-return (inj₂ "vote"))
           Contract))
       pre                                                                              = x
       pre                                                                              = post
       []                                                                               = outs

   Take a moment to compare this with our initial goal above.  They
   look identical, except for the shorthand.

   Next, we apply the definition of RWS-weakestPre-bindPost:

     ∀ r → r ≡ pre →
       RWS-weakestPre
         (RWS-put (r & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote")))
         (RWS-Post++
           (RWS-weakestPre-bindPost unit                                        = P
             (λ _ → RWS-return (inj₂ "vote"))
             Contract)
           [])                                                                   = outs
         unit
         pre

   Notice that our "f" (the put operation) is applied to the quantified variable
   "r". This is to reduce the size of the refined goal after substitution
   (instead of "pre", in general "r" could be equal to a much more complex expression).

   Applying the definition of RWS-Post++, we have:

     ∀ r → r ≡ pre →
       RWS-weakestPre
         (RWS-put (r & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote")))
         (λ x post outs₁ → (RWS-weakestPre-bindPost unit
                             (λ _ → RWS-return (inj₂ "vote"))
                             Contract) x post ([] ++ outs₁))
         unit
         pre

   Our proof begins by peeling of the two first parameters, the first
   of which must be pre, due to the second:

   -}

       = λ where .pre refl →

   {-

   At this point, our goal looks like (using C-u C-c C-,):

   RWS-weakestPre
      (RWS-put
       (over pssSafetyData-rm
        (λ _ →
           safetyData1 &
           sdLastVote ?~
           Vote.newWithSignature voteData author ledgerInfo
           (ValidatorSigner.sign validatorSigner ledgerInfo))
        pre))
      (λ x post outs₁ →
         RWS-weakestPre-bindPost unit
         (λ _ →
            RWS-return
            (inj₂
             (Vote.newWithSignature voteData author ledgerInfo
              (ValidatorSigner.sign validatorSigner ledgerInfo))))
         Contract x post ([] ++ outs₁))
      unit pre

   We can see that this is a more precise version of what we have above (without the shorthand),
   repeated here:

       RWS-weakestPre
         (RWS-put (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))) = post
         (λ x post outs₁ → (RWS-weakestPre-bindPost unit                         = P
                             (λ _ → RWS-return (inj₂ "vote"))
                             Contract) x post ([] ++ outs₁))
         unit
         pre

   Next, we apply the definition of RWS-weakestPre (RWS-put ...)

      (λ x post outs₁ → (RWS-weakestPre-bindPost unit
                          (λ _ → RWS-return (inj₂ "vote"))
                          Contract) x post ([] ++ outs₁))
      unit
      (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))
      []

    Instantiating,

      RWS-weakestPre-bindPost
       unit                                                                   = ev
       (λ _ → RWS-return (inj₂ "vote"))                                      = f
       Contract                                                               = Post
       unit                                                                   = x
       (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))          = post
       ([] ++ []))                                                            = outs

    Applying the definition of RWS-weakestPre-bindPost once again, we have:

      ∀ r → r ≡ unit → RWS-weakestPre
                         (RWS-return (inj₂ "vote"))
                         (RWS-Post++
                           Contract                                           = P
                           ([] ++ [])))                                       = outs
                         unit
                         (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))

    And applying the definition of RWS-Post++ yields:

      ∀ r → r ≡ unit → RWS-weakestPre
                         (RWS-return (inj₂ "vote"))
                         (λ x post outs₁ → Contract rm x post ([] ++ [] ++ outs₁))
                         unit
                         (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))

    Peeling off another couple of parameters (the first must be unit because of the second):
 -}

                      λ where .unit refl →

 {-

 The goal now looks like (using C-c C-,):

    Contract
      (inj₂
       (Vote.newWithSignature voteData author ledgerInfo
        (ValidatorSigner.sign validatorSigner ledgerInfo)))
      (LibraBFT.ImplShared.Consensus.Types.s pre
       ((λ { F rf f (SafetyRules∙new v vv vvv)
               → (rf Category.Functor.RawFunctor.<$>
                  (λ y' → SafetyRules∙new y' vv vvv))
                 (f v)
           })
        (λ x → x) Optics.Functorial.if
        ((λ { F rf f (PersistentSafetyStorage∙new v vv)
                → (rf Category.Functor.RawFunctor.<$>
                   (λ y' → PersistentSafetyStorage∙new y' vv))
                  (f v)
            })
         (λ x → x) Optics.Functorial.if
         (λ _ →
            safetyData1 &
            sdLastVote ?~
            Vote.newWithSignature voteData author ledgerInfo
            (ValidatorSigner.sign validatorSigner ledgerInfo)))
        (LibraBFT.ImplShared.Consensus.Types.g pre)))
      []

 Applying our shorthand, this yields:

    Contract
      (inj₂ "vote")
      (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))
      []

 Or (using C-u C-c C-,), we have the following goal:

    RWS-weakestPre
      (RWS-return
       (inj₂
        (Vote.newWithSignature voteData author ledgerInfo
         (ValidatorSigner.sign validatorSigner ledgerInfo))))
      (λ x post outs₁ → Contract x post (([] ++ []) ++ outs₁)) unit
      (over pssSafetyData-rm
       (λ _ →
          safetyData1 &
          sdLastVote ?~
          Vote.newWithSignature voteData author ledgerInfo
          (ValidatorSigner.sign validatorSigner ledgerInfo))
       pre)

 Applying our shorthand, this yields:

     RWS-weakestPre
       (RWS-return (inj₂ "vote"))                                       = x
       (λ x post outs₁ → Contract x post ([] ++ [] ++ outs₁))            = P
       unit                                                              = ev
       (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))     = pre

   Again, this looks like what we expect from above, so we can press
   on.  Now, applying the definition of RWS-weakestPre (RWS-return ...):

     (λ x post outs₁ → Contract x post ([] ++ [] ++ outs₁))
        (RWS-return (inj₂ "vote"))
        (pre & pssSafetyData-rm ∙~ ("safetyData1" & sdLastVote ?~ "vote"))
        []

   Finally, this reduces to the goal of:

     [] ≡ []

   which we prove with
   -}
                               refl


{-# OPTIONS --postfix-projections #-}
{-# OPTIONS --allow-unsolved-metas #-}

module StateSizedIO.writingOOsUsingIOVers4ReaderMethods where

open import StateSizedIO.RObject
open import StateSizedIO.Object
open import StateSizedIO.Base
open import Data.Product
open import Data.Nat
open import Data.Fin
open import Data.Bool
open import Function
open import Data.Unit
open import Data.String
open import Unit
open import Data.Bool.Base
open import Relation.Binary.PropositionalEquality
open import SizedIO.Console
open import Size
open import SizedIO.Base
open import Data.Sum
open import Data.Empty

-- ### new imports
--
open import StateSizedIO.cellStateDependent using (CellInterfaceˢ; empty; cellPempty')
open import NativeIO

objectInterfToIOInterfˢ : RInterfaceˢ → IOInterfaceˢ
objectInterfToIOInterfˢ I .IOStateˢ = I .Stateˢ
objectInterfToIOInterfˢ I .Commandˢ s = I .Methodˢ s ⊎ I .RMethodˢ s
objectInterfToIOInterfˢ I .Responseˢ s (inj₁ c) = I .Resultˢ s c
objectInterfToIOInterfˢ I .Responseˢ s (inj₂ c) = I .RResultˢ s c -- I .Resultˢ
objectInterfToIOInterfˢ I .IOnextˢ s (inj₁ c) r = I .nextˢ s c r
objectInterfToIOInterfˢ I .IOnextˢ s (inj₂ c) r = s -- I .nextˢ

ioInterfToObjectInterfˢ : IOInterfaceˢ → RInterfaceˢ
ioInterfToObjectInterfˢ I .Stateˢ = I .IOStateˢ
ioInterfToObjectInterfˢ I .Methodˢ = I .Commandˢ
ioInterfToObjectInterfˢ I .Resultˢ = I .Responseˢ --
ioInterfToObjectInterfˢ I .nextˢ = I .IOnextˢ
ioInterfToObjectInterfˢ I .RMethodˢ s = ⊥
ioInterfToObjectInterfˢ I .RResultˢ s ()

data DecSets : Set where
  fin : ℕ → DecSets

TDecSets : DecSets → Set
TDecSets (fin n) = Fin n

toDecSets : ∀{n} → (x : Fin n) → DecSets
toDecSets x = fin (toℕ x)

_==fin_ : {n : ℕ} → Fin n → Fin n → Bool
_==fin_ {zero} () t
_==fin_ {suc _} zero zero = true
_==fin_ {suc _} zero (suc _) = false
_==fin_ {suc _} (suc _) zero = false
_==fin_ {suc _} (suc s) (suc t) = s ==fin t

transferFin : {n : ℕ} → (P : Fin n → Set) →
              (i j : Fin n) → T (i ==fin j) →
              P i → P j
transferFin {zero} P () j q p
transferFin {suc n} P zero zero q p = p
transferFin {suc n} P zero (suc j) () p
transferFin {suc n} P (suc i) zero () p
transferFin {suc n} P (suc i) (suc j) q p = transferFin {n} (P ∘ suc) i j q p

_==DecSets_ : {d : DecSets} → TDecSets d → TDecSets d  → Bool
_==DecSets_ {fin n} = _==fin_

transferFin' : {n : ℕ} → (P : Fin n → Set) →
              (i j : Fin n) → ((i ==fin j) ≡ true) →
              P i → P j
transferFin' {zero} P () j q p
transferFin' {suc n} P zero zero q p = p
transferFin' {suc n} P zero (suc j) () p
transferFin' {suc n} P (suc i) zero () p
transferFin' {suc n} P (suc i) (suc j) q p = transferFin' {n} (P ∘ suc) i j q p

transferDecSets : {J : DecSets} → (P : TDecSets J → Set) →
              (i j : TDecSets J) → ((i ==DecSets j) ≡ true) →
              P i → P j
transferDecSets {(fin n)} P i j q p = transferFin' {n} P i j q p

{-
transferDec : {J : DecSets} → (P : TDecSets J  → Set) →
              (i j : TDecSets) → ((i ==DecSets j) ≡ true) →
              P i → P j
-}

--with {!!} inspect {!!} --(_==DecSets_ j j')
--... | x = {!!}

{-
... | true = {!!} -- {!(I j).nextˢ (f j) m ?!}
... | false = {!!}
-}

{-
    = if (j ==DecSets j') then  else {!!}
-}

module _ (I : IOInterfaceˢ )
         (let S = IOStateˢ I) (let C = Commandˢ I)
         (let R = Responseˢ I) (let n = IOnextˢ I)
           where

  mutual

-- \writingOOsUsingIOVersFourReaderMethodsIOind
    data IOˢind (A : S → Set) (s : S) : Set where
      doˢ''      :  (c : C s) (f : (r : R s c) → IOˢind A (n s c r)) → IOˢind A s
      returnˢ''  :  (a : A s) → IOˢind A s

    IOˢindₚ : (A : Set)(s s' : S) → Set
    IOˢindₚ A s s' = IOˢind (λ s'' → (s'' ≡ s) × A) s

module _ {I : RInterfaceˢ } (let S = Stateˢ I) (let n = nextˢ I)
           where

-- \writingOOsUsingIOVersFourReaderMethodstranslateIOind
  translateˢ : {A : S → Set} (s : S) (obj : RObjectˢ I s) (p : IOˢind (objectInterfToIOInterfˢ I) A s)
               → Σ[ s′ ∈ S ]  (A s′ × RObjectˢ I s′)
  translateˢ s obj (returnˢ'' x)       =  s , (x , obj)
  translateˢ s obj (doˢ'' (inj₁ c) p)  = obj .objectMethod c ▹ λ {(x , o′) → translateˢ (n s c x) o′ (p x)  }
  translateˢ s obj (doˢ'' (inj₂ c) p)  = obj .readerMethod c ▹ λ x → translateˢ s obj (p x)
-- obj .objectMethod c ▹ λ {(x , o′)
--                                      → translateˢ {A} {n s c x} o′ (p x)  }

module _ {I : RInterfaceˢ }   (let S = Stateˢ I)
           where

  getAˢ : ∀{A : S → Set} (s : S)
               → RObjectˢ I s
               → IOˢind (objectInterfToIOInterfˢ I) A s
               → Σ[ s′ ∈ S ]  A s′
  getAˢ s obj (returnˢ'' x) =  s , x
  getAˢ s obj p             =  let  res = translateˢ s obj p
                               in   proj₁ res , proj₁ (proj₂ res)

module _ (I : IOInterfaceˢ )
         (let S = IOStateˢ I) (let C = Commandˢ I)
         (let R = Responseˢ I) (let n = IOnextˢ I)
           where

  mutual
    -- IOˢind' A sbegin send
    -- are programs which start in state sbegin and end in state send

    data IOˢind' (A : S → Set) (sbegin : S) : (send : S) → Set where

      doˢ'''     : {send : S} → (c : C sbegin)  →
                   (f : (r : R sbegin c) → IOˢind' A (n sbegin c r) send)
                  → IOˢind' A sbegin send
      returnˢ''' : (a : A sbegin) → IOˢind' A sbegin sbegin

module _ {I : RInterfaceˢ } (let S = Stateˢ I) (let n = nextˢ I)
           where

  translateˢ' : ∀{A : S → Set}{sbegin : S}{send : S}
               → RObjectˢ I sbegin
               → IOˢind' (objectInterfToIOInterfˢ I) A sbegin send
               → (A send × RObjectˢ I send)
  translateˢ' {A} {sbegin} {send} obj (returnˢ''' x) = x , obj
  translateˢ' {A} {sbegin} {send} obj (doˢ''' (inj₁ c) p) =
                   obj .objectMethod c ▹ λ {(x , o')
                   → translateˢ' {A} {n sbegin c x} {send} o' (p x)  }
  translateˢ' {A} {sbegin} {send} obj (doˢ''' (inj₂ c) p) =
                   obj .readerMethod c ▹ λ x
                   → translateˢ' {A} {sbegin} {send} obj (p x)

--                   obj .objectMethod c ▹ λ {(x , o')
--                   → translateˢ' {A} {n sbegin c x} {send} o' (p x)  }

module _ {I : RInterfaceˢ }   (let S = Stateˢ I)
           where

  getAˢ' : ∀{A : S → Set}{sbegin : S}{send : S}
               → RObjectˢ I sbegin
               → IOˢind' (objectInterfToIOInterfˢ I) A sbegin send
               → A send
  getAˢ' {A} {sbegin} {send} obj (returnˢ''' x) = x
  getAˢ' {A} {sbegin} {send} obj p = let res = translateˢ' {I} {A} {sbegin} {send} obj p
                        in proj₁ res

updateFinFunction : {n : ℕ} → (P : Fin n → Set)
                    → (f : (k : Fin n) → P k)
                    → (l : Fin n)
                    → (b : P l)
                    → (k : Fin n) → P k
updateFinFunction {zero} P f () b k
updateFinFunction {suc n} P f zero b zero = b
updateFinFunction {suc n} P f zero b (suc k) = f (suc k)
updateFinFunction {suc n} P f (suc l) b zero = f zero
updateFinFunction {suc n} P f (suc l) b (suc k) = updateFinFunction {n} (P ∘ suc)  (f ∘ suc) l b k

updateDecSetsFunction : {J : DecSets} → (P : TDecSets J → Set)
                    → (f : (k : TDecSets J) → P k)
                    → (l : TDecSets J)
                    → (b : P l)
                    → (k : TDecSets J) → P k
updateDecSetsFunction {fin n} P f l b k = updateFinFunction {n} P f l b k

updateFinFunctionStateChange : {n : ℕ}
                    → (P : Fin n → Set)
                    → (f : (k : Fin n) → P k)
                    → (Q : (k : Fin n) → P k → Set)
                    → (g : (k : Fin n) → Q k (f k) )
                    → (l : Fin n)
                    → (newP : P l)
                    → (newQ : Q l newP)
                    → (k : Fin n)
                    → Q k (updateFinFunction {n} P f l newP k)
updateFinFunctionStateChange {zero} P f Q g () newP newQ k
updateFinFunctionStateChange {suc n} P f Q g zero newP newQ zero = newQ
updateFinFunctionStateChange {suc n} P f Q g zero newP newQ (suc k) = g (suc k)
updateFinFunctionStateChange {suc n} P f Q g (suc l) newP newQ zero = g zero
updateFinFunctionStateChange {suc n} P f Q g (suc l) newP newQ (suc k) =
   updateFinFunctionStateChange {n} (P ∘ suc) (f ∘ suc)
                                (λ k p → Q (suc k) p)
                                (g ∘ suc) l newP newQ k

updateDecSetsFunctionStateChange : {J : DecSets}
                    → (P : TDecSets J → Set)
                    → (f : (k : TDecSets J) → P k)
                    → (Q : (k : TDecSets J) → P k → Set)
                    → (g : (k : TDecSets J) → Q k (f k) )
                    → (l : TDecSets J)
                    → (newP : P l)
                    → (newQ : Q l newP)
                    → (k : TDecSets J)
                    → Q k (updateDecSetsFunction {J} P f l newP k)
updateDecSetsFunctionStateChange {fin n} P f Q g l newP newQ k = updateFinFunctionStateChange {n} P f Q g l newP newQ k

objectInterfMultiToIOInterfˢ : (J : DecSets) → (TDecSets J → Interfaceˢ) → IOInterfaceˢ
objectInterfMultiToIOInterfˢ J I .IOStateˢ = (j : TDecSets J) →  (I j).Stateˢ
objectInterfMultiToIOInterfˢ J I .Commandˢ f  = Σ[ j ∈ TDecSets J ] (I j).Methodˢ (f j)
objectInterfMultiToIOInterfˢ J I .Responseˢ f (j , m) = (I j).Resultˢ (f j) m
objectInterfMultiToIOInterfˢ J I .IOnextˢ f (j , m) r =
   updateDecSetsFunction {J} (λ j₁ → I j₁ .Stateˢ) f j (I j .nextˢ (f j) m r)

{-
objectInterfMultiToIOInterfˢ J I .IOnextˢ f (j , m) r j' with (_==DecSets_ j j') | inspect (_==DecSets_ j) j'
... | true | [ eq ] = transferDecSets {J} (λ j'' → I j'' .Stateˢ) j j' eq ((I j).nextˢ (f j) m r)
... | false | [ eq ] = f j'
-}

translateMultiˢ : (J : DecSets) → (I : TDecSets J → Interfaceˢ) →
            (A : ((j : TDecSets J) →  (I j).Stateˢ) → Set)
            (f : (j : TDecSets J) →  (I j).Stateˢ)
            (obj : (j : TDecSets J) →  Objectˢ (I j) (f j))
             → IOˢind (objectInterfMultiToIOInterfˢ J I) A f
             → Σ[ s' ∈ ((j : TDecSets J) →  (I j).Stateˢ) ]
                (A s' × ( (j : TDecSets J) → Objectˢ (I j) (s' j)))
translateMultiˢ J I A f obj (doˢ'' (j , m) p) = (obj j) .objectMethod m ▹ λ {(r , o')
     → translateMultiˢ J I A (IOnextˢ (objectInterfMultiToIOInterfˢ J I) f (j , m) r)
        (updateDecSetsFunctionStateChange {J}
          (λ j₁ → I j₁ .Stateˢ)
          f
          (λ j₁ state → Objectˢ (I j₁) state)
          obj j
          (I j .nextˢ (f j) m r) o')
          (p r)}
translateMultiˢ J I A f obj (returnˢ'' a) = f , a , obj

module _ (I₁ : IOInterfaceˢ )
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         (I₂ : IOInterfaceˢ )
         (let S₂ = IOStateˢ I₂)
         (let C₂ = Commandˢ I₂)
         (let R₂ = Responseˢ I₂)
         (let n₂ = IOnextˢ I₂)
           where

  mutual

    record  IOˢindcoind (i : Size)(A : S₁ → S₂ → Set) (s₁ : S₁)(s₂ : S₂) : Set where
      coinductive
      field
            forceIC : {j : Size< i} → IOˢindcoind+ j A s₁ s₂

    data IOˢindcoind+ (i : Size)(A : S₁ → S₂ → Set) (s₁ : S₁)(s₂ : S₂) : Set where
       doˢIO      :  (c₁ : C₁ s₁) (f : (r₁ : R₁ s₁ c₁) → IOˢindcoind i A (n₁ s₁ c₁ r₁) s₂)
                     → IOˢindcoind+ i A s₁ s₂
       doˢobj     :  (c₂ : C₂ s₂)(f : (r₂ : R₂ s₂ c₂) → IOˢindcoind+ i A s₁ (n₂ s₂ c₂ r₂))
                     → IOˢindcoind+ i A s₁ s₂
       returnˢic  :  A s₁ s₂
                     → IOˢindcoind+ i A s₁ s₂
open IOˢindcoind public

module _ (I₁ : IOInterfaceˢ )
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         (I₂ : IOInterfaceˢ )
         (let S₂ = IOStateˢ I₂)
         (let C₂ = Commandˢ I₂)
         (let R₂ = Responseˢ I₂)
         (let n₂ = IOnextˢ I₂) where

  ioˢind2IOˢindcoind+ : (A : S₁ → S₂ → Set) (s₁ : S₁)(s₂ : S₂)
                        (p : IOˢind I₂ (λ s₂' → A s₁ s₂') s₂)
                        → IOˢindcoind+ I₁ I₂ ∞ A s₁ s₂
  ioˢind2IOˢindcoind+ A s₁ s₂ (doˢ'' c f) = doˢobj c λ r →
                                            ioˢind2IOˢindcoind+ A s₁ (IOnextˢ I₂ s₂ c r) (f r)
  ioˢind2IOˢindcoind+ A s₁ s₂ (returnˢ'' a) = returnˢic a

  ioˢind2IOˢindcoind : (A : S₁ → S₂ → Set) (s₁ : S₁)(s₂ : S₂)
                        (p : IOˢind I₂ (λ s₂' → A s₁ s₂') s₂)
                        → IOˢindcoind I₁ I₂ ∞ A s₁ s₂

  ioˢind2IOˢindcoind A s₁ s₂ p .forceIC = ioˢind2IOˢindcoind+ A s₁ s₂ p

{-
    translateˢ : ∀{A : S → Set}{s : S}
                 → Objectˢ I s
                 → IOˢindcoind+ (objectInterfToIOInterfˢ I) A s
                 → Σ[ s' ∈ S ]  (A s' × Objectˢ I s')
    translateˢ {A} {s} obj (returnˢ'' x) = s , (x , obj)
    translateˢ {A} {s} obj (doˢobj c p) = obj .objectMethod c ▹ λ {(x , o')
                                        → translateˢ {A} {n s c x} o' (p x)  }
-}

{-
  delayˢic : {i : Size}{A : S₁ → S₂ → Set}{s₁ : S₁}{s₂ : S₂}
           → IOˢindcoindShape i A s₁ s₂
           → IOˢindcoind (↑ i) A s₁ s₂
  delayˢic {i} {A} {s₁} {s₂} P .IOˢindcoind.forceIC {j} = P
-}

module _ {I : IOInterfaceˢ } (let S = IOStateˢ I)
           where
   _>>=ind_ : {A :  S → Set}{B : S → Set}{s : S}
              (m : IOˢind I A s)
              (f : (s' : S) (a : A s') → IOˢind I B s')
              → IOˢind I B s
   _>>=ind_  (doˢ'' c f₁) f = doˢ'' c (λ r → f₁ r >>=ind f)
   _>>=ind_  {s = s} (returnˢ'' a) f = f s a

module _ {I₁ : IOInterfaceˢ }
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         {I₂ : IOInterfaceˢ }
         (let S₂ = IOStateˢ I₂)
         (let C₂ = Commandˢ I₂)
         (let R₂ = Responseˢ I₂)
         (let n₂ = IOnextˢ I₂)
           where
   mutual
     _>>=indcoind+_ : {i : Size}{A : S₁ → S₂ → Set}
                      {B : S₁ → S₂ → Set}
                      {s₁ : S₁}{s₂ : S₂}
                      (p : IOˢindcoind+ I₁ I₂ i A s₁ s₂)
                      (f : {s₁' : S₁}{s₂' : S₂}(a : A s₁' s₂') → IOˢindcoind+ I₁ I₂ i B s₁' s₂')
                      → IOˢindcoind+ I₁ I₂ i B s₁ s₂
     doˢobj c f₁ >>=indcoind+ f = doˢobj c (λ r → f₁ r >>=indcoind+ f)
     doˢIO c f₁  >>=indcoind+ f = doˢIO c  (λ r → f₁ r >>=indcoind f)
     returnˢic x >>=indcoind+ f = f x

{-
     _>>=indcoindShape_ : {i : Size}{A : S₁ → S₂ → Set}
                      {B : S₁ → S₂ → Set}
                      {s₁ : S₁}{s₂ : S₂}
                      (p : IOˢindcoindShape I₁ I₂ i A s₁ s₂)
                      (f : (s₁' : S₁)(s₂' : S₂)(a : A s₁' s₂') → IOˢindcoind+ I₁ I₂ i B s₁' s₂')
                      → IOˢindcoind+ I₁ I₂ i B s₁ s₂
     doˢIO c₁ f₁ >>=indcoindShape f = returnˢ'' (doˢIO c₁ (λ r → f₁ r >>=indcoind f))
     _>>=indcoindShape_ {s₁ = s₁} {s₂ = s₂} (returnˢic x) f = x >>=indcoindaux' f
-}
     _>>=indcoind_ : {i : Size}{A : S₁ → S₂ → Set}
                      {B : S₁ → S₂ → Set}
                      {s₁ : S₁}{s₂ : S₂}
                      (p : IOˢindcoind I₁ I₂ i A s₁ s₂)
                      (f : {s₁' : S₁}{s₂' : S₂}(a : A s₁' s₂') → IOˢindcoind+ I₁ I₂ i B s₁' s₂')
                      → IOˢindcoind I₁ I₂ i B s₁ s₂
     (p >>=indcoind f) .forceIC {j} = p .forceIC >>=indcoind+ f

{-
     _>>=indcoindaux'_ : {i : Size}{A : S₁ → S₂ → Set}
                      {B : S₁ → S₂ → Set}
                      {s₁ : S₁}{s₂ : S₂}
                      (p : IOˢ' I₁ i (λ s₁' → A s₁' s₂) s₁)
                      (f : {s₁' : S₁}{s₂' : S₂}(a : A s₁' s₂') → IOˢindcoind+ I₁ I₂ i B s₁' s₂')
                      → IOˢindcoind+ I₁ I₂ i B s₁ s₂
     doˢ' c f₁ >>=indcoindaux' f = {!!} -- returnˢ'' (returnˢic (doˢ' c λ r → {!returnˢic!})) -- doˢ' c λ r → f₁ r >>=indcoindaux f
     _>>=indcoindaux'_ {s₁ = s₁}{s₂ = s₂} (returnˢ' a)  f = f {s₁} {s₂} a -- doˢobj {!inj₂ c!} {!!}
-}

{-
     _>>=indcoindaux_ : {i : Size}{A : S₁ → S₂ → Set}
                      {B : S₁ → S₂ → Set}
                      {s₁ : S₁}{s₂ : S₂}
                      (p : IOˢ I₁ i (λ s₁' → A s₁' s₂) s₁)
                      (f : (s₁' : S₁)(s₂' : S₂)(a : A s₁' s₂') → IOˢindcoind+ I₁ I₂ i B s₁' s₂')
                      → IOˢindcoind+ I₁ I₂ i B s₁ s₂
     p >>=indcoindaux f = {!!}
-}

module _ {I₁ : IOInterfaceˢ }
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         {I₂ : IOInterfaceˢ }
         (let S₂ = IOStateˢ I₂)
           where
  open IOˢindcoind

  delayˢic : {i : Size}{A : S₁ → S₂ → Set}{s₁ : S₁}{s₂ : S₂}
           → IOˢindcoind+ I₁ I₂ i A s₁ s₂
           → IOˢindcoind I₁ I₂ (↑ i) A s₁ s₂
  delayˢic {i} {A} {s₁} {s₂} P .forceIC {j} = P

--Σ (Stateˢ I₂) (λ s₄ → Σ (A s₃ s₄) (λ x → Objectˢ I₂ s₄))) s₁

--→ IOˢind I₂ (λ s₂ → A s₁ s₂) s₂

open IOˢindcoind public

module _ (I₁ : IOInterfaceˢ )
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         (I₂ : RInterfaceˢ )
         (let I₂′ = objectInterfToIOInterfˢ I₂)
         (let S₂ = Stateˢ I₂)(let n₂ = IOnextˢ I₂′)
           where
  mutual
    translateˢIndCoind : ∀ {i A s₁ s₂} (obj : RObjectˢ I₂ s₂) (p : IOˢindcoind I₁ I₂′ i A s₁ s₂)
                       → IOˢ I₁ i (λ s₁ → Σ[ s₂ ∈ S₂ ] (A s₁ s₂ × RObjectˢ I₂ s₂)) s₁
    translateˢIndCoind obj p .forceˢ = translateˢIndCoind+ obj (p .forceIC)

    translateˢIndCoind+ : ∀{i A s₁ s₂} (obj : RObjectˢ  I₂ s₂) (p : IOˢindcoind+ I₁ I₂′ i A s₁ s₂)
                          → IOˢ' I₁ i (λ s₁ → Σ[ s₂ ∈ S₂ ] (A s₁ s₂ × RObjectˢ I₂ s₂)) s₁
    translateˢIndCoind+ obj (doˢobj (inj₁ c) f) = obj .objectMethod c ▹ λ { (x , obj′) →
      translateˢIndCoind+ obj′ (f x)}
    translateˢIndCoind+ obj (doˢobj (inj₂ c) f) = obj .readerMethod c ▹ λ x  →
      translateˢIndCoind+ obj (f x)
    translateˢIndCoind+ obj (doˢIO c₁ f) = doˢ' c₁ λ r₁ →
      translateˢIndCoind obj (f r₁)
    translateˢIndCoind+ {i} {A} {s₁} {s₂} obj (returnˢic a) = returnˢ' (s₂ , a , obj)
{-
    translateˢIndCoindShape : ∀{i} → {A : S₁ → S₂ → Set}{s₁ : S₁}{s₂ : S₂}
                 → RObjectˢ  I₂ s₂
                 → IOˢindcoindShape I₁ I₂′ i A s₁ s₂
                 → IOˢ' I₁ i ((λ s₁ → Σ[ s₂ ∈ S₂ ]  (A s₁ s₂ × RObjectˢ I₂ s₂))) s₁
    translateˢIndCoindShape {i} {A} {.s₁} {.s₂} obj (doˢIO {s₁} {s₂} c₁ p)
           = doˢ' c₁ (λ r₁ → translateˢIndCoind {i} {A} {n₁ s₁ c₁ r₁} {s₂} obj (p r₁))
    translateˢIndCoindShape {i} {A} {.s₁} {.s₂} obj (returnˢic {s₁} {s₂} p)
           = fmapˢ' i (λ s a → ( s₂ , a , obj)) s₁ p
-}

---
--- ### file content of writingOOsUsingIO
---

{-
objectInterfMultiToIOInterfˢ J I .IOnextˢ f (j , m) r j' with (_==DecSets_ j j') | inspect (_==DecSets_ j) j'
... | true | [ eq ] = transferDecSets {J} (λ j'' → I j'' .Stateˢ) j j' eq ((I j).nextˢ (f j) m r)
... | false | [ eq ] = f j'
-}

module _ (I₁ : IOInterfaceˢ )
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         (I₂ : IOInterfaceˢ )
         (let S₂ = IOStateˢ I₂)
           where

unsizedIOInterfToIOInterfˢ : IOInterface → IOInterfaceˢ
unsizedIOInterfToIOInterfˢ x .IOStateˢ  = Unit
unsizedIOInterfToIOInterfˢ x .Commandˢ  = λ _ → x .Command
unsizedIOInterfToIOInterfˢ x .Responseˢ = λ _ → x .Response
unsizedIOInterfToIOInterfˢ x .IOnextˢ   _ _ _ =  unit

ConsoleInterfaceˢ : IOInterfaceˢ
ConsoleInterfaceˢ = unsizedIOInterfToIOInterfˢ consoleI

data RCellStateˢ  : Set where
  empty full  : RCellStateˢ

data RCellMethodEmpty (A : Set) : Set where
    put : A → RCellMethodEmpty A

data RCellMethodFull (A : Set)  : Set where
    put : A → RCellMethodFull A

data RRCellMethodEmpty (A : Set) : Set where

data RRCellMethodFull (A : Set)  : Set where
    get : RRCellMethodFull A

RCellMethodˢ : (A : Set) → RCellStateˢ → Set
RCellMethodˢ A empty = RCellMethodEmpty A
RCellMethodˢ A full = RCellMethodFull A

RRCellMethodˢ : (A : Set) → RCellStateˢ → Set
RRCellMethodˢ A empty = RRCellMethodEmpty A
RRCellMethodˢ A full = RRCellMethodFull A

putGen : {A : Set} → {i : RCellStateˢ} → A → RCellMethodˢ A i
putGen {A} {empty} = put
putGen {A} {full} = put

RCellResultFull : ∀{A} → RCellMethodFull A → Set
RCellResultFull (put _) = Unit

RCellResultEmpty : ∀{A} → RCellMethodEmpty A → Set
RCellResultEmpty (put _) = Unit

RRCellResultFull : ∀{A} → RRCellMethodFull A → Set
RRCellResultFull {A} get = A

RRCellResultEmpty : ∀{A} → RRCellMethodEmpty A → Set
RRCellResultEmpty ()

RCellResultˢ : (A : Set) → (s : RCellStateˢ) → RCellMethodˢ A s → Set
RCellResultˢ A empty = RCellResultEmpty{A}
RCellResultˢ A full = RCellResultFull{A}

RRCellResultˢ : (A : Set) → (s : RCellStateˢ) → RRCellMethodˢ A s → Set
RRCellResultˢ A empty = RRCellResultEmpty{A}
RRCellResultˢ A full = RRCellResultFull{A}

nˢ : ∀{A} → (s : RCellStateˢ) → (c : RCellMethodˢ A s) → (RCellResultˢ A s c) → RCellStateˢ
nˢ _ _ _ = full

RCellInterfaceˢ : (A : Set) → RInterfaceˢ
Stateˢ (RCellInterfaceˢ A)  = RCellStateˢ
Methodˢ (RCellInterfaceˢ A)  = RCellMethodˢ A
Resultˢ (RCellInterfaceˢ A)  = RCellResultˢ A
RMethodˢ (RCellInterfaceˢ A)  = RRCellMethodˢ A
RResultˢ (RCellInterfaceˢ A)  = RRCellResultˢ A
nextˢ (RCellInterfaceˢ A)  = nˢ

{-
mutual
   RcellPempty : (i : Size) → IOObject consoleI (RCellInterfaceˢ String) i empty
   method (cellPempty i) {j} (put str) = do (putStrLn ("put (" ++ str ++ ")")) λ _ →
                                         return (unit , cellPfull j str)

   cellPfull : (i : Size) → (str : String) → IOObject consoleI (CellInterfaceˢ String) i full
   method (cellPfull i str) {j} get        = do (putStrLn ("get (" ++ str ++ ")")) λ _ →
                                             return (str , cellPfull j str)
   method (cellPfull i str) {j} (put str') = do (putStrLn ("put (" ++ str' ++ ")")) λ _ →
                                             return (unit , cellPfull j str')
-}

-- UNSIZED Version, without IO
mutual
   RcellPempty' : ∀{A} → RObjectˢ (RCellInterfaceˢ A) empty
   RcellPempty' .objectMethod (put a)     =  (_ , RcellPfull' a)
   RcellPempty' .readerMethod ()

   RcellPfull' : ∀{A} → A → RObjectˢ (RCellInterfaceˢ A) full
   RcellPfull' a .readerMethod get         = a
   RcellPfull' a .objectMethod (put a')  = (_ , RcellPfull' a')

RCellInterfaceˢIO : IOInterfaceˢ
RCellInterfaceˢIO = objectInterfToIOInterfˢ (RCellInterfaceˢ String)

module _ (I : IOInterface)
       (let C = I .Command)
       (let R = I .Response)
       (let I' = unsizedIOInterfToIOInterfˢ I)
       (let C' = I' .Commandˢ)
       (let R' = I' .Responseˢ)
       (convertC : C' _ → C)
       (convertR : ∀{c : C} → Response I (convertC c)  →  I .Response c)

       where
  mutual

    flatternIOˢ : ∀ {A : Set}
                 → IOˢ (unsizedIOInterfToIOInterfˢ I) ∞ (λ _ → A) unit
                 → IO I ∞ A
    flatternIOˢ {A} p .force  = flatternIOˢ' (forceˢ p)

    flatternIOˢ' : {A : Set}
                 → IOˢ' (unsizedIOInterfToIOInterfˢ I) ∞ (λ _ → A) unit
                 → IO' I ∞ A
    flatternIOˢ' {A} (doˢ' cˢ f) = do' (convertC cˢ) (λ rˢ →
                    flatternIOˢ (f (convertR {cˢ} rˢ)))
    flatternIOˢ' {A} (returnˢ' a) = return' a

{-
doIOShape : {i : Size}
       {I₁ :  IOInterfaceˢ} {I₂ :  IOInterfaceˢ}
       {A : I₁ .IOStateˢ → I₂ .IOStateˢ → Set}
       {s₁ : I₁ .IOStateˢ}
       {s₂ : I₂ .IOStateˢ}
      (c₁ : I₁ .Commandˢ s₁) →
         ((r₁ : I₁ .Responseˢ s₁ c₁) →
          IOˢindcoind I₁ I₂ i  A (IOnextˢ I₁ s₁ c₁ r₁) s₂)
        →  IOˢindcoindShape I₁ I₂ i A  s₁ s₂
doIOShape  = doˢIO
-}

{-
callMethod'' : {I₂ :  IOInterfaceˢ}
             {A : I₂ .IOStateˢ → Set}
             {s₂ : I₂ .IOStateˢ}
             (c : Commandˢ I₂ s₂) →
             ((r : Responseˢ I₂ s₂ c) → IOˢind I₂ A (IOnextˢ I₂ s₂ c r))
             → IOˢind I₂ A s₂
callMethod'' = doˢobj
-}

doˢobj∞ : {I₁ : IOInterfaceˢ }{I₂ :  IOInterfaceˢ}
             {A : IOStateˢ I₁ → I₂ .IOStateˢ → Set}
             {s₁ : IOStateˢ I₁}
             {s₂ : I₂ .IOStateˢ}
             (c : Commandˢ I₂ s₂) →
             ((r : Responseˢ I₂ s₂ c) → IOˢindcoind+ I₁ I₂ ∞ A s₁ (IOnextˢ I₂ s₂ c r) )
             → IOˢindcoind I₁ I₂ ∞ A s₁ s₂
doˢobj∞ {I₁} {I₂} {A} {s₁} {s₂} c f .forceIC {j} = doˢobj c  f

{-
callMethod+ : {I₁ : IOInterfaceˢ }{I₂ :  IOInterfaceˢ}
             {A : IOStateˢ I₁ → I₂ .IOStateˢ → Set}
             {s₁ : IOStateˢ I₁}
             {s₂ : I₂ .IOStateˢ}
             (c : Commandˢ I₂ s₂) →
             ((r : Responseˢ I₂ s₂ c) → IOˢindcoind+ I₁ I₂ ∞ A s₁ (IOnextˢ I₂ s₂ c r) )
             → IOˢindcoind+ I₁ I₂ ∞ A s₁ s₂
callMethod+ {I₁} {I₂} {A} {s₁} {s₂} = doˢobj
-}

{-
we think not needed anymore
endIO : {I₁ :  IOInterfaceˢ} {I₂ :  IOInterfaceˢ}
--      {A : I₁ .IOStateˢ → I₂ .IOStateˢ → Set}
       {s₁ : I₁ .IOStateˢ}
       {s₂ : I₂ .IOStateˢ}
       → IOˢind I₂ (λ s → IOˢindcoind I₁ I₂ ∞ (λ _ _ → Unit) s₁ s) s₂
endIO {I₁} {I₂} {s₁} {s₂} = returnˢ'' (delayˢic (returnˢ'' (returnˢic (returnˢ' unit)))) -- (delayˢic (returnˢic (returnˢ' unit)))
--                returnˢ'' {I₂}
--             {!!} -- (delayˢic {!returnˢ''!} ) -- (returnˢ'' (returnˢic (returnˢ' unit))))   --(returnˢic (returnˢ' unit)))
-}

endIO+ : {I₁ :  IOInterfaceˢ} {I₂ :  IOInterfaceˢ}
       {s₁ : I₁ .IOStateˢ}
       {s₂ : I₂ .IOStateˢ}
       → IOˢindcoind+ I₁ I₂ ∞ (λ _ _ → Unit) s₁ s₂
endIO+ = returnˢic unit

endIO∞ : {I₁ :  IOInterfaceˢ} {I₂ :  IOInterfaceˢ}
       {s₁ : I₁ .IOStateˢ}
       {s₂ : I₂ .IOStateˢ}
       → IOˢindcoind I₁ I₂ ∞ (λ _ _ → Unit) s₁ s₂
endIO∞ .forceIC {j} = endIO+

doˢIO∞ : {i : Size}
        {I₁ :  IOInterfaceˢ} {I₂ :  IOInterfaceˢ}
       {s₁ : I₁ .IOStateˢ}
       {s₂ : I₂ .IOStateˢ}
       (c₁ : I₁ .Commandˢ s₁) →
       ((r₁ : I₁ .Responseˢ s₁ c₁) →
        IOˢindcoind I₁ I₂ i (λ _ _ → Unit) (IOnextˢ I₁ s₁ c₁ r₁) s₂)
       → IOˢindcoind I₁ I₂ i (λ _ _ → Unit) s₁ s₂
doˢIO∞ {i} c p .forceIC {j} = doˢIO c p

callProg : {I : IOInterfaceˢ }{A : I .IOStateˢ → Set}{s : I .IOStateˢ} (a : A s) → IOˢind I A s
callProg = returnˢ''

run' : IOˢindcoind ConsoleInterfaceˢ RCellInterfaceˢIO ∞ (λ x y → Unit)
          unit empty
       → NativeIO Unit
run' prog = translateIOConsole
               (flatternIOˢ  consoleI (λ c → c) (λ r → r)
              (fmapˢ ∞ (λ x y → unit) unit
                (translateˢIndCoind ConsoleInterfaceˢ
                                    (RCellInterfaceˢ String) RcellPempty' (prog))))

module _ {objInf : RInterfaceˢ}
         (let objIOInf = objectInterfToIOInterfˢ objInf)
         {objState : objIOInf .IOStateˢ }
           where
        run_startingWith_ :  IOˢindcoind ConsoleInterfaceˢ objIOInf ∞ (λ x y → Unit) unit objState
                             → RObjectˢ objInf objState → NativeIO Unit
        run prog startingWith obj = translateIOConsole
           (flatternIOˢ  consoleI (λ c → c) (λ r → r) (fmapˢ ∞ (λ x y → unit) unit
                                    (translateˢIndCoind ConsoleInterfaceˢ objInf obj prog)))

        run+_startingWith_ : IOˢindcoind+ ConsoleInterfaceˢ objIOInf ∞ (λ _ _ → Unit) unit objState
              → RObjectˢ objInf objState
              → NativeIO Unit
        run+ prog startingWith obj = translateIOConsole
                         (flatternIOˢ consoleI id id (fmapˢ ∞  (λ _ _ → unit) unit
                              (delayˢ (translateˢIndCoind+ ConsoleInterfaceˢ  objInf obj prog))))
-- (ioInterfToObjectInterfˢ objIOInf)
--- ### END of file content of writingOOsUsingIO
---

{-

obj .objectMethod c ▹ λ {(x , o')
                                      → translateˢ {A} {n s c x} o' (p x)  }

                              let q : Σ[ s' ∈ S₂ ]
                                        (IOˢindcoindShape I₁ I₂′ i A s₁ s'
                                         × Objectˢ I₂ s')
                                  q = translateˢ obj p
                              in translateˢIndCoindShape (proj₂ (proj₂ q)) (proj₁ (proj₂ q)) -}

module _ (I₁ : IOInterfaceˢ )
         (let S₁ = IOStateˢ I₁) (let C₁ = Commandˢ I₁)
         (let R₁ = Responseˢ I₁) (let n₁ = IOnextˢ I₁)
         (I₂ : IOInterfaceˢ )
         (let S₂ = IOStateˢ I₂)
         (let C₂ = Commandˢ I₂)
         (let R₂ = Responseˢ I₂)
         (let n₂ = IOnextˢ I₂)
         (I₂' : IOInterface)
         (let C₂' = I₂' .Command)
         (let R₂' = I₂' .Response)
         (let I₂'' = unsizedIOInterfToIOInterfˢ I₂')
         (let C₂'' = I₂'' .Commandˢ)
         (let R₂'' = I₂'' .Responseˢ)
         (convertC : (s₂ : S₂)(c₂ : C₂ s₂) → C₂')
         (convertR : (s₂ : S₂)(c₂ : C₂ s₂)(r₂ : R₂' (convertC s₂ c₂)) → R₂ s₂ c₂)
         (A : Set)
           where

   mutual
    translateIndCoindFlatteningObj : ∀{i} (s₁ : S₁) (s₂ : S₂)
                                       → IOˢindcoind I₁ I₂ i (λ _ _ →  A) s₁ s₂
                                       → IOˢindcoind I₁ I₂'' i (λ _ _ →  A) s₁ _
    translateIndCoindFlatteningObj {i} s₁ s₂ p .forceIC {j} = translateIndCoindFlatteningObj+ {j} s₁ s₂ (p .forceIC {j})

    translateIndCoindFlatteningObj+ : ∀{i} (s₁ : S₁) (s₂ : S₂)
                                       → IOˢindcoind+ I₁ I₂ i (λ _ _ →  A) s₁ s₂
                                       → IOˢindcoind+ I₁ I₂'' i (λ _ _ →  A) s₁ _
    translateIndCoindFlatteningObj+ {i} s₁ s₂ (doˢIO c₁ f) = doˢIO c₁ λ r₁ → translateIndCoindFlatteningObj (n₁ s₁ c₁ r₁) s₂ (f r₁)
    translateIndCoindFlatteningObj+ {i} s₁ s₂ (doˢobj c₂ f) = doˢobj (convertC s₂ c₂) λ r₂ →
                                                              translateIndCoindFlatteningObj+ s₁ (n₂ s₂ c₂ (convertR s₂ c₂ r₂)) (f (convertR s₂ c₂ r₂))
    translateIndCoindFlatteningObj+ {i} s₁ s₂ (returnˢic x) = returnˢic x


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Inference(x : X) where
  import OutsideIn.TopLevel as TL
  import OutsideIn.TypeSchema as TS
  import OutsideIn.Expressions as E
  import OutsideIn.Environments as V
  import OutsideIn.Constraints as C
  import OutsideIn.Inference.Solver as S
  import OutsideIn.Inference.Prenexer as P
  import OutsideIn.Inference.Separator as SP
  import OutsideIn.Inference.ConstraintGen as CG

  open S(x)
  open P(x)
  open SP(x)
  open CG(x)
  open X(x)
  open TL(x)
  open TS(x)
  open E(x)
  open V(x)
  open C(x)

  private
    module PlusN-m {n} = Monad(PlusN-is-monad {n})
    module QC-f = Functor(qconstraint-is-functor)
    module Ax-f = Functor(axiomscheme-is-functor)
    module Exp-f {ev}{s} = Functor(expression-is-functor₂ {ev}{s})
    module TS-f {x} = Functor(type-schema-is-functor {x})
    module Type-m  = Monad(type-is-monad)
    module Type-f  = Functor(type-is-functor)

  open Type-m

  data _,_►_ {x ev : Set}⦃ eq : Eq x ⦄(Q : AxiomScheme x)(Γ : Environment ev x) : Program ev x → Set where
    Empty : Q , Γ ► end
    BindA : ∀ {r}{m}{e : Expression ev (x ⨁ m) r}{prog : Program (Ⓢ ev) x}{τ}{C : Constraint (x ⨁ m) Extended}{Qc}{f}{f′}
              {C′ : Constraint ((x ⨁ m) ⨁ f) Flat}{r}{C′′ : SeparatedConstraint ((x ⨁ m) ⨁ f) r}{θ : (x ⨁ m) ⨁ f → Type ((x ⨁ m) ⨁ f′)}
         → TS-f.map (PlusN-m.unit {m}) ∘ Γ ► e ∶ τ ↝ C
         → C prenex: f , C′
         → C′ separate: r , C′′
         → let eq′ = PlusN-eq {m} eq in Ax-f.map (PlusN-m.unit {m}) Q , Qc , f solv► C′′ ↝ f′ , ε , θ
         → Q , ⟨ ∀′ m · Qc ⇒ τ ⟩, Γ ► prog
         → Q , Γ ► bind₂ m · e  ∷ Qc ⇒ τ , prog
    Bind :  ∀{r}{e : Expression ev x r}{prog : Program (Ⓢ ev) x}{C : Constraint (Ⓢ x) Extended}{f}{C′ : Constraint (x ⨁ suc f) Flat}
             {r′}{C′′ : SeparatedConstraint (x ⨁ suc f) r′}{n}{θ : x ⨁ suc f → Type (x ⨁ n)}{Qr}
         → TS-f.map (suc) ∘ Γ ► Exp-f.map suc e ∶ unit zero  ↝ C
         → C prenex: f , C′
         → C′ separate: r′ , C′′
         → Q , ε , suc f solv► C′′ ↝ n , Qr , θ
         → Q , ⟨ ∀′ n · Qr ⇒ (θ (PlusN-m.unit {f} zero)) ⟩, Γ ► prog
         → Q , Γ ► bind₁ e , prog

  go :  {ev tv : Set}(Q : AxiomScheme tv)(Γ : Environment ev tv) → (eq : Eq tv) → (p : Program ev tv) → Ⓢ (Q , Γ ► p)
  go Q Γ eq (end) = suc Empty
  go {ev}{tv} Q Γ eq (bind₁ e , prog)
                       with genConstraint {ev}{Ⓢ tv} (TS-f.map suc ∘ Γ) (Exp-f.map suc e) (unit zero)
  ... | C , prf₁       with prenex C
  ... | f , C′ , prf₂  with separate C′
  ... | r , C′′ , prf₃ with solver eq (suc f) Q ε C′′
  ... | zero = zero
  ... | suc (m , Qr , θ , prf₄) with go Q (⟨ ∀′ m · Qr ⇒ (θ (PlusN-m.unit {f} zero)) ⟩, Γ) eq prog
  ... | zero = zero
  ... | suc prf₅ = suc (Bind prf₁ prf₂ prf₃ prf₄ prf₅)
  go Q Γ eq (bind₂ m · e ∷ Qc ⇒ τ , prog)
                       with genConstraint (TS-f.map (PlusN-m.unit {m}) ∘ Γ) e τ
  ... | C , prf₁       with prenex C
  ... | f , C′ , prf₂  with separate C′
  ... | r , C′′ , prf₃ with solver (PlusN-eq {m} eq) f (Ax-f.map (PlusN-m.unit {m}) Q) Qc C′′
  ... | zero = zero
  ... | suc (f′ , Qr , θ , prf₄) with is-ε Qr
  ... | no _ = zero
  ... | yes prf₄′                with go Q (⟨ ∀′ m · Qc ⇒ τ ⟩, Γ) eq prog
  ... | zero = zero
  ... | suc prf₅ = let
         eq′ =  PlusN-eq {m} eq
        in suc (BindA prf₁ prf₂ prf₃ (subst (λ Qr → Ax-f.map (PlusN-m.unit {m}) Q , Qc , f solv► C′′ ↝ f′ , Qr , θ  ) prf₄′ prf₄) prf₅)


module Schedule where

open import Data.Bool
open import Data.Fin
open import Data.Empty
open import Data.List
open import Data.List.All
open import Data.Maybe
open import Data.Nat
open import Data.Product
open import Data.Sum
open import Data.Unit
open import Function using (_$_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Typing
open import Syntax
open import Global
open import Channel
open import Values
open import Session

-- outcomes of step
data Event : Set where
  Terminated Forked Restarted Halted New Closed NotClosed WaitSkipped : Event
  SendSkipped Received NotReceived : Event
  Stuck : Event
  Selected NotSelected : Event
  NSelected NotNSelected BranchSkipped NBranchSkipped : Event

data NextPool : Set where
  _,_ : ∀ {G} → Event → ThreadPool G → NextPool

module Alternative where
  step : ∀ {Gtop G1 G2} → SSplit Gtop G1 G2 → ThreadPool G1 → ThreadPool G2 → NextPool
  step ss-top (tnil ina) tp2@(tnil _) = Terminated , tp2

  step ss-top (tnil ina) tp2 = Stuck , tp2

  step ss-top (tcons ss (Fork{G₁ = G₁}{G₂ = G₂} ss₁ κ₁ κ₂) tp) tp2
    with ssplit-compose ss ss₁
  ... | Gi , ss₁₃ , ss₂₄ with ssplit-refl-right G₁ | ssplit-refl-right G₂
  ... | Gunit , ss-G1GunitG1 | G2unit , ss-G2GuG2 =
    Forked , (tappend ss-top ((tcons ss₁₃ (apply-cont ss-G1GunitG1 κ₁ (VUnit (ssplit-inactive-right ss-G1GunitG1)))
                             (tcons ss₂₄ (Ready ss-G2GuG2 (VUnit (ssplit-inactive-right ss-G2GuG2)) κ₂) tp))) tp2)

  step ss-top (tcons ss (Ready ss₁ v κ) tp) tp2 =
    Restarted , (tappend ss-top (tsnoc ss tp (apply-cont ss₁ κ v)) tp2)

  step ss-top (tcons ss (Halt inaG x₁ x₂) tp) tp2
    rewrite inactive-left-ssplit ss inaG = Halted , (tappend ss-top tp tp2)

  step ss-top (tcons{G₁} ss (New s κ) tp) tp2
    with ssplit-refl-right G₁
  ... | Gi , ss-GiG1
    with ssplit-inactive-right ss-GiG1
  ... | ina-Gi = New , (tappend (ss-left ss-top) ((tcons (ss-left ss)
           (Ready (ss-left ss-GiG1) (VPair (ss-posneg (inactive-ssplit-trivial ina-Gi)) (VChan POS (here-pos ina-Gi (subF-refl _))) (VChan NEG (here-neg ina-Gi (subF-refl _)))) (lift-cont κ))
           (lift-threadpool tp))) (lift-threadpool tp2))

  step ss-top (tcons{G₁}{G₂} ss cmd@(Close ss-vκ v κ) tp) tp2
    with ssplit-compose ss-top ss
  ... | Gi , ss-top1 , ss-top2
    with ssplit-refl-left-inactive Gi
  ... | G' , ina-G' , ss-GG'
    with matchWaitAndGo ss-top1 (ss-vκ , v , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G')
  ... | just (Gnext , tpnext) = Closed , tpnext
  ... | nothing
    with ssplit-compose5 ss-top ss
  ... | Gi' , ss-top1' , ss-top2' = step ss-top1' tp (tsnoc ss-top2' tp2 cmd)

  step ss-top (tcons ss cmd@(Wait ss₁ v κ) tp) tp2
    with ssplit-compose5 ss-top ss
  ... | Gi , ss-top1 , ss-top2 =
    step ss-top1 tp (tsnoc ss-top2 tp2 cmd)

  step ss-top (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp) tp2
    with ssplit-compose5 ss-top ss
  ... | Gi , ss-top1 , ss-top2 =
    step ss-top1 tp (tsnoc ss-top2 tp2 cmd)

  step ss-top (tcons{G₁}{G₂} ss cmd@(Recv ss-vκ vch κ) tp) tp2
    with ssplit-compose ss-top ss
  ... | Gi , ss-top1 , ss-top2
    with ssplit-refl-left-inactive Gi
  ... | G' , ina-G' , ss-GG'
    with matchSendAndGo ss-top1 (ss-vκ , vch , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G')
  ... | just (G-next , tp-next) =
    Received , tp-next
  ... | nothing
    with ssplit-compose5 ss-top ss
  ... | Gi' , ss-top1' , ss-top2' =
    step ss-top1' tp (tsnoc ss-top2' tp2 cmd)

  step ss-top (tcons{G₁}{G₂} ss cmd@(Select ss-vκ lab vch κ) tp) tp2
    with ssplit-compose ss-top ss
  ... | Gi , ss-top1 , ss-top2
    with ssplit-refl-left-inactive Gi
  ... | G' , ina-G' , ss-GG'
    with matchBranchAndGo ss-top1 (ss-vκ , lab , vch , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G')
  ... | just (G-next , tp-next) =
    Selected , tp-next
  ... | nothing
    with ssplit-compose5 ss-top ss
  ... | Gi' , ss-top1' , ss-top2' =
    step ss-top1' tp (tsnoc ss-top2' tp2 cmd)

  step ss-top (tcons ss cmd@(Branch ss₁ vch dcont) tp) tp2
    with ssplit-compose5 ss-top ss
  ... | Gi , ss-top1 , ss-top2 =
    step ss-top1 tp (tsnoc ss-top2 tp2 cmd)

  step ss-top (tcons{G₁}{G₂} ss cmd@(NSelect ss-vκ lab vch κ) tp) tp2
    with ssplit-compose ss-top ss
  ... | Gi , ss-top1 , ss-top2
    with ssplit-refl-left-inactive Gi
  ... | G' , ina-G' , ss-GG'
    with matchNBranchAndGo ss-top1 (ss-vκ , lab , vch , κ) ss-GG' (tappend ss-top2 tp tp2) (tnil ina-G')
  ... | just (G-next , tp-next) = NSelected , tp-next
  ... | nothing
    with ssplit-compose5 ss-top ss
  ... | Gi' , ss-top1' , ss-top2' =
    step ss-top1' tp (tsnoc ss-top2' tp2 cmd)

  step ss-top (tcons ss cmd@(NBranch ss₁ vch dcont) tp) tp2
    with ssplit-compose5 ss-top ss
  ... | Gi , ss-top1 , ss-top2 =
    step ss-top1 tp (tsnoc ss-top2 tp2 cmd)

module Original where
  step : ∀ {G} → ThreadPool G → NextPool
  step (tnil ina) =
    Terminated , tnil ina
  step (tcons ss (Fork{G₁ = G₁}{G₂ = G₂} ss₁ κ₁ κ₂) tp) with ssplit-compose ss ss₁
  ... | Gi , ss₁₃ , ss₂₄ with ssplit-refl-right G₁ | ssplit-refl-right G₂
  ... | Gunit , ss-G1GunitG1 | G2unit , ss-G2GuG2 =
    Forked , (tcons ss₁₃ (apply-cont ss-G1GunitG1 κ₁ (VUnit (ssplit-inactive-right ss-G1GunitG1)))
                    (tcons ss₂₄ (apply-cont ss-G2GuG2 κ₂ (VUnit (ssplit-inactive-right ss-G2GuG2))) tp))
  step (tcons ss (Ready ss₁ v κ) tp) =
    Restarted , (tsnoc ss tp (apply-cont ss₁ κ v))
  step (tcons ss (Halt inaG x₁ x₂) tp) rewrite inactive-left-ssplit ss inaG =
    Halted , tp
  step (tcons{G₁} ss (New s κ) tp) with ssplit-refl-right G₁
  ... | Gi , ss-GiG1 with ssplit-inactive-right ss-GiG1
  ... | ina-Gi =
    New , (tcons (ss-left ss)
             (apply-cont (ss-left ss-GiG1) (lift-cont κ) (VPair (ss-posneg (inactive-ssplit-trivial ina-Gi)) (VChan POS (here-pos ina-Gi (subF-refl _))) (VChan NEG (here-neg ina-Gi (subF-refl _)))))
             (lift-threadpool tp))
  step (tcons{G₁}{G₂} ss cmd@(Close ss-vκ v κ) tp) with ssplit-refl-left-inactive G₂
  ... | G' , ina-G' , ss-GG' with matchWaitAndGo ss (ss-vκ , v , κ) ss-GG' tp (tnil ina-G')
  ... | just (Gnext , tpnext) = Closed , tpnext
  ... | nothing = NotClosed , (tsnoc ss tp cmd)
  step (tcons ss cmd@(Wait ss₁ v κ) tp) =
    WaitSkipped , (tsnoc ss tp cmd)
  step (tcons ss cmd@(Send ss₁ ss-args vch v κ) tp) =
    SendSkipped , (tsnoc ss tp cmd)
  step (tcons{G₁}{G₂} ss cmd@(Recv ss-vκ vch κ) tp) with ssplit-refl-left-inactive G₂
  ... | G' , ina-G' , ss-GG' with matchSendAndGo ss (ss-vκ , vch , κ) ss-GG' tp (tnil ina-G')
  ... | just (G-next , tp-next) = Received , tp-next
  ... | nothing = NotReceived , (tsnoc ss tp cmd)
  step (tcons{G₁}{G₂} ss cmd@(Select ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂
  ... | G' , ina-G' , ss-GG' with matchBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G')
  ... | just (G-next , tp-next) = Selected , tp-next
  ... | nothing = NotSelected , (tsnoc ss tp cmd)
  step (tcons ss cmd@(Branch ss-vκ vch dcont) tp) =
    BranchSkipped , (tsnoc ss tp cmd)
  step (tcons{G₁}{G₂} ss cmd@(NSelect ss-vκ lab vch κ) tp) with ssplit-refl-left-inactive G₂
  ... | G' , ina-G' , ss-GG' with matchNBranchAndGo ss (ss-vκ , lab , vch , κ) ss-GG' tp (tnil ina-G')
  ... | just (G-next , tp-next) = NSelected , tp-next
  ... | nothing = NotNSelected , (tsnoc ss tp cmd)
  step (tcons ss cmd@(NBranch ss-vκ vch dcont) tp) =
    NBranchSkipped , (tsnoc ss tp cmd)

open Alternative

single-step : (∃ λ G → ThreadPool G) → Event × (∃ λ G → ThreadPool G)
single-step (G , tp)
  with ssplit-refl-left-inactive G
... | G' , ina-G' , ss-GG'
  with step ss-GG' tp (tnil ina-G')
... | ev , tp' = ev , ( _ , tp')

-- stuff to run ...
data Gas : Set where
  Empty : Gas
  More  : Gas → Gas

-- outcomes of scheduling
data Outcome : Set where
  Terminated : Outcome
  _,_ : Event → Outcome → Outcome
  OutOfGas : ∀ {G} → ThreadPool G → Outcome

-- thread scheduling
schedule : {G : SCtx} → Gas → ThreadPool G → Outcome
schedule Empty tp = OutOfGas tp
schedule{G} (More gas) tp
  with single-step (_ , tp)
... | Terminated , _ , tp' = Terminated
... | ev , _ , tp' = ev , (schedule gas tp')

-- start main thread
start : Gas → Expr [] TUnit → Outcome
start f e =
  schedule f (tcons ss-[] (run [] ss-[] e (vnil []-inactive) (halt []-inactive UUnit)) (tnil []-inactive))


------------------------------------------------------------------------
-- A definitional interpreter
------------------------------------------------------------------------

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

module Lambda.Delay-monad.Interpreter where

open import Equality.Propositional
open import Prelude
open import Prelude.Size

open import Maybe equality-with-J
open import Monad equality-with-J
open import Vec.Function equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity
open import Delay-monad.Monad

open import Lambda.Syntax hiding ([_])

open Closure Tm

------------------------------------------------------------------------
-- An interpreter monad

-- The interpreter monad.

M : ∀ {ℓ} → Size → Type ℓ → Type ℓ
M i = MaybeT (λ A → Delay A i)

-- A variant of the interpreter monad.

M′ : ∀ {ℓ} → Size → Type ℓ → Type ℓ
M′ i = MaybeT (λ A → Delay′ A i)

-- A lifted variant of later.

laterM : ∀ {i a} {A : Type a} → M′ i A → M i A
run (laterM x) = later (run x)

-- A lifted variant of weak bisimilarity.

infix 4 _≈M_

_≈M_ : ∀ {a} {A : Type a} → M ∞ A → M ∞ A → Type a
x ≈M y = run x ≈ run y

------------------------------------------------------------------------
-- The interpreter

infix 10 _∙_

mutual

  ⟦_⟧ : ∀ {i n} → Tm n → Env n → M i Value
  ⟦ con i ⟧   ρ = return (con i)
  ⟦ var x ⟧   ρ = return (ρ x)
  ⟦ ƛ t ⟧     ρ = return (ƛ t ρ)
  ⟦ t₁ · t₂ ⟧ ρ = ⟦ t₁ ⟧ ρ >>= λ v₁ →
                  ⟦ t₂ ⟧ ρ >>= λ v₂ →
                  v₁ ∙ v₂

  _∙_ : ∀ {i} → Value → Value → M i Value
  con i  ∙ v₂ = fail
  ƛ t₁ ρ ∙ v₂ = laterM (⟦ t₁ ⟧′ (cons v₂ ρ))

  ⟦_⟧′ : ∀ {i n} → Tm n → Env n → M′ i Value
  force (run (⟦ t ⟧′ ρ)) = run (⟦ t ⟧ ρ)

------------------------------------------------------------------------
-- An example

-- The semantics of Ω is the non-terminating computation never.

Ω-loops : ∀ {i} → [ i ] run (⟦ Ω ⟧ nil) ∼ never
Ω-loops = later λ { .force → Ω-loops }


open import Data.Empty
open import Data.List renaming (_∷_ to _∷ₗ_ ; [_] to [_]ₗ)
open import Data.Maybe
open import Data.Product
open import Data.Sum
open import Data.Unit

open import AEff
open import AwaitingComputations
open import EffectAnnotations
open import Preservation
open import ProcessPreservation
open import Progress
open import Renamings
open import Substitutions
open import Types

open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Negation

module ProcessProgress where

-- PROCESS RESULTS

data ParResult⟨_⟩ : {o : O} {PP : PType o} → [] ⊢P⦂ PP → Set where

  run    : {X : VType}
           {o : O}
           {i : I} →
           {M : [] ⊢M⦂ X ! (o , i)} →
           RunResult⟨ [] ∣ M ⟩ →
           --------------------------
           ParResult⟨ run M ⟩

  par    : {o o' : O}
           {PP : PType o}
           {QQ : PType o'}
           {P : [] ⊢P⦂ PP}
           {Q : [] ⊢P⦂ QQ} →
           ParResult⟨ P ⟩ →
           ParResult⟨ Q ⟩ →
           ------------------
           ParResult⟨ P ∥ Q ⟩

data ProcResult⟨_⟩ : {o : O} {PP : PType o} → [] ⊢P⦂ PP → Set where

  proc   : {o : O}
           {PP : PType o}
           {P : [] ⊢P⦂ PP} →
           ParResult⟨ P ⟩ →
           -----------------
           ProcResult⟨ P ⟩

  signal : {o : O}
           {PP : PType o}
           {op : Σₛ}
           {p : op ∈ₒ o}
           {V : [] ⊢V⦂ ``(payload op)}
           {P : [] ⊢P⦂ PP} →
           ProcResult⟨ P ⟩ →
           ---------------------------
           ProcResult⟨ ↑ op p V P ⟩

-- PROGRESS THEOREM FOR PROCESSES

{- THEOREM 4.3 -}

proc-progress : {o : O}
                {PP : PType o} →
                (P : [] ⊢P⦂ PP) →
                -------------------------------------------------------------------------------
                (Σ[ o' ∈ O ] Σ[ QQ ∈ PType o' ] Σ[ r ∈ PP ⇝ QQ ] Σ[ Q ∈ [] ⊢P⦂ QQ ] (P [ r ]↝ Q)
                 ⊎
                 ProcResult⟨ P ⟩)

proc-progress (run {X} {o} {i} M) with progress M
... | inj₁ (M' , r) =
  inj₁ (_ , _ , _ , _ , run r)
... | inj₂ (comp R) =
  inj₂ (proc (run R))
... | inj₂ (signal {_} {_} {_} {_} {p} {V} {Q} R) =
  inj₁ (_ , _ , _ , _ , ↑ p V Q)
proc-progress (P ∥ Q) with proc-progress P
... | inj₁ (o' , PP' , r , P' , r') =
  inj₁ (_ , _ , _ , _ , context ([-] ∥ₗ Q) r')
... | inj₂ R with proc-progress Q
... | inj₁ (o' , QQ' , r , Q' , r') =
  inj₁ (_ , _ , _ , _ , context (P ∥ᵣ [-]) r')
proc-progress (P ∥ Q) | inj₂ (proc R) | inj₂ (proc R') =
  inj₂ (proc (par R R'))
proc-progress (P ∥ .(↑ _ _ _ _)) | inj₂ R | inj₂ (signal {_} {_} {_} {p} {V} {Q} R') =
  inj₁ (_ , _ , _ , _ , ↑-∥ᵣ p V P Q)
proc-progress (.(↑ _ _ _ _) ∥ Q) | inj₂ (signal {_} {_} {_} {p} {V} {P} R) | inj₂ R' =
  inj₁ (_ , _ , _ , _ , ↑-∥ₗ p V P Q)
proc-progress (↑ op p V P) with proc-progress P
... | inj₁ (o' , PP' , r , P' , r') =
  inj₁ (_ , _ , _ , _ , context (↑ op p V [-]) r')
... | inj₂ R =
  inj₂ (signal R)
proc-progress (↓ op V P) with proc-progress P
... | inj₁ (o' , OO' , r , P' , r') =
  inj₁ (_ , _ , _ , _ , context (↓ op V [-]) r')
... | inj₂ (proc (run {_} {_} {_} {M} R)) =
  inj₁ (_ , _ , _ , _ , ↓-run V M)
... | inj₂ (proc (par {_} {_} {_} {_} {Q} {Q'} R R')) =
  inj₁ (_ , _ , _ , _ , ↓-∥ V Q Q')
... | inj₂ (signal {_} {_} {_} {p} {W} {Q} R) =
  inj₁ (_ , _ , _ , _ , ↓-↑ p V W Q)


module sn-calculus-confluence.potpot where

open import utility
open import sn-calculus
open import context-properties
  using (->pot-view)

open import Esterel.Lang
open import Esterel.Lang.CanFunction
  using (Can ; Canₛ ; Canₛₕ ; Canθ ; Canθₛ ; Canθₛₕ)
open import Esterel.Lang.CanFunction.Properties
  using ( canθₛ-set-sig-monotonic-absence-lemma ; canθₛₕ-set-sig-monotonic-absence-lemma
        ; canθ-shr-var-irr
        )
open import Esterel.Environment as Env
  using (Env ; Θ ; _←_ ; module SigMap ; module ShrMap ; module VarMap)
open import Esterel.Context
open import Esterel.CompletionCode as Code
  using () renaming (CompletionCode to Code)
open import Esterel.Variable.Signal as Signal
  using (Signal)
open import Esterel.Variable.Shared as SharedVar
  using (SharedVar)
open import Esterel.Variable.Sequential as SeqVar
  using (SeqVar)

open import Data.Bool
  using (Bool ; true ; false ; if_then_else_)
open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.List
  using (List ; [] ; _∷_ ; [_])
open import Data.List.Any
  using (Any ; here ; there ; any)
open import Data.Maybe
  using (Maybe ; just ; nothing)
open import Data.Nat
  using (ℕ ; _≟_ ; zero ; suc ; _+_)
open import Data.Nat.Properties.Simple
  using ( +-comm ; +-assoc)
open import Data.Product
  using (Σ ; Σ-syntax ; _,_ ; proj₁ ; proj₂ ; _,′_ ; _×_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function
  using (_∘_ ; id ; _∋_)
open import Relation.Nullary
  using (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; sym ; trans ; cong ; subst ; module ≡-Reasoning)

open ->pot-view
open ≡-Reasoning
  using (begin_ ; _∎ ; _≡⟨_⟩_ ; _≡⟨⟩_)

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

pot-pot-conf-rec : ∀{p θ ql θl qr θr eql eqr A Al Ar Aql Arl}
                 → {ρθ·psn⟶₁ρθl·ql  :  (ρ⟨ θ , A ⟩· p) sn⟶₁ (ρ⟨ θl , Al ⟩· ql)}
                 → {ρθ·psn⟶₁ρθr·qr  :  (ρ⟨ θ , A ⟩· p) sn⟶₁ (ρ⟨ θr , Ar ⟩· qr)}
                 → ->pot-view  ρθ·psn⟶₁ρθl·ql  eql Aql
                 → ->pot-view  ρθ·psn⟶₁ρθr·qr  eqr Arl
                 → (ρ⟨ θl , Al ⟩· ql ≡ ρ⟨ θr , Ar ⟩· qr)
                   ⊎
                   Σ[ θo ∈ Env ]
                   (ρ⟨ θl , Al ⟩· ql) sn⟶₁ (ρ⟨ θo , A ⟩· p) ×
                   (ρ⟨ θr , Ar ⟩· qr) sn⟶₁ (ρ⟨ θo , A ⟩· p)

pot-pot-conf-rec {p} {θ} {.p} {θl} {.p} {θr} {_} {_} {A} {.A} {.A} {refl} {refl}
                 {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
                 {.(rabsence {θ} {p} {S'} S'∈ θS'≡unknown S'∉can-p-θ)}
                 (vabsence S S∈ θS≡unknown S∉can-p-θ)
                 (vabsence S' S'∈ θS'≡unknown S'∉can-p-θ)
  with S Signal.≟ S'
... | yes refl = inj₁ refl
... | no S≢S' =
  inj₂
  (_ ,
   subst (λ sig* → ρ⟨ θl , A ⟩· p sn⟶₁ ρ⟨ (Θ sig* (Env.shr θl) (Env.var θl))  , A ⟩· p)
     (SigMap.put-comm {_} {Env.sig θ} {S} {S'} {Signal.absent} {Signal.absent} S≢S')
     (rabsence {θl} {p} {S'} S'∈Domθl θlS'≡unknown
       (λ S'∈can-p-θl →
         S'∉can-p-θ
           (canθₛ-set-sig-monotonic-absence-lemma (Env.sig θ) 0 p S Env.[]env
             S∈ θS≡unknown (Signal.unwrap S') S'∈can-p-θl))) ,′
   rabsence {θr} {p} {S} S∈Domθr θrS≡unknown
     (λ S∈can-p-θr →
       S∉can-p-θ
         (canθₛ-set-sig-monotonic-absence-lemma (Env.sig θ) 0 p S' Env.[]env
             S'∈ θS'≡unknown (Signal.unwrap S) S∈can-p-θr)))
  where
    S∈Domθr      = Env.sig-set-mono' {S}  {S'} {θ} {Signal.absent} {S'∈} S∈
    S'∈Domθl     = Env.sig-set-mono' {S'} {S}  {θ} {Signal.absent} {S∈}  S'∈
    θrS≡unknown  = SigMap.putputget {_} {Env.sig θ} {S}  {S'} {Signal.unknown} {Signal.absent}
                      S≢S'         S∈  S∈Domθr  θS≡unknown
    θlS'≡unknown = SigMap.putputget {_} {Env.sig θ} {S'} {S}  {Signal.unknown} {Signal.absent}
                     (S≢S' ∘ sym) S'∈ S'∈Domθl θS'≡unknown

pot-pot-conf-rec {p} {θ} {.p} {θl} {.p} {θr} {_} {_} {A} {.A} {.A} {refl} {refl}
                 {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
                 {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
                 (vabsence S S∈ θS≡unknown S∉can-p-θ)
                 (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ) =
  inj₂
  (_ ,
   rreadyness {θl} {p} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-p-θl →
       s∉can-p-θ
         (canθₛₕ-set-sig-monotonic-absence-lemma (Env.sig θ) 0 p S Env.[]env
           S∈ θS≡unknown (SharedVar.unwrap s) s∈can-p-θl)) ,′
   rabsence {θr} {p} {S} S∈ θS≡unknown
     (λ S∈can-p-θr →
       S∉can-p-θ
         (subst (Signal.unwrap S ∈_)
           (cong proj₁ (canθ-shr-var-irr (Env.sig θ) 0 p Env.[]env Env.[]env refl))
           S∈can-p-θr)))

pot-pot-conf-rec {p} {θ} {.p} {θl} {.p} {θr} {_} {_} {A} {.A} {.A} {refl} {refl}
                 {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
                 {.(rabsence {θ} {p} {S} S∈ θS≡unknown S∉can-p-θ)}
                 (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
                 (vabsence S S∈ θS≡unknown S∉can-p-θ) =
  inj₂
  (_ ,
   rabsence {θl} {p} {S} S∈ θS≡unknown
     (λ S∈can-p-θl →
       S∉can-p-θ
         (subst (Signal.unwrap S ∈_)
           (cong proj₁ (canθ-shr-var-irr (Env.sig θ) 0 p Env.[]env Env.[]env refl))
           S∈can-p-θl)) ,′
   rreadyness {θr} {p} {s} s∈ θs≡old⊎θs≡new
     (λ s∈can-p-θr →
       s∉can-p-θ
         (canθₛₕ-set-sig-monotonic-absence-lemma (Env.sig θ) 0 p S Env.[]env
           S∈ θS≡unknown (SharedVar.unwrap s) s∈can-p-θr)))

pot-pot-conf-rec {p} {θ} {.p} {θl} {.p} {θr} {_} {_} {A} {.A} {.A} {refl} {refl}
                 {.(rreadyness {θ} {p} {s} s∈ θs≡old⊎θs≡new s∉can-p-θ)}
                 {.(rreadyness {θ} {p} {s'} s'∈ θs'≡old⊎θs'≡new s'∉can-p-θ)}
                 (vreadyness s s∈ θs≡old⊎θs≡new s∉can-p-θ)
                 (vreadyness s' s'∈ θs'≡old⊎θs'≡new s'∉can-p-θ)
  with s SharedVar.≟ s'
... | yes refl rewrite Env.shr-vals-∈-irr {s'} {θ} s∈ s'∈ = inj₁ refl
... | no s≢s' =
  inj₂
  (_ ,
   subst (λ shr* → ρ⟨ θl  , A ⟩· p sn⟶₁ ρ⟨ (Θ (Env.sig θl) shr* (Env.var θl))  , A ⟩· p)
     (cong Env.shr
       (begin
           Env.set-shr {s'} θl s'∈Domθl SharedVar.ready
             (Env.shr-vals {s'} θl s'∈Domθl)
        ≡⟨ cong (Env.set-shr {s'} θl s'∈Domθl SharedVar.ready ∘ proj₂) θls'≡θs' ⟩
           Env.set-shr {s'} θl s'∈Domθl SharedVar.ready θs'
        ≡⟨ cong (λ shr* → Θ (Env.sig θ) shr* (Env.var θ))
             (ShrMap.put-comm {_} {Env.shr θ} {s} {s'}
               {SharedVar.ready , θs} {SharedVar.ready , θs'} s≢s') ⟩
           Env.set-shr {s} θr s∈Domθr SharedVar.ready θs
        ≡⟨ cong (Env.set-shr {s} θr s∈Domθr SharedVar.ready ∘ proj₂) (sym θrs≡θs) ⟩
           Env.set-shr {s} θr s∈Domθr SharedVar.ready
             (Env.shr-vals {s} θr s∈Domθr)
        ∎))
     (rreadyness {θl} {p} {s'} s'∈Domθl
       (Data.Sum.map
         (trans (cong proj₁ θls'≡θs'))
         (trans (cong proj₁ θls'≡θs'))
         θs'≡old⊎θs'≡new)
       (λ s'∈can-p-θl →
         s'∉can-p-θ
           (subst (SharedVar.unwrap s' ∈_)
             (cong (proj₂ ∘ proj₂) (canθ-shr-var-irr (Env.sig θ) 0 p Env.[]env Env.[]env refl))
             s'∈can-p-θl))) ,′
   rreadyness {θr} {p} {s} s∈Domθr
     (Data.Sum.map
       (trans (cong proj₁ θrs≡θs))
       (trans (cong proj₁ θrs≡θs))
       θs≡old⊎θs≡new)
     (λ s∈can-p-θr →
       s∉can-p-θ
         (subst (SharedVar.unwrap s ∈_)
           (cong (proj₂ ∘ proj₂) (canθ-shr-var-irr (Env.sig θ) 0 p Env.[]env Env.[]env refl))
           s∈can-p-θr)))
  where
    θs       = Env.shr-vals {s} θ s∈
    θs'      = Env.shr-vals {s'} θ s'∈
    s∈Domθr  = Env.shr-set-mono' {s}  {s'} {θ} {SharedVar.ready} {θs'} {s'∈} s∈
    s'∈Domθl = Env.shr-set-mono' {s'} {s}  {θ} {SharedVar.ready} {θs}  {s∈}  s'∈
    θrs≡θs   = ShrMap.putputget {_} {Env.shr θ} {s}  {s'} {_} {SharedVar.ready ,′ θs'}
                      s≢s'         s∈  s∈Domθr  refl
    θls'≡θs' = ShrMap.putputget {_} {Env.shr θ} {s'}  {s} {_} {SharedVar.ready ,′ θs}
                     (s≢s' ∘ sym) s'∈ s'∈Domθl  refl