{- 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
-}

-- This module contains definitions of properties of only the behavior of the
-- handlers, nothing concerning the system state.

open import LibraBFT.Base.Types
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Concrete.Records
open import LibraBFT.Impl.Consensus.ConsensusTypes.Block as Block
open import LibraBFT.Impl.Consensus.EpochManagerTypes
import      LibraBFT.Impl.Handle as Handle
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import LibraBFT.ImplShared.Consensus.Types.EpochDep
open import LibraBFT.ImplShared.Interface.Output
open import LibraBFT.ImplShared.Util.Dijkstra.All
open import Optics.All
open import Util.ByteString
open import Util.KVMap                                   as Map
open import Util.Lemmas
open import Util.PKCS
open import Util.Prelude

open import LibraBFT.ImplShared.Util.HashCollisions Handle.InitHandler.initAndHandlers
open import LibraBFT.Abstract.Types.EpochConfig UID NodeId
open        ParamsWithInitAndHandlers Handle.InitHandler.initAndHandlers
open import Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms
                      Handle.InitHandler.initAndHandlers
                      PeerCanSignForPK PeerCanSignForPK-stable

module LibraBFT.Impl.Properties.Util where

module Meta where
  getLastVoteEpoch : SafetyData → Epoch
  getLastVoteEpoch sd = (Maybe-maybe{B = const Epoch} (_^∙ vEpoch) (sd ^∙ sdEpoch)) ∘ (_^∙ sdLastVote) $ sd
  -- getLastVoteEpoch rm = (maybe{B = const Epoch} (_^∙ vEpoch) (rm ^∙ pssSafetyData-rm ∙ sdEpoch)) ∘ (_^∙ pssSafetyData-rm ∙ sdLastVote) $ rm

  getLastVoteRound : SafetyData → Round
  getLastVoteRound = (Maybe-maybe{B = const Round} (_^∙ vRound) 0) ∘ (_^∙ sdLastVote)
  -- getLastVoteRound = maybe{B = const Round} (_^∙ vRound) 0 ∘ (_^∙ pssSafetyData-rm ∙ sdLastVote)

  subst-getLastVoteRound : ∀ {sd1 sd2} → sd1 ≡ sd2 → getLastVoteRound sd1 ≡ getLastVoteRound sd2
  subst-getLastVoteRound refl = refl

module OutputProps where
  module _ (outs : List Output) where
    None : Set
    None = outs ≡ []

    NoVotes     = NoneOfKind outs isSendVote?
    NoProposals = NoneOfKind outs isBroadcastProposal?
    NoSyncInfos = NoneOfKind outs isBroadcastSyncInfo?
    NoMsgs      = NoneOfKind outs isOutputMsg?
    NoErrors    = NoneOfKind outs isLogErr?

    NoMsgs⇒× : NoMsgs → NoProposals × NoVotes × NoSyncInfos
    proj₁ (NoMsgs⇒× noMsgs) =
      filter-∪?-[]₁ outs isBroadcastProposal? _ noMsgs
    proj₁ (proj₂ (NoMsgs⇒× noMsgs)) =
      filter-∪?-[]₂ outs _ isSendVote?
        (filter-∪?-[]₂ outs _ _ noMsgs)
    proj₂ (proj₂ (NoMsgs⇒× noMsgs)) =
      filter-∪?-[]₁ outs isBroadcastSyncInfo? _
        (filter-∪?-[]₂ outs _ _ noMsgs)

    NoMsgs⇒NoProposals : NoMsgs → NoProposals
    NoMsgs⇒NoProposals = proj₁ ∘ NoMsgs⇒×

    NoMsgs⇒NoVotes : NoMsgs → NoVotes
    NoMsgs⇒NoVotes = proj₁ ∘ proj₂ ∘ NoMsgs⇒×

    OneVote : VoteMsg → List Author → Set
    OneVote vm pids = List-filter isSendVote? outs ≡ (SendVote vm pids ∷ [])

  ++-NoMsgs      = λ xs ys → ++-NoneOfKind xs ys isOutputMsg?
  ++-NoVotes     = λ xs ys → ++-NoneOfKind xs ys isSendVote?
  ++-NoProposals = λ xs ys → ++-NoneOfKind xs ys isBroadcastProposal?

  ++-NoVotes-OneVote : ∀ xs ys {vm} {pids} → NoVotes xs → OneVote ys vm pids
                       → OneVote (xs ++ ys) vm pids
  ++-NoVotes-OneVote xs ys nv ov
    rewrite List-filter-++ isSendVote? xs ys
    |       nv = ov

  ++-OneVote-NoVotes : ∀ xs {vm pids} ys → OneVote xs vm pids → NoVotes ys
                       → OneVote (xs ++ ys) vm pids
  ++-OneVote-NoVotes xs ys ov nv
    rewrite List-filter-++ isSendVote? xs ys
    |       nv
    |       ov = refl

module BlockProps (b : Block) where
  ∈BlockTree_      : BlockTree → Set
  ∈BlockTree bt    = ∃[ eb ] (btGetBlock (b ^∙ bId) bt ≡ just eb)

  ∈BlockStore_     : BlockStore → Set
  ∈BlockStore bs   = ∈BlockTree (bs ^∙ bsInner)

  ∈RoundManager_   : RoundManager → Set
  ∈RoundManager rm = ∈BlockStore (rm ^∙ lBlockStore)

module QCProps where

  data _∈BlockTree_ (qc : QuorumCert) (bt : BlockTree) : Set where
    inHQC : qc ≡ bt ^∙ btHighestQuorumCert → qc ∈BlockTree bt
    inHCC : qc ≡ bt ^∙ btHighestCommitCert → qc ∈BlockTree bt

  _∈RoundManager_ : (qc : QuorumCert) (rm : RoundManager) → Set
  qc ∈RoundManager rm =  qc ∈BlockTree (rm ^∙ lBlockStore ∙ bsInner)

  ∈Post⇒∈PreOr' : ∀ {A : Set} (_QC∈_ : QuorumCert → A → Set) (Q : QuorumCert → Set) (pre post : A) → Set
  ∈Post⇒∈PreOr' _QC∈_ Q pre post = ∀ qc → qc QC∈ post → qc QC∈ pre ⊎ Q qc

  ∈Post⇒∈PreOr'-∙ : ∀ {A B : Set}
                    → (l : Lens A B)
                    → (_QC∈B_ : QuorumCert → B → Set)
                    → (_QC∈A_ : QuorumCert → A → Set)
                    → (∀ {q st} → q QC∈B (st ^∙ l) → q QC∈A st)
                    → (∀ {q st} → q QC∈A st → q QC∈B (st ^∙ l))
                    → (Q : QuorumCert → Set)
                    → (pre post : A)
                    → ∈Post⇒∈PreOr' _QC∈B_ Q (pre ^∙ l) (post ^∙ l)
                    → ∈Post⇒∈PreOr' _QC∈A_ Q pre post
  ∈Post⇒∈PreOr'-∙ l _QC∈B_ _QC∈A_ prfBA prfAB Q pre post QCB qc qc∈Apost =
    ⊎-map₁ prfBA (QCB qc (prfAB qc∈Apost))

  ∈Post⇒∈PreOr-∙-BT-RM : _
  ∈Post⇒∈PreOr-∙-BT-RM = ∈Post⇒∈PreOr'-∙ lBlockTree _∈BlockTree_ _∈RoundManager_ id id

  ∈Post⇒∈PreOrBT : (Q : QuorumCert → Set) (pre post : BlockTree) → Set
  ∈Post⇒∈PreOrBT = ∈Post⇒∈PreOr' _∈BlockTree_

  ∈BlockTree-upd-hqc : ∀ {bt1 bt2}
                       → {Q : QuorumCert → Set}
                       → bt1 ≡L bt2 at btHighestCommitCert
                       → Q (bt2 ^∙ btHighestQuorumCert)
                       → ∈Post⇒∈PreOrBT Q bt1 bt2
  ∈BlockTree-upd-hqc refl Q _ (inHQC refl) = inj₂ Q
  ∈BlockTree-upd-hqc refl _ _ (inHCC refl) = inj₁ (inHCC refl)

  ∈BlockTree-upd-hcc : ∀ {bt1 bt2}
                       → {Q : QuorumCert → Set}
                       → bt1 ≡L bt2 at btHighestQuorumCert
                       → Q (bt2 ^∙ btHighestCommitCert)
                       → ∈Post⇒∈PreOrBT Q bt1 bt2
  ∈BlockTree-upd-hcc refl _ _ (inHQC refl) = inj₁ (inHQC refl)
  ∈BlockTree-upd-hcc refl Q _ (inHCC refl) = inj₂ Q

  ∈Post⇒∈PreOr : (Q : QuorumCert → Set) (pre post : RoundManager) → Set
  ∈Post⇒∈PreOr = ∈Post⇒∈PreOr' _∈RoundManager_

  ∈Post⇒∈PreOr'-refl : ∀ {A : Set}
                      → (_QC∈_ : QuorumCert → A → Set) (Q : QuorumCert → Set)
                      → ∀ {pre : A}
                      → ∈Post⇒∈PreOr' _QC∈_ Q pre pre
  ∈Post⇒∈PreOr'-refl _ _ _ = inj₁

  ∈Post⇒∈PreOrBT-QCs≡ : ∀ {bt1 bt2}
                        → (Q : QuorumCert → Set)
                        → bt1 ≡L bt2 at btHighestCommitCert
                        → bt1 ≡L bt2 at btHighestQuorumCert
                        → ∈Post⇒∈PreOrBT Q bt1 bt2
  ∈Post⇒∈PreOrBT-QCs≡ Q refl refl _ (inHQC refl) = inj₁ (inHQC refl)
  ∈Post⇒∈PreOrBT-QCs≡ Q refl refl _ (inHCC refl) = inj₁ (inHCC refl)

  ∈Post⇒∈PreOr'-trans : ∀ {A : Set}
                      → (_QC∈_ : QuorumCert → A → Set) (Q : QuorumCert → Set)
                      → ∀ {pre int post : A}
                      → ∈Post⇒∈PreOr' _QC∈_ Q pre int
                      → ∈Post⇒∈PreOr' _QC∈_ Q int post
                      → ∈Post⇒∈PreOr' _QC∈_ Q pre post
  ∈Post⇒∈PreOr'-trans _QC∈_ Q pre→int int→post qc qc∈post
     with int→post qc qc∈post
  ... | Right y = Right y
  ... | Left  x
     with pre→int qc x
  ... | Right y = Right y
  ... | Left x₁ = Left x₁

  ∈Post⇒∈PreOrBT-trans : ∀ (Q : QuorumCert → Set) {pre int post}
                       → ∈Post⇒∈PreOrBT Q pre int
                       → ∈Post⇒∈PreOrBT Q int post
                       → ∈Post⇒∈PreOrBT Q pre post
  ∈Post⇒∈PreOrBT-trans = ∈Post⇒∈PreOr'-trans _∈BlockTree_

  -- TODO-1: Factor out a property about a single output:
  -- λ out → ∃₂ λ qc nm → qc QC∈NM nm × nm Msg∈Out out
  OutputQc∈RoundManager : List Output → RoundManager → Set
  OutputQc∈RoundManager outs rm =
    All (λ out → ∀ qc nm → qc QC∈NM nm → nm Msg∈Out out → qc ∈RoundManager rm) outs

  ¬OutputQc : List Output → Set
  ¬OutputQc outs = All (λ out → ∀ qc nm → qc QC∈NM nm → nm Msg∈Out out → ⊥) outs

  ++-OutputQc∈RoundManager
    : ∀ {rm outs₁ outs₂}
      → OutputQc∈RoundManager outs₁ rm → OutputQc∈RoundManager outs₂ rm
      → OutputQc∈RoundManager (outs₁ ++ outs₂) rm
  ++-OutputQc∈RoundManager = All-++

  ++-¬OutputQc : ∀ {outs₁ outs₂} → ¬OutputQc outs₁ → ¬OutputQc outs₂
                 → ¬OutputQc (outs₁ ++ outs₂)
  ++-¬OutputQc = All-++

  NoMsgs⇒¬OutputQc : ∀ outs → OutputProps.NoMsgs outs → ¬OutputQc outs
  NoMsgs⇒¬OutputQc outs noMsgs =
    All-map help (noneOfKind⇒All¬ outs _ noMsgs)
    where
    help : ∀ {out : Output} → ¬ IsOutputMsg out → ∀ qc nm → qc QC∈NM nm → nm Msg∈Out out → ⊥
    help ¬msg qc .(P _) qc∈m inBP = ¬msg (Left tt)
    help ¬msg qc .(V _) qc∈m inSV = ¬msg (Right (Right tt))

  ¬OutputQc⇒OutputQc∈RoundManager : ∀ outs rm → ¬OutputQc outs → OutputQc∈RoundManager outs rm
  ¬OutputQc⇒OutputQc∈RoundManager outs rm noOutQcs =
    All-map (λ ¬outqc qc nm qc∈nm nm∈out → ⊥-elim (¬outqc qc nm qc∈nm nm∈out))
      noOutQcs

  NoMsgs⇒OutputQc∈RoundManager : ∀ outs rm → OutputProps.NoMsgs outs → OutputQc∈RoundManager outs rm
  NoMsgs⇒OutputQc∈RoundManager outs rm noMsgs =
    ¬OutputQc⇒OutputQc∈RoundManager outs rm (NoMsgs⇒¬OutputQc outs noMsgs)

  SigForVote∈Rm-SentB4 : Vote → PK → QuorumCert → RoundManager → SentMessages → Set
  SigForVote∈Rm-SentB4 v pk qc rm pool =
    qc ∈RoundManager rm
    → WithVerSig pk v →
    ∀ {vs : Author × Signature} → let (pid , sig) = vs in
      vs ∈ qcVotes qc → rebuildVote qc vs ≈Vote v
    → ¬(∈BootstrapInfo-impl fakeBootstrapInfo sig)
    → MsgWithSig∈ pk sig pool

  SigsForVotes∈Rm-SentB4 : SentMessages → RoundManager → Set
  SigsForVotes∈Rm-SentB4 pool rm = ∀ {qc v pk} → SigForVote∈Rm-SentB4 v pk qc rm pool

  ++-SigsForVote∈Rm-SentB4
    : ∀ {pool rm} → (msgs : SentMessages) → SigsForVotes∈Rm-SentB4 pool rm
      → SigsForVotes∈Rm-SentB4 (msgs ++ pool) rm
  ++-SigsForVote∈Rm-SentB4{pool} msgs sfvb4 qc∈rm sig vs∈qc rbld≈v ¬bootstrap =
    MsgWithSig∈-++ʳ{ms = msgs} (sfvb4 qc∈rm sig vs∈qc rbld≈v ¬bootstrap)

module Invariants where

  ------------ properties for BlockTree validity

  -- The property that a block tree `bt` has only valid QCs with respect to epoch config `𝓔`
  AllValidQCs : (𝓔 : EpochConfig) (bt : BlockTree) → Set
  AllValidQCs 𝓔 bt = (hash : HashValue) → Maybe-maybe (WithEC.MetaIsValidQC 𝓔) ⊤ (lookup hash (bt ^∙ btIdToQuorumCert))

  AllValidBlocks : BlockTree → Set
  AllValidBlocks bt = ∀ {bid eb}
                    → btGetBlock bid bt ≡ just eb
                    → BlockId-correct (eb ^∙ ebBlock) × BlockHash≡ (eb ^∙ ebBlock)  bid

  ------------ types for and definitions of invariants for BlockTree, BlockStore, SafetyData, SafetyRules

  record ECinfo : Set where
    constructor mkECinfo
    field
      ecVV : ValidatorVerifier
      ecEP : Epoch
  open ECinfo

  WithECinfo : Set → Set
  WithECinfo A = A × ECinfo

  BlockTree-EC  = WithECinfo BlockTree
  BlockStore-EC = WithECinfo BlockStore

  module _ (btEC : BlockTree-EC) where
    private
      bt  = proj₁ btEC
      eci = proj₂ btEC
      vv = ecVV eci
      ep = ecEP eci

    record BlockTreeInv : Set where
      constructor mkBlockTreeInv
      field
        allValidQCs    : (vvC : ValidatorVerifier-correct $ vv) → AllValidQCs (α-EC-VV (vv , vvC) ep) bt
        allValidBlocks : AllValidBlocks bt
  open BlockTreeInv

  module _ (bsEC : BlockStore-EC) where
    private
      bs   = proj₁ bsEC
      eci =  proj₂ bsEC

    record BlockStoreInv : Set where
      constructor mkBlockStoreInv
      field
        blockTreeValid : BlockTreeInv (bs ^∙ bsInner , eci)
  open BlockStoreInv

  module _ (sd : SafetyData) where
    -- SafetyRules invariants
    record SafetyDataInv : Set where
      constructor mkSafetyDataInv
      field
        lvEpoch≡ : Meta.getLastVoteEpoch sd ≡ sd ^∙ sdEpoch
        lvRound≤ : Meta.getLastVoteRound sd ≤ sd ^∙ sdLastVotedRound
  open SafetyDataInv

  subst-SafetyDataInv : ∀ {sd1 sd2}
                      → sd1 ^∙ sdLastVote       ≡ sd2 ^∙ sdLastVote
                      → sd1 ^∙ sdEpoch          ≡ sd2 ^∙ sdEpoch
                      → sd1 ^∙ sdLastVotedRound ≡ sd2 ^∙ sdLastVotedRound
                      → SafetyDataInv sd1 → SafetyDataInv sd2
  subst-SafetyDataInv refl refl refl (mkSafetyDataInv lvEpoch≡₁ lvRound≤₁) =
    mkSafetyDataInv lvEpoch≡₁ lvRound≤₁

  module _ (sr : SafetyRules) where
    -- SafetyRules invariants
    record SafetyRulesInv : Set where
      constructor mkSafetyRulesInv
      field
        sdInv : SafetyDataInv (sr ^∙ srPersistentStorage ∙ pssSafetyData)
  open SafetyRulesInv

  ------------ types for and definition of RoundManagerInv

  EpochsMatch : RoundManager → Set
  EpochsMatch rm = rm ^∙ rmEpochState ∙ esEpoch ≡ rm ^∙ pssSafetyData-rm ∙ sdEpoch

  rm→ECinfo : RoundManager → ECinfo
  rm→ECinfo rm = mkECinfo (rm ^∙ rmEpochState ∙ esVerifier) (rm ^∙ rmEpoch)

  rm→BlockTree-EC : RoundManager → BlockTree-EC
  rm→BlockTree-EC rm = (rm ^∙ lBlockStore ∙ bsInner , rm→ECinfo rm)

  rm→BlockStore-EC : RoundManager → BlockStore-EC
  rm→BlockStore-EC rm = (rm ^∙ lBlockStore , rm→ECinfo rm)

  -- NOTE: This will be proved by induction on reachable states using the
  -- property that peer handlers preserve invariants. That is to say, many of
  -- these cannot be proven as a post-condition of the peer handler: one can
  -- only prove of the handler that if the invariant holds for the prestate,
  -- then it holds for the poststate.

  record RoundManagerInv (rm : RoundManager) : Set where
    constructor mkRoundManagerInv
    field
      rmCorrect        : ValidatorVerifier-correct (rm ^∙ rmValidatorVerifer)
      rmEpochsMatch    : EpochsMatch rm
      rmBlockStoreInv  : BlockStoreInv  (rm→BlockStore-EC rm)
      rmSafetyRulesInv : SafetyRulesInv (rm ^∙ lSafetyRules)
  open RoundManagerInv

  -- This is just the beginning of the invariant for EpochManager, collecting properties we already
  -- expect to be required even though the top-level peer state is RoundManager for now (in future,
  -- when we prove properties related to epoch change, the peers state will become EpochManager).
  record EpochManagerInv (em : EpochManager) : Set where
    constructor mkEpochManagerInv
    field
      -- SafetyRule properties
      emiSRI : ∀ {sr} → em ^∙ emSafetyRulesManager ∙ srmInternalSafetyRules ≡ SRWLocal sr
                      → SafetyRulesInv sr × sr ^∙ srPersistentStorage ∙ pssSafetyData ∙ sdLastVote ≡ nothing
  open EpochManagerInv

  hash≡⇒≈Block : ∀ {b1 b2 : Block}
               → BlockId-correct b1
               → BlockId-correct b2
               → BlockHash≡ b1 (b2 ^∙ bId)
               → b1 ≈Block b2
  hash≡⇒≈Block {b1} {b2} refl refl hashb1≡idb2
     with hashBD-inj hashb1≡idb2
  ...| bdInj = sameBlockData⇒≈ {b1} {b2} hashb1≡idb2 bdInj

  module Reqs (b : Block) (bt : BlockTree) where
    -- TODO: State and use assumptions about hash collisions.  The following is one example that will
    -- likely need to be refined.
    NoHC1 = ∀ {eb}
            → btGetBlock (b ^∙ bId) bt ≡ just eb
            → BlockId-correct b
            → (eb ^∙ ebBlock) ≈Block b

  -- TODO: probably don't need this generality, consider moving into Handle.Properties (only place
  -- it is used so far), then we could streamline as rmi is required only to avoid cyclic lookups
  module _ {st} (reach : ReachableSystemState st)
           {pm : ProposalMsg} {sndr : NodeId} (nm∈pool : (sndr , P pm) ∈ msgPool st)
           (pid : NodeId) (ini : initialised st pid ≡ initd) where

    open PerReachableState reach

    private
      rm  = peerStates st pid
      bt  = rm ^∙ lBlockTree
      b   = pm ^∙ pmProposal

    nohc : RoundManagerInv rm
         → rm ^∙ lBlockTree ≡ bt
         → BlockId-correct b
         → Reqs.NoHC1 b bt
    nohc rmi refl refl {eb} jeb refl
       with allValidBlocks (blockTreeValid (rmBlockStoreInv rmi)) jeb
    ...| bidCorr , bid
       with (blockData-bsl (b ^∙ bBlockData)) ≟-BSL (blockData-bsl (eb ^∙ ebBlock ∙ bBlockData))
    ...| yes bsls≡ = hash≡⇒≈Block {eb ^∙ ebBlock} {b} bidCorr refl bid
    ...| no  neq rewrite sym bid
       = ⊥-elim (meta-no-collision-in-sys (msgRmHC (inP nm∈pool (inPM inB))
                                                   ini
                                                   (inRM (inBS jeb inB))
                                                   (sym bid)
                                                   neq))

  -- Valid blocks have IDs computed by the hash of their BlockData
  -- These are passed as module parameters through the proofs

  ValidBlock = Σ Block BlockId-correct

  vbBlock : ValidBlock → Block
  vbBlock = proj₁

  vbValid : (vb : ValidBlock) → BlockId-correct (vbBlock vb)
  vbValid = proj₂

  ------------ Preserves and related definitions and utilities

  Preserves : ∀ {ℓ} {A : Set} → (P : A → Set ℓ) (pre post : A) → Set ℓ
  Preserves Pred pre post = Pred pre → Pred post

  PreservesL : ∀ {ℓ} {A B : Set}
               → (P : A → Set ℓ) (l : Lens A B)
               → (b₁ b₂ : B) → Set ℓ
  PreservesL Pred l b₁ b₂ = ∀ a → Preserves Pred (a & l ∙~ b₁) (a & l ∙~ b₂)

  reflPreserves : ∀ {ℓ} {A : Set} (P : A → Set ℓ) → Reflexive (Preserves P)
  reflPreserves Pred = id

  reflPreservesRoundManagerInv : Reflexive (Preserves RoundManagerInv)
  reflPreservesRoundManagerInv = reflPreserves RoundManagerInv

  transPreserves : ∀ {ℓ} {A : Set} (P : A → Set ℓ) → Transitive (Preserves P)
  transPreserves Pred p₁ p₂ = p₂ ∘ p₁

  transPreservesL : ∀ {ℓ} {A B : Set}
                  → (P : A → Set ℓ) (l : Lens A B)
                  → {b₁ b₂ b₃ : B}
                  → PreservesL P l b₁ b₂
                  → PreservesL P l b₂ b₃
                  → PreservesL P l b₁ b₃
  transPreservesL Pred l p₁ p₂ a = transPreserves Pred (p₁ a) (p₂ a)

  transPreservesRoundManagerInv : Transitive (Preserves RoundManagerInv)
  transPreservesRoundManagerInv = transPreserves RoundManagerInv

  BSInv⇒BTInv-pres : ∀ {eci} {pre post : BlockStore}
                   → Preserves BlockStoreInv (pre , eci) (post , eci)
                   → Preserves BlockTreeInv (pre ^∙ bsInner , eci) (post ^∙ bsInner , eci)
  BSInv⇒BTInv-pres presBS btiPre = BlockStoreInv.blockTreeValid (presBS $ mkBlockStoreInv btiPre)

  mkPreservesSafetyRulesInv
    : ∀ {pre post}
      → Preserves SafetyDataInv (pre ^∙ srPersistentStorage ∙ pssSafetyData) (post ^∙ srPersistentStorage ∙ pssSafetyData)
      → Preserves SafetyRulesInv pre post
  mkPreservesSafetyRulesInv lvP (mkSafetyRulesInv lv) = mkSafetyRulesInv (lvP lv)

  mkPreservesRoundManagerInv
    : ∀ {pre post}
      → Preserves ValidatorVerifier-correct (pre ^∙ rmValidatorVerifer) (post ^∙ rmValidatorVerifer)
      → Preserves EpochsMatch                pre                         post
      → Preserves BlockStoreInv             (rm→BlockStore-EC pre)      (rm→BlockStore-EC post)
      → Preserves SafetyRulesInv            (pre ^∙ rmSafetyRules)      (post ^∙ rmSafetyRules)
      → Preserves RoundManagerInv            pre                         post
  mkPreservesRoundManagerInv rmP emP bsP srP (mkRoundManagerInv rmCorrect epochsMatch bsInv srInv) =
    mkRoundManagerInv (rmP rmCorrect) (emP epochsMatch) (bsP bsInv) (srP srInv)

module InitProofDefs where
  open Invariants

-- RoundManager properties

  _IsNormalRoundManagerOf_ : RoundManager → EpochManager → Set
  _IsNormalRoundManagerOf_ rm em =
    em ^∙ emProcessor ≡ just (RoundProcessorNormal rm)

  IsNormalRoundManagerOf-inj :
    ∀ {em} {rm1} {rm2}
    → rm1 IsNormalRoundManagerOf em
    → rm2 IsNormalRoundManagerOf em
    → rm1 ≡ rm2
  IsNormalRoundManagerOf-inj refl refl = refl

  InitSdLV≡ : RoundManager → Maybe Vote → Set
  InitSdLV≡ rm mv = rm ^∙ rmSafetyRules ∙ srPersistentStorage
                        ∙ pssSafetyData ∙ sdLastVote ≡ mv

  InitSigs∈bs : RoundManager → Set
  InitSigs∈bs rm = ∀ {bsi vs qc}
                   → vs              ∈     qcVotes qc
                   → qc QCProps.∈RoundManager rm
                   → ∈BootstrapInfo-impl bsi (proj₂ vs)

  -- Message properties

  -- During epoch initialisation, no messages are sent
  -- EXCEPT the leader of Round 1 SENDS a ProposalMsg during initialization.
  -- Rust/Haskell impls do not include signatures in the genesis QC's LIWS.
  -- The initial proposal for (Epoch N) (Round 1) is built on a QC with empty signatures.

  InitIsInitPM' : NetworkMsg → Set
  InitIsInitPM' m = ∃[ pm ] ( m ≡ P pm
                            × ∀ {vs qc}
                            → vs   ∈ qcVotes qc
                            → qc QC∈NM       m
                            → ⊥)

  InitIsInitPM : List (Action NetworkMsg) → Set
  InitIsInitPM acts = ∀ {m}
                      → send m ∈ acts
                      → InitIsInitPM' m

  record InitContractOk (mv : Maybe Vote) (rm : RoundManager) (outs : List Output) : Set where
    constructor mkInitContractOk
    field
      rmInv       : RoundManagerInv rm
      sdLV≡       : InitSdLV≡ rm mv
      sigs∈bs     : InitSigs∈bs rm
      isInitPM    : InitIsInitPM (outputsToActions {State = rm} outs)
  open InitContractOk

  EMInitCond : Maybe Vote → EpochManager × List Output → Set
  EMInitCond mv (em , outs) = ∃[ rm ] ( rm IsNormalRoundManagerOf em × InitContractOk mv rm outs )

  InitContract : Maybe Vote → EitherD-Post ErrLog (EpochManager × List Output)
  InitContract _ (Left x)        = ⊤
  InitContract mv (Right em×outs) = EMInitCond mv em×outs

module RoundManagerTransProps where
  -- Relations between the pre/poststate which may or may not hold, depending on
  -- the particular peer handler invoked

  -- - The epoch is unchanged
  NoEpochChange : (pre post : RoundManager) → Set
  NoEpochChange pre post = pre ≡L post at rmEpoch

  reflNoEpochChange : Reflexive NoEpochChange
  reflNoEpochChange = refl

  transNoEpochChange : Transitive NoEpochChange
  transNoEpochChange = trans

  NoSafetyDataChange : (pre post : RoundManager) → Set
  NoSafetyDataChange pre post = pre ≡L post at pssSafetyData-rm

  reflNoSafetyDataChange : Reflexive NoSafetyDataChange
  reflNoSafetyDataChange = refl

  transNoSafetyDataChange : Transitive NoSafetyDataChange
  transNoSafetyDataChange = trans

  -- - state changes from generating or not generating a vote
  LastVoteIs : RoundManager → Vote → Set
  LastVoteIs rm v = just v ≡ rm ^∙ pssSafetyData-rm ∙ sdLastVote

  module _ (pre post : RoundManager) (vote : Vote) where

    record VoteOldGenerated : Set where
      constructor mkVoteOldGenerated
      field
        -- NOTE: The implementation maintains an invariant that the round
        -- associated with `sdLastVote` (if the vote exists) is less than or
        -- equal to the field `sdLastVotedRound`.
        lvr≡ : pre ≡L post at pssSafetyData-rm ∙ sdLastVotedRound
        lv≡  : pre ≡L post at pssSafetyData-rm ∙ sdLastVote

    record VoteNewGenerated : Set where
      constructor mkVoteNewGenerated
      field
        lvr< : pre [ _<_ ]L post at pssSafetyData-rm ∙ sdLastVotedRound
        lvr≡ : vote ^∙ vRound ≡ post ^∙ pssSafetyData-rm ∙ sdLastVotedRound

    -- NOTE: This is saying that /state changes/ associated to generating a vote
    -- have occurred, not that the generated vote has been sent.
    record VoteGenerated : Set where
      constructor mkVoteGenerated
      field
        lv≡v    : LastVoteIs post vote
        voteSrc : VoteOldGenerated ⊎ VoteNewGenerated

    isVoteNewGenerated : VoteGenerated → Bool
    isVoteNewGenerated = isRight ∘ VoteGenerated.voteSrc

  reflVoteOldGenerated : ∀ {v} → Reflexive (λ pre post → VoteOldGenerated pre post v)
  reflVoteOldGenerated = mkVoteOldGenerated refl refl

  VoteGeneratedNotSaved : (pre post : RoundManager) → Set
  VoteGeneratedNotSaved pre post = ∃[ v ] VoteGenerated pre post v

  module _ (pre post : RoundManager) where
    -- In
    -- `LibraBFT.Impl.Consensus.SafetyRules.SafetyRules.agda::contructAndSignVoteM`,
    -- it is possible for us to update the field `pssSafetyData-rm ∙ sdLastVotedRound`
    -- without actually returning a vote. Therefore, the most we can say after
    -- returing from this function is that this field in the poststate is greater
    -- than or equal to the value it started at in the prestate.
    --
    -- However, it is also possible to return a vote *without* updating the last
    -- voted round. Many functions in `LibraBFT.Impl.Consensus.RoundManager` neither
    -- return a vote nor update the last voted round, and the lemma
    -- `pseudotransVoteSent` in those cases -- but is unprovable if we do not
    -- distinguish the cases where the last voted round cannot be increased.
    -- Therefore, it is convenient to track in the type of `NoVoteSent`, with the
    -- parameter `lvr≡?`, which case we are dealing with
    record VoteNotGenerated  (lvr≡? : Bool) : Set where
      constructor mkVoteNotGenerated
      field
        lv≡  : pre ≡L post at pssSafetyData-rm ∙ sdLastVote
        lvr≤ : pre [ if lvr≡? then _≡_ else _<_ ]L post at pssSafetyData-rm ∙ sdLastVotedRound

  reflVoteNotGenerated : Reflexive (λ pre post → VoteNotGenerated pre post true)
  reflVoteNotGenerated = mkVoteNotGenerated refl refl

  transVoteNotGenerated
    : ∀ {s₁ s₂ s₃ lvr≡?₁ lvr≡?₂}
      → VoteNotGenerated s₁ s₂ lvr≡?₁ → VoteNotGenerated s₂ s₃ lvr≡?₂
      → VoteNotGenerated s₁ s₃ (lvr≡?₁ ∧ lvr≡?₂)
  transVoteNotGenerated {lvr≡?₁ = false} {false} (mkVoteNotGenerated lv≡ lvr≤) (mkVoteNotGenerated lv≡₁ lvr≤₁) =
    mkVoteNotGenerated (trans lv≡ lv≡₁) (<-trans lvr≤ lvr≤₁)
  transVoteNotGenerated {lvr≡?₁ = false} {true} (mkVoteNotGenerated lv≡ lvr≤) (mkVoteNotGenerated lv≡₁ lvr≤₁) =
    mkVoteNotGenerated (trans lv≡ lv≡₁) (≤-trans lvr≤ (≡⇒≤ lvr≤₁))
  transVoteNotGenerated {lvr≡?₁ = true} {false} (mkVoteNotGenerated lv≡ lvr≤) (mkVoteNotGenerated lv≡₁ lvr≤₁) =
    mkVoteNotGenerated (trans lv≡ lv≡₁) (≤-trans (s≤s (≡⇒≤ lvr≤)) lvr≤₁)
  transVoteNotGenerated {lvr≡?₁ = true} {true} (mkVoteNotGenerated lv≡ lvr≤) (mkVoteNotGenerated lv≡₁ lvr≤₁) =
    mkVoteNotGenerated (trans lv≡ lv≡₁) (trans lvr≤ lvr≤₁)

  glue-VoteGenerated-VoteNotGenerated
    : ∀ {s₁ s₂ s₃ v} → VoteGenerated s₁ s₂ v → VoteNotGenerated s₂ s₃ true
      → VoteGenerated s₁ s₃ v
  glue-VoteGenerated-VoteNotGenerated (mkVoteGenerated lv≡v (inj₁ (mkVoteOldGenerated lvr≡₁ lv≡₁))) (mkVoteNotGenerated lv≡ lvr≤) =
    mkVoteGenerated (trans lv≡v lv≡) (inj₁ (mkVoteOldGenerated (trans lvr≡₁ lvr≤) (trans lv≡₁ lv≡)))
  glue-VoteGenerated-VoteNotGenerated (mkVoteGenerated lv≡v (inj₂ (mkVoteNewGenerated lvr< lvr≡))) (mkVoteNotGenerated lv≡ lvr≤) =
    mkVoteGenerated ((trans lv≡v lv≡)) (inj₂ (mkVoteNewGenerated (≤-trans lvr< (≡⇒≤ lvr≤)) (trans lvr≡ lvr≤)))

  glue-VoteNotGenerated-VoteGenerated
    : ∀ {s₁ s₂ s₃ v} → VoteNotGenerated s₁ s₂ true → VoteGenerated s₂ s₃ v
      → VoteGenerated s₁ s₃ v
  glue-VoteNotGenerated-VoteGenerated (mkVoteNotGenerated lv≡ lvr≤) (mkVoteGenerated lv≡v (inj₁ (mkVoteOldGenerated lvr≡₁ lv≡₁))) =
    mkVoteGenerated lv≡v (inj₁ (mkVoteOldGenerated (trans lvr≤ lvr≡₁) (trans lv≡ lv≡₁)))
  glue-VoteNotGenerated-VoteGenerated (mkVoteNotGenerated lv≡ lvr≤) (mkVoteGenerated lv≡v (inj₂ (mkVoteNewGenerated lvr<₁ lvr≡₁))) =
    mkVoteGenerated lv≡v (inj₂ (mkVoteNewGenerated (≤-trans (s≤s (≡⇒≤ lvr≤)) lvr<₁) lvr≡₁))

  glue-VoteNotGenerated-VoteGeneratedNotSaved
    : ∀ {s₁ s₂ s₃} → VoteNotGenerated s₁ s₂ true → VoteGeneratedNotSaved s₂ s₃
      → VoteGeneratedNotSaved s₁ s₃
  glue-VoteNotGenerated-VoteGeneratedNotSaved vng (v , vg) =
    v , glue-VoteNotGenerated-VoteGenerated vng vg

-- Properties for voting
module Voting where

  open Invariants

  VoteEpochIs : (vote : Vote) (e : Epoch) → Set
  VoteEpochIs vote e = vote ^∙ vEpoch ≡ e

  VoteRoundIs : (vote : Vote) (r : Round) → Set
  VoteRoundIs vote r = vote ^∙ vRound ≡ r

  record VoteMadeFromBlock (vote : Vote) (block : Block) : Set where
    constructor mkVoteMadeFromBlock
    field
      epoch≡      : vote ^∙ vEpoch ≡ block ^∙ bEpoch
      round≡      : vote ^∙ vRound ≡ block ^∙ bRound
      proposedId≡ : vote ^∙ vProposedId ≡ block ^∙ bId

  VoteMadeFromBlock⇒VoteEpochRoundIs : ∀ {v b} → VoteMadeFromBlock v b → VoteEpochIs v (b ^∙ bEpoch) × VoteRoundIs v (b ^∙ bRound)
  VoteMadeFromBlock⇒VoteEpochRoundIs (mkVoteMadeFromBlock epoch≡ round≡ proposedID) = epoch≡ , round≡

  VoteTriggeredByBlock : (vote : Vote) (block : Block) (new? : Bool) → Set
  VoteTriggeredByBlock vote block true = VoteMadeFromBlock vote block
  VoteTriggeredByBlock vote block false = VoteRoundIs vote (block ^∙ bRound)

  record VoteGeneratedCorrect (pre post : RoundManager) (vote : Vote) (block : Block) : Set where
    constructor mkVoteGeneratedCorrect
    field
      state          : RoundManagerTransProps.VoteGenerated pre post vote
    voteNew? = RoundManagerTransProps.isVoteNewGenerated pre post vote state
    field
      blockTriggered : VoteTriggeredByBlock vote block voteNew?

  substVoteGeneratedCorrect
    : ∀ {pre post vote} (block₁ block₂ : Block) → block₁ ≈Block block₂
      → VoteGeneratedCorrect pre post vote block₁ → VoteGeneratedCorrect pre post vote block₂
  substVoteGeneratedCorrect block₁ block₂ bd≡ (mkVoteGeneratedCorrect state blockTriggered)
     with state
  ...| RoundManagerTransProps.mkVoteGenerated lv≡v voteSrc
     with voteSrc
  ...| Left vog rewrite bd≡ =
     mkVoteGeneratedCorrect (RoundManagerTransProps.mkVoteGenerated lv≡v (Left vog)) blockTriggered
  ...| Right vng
     with blockTriggered
  ...| mkVoteMadeFromBlock epoch≡ round≡ proposedID rewrite bd≡
     = mkVoteGeneratedCorrect
         (RoundManagerTransProps.mkVoteGenerated lv≡v (Right vng))
         (mkVoteMadeFromBlock epoch≡ round≡ proposedID)

  record VoteGeneratedUnsavedCorrect (pre post : RoundManager) (block : Block) : Set where
    constructor mkVoteGeneratedUnsavedCorrect
    field
      vote           : Vote
      voteGenCorrect : VoteGeneratedCorrect pre post vote block

  glue-VoteGeneratedCorrect-VoteNotGenerated
    : ∀ {s₁ s₂ s₃ vote block}
      → VoteGeneratedCorrect s₁ s₂ vote block
      → RoundManagerTransProps.VoteNotGenerated s₂ s₃ true
      → VoteGeneratedCorrect s₁ s₃ vote block
  glue-VoteGeneratedCorrect-VoteNotGenerated vgc@(mkVoteGeneratedCorrect vg@(RoundManagerTransProps.mkVoteGenerated lv≡v (inj₁ oldVG)) blockTriggered) vng =
    mkVoteGeneratedCorrect (RoundManagerTransProps.glue-VoteGenerated-VoteNotGenerated vg vng) blockTriggered
  glue-VoteGeneratedCorrect-VoteNotGenerated vgc@(mkVoteGeneratedCorrect vg@(RoundManagerTransProps.mkVoteGenerated lv≡v (inj₂ newVG)) blockTriggered) vng =
    mkVoteGeneratedCorrect (RoundManagerTransProps.glue-VoteGenerated-VoteNotGenerated vg vng) blockTriggered

  glue-VoteNotGenerated-VoteGeneratedCorrect
    : ∀ {s₁ s₂ s₃ vote block}
      → RoundManagerTransProps.VoteNotGenerated s₁ s₂ true
      → VoteGeneratedCorrect s₂ s₃ vote block
      → VoteGeneratedCorrect s₁ s₃ vote block
  glue-VoteNotGenerated-VoteGeneratedCorrect vng (mkVoteGeneratedCorrect vg@(RoundManagerTransProps.mkVoteGenerated lv≡v (inj₁ oldVG)) blockTriggered) =
    mkVoteGeneratedCorrect (RoundManagerTransProps.glue-VoteNotGenerated-VoteGenerated vng vg) blockTriggered
  glue-VoteNotGenerated-VoteGeneratedCorrect vng (mkVoteGeneratedCorrect vg@(RoundManagerTransProps.mkVoteGenerated lv≡v (inj₂ newVG)) blockTriggered) =
    mkVoteGeneratedCorrect (RoundManagerTransProps.glue-VoteNotGenerated-VoteGenerated vng vg)
      blockTriggered

  glue-VoteNotGenerated-VoteGeneratedUnsavedCorrect
    : ∀ {s₁ s₂ s₃ block}
      → RoundManagerTransProps.VoteNotGenerated s₁ s₂ true
      → VoteGeneratedUnsavedCorrect s₂ s₃ block
      → VoteGeneratedUnsavedCorrect s₁ s₃ block
  glue-VoteNotGenerated-VoteGeneratedUnsavedCorrect vng (mkVoteGeneratedUnsavedCorrect vote voteGenCorrect) =
    mkVoteGeneratedUnsavedCorrect vote (glue-VoteNotGenerated-VoteGeneratedCorrect vng voteGenCorrect)

  -- The handler correctly voted (including state updates) on `block`, assuming
  -- the safety data epoch matches the block epoch.
  record VoteSentCorrect (pre post : RoundManager) (outs : List Output) (block : Block) : Set where
    constructor mkVoteSentCorrect
    field
      vm           : VoteMsg
      pid          : Author
      voteMsgOuts  : OutputProps.OneVote outs vm (pid ∷ [])
      vgCorrect    : VoteGeneratedCorrect pre post (vm ^∙ vmVote) block
    open VoteGeneratedCorrect vgCorrect

  -- The handler correctly did not vote on `block`
  record VoteUnsentCorrect (pre post : RoundManager) (outs : List Output) (block : Block) (lvr≡? : Bool) : Set where
    constructor mkVoteUnsentCorrect
    field
      noVoteMsgOuts : OutputProps.NoVotes outs
      nvg⊎vgusc    : RoundManagerTransProps.VoteNotGenerated pre post lvr≡? ⊎ VoteGeneratedUnsavedCorrect pre post block

  glue-VoteNotGenerated-VoteUnsentCorrect
    : ∀ {s₁ s₂ s₃ outs₁ outs₂ block lvr≡?}
      → RoundManagerTransProps.VoteNotGenerated s₁ s₂ true → OutputProps.NoVotes outs₁
      → VoteUnsentCorrect s₂ s₃ outs₂ block lvr≡?
      → VoteUnsentCorrect s₁ s₃ (outs₁ ++ outs₂) block lvr≡?
  glue-VoteNotGenerated-VoteUnsentCorrect{outs₁ = outs₁} vng₁ nvo (mkVoteUnsentCorrect noVoteMsgOuts (inj₁ vng₂)) =
    mkVoteUnsentCorrect (OutputProps.++-NoVotes outs₁ _ nvo noVoteMsgOuts) (inj₁ (RoundManagerTransProps.transVoteNotGenerated vng₁ vng₂))
  glue-VoteNotGenerated-VoteUnsentCorrect{outs₁ = outs₁} vng₁ nvo (mkVoteUnsentCorrect noVoteMsgOuts (inj₂ vgus)) =
    mkVoteUnsentCorrect ((OutputProps.++-NoVotes outs₁ _ nvo noVoteMsgOuts)) (inj₂ (glue-VoteNotGenerated-VoteGeneratedUnsavedCorrect vng₁ vgus))

  -- The handler correctly attempted to vote on `block`, assuming the safety
  -- data epoch matches the block epoch.
  VoteAttemptCorrect : (pre post : RoundManager) (outs : List Output) (block : Block) → Set
  VoteAttemptCorrect pre post outs block =
    (∃[ lvr≡? ] VoteUnsentCorrect pre post outs block lvr≡?) ⊎ VoteSentCorrect pre post outs block

  -- The voting process ended before `pssSafetyData-rm` could be updated
  voteAttemptBailed : ∀ {rm block} outs → OutputProps.NoVotes outs → VoteAttemptCorrect rm rm outs block
  voteAttemptBailed outs noVotesOuts = inj₁ (true , mkVoteUnsentCorrect noVotesOuts (inj₁ RoundManagerTransProps.reflVoteNotGenerated))

  glue-VoteNotGenerated-VoteAttemptCorrect
    : ∀ {s₁ s₂ s₃ outs₁ outs₂ block}
      → RoundManagerTransProps.VoteNotGenerated s₁ s₂ true → OutputProps.NoVotes outs₁
      → VoteAttemptCorrect s₂ s₃ outs₂ block
      → VoteAttemptCorrect s₁ s₃ (outs₁ ++ outs₂) block
  glue-VoteNotGenerated-VoteAttemptCorrect{outs₁ = outs₁} vng nvo (inj₁ (lvr≡? , vusCorrect)) =
    inj₁ (lvr≡? , glue-VoteNotGenerated-VoteUnsentCorrect{outs₁ = outs₁} vng nvo vusCorrect)
  glue-VoteNotGenerated-VoteAttemptCorrect{outs₁ = outs₁} vng nvo (inj₂ (mkVoteSentCorrect vm pid voteMsgOuts vgCorrect)) =
    inj₂ (mkVoteSentCorrect vm pid (OutputProps.++-NoVotes-OneVote outs₁ _ nvo voteMsgOuts) (glue-VoteNotGenerated-VoteGeneratedCorrect vng vgCorrect))

  VoteAttemptEpochReq : ∀ {pre post outs block} → VoteAttemptCorrect pre post outs block → Set
  VoteAttemptEpochReq (inj₁ (_ , mkVoteUnsentCorrect _ (inj₁ _))) =
    ⊤
  VoteAttemptEpochReq{pre}{block = block} (inj₁ (_ , mkVoteUnsentCorrect _ (inj₂ _))) =
    pre ^∙ pssSafetyData-rm ∙ sdEpoch ≡ (block ^∙ bEpoch)
  VoteAttemptEpochReq{pre}{block = block} (inj₂ _) =
    pre ^∙ pssSafetyData-rm ∙ sdEpoch ≡ (block ^∙ bEpoch)

  voteAttemptEpochReq!
    : ∀ {pre post outs block} → (vac : VoteAttemptCorrect pre post outs block)
      → pre ^∙ pssSafetyData-rm ∙ sdEpoch ≡ block ^∙ bEpoch → VoteAttemptEpochReq vac
  voteAttemptEpochReq! (inj₁ (_ , mkVoteUnsentCorrect _ (inj₁ _))) eq = tt
  voteAttemptEpochReq! (inj₁ (_ , mkVoteUnsentCorrect _ (inj₂ _))) eq = eq
  voteAttemptEpochReq! (inj₂ _) eq = eq

  record VoteAttemptCorrectWithEpochReq (pre post : RoundManager) (outs : List Output) (block : Block) : Set where
    constructor mkVoteAttemptCorrectWithEpochReq
    field
      voteAttempt : VoteAttemptCorrect pre post outs block
      sdEpoch≡?   : VoteAttemptEpochReq voteAttempt

  voteAttemptCorrectAndSent⇒voteSentCorrect : ∀ {pre post outs block vm}
                         → send (V vm) ∈ outputsToActions{pre} outs
                         → VoteAttemptCorrectWithEpochReq pre post outs block
                         → VoteSentCorrect                pre post outs block
  voteAttemptCorrectAndSent⇒voteSentCorrect{pre}{outs = outs} vm∈outs (mkVoteAttemptCorrectWithEpochReq (Left (_ , mkVoteUnsentCorrect noVoteMsgOuts _)) _) =
    ⊥-elim (sendVote∉actions{outs}{st = pre} (sym noVoteMsgOuts) vm∈outs)
  voteAttemptCorrectAndSent⇒voteSentCorrect{pre}{outs = outs}{vm = vm} vm∈outs (mkVoteAttemptCorrectWithEpochReq (Right vsc) _) = vsc


{-# OPTIONS --safe #-}

module Definition.Conversion.Transitivity where

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

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

mutual
  -- Transitivity of algorithmic equality of neutrals.
  trans~↑! : ∀ {t u v A B Γ Δ l l'}
         → l PE.≡ l'
         → ⊢ Γ ≡ Δ
         → Γ ⊢ t ~ u ↑! A ^ l
         → Δ ⊢ u ~ v ↑! B ^ l'
         → Γ ⊢ t ~ v ↑! A ^ l
         × Γ ⊢ A ≡ B ^ [ ! , l ]
  trans~↑! el Γ≡Δ (var-refl x₁ x≡y) (var-refl x₂ x≡y₁) =
    var-refl x₁ (PE.trans x≡y x≡y₁)
    , proj₂ (neTypeEq (var _) x₁
               (PE.subst (λ x → _ ⊢ var x ∷ _ ^ _) (PE.sym x≡y)
                         (stabilityTerm (symConEq Γ≡Δ) (PE.subst (λ lx → _ ⊢ _ ∷ _ ^ [ ! , lx ]) (PE.sym el) x₂))))
  trans~↑! el Γ≡Δ (app-cong {rF = !} t~u a<>b) (app-cong {rF = !} u~v b<>c) =
    let t~v , ΠFG≡ΠF′G′ = trans~↓! PE.refl Γ≡Δ t~u u~v
        F≡F₁ , rF≡rF₁ , lF≡lF₁ , lG≡lG₁ , G≡G₁ = injectivity ΠFG≡ΠF′G′
        a<>c = transConv↑Term Γ≡Δ F≡F₁ a<>b (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ _ ^ ι x) (PE.sym lF≡lF₁) b<>c)
    in  app-cong t~v a<>c , substTypeEq G≡G₁ (soundnessConv↑Term a<>b)
  trans~↑! el Γ≡Δ (app-cong {rF = %} t~u a<>b) (app-cong {rF = %} u~v b<>c) =
    let t~v , ΠFG≡ΠF′G′ = trans~↓! PE.refl Γ≡Δ t~u u~v
        F≡F₁ , rF≡rF₁ , lF≡lF₁ , lG≡lG₁ , G≡G₁ = injectivity ΠFG≡ΠF′G′
        ⊢Γ = proj₁ (proj₂ (contextConvSubst Γ≡Δ))
        a<>c = trans~↑% Γ≡Δ a<>b (conv~↑% (PE.subst (λ x → _ ⊢ _ ~ _ ↑%  _ ^ ι x) (PE.sym lF≡lF₁) b<>c) (stabilityEq Γ≡Δ (sym F≡F₁)))
        _ , _ , t≡v = soundness~↑% a<>b
    in  app-cong t~v a<>c , substTypeEq G≡G₁ t≡v
  trans~↑! el Γ≡Δ (app-cong {rF = !} t~u a<>b) (app-cong {rF = %} u~v b<>c) =
   let whnfA , neK , neL = ne~↓! t~u
       ⊢A , ⊢k , ⊢l₁ = syntacticEqTerm (soundness~↓! t~u)
       ⊢A' , ⊢l₁' , ⊢l = syntacticEqTerm (soundness~↓! u~v)
       _ , ΠFG≡ΠF₂G₂ = neTypeEq neL ⊢l₁ (stabilityTerm (symConEq Γ≡Δ) ⊢l₁')
       F≡F₂ , rF≡rF₂ , G≡G₂ = injectivity ΠFG≡ΠF₂G₂
   in ⊥-elim (relevance-discr rF≡rF₂)
  trans~↑! el Γ≡Δ (app-cong {rF = %} t~u a<>b) (app-cong {rF = !} u~v b<>c) =
   let whnfA , neK , neL = ne~↓! t~u
       ⊢A , ⊢k , ⊢l₁ = syntacticEqTerm (soundness~↓! t~u)
       ⊢A' , ⊢l₁' , ⊢l = syntacticEqTerm (soundness~↓! u~v)
       _ , ΠFG≡ΠF₂G₂ = neTypeEq neL ⊢l₁ (stabilityTerm (symConEq Γ≡Δ) ⊢l₁')
       F≡F₂ , rF≡rF₂ , G≡G₂ = injectivity ΠFG≡ΠF₂G₂
   in ⊥-elim (relevance-discr (PE.sym rF≡rF₂))
  trans~↑! PE.refl Γ≡Δ (natrec-cong A<>B a₀<>b₀ aₛ<>bₛ t~u) (natrec-cong B<>C b₀<>c₀ bₛ<>cₛ u~v) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        A≡B = soundnessConv↑ A<>B
        F[0]≡F₁[0] = substTypeEq A≡B (refl (zeroⱼ ⊢Γ))
        ΠℕFs≡ΠℕF₁s = sucCong A≡B
        A<>C = transConv↑ (Γ≡Δ ∙ (refl (univ (ℕⱼ ⊢Γ)))) A<>B B<>C
        a₀<>c₀ = transConv↑Term Γ≡Δ F[0]≡F₁[0] a₀<>b₀ b₀<>c₀
        aₛ<>cₛ = transConv↑Term Γ≡Δ ΠℕFs≡ΠℕF₁s aₛ<>bₛ bₛ<>cₛ
        t~v , _ = trans~↓! PE.refl Γ≡Δ t~u u~v
    in  natrec-cong A<>C a₀<>c₀ aₛ<>cₛ t~v
    ,   substTypeEq A≡B (soundness~↓! t~u)
  trans~↑! PE.refl Γ≡Δ (Emptyrec-cong A<>B t~u) (Emptyrec-cong B<>C u~v) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        A≡B = soundnessConv↑ A<>B
        A<>C = transConv↑ Γ≡Δ A<>B B<>C
        ⊢t , ⊢u , t≡u = soundness~↑% t~u
        _ , ⊢v , u≡v = soundness~↑% u~v
        t~v = %~↑ ⊢t (stabilityTerm (symConEq Γ≡Δ) ⊢v)
    in  Emptyrec-cong A<>C t~v , A≡B
  trans~↑! el Γ≡Δ (Id-cong X x x₁) (Id-cong Y x₂ x₃) =
    let XY , [U] = trans~↓! el Γ≡Δ X Y
        X≡Y = univ (soundness~↓! XY)
        Y≡Y = PE.subst (λ lx → _ ⊢ _ ≡ _ ^ [ ! , ι lx ]) (PE.sym (next-inj el)) (univ (soundness~↓! Y))
        x₂' = PE.subst (λ lx → _ ⊢ _ [conv↑] _ ∷ _ ^ ι lx) (PE.sym (next-inj el)) x₂
        t~t = transConv↑Term Γ≡Δ X≡Y x (convConvTerm x₂' Y≡Y)
        x₃' = PE.subst (λ lx → _ ⊢ _ [conv↑] _ ∷ _ ^ ι lx) (PE.sym (next-inj el)) x₃
        u~u = transConv↑Term Γ≡Δ X≡Y x₁ (convConvTerm x₃' Y≡Y)
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-cong XY t~t u~u , PE.subst (λ lx → _ ⊢ _ ≡ SProp lx ^ [ ! , _ ]) (next-inj el) (refl (Ugenⱼ ⊢Γ))
  trans~↑! el Γ≡Δ (Id-ℕ X x) (Id-ℕ Y x₁) =
    let t~t , ℕ≡ℕ = trans~↓! PE.refl Γ≡Δ X Y
        u~u = transConv↑Term Γ≡Δ ℕ≡ℕ x x₁
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-ℕ t~t u~u , refl (Ugenⱼ ⊢Γ)
  trans~↑! el Γ≡Δ (Id-ℕ0 X) (Id-ℕ0 Y) =
    let t~t , ℕ≡ℕ = trans~↓! PE.refl Γ≡Δ X Y
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-ℕ0 t~t , refl (Ugenⱼ ⊢Γ)
  trans~↑! el Γ≡Δ (Id-ℕS x X) (Id-ℕS x₁ Y) =
    let X~X , ℕ≡ℕ = trans~↓! PE.refl Γ≡Δ X Y
        t~t = transConv↑Term Γ≡Δ ℕ≡ℕ x x₁
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-ℕS t~t X~X , refl (Ugenⱼ ⊢Γ)
  trans~↑! el Γ≡Δ (Id-U X x) (Id-U Y x₁) =
    let t~t , U≡U = trans~↓! PE.refl Γ≡Δ X Y
        u~u = transConv↑Term Γ≡Δ U≡U x x₁
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-U t~t u~u , refl (Ugenⱼ ⊢Γ)
  trans~↑! el Γ≡Δ (Id-Uℕ X) (Id-Uℕ Y) =
    let t~t , _ = trans~↓! PE.refl Γ≡Δ X Y
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-Uℕ t~t , refl (Ugenⱼ ⊢Γ)
  trans~↑! el Γ≡Δ (Id-UΠ x X) (Id-UΠ x₁ Y) =
    let t~t , U≡U = trans~↓! PE.refl Γ≡Δ X Y
        u~u = transConv↑Term Γ≡Δ U≡U x x₁
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in Id-UΠ u~u t~t , refl (Ugenⱼ ⊢Γ)
  trans~↑! el Γ≡Δ (cast-cong X x x₁ x₂ x₃) (cast-cong Y x₄ x₅ x₆ x₇) =
    let XY , [U] = trans~↓! PE.refl Γ≡Δ X Y
        X≡Y = univ (soundness~↓! XY)
        Y≡Y = univ (soundness~↓! Y)
        t~t = transConv↑Term Γ≡Δ [U] x x₄
        u~u = transConv↑Term Γ≡Δ X≡Y x₁ (convConvTerm x₅ Y≡Y)
        A₁≡B = trans (soundnessConv↑Term t~t) (sym (soundnessConv↑Term (stabilityConv↑Term (symConEq Γ≡Δ) x₄)))
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in cast-cong XY t~t u~u x₂ (stabilityTerm (symConEq Γ≡Δ) x₇) , univ A₁≡B
  trans~↑! el Γ≡Δ (cast-ℕ X x x₁ x₂) (cast-ℕ Y x₃ x₄ x₅) =
    let XY , [U] = trans~↓! PE.refl Γ≡Δ X Y
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        t~t = transConv↑Term Γ≡Δ (refl (univ (ℕⱼ  ⊢Γ))) x x₃
    in cast-ℕ XY t~t x₁ (stabilityTerm (symConEq Γ≡Δ) x₅) , univ (soundness~↓! X)
  trans~↑! el Γ≡Δ (cast-ℕℕ X x x₁) (cast-ℕℕ Y x₂ x₃) =
    let XY , N = trans~↓! PE.refl Γ≡Δ X Y
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in cast-ℕℕ XY x (stabilityTerm (symConEq Γ≡Δ) x₃) , N
  trans~↑! el Γ≡Δ (cast-Π x X x₁ x₂ x₃) (cast-Π x₄ Y x₅ x₆ x₇) =
    let XY , [U] = trans~↓! PE.refl Γ≡Δ X Y
        X≡Y = soundness~↓! XY
        Y≡Y = univ (soundnessConv↑Term x₄)
        t~t = transConv↑Term Γ≡Δ [U] x x₄
        u~u = transConv↑Term Γ≡Δ (univ (soundnessConv↑Term t~t)) x₁ (convConvTerm x₅ Y≡Y)
        A₁≡B = trans X≡Y (sym (soundness~↓! (stability~↓! (symConEq Γ≡Δ) Y)))
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
    in cast-Π t~t XY u~u x₂ (stabilityTerm (symConEq Γ≡Δ) x₇) , univ A₁≡B
  trans~↑! el Γ≡Δ (cast-Πℕ x x₁ x₂ x₃) (cast-Πℕ x₄ x₅ x₆ x₇) =
    let Y≡Y = univ (soundnessConv↑Term x₄)
        ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        t~t = transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ)) x x₄
        u~u = transConv↑Term Γ≡Δ (univ (soundnessConv↑Term t~t)) x₁ (convConvTerm x₅ Y≡Y)
    in cast-Πℕ t~t u~u x₂ (stabilityTerm (symConEq Γ≡Δ) x₇) , refl (univ (ℕⱼ  ⊢Γ))
  trans~↑! el Γ≡Δ (cast-ℕΠ x x₁ x₂ x₃) (cast-ℕΠ x₄ x₅ x₆ x₇) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        t~t = transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ)) x x₄
        u~u = transConv↑Term Γ≡Δ (refl (univ (ℕⱼ  ⊢Γ))) x₁ x₅
    in cast-ℕΠ t~t u~u x₂ (stabilityTerm (symConEq Γ≡Δ) x₇) , univ (soundnessConv↑Term x)
  trans~↑! el Γ≡Δ (cast-ΠΠ%! x x₁ x₂ x₃ x₄) (cast-ΠΠ%! x₅ x₆ x₇ x₈ x₉) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        A~A = transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ)) x x₅
        B~B = transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ)) x₁ x₆
        u~u = transConv↑Term Γ≡Δ (univ (soundnessConv↑Term x)) x₂ x₇
    in cast-ΠΠ%! A~A B~B u~u x₃ (stabilityTerm (symConEq Γ≡Δ) x₉) ,
       trans (univ (soundnessConv↑Term B~B)) (sym (univ (soundnessConv↑Term (stabilityConv↑Term (symConEq Γ≡Δ) x₆))))
  trans~↑! el Γ≡Δ (cast-ΠΠ!% x x₁ x₂ x₃ x₄) (cast-ΠΠ!% x₅ x₆ x₇ x₈ x₉) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        A~A = transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ)) x x₅
        B~B = transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ)) x₁ x₆
        u~u = transConv↑Term Γ≡Δ (univ (soundnessConv↑Term x)) x₂ x₇
    in cast-ΠΠ!% A~A B~B u~u x₃ (stabilityTerm (symConEq Γ≡Δ) x₉) ,
       trans (univ (soundnessConv↑Term B~B)) (sym (univ (soundnessConv↑Term (stabilityConv↑Term (symConEq Γ≡Δ) x₆))))

  trans~↑% : ∀ {t u v A Γ Δ  l}
         → ⊢ Γ ≡ Δ
         → Γ ⊢ t ~ u ↑% A ^ l
         → Δ ⊢ u ~ v ↑% A ^ l
         → Γ ⊢ t ~ v ↑% A ^ l
  trans~↑% Γ≡Δ (%~↑ ⊢t ⊢u) (%~↑ ⊢u′ ⊢v) =
    let ⊢Δu′ = stabilityTerm (symConEq Γ≡Δ) ⊢u′
        ⊢Δv = stabilityTerm (symConEq Γ≡Δ) ⊢v
    in %~↑ ⊢t ⊢Δv

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

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

  -- Transitivity of algorithmic equality of types in WHNF.
  transConv↓ : ∀ {A B C r Γ Δ}
            → ⊢ Γ ≡ Δ
            → Γ ⊢ A [conv↓] B ^ r
            → Δ ⊢ B [conv↓] C ^ r
            → Γ ⊢ A [conv↓] C ^ r
  transConv↓ Γ≡Δ (U-refl e x) (U-refl e₁ x₁) = U-refl (PE.trans e e₁) x
  transConv↓ Γ≡Δ (univ x) (univ y) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        X = transConv↓Term Γ≡Δ (refl (Ugenⱼ ⊢Γ )) PE.refl x y
    in univ X

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

  -- Transitivity of algorithmic equality of terms in WHNF.
  transConv↓Term : ∀ {t u v A B Γ Δ l l'}
                → ⊢ Γ ≡ Δ
                → Γ ⊢ A ≡ B ^ [ ! , l ]
                → l PE.≡ l'
                → Γ ⊢ t [conv↓] u ∷ A ^ l
                → Δ ⊢ u [conv↓] v ∷ B ^ l'
                → Γ ⊢ t [conv↓] v ∷ A ^ l

  transConv↓Term {Δ = Δ} Γ≡Δ A≡B el (ne x) (ne x₁) = ne (proj₁ (trans~↓! PE.refl Γ≡Δ x (PE.subst (λ lx → Δ ⊢ _ ~ _ ↓! Univ _ _ ^ lx) (PE.sym el) x₁)))
  transConv↓Term Γ≡Δ A≡B el (ℕ-ins x) (ℕ-ins x₁) =
    ℕ-ins (proj₁ (trans~↓! PE.refl Γ≡Δ x x₁))
  transConv↓Term {Δ = Δ} Γ≡Δ A≡B el (ne-ins t u x x₁) (ne-ins {k} {l} {M} {N} t′ u′ x₂ x₃) =
    ne-ins t (conv (stabilityTerm (symConEq Γ≡Δ) (PE.subst (λ lx → Δ ⊢ l ∷ N ^ [ ! , lx ]) (PE.sym el) u′))
                   (sym A≡B)) x
           (proj₁ (trans~↓! PE.refl Γ≡Δ x₁ (PE.subst (λ lx → Δ ⊢ k ~ l ↓! M ^ lx ) (PE.sym el) x₃)))
  transConv↓Term Γ≡Δ A≡B el (zero-refl x) (zero-refl x₁) =
    zero-refl x
  transConv↓Term Γ≡Δ A≡B el (suc-cong x) (suc-cong x₁) =
    suc-cong (transConv↑Term Γ≡Δ A≡B x x₁)
  transConv↓Term {Δ = Δ} Γ≡Δ A≡B el (η-eq {rF = rF₁} l< l<' x x₁ x₂ y y₁ x₃)
                                    (η-eq {u} {v} {F} {G} {rF} {lF} {lG} {l} l<'' l<''' x₄ x₅ x₆ y₂ y₃ x₇) =
    let F₁≡F , rF₁≡rF , lF₁≡lF , lG₁≡lG , G₁≡G = injectivity (PE.subst (λ lx → _ ⊢ _ ≡ Π _ ^ _ ° _ ▹ _ ° _ ° lx ^ _) (ιinj (PE.sym el)) A≡B )
    in  η-eq l< l<' x x₁ (conv (stabilityTerm (symConEq Γ≡Δ)
                                           (PE.subst (λ lx → Δ ⊢ v ∷ Π F ^ rF ° lF ▹ G ° lG ° l ^ [ ! , lx ]) (PE.sym el) x₆))
                            (sym A≡B))
             y y₃ (transConv↑Term (Γ≡Δ ∙ F₁≡F) G₁≡G x₃
                                  (PE.subst (λ lx → Δ ∙ F ^ [ rF₁ , _ ] ⊢  _ ∘ _ ^ _ [conv↑] wk1 v ∘ var 0 ^ _ ∷ G ^ ι lx)
                                            (PE.sym lG₁≡lG)
                                  (PE.subst (λ lx → Δ ∙ F ^ [ rF₁ , _ ] ⊢  wk1 u ∘ var 0 ^ lx [conv↑] wk1 v ∘ var 0 ^ lx ∷ G ^ ι lG)
                                            (PE.sym (ιinj el))
                                  (PE.subst (λ lx → Δ ∙ F ^ [ rF₁ , lx ] ⊢  wk1 u ∘ var 0 ^ l [conv↑] wk1 v ∘ var 0 ^ l ∷ G ^ ι lG)
                                            (PE.sym (PE.cong ι lF₁≡lF))
                                  (PE.subst (λ rx → Δ ∙ F ^ [ rx , ι lF ] ⊢ _ [conv↑] _ ∷ _ ^ _) (PE.sym rF₁≡rF) x₇)))))
  transConv↓Term Γ≡Δ A≡B el (ℕ-refl x) (ℕ-refl x₁) = ℕ-refl x
  transConv↓Term Γ≡Δ A≡B el (Empty-refl PE.refl x) (Empty-refl PE.refl x₁) = Empty-refl PE.refl x
  transConv↓Term Γ≡Δ A≡B el (U-refl e x) (U-refl e₁ x₁) = U-refl (PE.trans e e₁) x
  transConv↓Term Γ≡Δ A≡B el (Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' x₅ x₆ x₇) (Π-cong PE.refl PE.refl PE.refl PE.refl x₁₁ x₁₂ x₁₃ x₁₄ x₁₅) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        rF≡rF₁ , _ = Uinjectivity A≡B
    in Π-cong PE.refl PE.refl PE.refl PE.refl l< l<' x₅ (transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ )) x₆ x₁₄)
              (transConv↑Term (Γ≡Δ ∙ univ (soundnessConv↑Term x₆))
                              (PE.subst (λ rx → _ ⊢ _ ≡ Univ rx _ ^ _) rF≡rF₁ (refl (Ugenⱼ (⊢Γ ∙ x₅)) ) ) x₇ x₁₅)
  transConv↓Term Γ≡Δ A≡B el (∃-cong PE.refl x₅ x₆ x₇) (∃-cong PE.refl x₁₃ x₁₄ x₁₅) =
    let ⊢Γ , _ , _ = contextConvSubst Γ≡Δ
        rF≡rF₁ , _ = Uinjectivity A≡B
    in ∃-cong PE.refl x₅ (transConv↑Term Γ≡Δ (refl (Ugenⱼ ⊢Γ )) x₆ (PE.subst (λ l → _ ⊢ _ [conv↑] _ ∷ SProp l ^ next l) (next-inj (PE.sym el)) x₁₄ ))
                 (transConv↑Term (Γ≡Δ ∙ univ (soundnessConv↑Term x₆)) (refl (Ugenⱼ (⊢Γ ∙ x₅))) x₇
                                 (PE.subst (λ l → _ ∙ _ ^ [ % , ι l ]  ⊢ _ [conv↑] _ ∷ SProp l ^ next l) (next-inj (PE.sym el)) x₁₅ ))

  transConv↓Term Γ≡Δ A≡B PE.refl (ℕ-refl x) (η-eq x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) = ⊥-elim (WF.U≢Π! A≡B)
  transConv↓Term Γ≡Δ A≡B el (Empty-refl {l} PE.refl x) (η-eq x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) =
    let X = PE.subst (λ lx → _ ⊢ SProp l ≡  Π _ ^ _ ° _ ▹ _ ° _ ° _ ^ [ _ , lx ]) el A≡B
    in ⊥-elim (WF.U≢Π! X)
  transConv↓Term Γ≡Δ A≡B el (Π-cong {rΠ = rΠ} {lΠ = lΠ} x x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₀) (η-eq x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃ x₁₄ x₁₅) =
    let X = PE.subst (λ lx → _ ⊢ Univ rΠ lΠ ≡ Π _ ^ _ ° _ ▹ _ ° _ ° _ ^ [ _ , lx ]) el A≡B
    in ⊥-elim (WF.U≢Π! X)
  transConv↓Term Γ≡Δ A≡B el (∃-cong {l = l} x₅ x₆ x₇ x₀) (η-eq x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃ x₁₄ x₁₅) =
    let X = PE.subst (λ lx → _ ⊢ SProp l ≡ Π _ ^ _ ° _ ▹ _ ° _ ° _ ^ [ _ , lx ]) el A≡B
    in ⊥-elim (WF.U≢Π! X)

  transConv↓Term Γ≡Δ A≡B el (ne x) (ℕ-ins x₁) = ⊥-elim (WF.U≢ℕ! A≡B)
  transConv↓Term Γ≡Δ A≡B PE.refl (ne x) (ne-ins x₁ x₂ x₃ x₄) = ⊥-elim (WF.U≢ne! x₃ A≡B)
  transConv↓Term Γ≡Δ A≡B PE.refl (ne x) (η-eq x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) = ⊥-elim (WF.U≢Π! A≡B)
  --transConv↓Term Γ≡Δ A≡B el (zero-refl x) (zero-refl x₁) = {!!}
  transConv↓Term Γ≡Δ A≡B el (ℕ-ins x) (ne-ins t u x₂ x₃) = ⊥-elim (WF.ℕ≢ne! x₂ A≡B)
  transConv↓Term Γ≡Δ A≡B PE.refl (ℕ-ins x) (η-eq _ _ x₂ x₃ x₄ y y₁ x₅) = ⊥-elim (WF.ℕ≢Π! A≡B)
  transConv↓Term Γ≡Δ A≡B el (ℕ-ins x) (ne x₁) = ⊥-elim (WF.U≢ℕ! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B PE.refl (ne-ins x x₁ x₂ x₃) (ne x₄) = ⊥-elim (WF.U≢ne! x₂ (sym A≡B))
  transConv↓Term  Γ≡Δ A≡B PE.refl (ne-ins t u x x₁) (ℕ-ins x₂) =
    ⊥-elim (WF.ℕ≢ne! x (sym A≡B))
  transConv↓Term Γ≡Δ A≡B PE.refl (ne-ins x x₁ x₂ x₃) (η-eq x₄ x₅ x₆ x₇ x₈ x₉ x₁₀ x₁₁) = ⊥-elim (WF.Π≢ne x₂ (sym A≡B))
  transConv↓Term Γ≡Δ A≡B PE.refl (zero-refl x) (η-eq x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) =  ⊥-elim (WF.ℕ≢Π! A≡B)
  transConv↓Term Γ≡Δ A≡B PE.refl (suc-cong x) (η-eq x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) =  ⊥-elim (WF.ℕ≢Π! A≡B)
  transConv↓Term Γ≡Δ A≡B el (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (ne x₈) = ⊥-elim (WF.U≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B el (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (ℕ-refl x₈) = ⊥-elim (WF.U≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B el (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (Empty-refl x₀ x₈) = ⊥-elim (WF.U≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B el (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (Π-cong x₀ x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃ x₁₄ x₁₅) = ⊥-elim (WF.U≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B el (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (∃-cong x₀ x₁₃ x₁₄ x₁₅) = ⊥-elim (WF.U≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B PE.refl (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (ℕ-ins x₈) = ⊥-elim (WF.ℕ≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B el (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (ne-ins x₈ x₉ x₁₀ x₁₁) = ⊥-elim (WF.Π≢ne x₁₀ A≡B)
  transConv↓Term Γ≡Δ A≡B PE.refl (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (zero-refl x₈) = ⊥-elim (WF.ℕ≢Π! (sym A≡B))
  transConv↓Term Γ≡Δ A≡B PE.refl (η-eq x x₁ x₂ x₃ x₄ x₅ x₆ x₇) (suc-cong x₈) = ⊥-elim (WF.ℕ≢Π! (sym A≡B))

-- Transitivity of algorithmic equality of types of the same context.
transConv : ∀ {A B C r Γ}
          → Γ ⊢ A [conv↑] B ^ r
          → Γ ⊢ B [conv↑] C ^ r
          → Γ ⊢ A [conv↑] C ^ r
transConv A<>B B<>C =
  let Γ≡Γ = reflConEq (wfEq (soundnessConv↑ A<>B))
  in  transConv↑ Γ≡Γ A<>B B<>C

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

trans~↑!Term : ∀ {t u v A Γ l}
              → Γ ⊢ t ~ u ↑% A ^ l
              → Γ ⊢ u ~ v ↑% A ^ l
              → Γ ⊢ t ~ v ↑% A ^ l
trans~↑!Term t<>u u<>v =
  let _ , _ , t≡u = soundness~↑% t<>u
      Γ≡Γ = reflConEq (wfEqTerm t≡u)
  in  trans~↑% Γ≡Γ t<>u u<>v


{-# OPTIONS --without-K --rewriting #-}

{-
Imports everything that is not imported by something else.
This is not supposed to be used anywhere, this is just a simple way to
do `make all'

This file is intentionally named index.agda so that
Agda will generate index.html.

  favonia:
  On 2017/05/08, I further partition the results into multiple
  independent index[n].agda files because the garbage collection
  is not really working.
-}

module index1 where

{- some group theory results -}
import groups.ReducedWord
import groups.ProductRepr
import groups.CoefficientExtensionality

{- homotopy groups of circles -}
import homotopy.LoopSpaceCircle
import homotopy.PinSn
import homotopy.HopfJunior
import homotopy.Hopf

{- cohomology -}
import cohomology.EMModel
import cohomology.Sigma
import cohomology.Coproduct
import cohomology.Torus
import cohomology.InverseInSusp
import cohomology.MayerVietoris
-- import cohomology.MayerVietorisExact -- FIXME

{- prop * prop is still a prop -}
import homotopy.PropJoinProp

{- a space with preassigned homotopy groups -}
import homotopy.SpaceFromGroups

{- pushout 3x3 lemma -}
{- These takes lots of time and memory to check. -}
-- import homotopy.3x3.Commutes -- commented out because this does not run on travis.
-- import homotopy.JoinAssoc3x3 -- commented out because this does not run on travis.

{- covering spaces -}
import homotopy.GroupSetsRepresentCovers
import homotopy.AnyUniversalCoverIsPathSet
import homotopy.PathSetIsInitalCover
import homotopy.CircleCover

{- van kampen -}
-- see index3.agda

{- blakers massey -}
-- see index3.agda

{- cw complexes -}
-- see index2.agda

-- There are some unported theorems

-- import Spaces.IntervalProps
-- import Algebra.F2NotCommutative
-- import Spaces.LoopSpaceDecidableWedgeCircles
-- import Homotopy.PullbackIsPullback
-- import Homotopy.PushoutIsPushout
-- import Homotopy.Truncation
-- import Sets.QuotientUP


open import Prelude

module Implicits.Resolution.Finite.Algorithm where

open import Induction.WellFounded
open import Induction.Nat
open import Data.Fin.Substitution
open import Data.Nat.Base using (_<′_)
open import Data.List.Any
open Membership-≡
open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification
open import Implicits.Syntax.Type.Unification.Lemmas
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Implicits.Resolution.Finite.Resolution
open import Implicits.Resolution.Termination
open import Function.Inverse as Inv using (_↔_; module Inverse)
open import Function.Equality hiding (cong; flip; const)
open import Data.List.Any.Properties using (Any↔)
open import Data.Nat hiding (_<_)
open import Data.Nat.Properties
open import Relation.Binary using (module DecTotalOrder)
open DecTotalOrder decTotalOrder using () renaming
  (refl to ≤-refl; trans to ≤-trans)
open Lexicographic using (left; right)

module M = MetaTypeMetaSubst

module Lemmas where
  postulate lem₄ : ∀ {m ν} (a : MetaType m (suc ν)) u us → from-meta ((M.open-meta a) M./ (us M.↑) M./ (M.sub u)) ≡ (from-meta (a M./ (us M.↑tp))) tp[/tp from-meta u ]

  m<-Acc : ∀ {m ν} → MetaType m ν → Set
  m<-Acc {m} {ν} r = Acc _m<_ (m , ν , r)

  ρ<-Acc : ∀ {ν} → Type ν → Set
  ρ<-Acc {ν} r = Acc _ρ<_ (ν , r)

  module Arg<-well-founded  where
    open Lexicographic (_N<_) (const _ρ<_)

    open import Induction.Nat
    open import Data.Nat.Properties
    module image = Subrelation {A = ℕ} {_N<_} {_<′_} ≤⇒≤′

    arg<-well-founded : Well-founded _<_
    arg<-well-founded = well-founded (image.well-founded <-well-founded) ρ<-well-founded

    _arg<_ = _<_

    -- Accessibility of the 'goal' type during resolution.
    -- Either the *head* of the goal shrinks (Oliveira's termination condition)
    -- Or the head size remains equal and the goal shrinks in an absolute sense.
    Arg<-Acc : ∀ {ν} → Type ν → Set
    Arg<-Acc a = Acc _arg<_ (h|| a || , (, a))

  open Arg<-well-founded using (Arg<-Acc; arg<-well-founded) public

  lem₆ : ∀ {ν μ} (a : Type ν) (b : Type (suc μ)) c → (, a) hρ< (, b) → (, a) hρ< (, b tp[/tp c ])
  lem₆ a b c p = ≤-trans p (h||a/s|| b (TypeSubst.sub c))
    where open SubstSizeLemmas

  lem₅ : ∀ {ν μ} {Δ : ICtx ν} {b τ} (a : Type μ) → Δ ⊢ b ↓ τ → (, a) hρ< (, b) → (, a) hρ< (, simpl τ)
  lem₅ {τ = τ} a (i-simp .τ) q = q
  lem₅ a (i-iabs _ _ p) q = lem₅ a p q
  lem₅ a (i-tabs {ρ = b} c p) q = lem₅ a p (lem₆ a b c q)

open Lemmas

mutual

  match' : ∀ {m ν ρ} (Δ : ICtx ν) (r∈Δ : ρ List.∈ Δ) τ → (r : MetaType m ν) →
           Arg<-Acc (simpl τ) →
           m<-Acc r →
           Maybe (∃ λ u → Δ ⊢ from-meta (r M./ u) ↓ τ)
  match' Δ r∈Δ τ (simpl x) f g with mgu (simpl x) τ | sound (simpl x) τ
  match' Δ r∈Δ τ (simpl x) f g | just u | just u-unifies =
    just (u , subst (λ a → Δ ⊢ a ↓ τ) (sym u-unifies) (i-simp τ))
  match' Δ r∈Δ τ (simpl x) f g | nothing | _ = nothing

  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) with match' Δ r∈Δ τ b (acc f) (g _ (b-m<-a⇒b a b))
  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) | nothing = nothing
  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ)
    with (from-meta (a M./ u)) hρ<? (from-meta (b M./ u))
  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | yes ρ₁<
    with resolve' Δ (from-meta (a M./ u)) (f _ (left (lem₅ (from-meta (a M./ u)) b/u↓τ ρ₁<)))
  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | yes ρ₁< | just ⊢ᵣa =
    just (u , i-iabs ρ₁< ⊢ᵣa b/u↓τ)
  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | yes _ | nothing = nothing
  match' Δ r∈Δ τ (a ⇒ b) (acc f) (acc g) | just (u , b/u↓τ) | no p = nothing

  match' Δ r∈Δ τ (∀' a) f (acc g) with match' Δ r∈Δ τ (open-meta a) f (g _ (open-meta-a-m<-∀'a a))
  match' Δ r∈Δ τ (∀' a) f (acc g) | just p = just $ lem p
    where
      lem : (∃ λ u → Δ ⊢ (from-meta ((open-meta a) M./ u)) ↓ τ) →
          ∃ λ u' → Δ ⊢ (from-meta (∀' a M./ u')) ↓ τ
      lem (u ∷ us , p) = us , (i-tabs (from-meta u) (subst (λ v → Δ ⊢ v ↓ τ) (begin
            from-meta (M._/_ (open-meta a) (u ∷ us))
              ≡⟨ cong (λ v → from-meta (M._/_ (open-meta a) v)) (sym $ us↑-⊙-sub-u≡u∷us u us) ⟩
            from-meta ((open-meta a) M./ (us M.↑ M.⊙ (M.sub u)))
              ≡⟨ cong from-meta (/-⊙ (open-meta a)) ⟩
            from-meta ((open-meta a) M./ us M.↑ M./ (M.sub u))
              ≡⟨ lem₄ a u us ⟩
            from-meta (M._/_ a (us M.↑tp)) tp[/tp from-meta u ] ∎) p))
          where open MetaTypeMetaLemmas hiding (subst)
  match' Δ r∈Δ τ (∀' r) f (acc g) | nothing = nothing

  -- match defers to match', which concerns itself with MetaTypes.
  -- If match' finds a match, we can use the fact that we have zero unification variables open here
  -- to show that we found the right thing.
  match : ∀ {ν ρ} (Δ : ICtx ν) (r∈Δ : ρ List.∈ Δ) r τ → Arg<-Acc (simpl τ) → Maybe (Δ ⊢ r ↓ τ)
  match Δ r∈Δ a τ f with match' Δ r∈Δ τ (to-meta {zero} a) f (m<-well-founded _)
  match Δ r∈Δ a τ f | just x = just (lem x)
    where
      eq : ∀ {ν} {a : Type ν} {s} → from-meta (to-meta {zero} a M./ s) ≡ a
      eq {a = a} {s = []} = begin
          from-meta (M._/_ (to-meta {zero} a) [])
          ≡⟨ cong (λ q → from-meta q) (MetaTypeMetaLemmas.id-vanishes (to-meta {zero} a)) ⟩
          from-meta (to-meta {zero} a)
          ≡⟨ to-meta-zero-vanishes ⟩
          a ∎
      lem : ∃ (λ u → Δ ⊢ from-meta (to-meta {zero} a M./ u) ↓ τ) →
                Δ ⊢ a ↓ τ
      lem ([] , proj₂) = subst (λ u → Δ ⊢ u ↓ τ) eq proj₂
  match Δ r∈Δ a τ f | nothing = nothing

  match1st : ∀ {ν} (Δ : ICtx ν) τ → Arg<-Acc (simpl τ) →
             Maybe (∃₂ λ r (r∈Δ : r List.∈ Δ) → Δ ⊢ r ↓ τ)
  match1st {ν = ν} Δ τ f = match1st' Δ Prelude.id
    where
      match1st' : ∀ (ρs : ICtx ν) → ρs ⊆ Δ → Maybe (∃₂ λ r (r∈Δ : r List.∈ Δ) → Δ ⊢ r ↓ τ)
      match1st' List.[] sub = nothing
      match1st' (x List.∷ xs) sub with match Δ (sub (here refl)) x τ f
      match1st' (x List.∷ xs) sub | just px = just (x , ((sub (here refl)) , px))
      match1st' (x List.∷ xs) sub | nothing with match1st' xs (λ r∈xs → sub (there r∈xs))
      match1st' (x List.∷ xs) sub | nothing | just p = just p
      match1st' (x List.∷ xs) sub | nothing | nothing = nothing

  resolve' : ∀ {ν} (Δ : ICtx ν) r → Arg<-Acc r → (Maybe (Δ ⊢ᵣ r))
  resolve' Δ (simpl x) f with match1st Δ x f
  resolve' Δ (simpl x) f | just (_ , r∈Δ , r↓x) = just (r-simp r∈Δ r↓x)
  resolve' Δ (simpl x) f | nothing = nothing
  resolve' Δ (a ⇒ b) (acc f) with resolve' (a List.∷ Δ) b (f _ (right (b-ρ<-a⇒b a b)))
  resolve' Δ (a ⇒ b) (acc f) | just p = just (r-iabs p)
  resolve' Δ (a ⇒ b) (acc f) | nothing = nothing
  resolve' Δ (∀' r) (acc f) with resolve' (ictx-weaken Δ) r (f _ (right (a-ρ<-∀a r)))
  resolve' Δ (∀' r) (acc f) | just p = just (r-tabs p)
  resolve' Δ (∀' r) (acc f) | nothing = nothing

  resolve : ∀ {ν} (Δ : ICtx ν) r → (Maybe (Δ ⊢ᵣ r))
  resolve Δ r = resolve' Δ r (arg<-well-founded _)


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

module Definition.Conversion.FullReduction where

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening
open import Definition.Conversion
open import Definition.Conversion.Whnf
open import Definition.Typed.Consequences.InverseUniv
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.NeTypeEq
open import Definition.Typed.Consequences.Substitution

open import Tools.Product
import Tools.PropositionalEquality as PE

mutual
  data NfNeutral : Term → Set where
    var       : ∀ n                              → NfNeutral (var n)
    ∘ₙ        : ∀ {k u}     → NfNeutral k → Nf u → NfNeutral (k ∘ u)
    fstₙ      : ∀ {p}       → NfNeutral p        → NfNeutral (fst p)
    sndₙ      : ∀ {p}       → NfNeutral p        → NfNeutral (snd p)
    natrecₙ   : ∀ {C c g k} → Nf C → Nf c → Nf g → NfNeutral k
                                                 → NfNeutral (natrec C c g k)
    Emptyrecₙ : ∀ {C k}     → Nf C → NfNeutral k → NfNeutral (Emptyrec C k)

  data Nf : Term → Set where
    Uₙ     : Nf U
    Πₙ     : ∀ {A B} → Nf A → Nf B → Nf (Π A ▹ B)
    Σₙ     : ∀ {A B} → Nf A → Nf B → Nf (Σ A ▹ B)
    ℕₙ     : Nf ℕ
    Emptyₙ : Nf Empty
    Unitₙ  : Nf Unit

    lamₙ   : ∀ {t} → Nf t → Nf (lam t)
    prodₙ  : ∀ {t u} → Nf t → Nf u → Nf (prod t u)
    zeroₙ  : Nf zero
    sucₙ   : ∀ {t} → Nf t → Nf (suc t)
    starₙ  : Nf star

    ne     : ∀ {n} → NfNeutral n → Nf n

mutual
  fullRedNe : ∀ {t A Γ} → Γ ⊢ t ~ t ↑ A → ∃ λ u → NfNeutral u × Γ ⊢ t ≡ u ∷ A
  fullRedNe (var-refl x _) = var _ , var _ , refl x
  fullRedNe (app-cong t u) =
    let t′ , nfT′ , t≡t′ = fullRedNe~↓ t
        u′ , nfU′ , u≡u′ = fullRedTerm u
    in  (t′ ∘ u′) , (∘ₙ nfT′ nfU′) , app-cong t≡t′ u≡u′
  fullRedNe (fst-cong p~p) =
    let p′ , neP′ , p≡p′ = fullRedNe~↓ p~p
        ⊢ΣFG , _ , _ = syntacticEqTerm p≡p′
        ⊢F , ⊢G = syntacticΣ ⊢ΣFG
    in  fst p′ , fstₙ neP′ , fst-cong ⊢F ⊢G p≡p′
  fullRedNe (snd-cong p~p) =
    let p′ , neP′ , p≡p′ = fullRedNe~↓ p~p
        ⊢ΣFG , _ , _ = syntacticEqTerm p≡p′
        ⊢F , ⊢G = syntacticΣ ⊢ΣFG
    in  snd p′ , sndₙ neP′ , snd-cong ⊢F ⊢G p≡p′
  fullRedNe (natrec-cong C z s n) =
    let C′ , nfC′ , C≡C′ = fullRed C
        z′ , nfZ′ , z≡z′ = fullRedTerm z
        s′ , nfS′ , s≡s′ = fullRedTerm s
        n′ , nfN′ , n≡n′ = fullRedNe~↓ n
    in  natrec C′ z′ s′ n′ , natrecₙ nfC′ nfZ′ nfS′ nfN′
     ,  natrec-cong C≡C′ z≡z′ s≡s′ n≡n′
  fullRedNe (Emptyrec-cong C n) =
    let C′ , nfC′ , C≡C′ = fullRed C
        n′ , nfN′ , n≡n′ = fullRedNe~↓ n
    in  Emptyrec C′ n′ , Emptyrecₙ nfC′ nfN′
     ,  Emptyrec-cong C≡C′ n≡n′

  fullRedNe~↓ : ∀ {t A Γ} → Γ ⊢ t ~ t ↓ A → ∃ λ u → NfNeutral u × Γ ⊢ t ≡ u ∷ A
  fullRedNe~↓ ([~] A D whnfB k~l) =
    let u , nf , t≡u = fullRedNe k~l
    in  u , nf , conv t≡u (subset* D)

  fullRed : ∀ {A Γ} → Γ ⊢ A [conv↑] A → ∃ λ B → Nf B × Γ ⊢ A ≡ B
  fullRed ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′)
    rewrite whrDet* (D , whnfA′) (D′ , whnfB′) =
    let B″ , nf , B′≡B″ = fullRedConv↓ A′<>B′
    in  B″ , nf , trans (subset* D′) B′≡B″

  fullRedConv↓ : ∀ {A Γ} → Γ ⊢ A [conv↓] A → ∃ λ B → Nf B × Γ ⊢ A ≡ B
  fullRedConv↓ (U-refl ⊢Γ) = U , Uₙ , refl (Uⱼ ⊢Γ)
  fullRedConv↓ (ℕ-refl ⊢Γ) = ℕ , ℕₙ , refl (ℕⱼ ⊢Γ)
  fullRedConv↓ (Empty-refl ⊢Γ) = Empty , Emptyₙ , refl (Emptyⱼ ⊢Γ)
  fullRedConv↓ (Unit-refl ⊢Γ) = Unit , Unitₙ , refl (Unitⱼ ⊢Γ)
  fullRedConv↓ (ne A) =
    let B , nf , A≡B = fullRedNe~↓ A
    in  B , ne nf , univ A≡B
  fullRedConv↓ (Π-cong ⊢F F G) =
    let F′ , nfF′ , F≡F′ = fullRed F
        G′ , nfG′ , G≡G′ = fullRed G
    in  Π F′ ▹ G′ , Πₙ nfF′ nfG′ , Π-cong ⊢F F≡F′ G≡G′
  fullRedConv↓ (Σ-cong ⊢F F G) =
    let F′ , nfF′ , F≡F′ = fullRed F
        G′ , nfG′ , G≡G′ = fullRed G
    in  Σ F′ ▹ G′ , Σₙ nfF′ nfG′ , Σ-cong ⊢F F≡F′ G≡G′

  fullRedTerm : ∀ {t A Γ} → Γ ⊢ t [conv↑] t ∷ A → ∃ λ u → Nf u × Γ ⊢ t ≡ u ∷ A
  fullRedTerm ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u)
    rewrite whrDet*Term (d , whnft′) (d′ , whnfu′) =
    let u″ , nf , u′≡u″ = fullRedTermConv↓ t<>u
    in  u″ , nf , conv (trans (subset*Term d′) u′≡u″) (sym (subset* D))

  fullRedTermConv↓ : ∀ {t A Γ} → Γ ⊢ t [conv↓] t ∷ A → ∃ λ u → Nf u × Γ ⊢ t ≡ u ∷ A
  fullRedTermConv↓ (ℕ-ins t) =
    let u , nf , t≡u = fullRedNe~↓ t
    in  u , ne nf , t≡u
  fullRedTermConv↓ (Empty-ins t) =
    let u , nf , t≡u = fullRedNe~↓ t
    in  u , ne nf , t≡u
  fullRedTermConv↓ (Unit-ins t) =
    let u , nf , t≡u = fullRedNe~↓ t
    in  u , ne nf , t≡u
  fullRedTermConv↓ (ne-ins ⊢t _ _ t) =
    let u , nfU , t≡u = fullRedNe~↓ t
        _ , ⊢t∷M , _ = syntacticEqTerm t≡u
        _ , neT , _ = ne~↓ t
    in  u , ne nfU , conv t≡u (neTypeEq neT ⊢t∷M ⊢t)
  fullRedTermConv↓ (univ ⊢t _ t) =
    let u , nf , t≡u = fullRedConv↓ t
    in  u , nf , inverseUnivEq ⊢t t≡u
  fullRedTermConv↓ (zero-refl ⊢Γ) = zero , zeroₙ , refl (zeroⱼ ⊢Γ)
  fullRedTermConv↓ (suc-cong t) =
    let u , nf , t≡u = fullRedTerm t
    in  suc u , sucₙ nf , suc-cong t≡u
  fullRedTermConv↓ (η-eq ⊢t _ _ _ t∘0) =
    let u , nf , t∘0≡u = fullRedTerm t∘0
        _ , _ , ⊢u = syntacticEqTerm t∘0≡u
        ⊢F , _ = syntacticΠ (syntacticTerm ⊢t)
        ΓF⊢ = wf ⊢F ∙ ⊢F
        wk⊢F = wk (step id) ΓF⊢ ⊢F
        ΓFF'⊢ = ΓF⊢ ∙ wk⊢F
        wk⊢u = wkTerm (lift (step id)) ΓFF'⊢ ⊢u
        λu∘0 = lam (U.wk (lift (step id)) u) ∘ var 0
    in  lam u , lamₙ nf
     ,  η-eq ⊢F ⊢t (lamⱼ ⊢F ⊢u)
                (trans t∘0≡u (PE.subst₂ (λ x y → _ ⊢ x ≡ λu∘0 ∷ y)
                                        (wkSingleSubstId u) (wkSingleSubstId _)
                                        (sym (β-red wk⊢F wk⊢u (var ΓF⊢ here)))))
  fullRedTermConv↓ (Σ-η ⊢t _ tProd _ fstConv sndConv) =
    let fst′ , nfFst′ , fst≡fst′ = fullRedTerm fstConv
        snd′ , nfSnd′ , snd≡snd′ = fullRedTerm sndConv
        _ , _ , ⊢fst′ = syntacticEqTerm fst≡fst′
        _ , _ , ⊢snd′₁ = syntacticEqTerm snd≡snd′
        ⊢ΣFG = syntacticTerm ⊢t
        ⊢F , ⊢G = syntacticΣ ⊢ΣFG

        Gfst≡Gfst′ = substTypeEq (refl ⊢G) fst≡fst′
        ⊢snd′ = conv ⊢snd′₁ Gfst≡Gfst′
        ⊢prod = prodⱼ ⊢F ⊢G ⊢fst′ ⊢snd′

        fstprod≡fst′ = Σ-β₁ ⊢F ⊢G ⊢fst′ ⊢snd′
        fst≡fstprod = trans fst≡fst′ (sym fstprod≡fst′)
        Gfst≡Gfstprod = substTypeEq (refl ⊢G) fst≡fstprod
        sndprod≡snd′ = conv (Σ-β₂ ⊢F ⊢G ⊢fst′ ⊢snd′) (sym Gfst≡Gfstprod)
        snd≡sndprod = trans snd≡snd′ (sym sndprod≡snd′)
    in  prod fst′ snd′ , prodₙ nfFst′ nfSnd′
      , Σ-η ⊢F ⊢G ⊢t ⊢prod fst≡fstprod snd≡sndprod
  fullRedTermConv↓ (η-unit ⊢t _ tUnit _) =
    star , starₙ , η-unit ⊢t (starⱼ (wfTerm ⊢t))


------------------------------------------------------------------------
-- Normalization of raw terms in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Syntax.Normalization where

open import Data.Context.WellFormed using (module ⊤-WellFormed)
open import Data.Fin using (Fin; zero; suc; raise; lift)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas using (module VarLemmas)
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Typed
open import Data.Maybe using (just; nothing)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.List using ([]; _∷_; _∷ʳ_)
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.Vec as Vec using ([]; _∷_)
import Data.Vec.Properties as VecProps
open import Function using (_∘_; flip)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε)
open import Relation.Binary.PropositionalEquality as P hiding ([_])

open import FOmegaInt.Reduction.Full
open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution

open Syntax

----------------------------------------------------------------------
-- Kind simplification as a relation.

infix 4 ⌊_⌋≡_

-- Kind simplification (aka erasure to shapes) as a relation.
--
-- We introduce an inductively defined relation on kinds (and shapes)
-- that precisely relates a (dependent) kind to its shape.  Proofs of
-- ⌊ j ⌋≡ k are equivalent to proofs that ⌊ j ⌋ ≡ k, as witnessed by
-- the ⌊⌋-⌊⌋≡ and ⌊⌋≡⇒⌊⌋-≡ lemmas below, but the former are easier to
-- work with in certain functions and lemmas that are defined by
-- recursion on shapes since the recursion structure then matches the
-- inductive structure of the relation.  A prime example of this is
-- η-expansion as implemented below (see the definition of η-exp in
-- the TrackSimpleKindsEtaExp module).  Most lemmas about η-expansion
-- also use the ⌊_⌋≡_ relation in a similar way.

data ⌊_⌋≡_ {T n} : Kind T n → SKind → Set where
  is-★ : ∀ {a b}                                   → ⌊ a ⋯ b ⌋≡ ★
  is-⇒ : ∀ {j₁ j₂ k₁ k₂} → ⌊ j₁ ⌋≡ k₁ → ⌊ j₂ ⌋≡ k₂ → ⌊ Π j₁ j₂ ⌋≡ k₁ ⇒ k₂

-- Kind simplification as a relation agrees with kind simplification
-- as a function.

⌊⌋-⌊⌋≡ : ∀ {T n} (k : Kind T n) → ⌊ k ⌋≡ ⌊ k ⌋
⌊⌋-⌊⌋≡ (a ⋯ b) = is-★
⌊⌋-⌊⌋≡ (Π j k) = is-⇒ (⌊⌋-⌊⌋≡ j) (⌊⌋-⌊⌋≡ k)

⌊⌋≡⇒⌊⌋-≡ : ∀ {T n k} {j : Kind T n} → ⌊ j ⌋≡ k → ⌊ j ⌋ ≡ k
⌊⌋≡⇒⌊⌋-≡ is-★                   = refl
⌊⌋≡⇒⌊⌋-≡ (is-⇒ ⌊j₁⌋=k₁ ⌊j₂⌋=k₂) =
  cong₂ _⇒_ (⌊⌋≡⇒⌊⌋-≡ ⌊j₁⌋=k₁) (⌊⌋≡⇒⌊⌋-≡ ⌊j₂⌋=k₂)

⌊⌋≡-trans : ∀ {T n m k} {j : Kind T n} {l : Kind T m} →
            ⌊ j ⌋ ≡ ⌊ l ⌋ → ⌊ l ⌋≡ k → ⌊ j ⌋≡ k
⌊⌋≡-trans ⌊j⌋≡⌊l⌋ ⌊l⌋≡k rewrite (sym (⌊⌋≡⇒⌊⌋-≡ ⌊l⌋≡k)) =
  subst (⌊ _ ⌋≡_) ⌊j⌋≡⌊l⌋ (⌊⌋-⌊⌋≡ _)

-- Kind simplification is proof-irrelevant.

⌊⌋≡-pirr : ∀ {T n k} {j : Kind T n} → (p₁ p₂ : ⌊ j ⌋≡ k) → p₁ ≡ p₂
⌊⌋≡-pirr is-★ is-★                     = refl
⌊⌋≡-pirr (is-⇒ p₁₁ p₁₂) (is-⇒ p₂₁ p₂₂) =
  cong₂ is-⇒ (⌊⌋≡-pirr p₁₁ p₂₁) (⌊⌋≡-pirr p₁₂ p₂₂)

-- A type of abstract lemma stating that kind simplification as a
-- relation commutes with substitution.

KindSimpAppLemma : ∀ {T T′} (app : Application (Kind T) T′) → Set
KindSimpAppLemma {_} {T′} app =
  ∀ {m n j k} {σ : Sub T′ m n} → ⌊ j ⌋≡ k → ⌊ j / σ ⌋≡ k
  where open Application app

-- Lemmas relating kind simplification to operations on T-kinds.

record KindSimpLemmas (T : ℕ → Set) : Set₁ where

  field lemmas : TermLikeLemmas (Kind T) Term
  open TermLikeLemmas lemmas
    using (termApplication; varApplication; weaken; weaken⋆)

  field
    ⌊⌋≡-/    : KindSimpAppLemma termApplication
    ⌊⌋≡-/Var : KindSimpAppLemma varApplication

  -- Kind simplification as a relation commutes with weakening.

  ⌊⌋≡-weaken : ∀ {n k} {j : Kind T n} → ⌊ j ⌋≡ k → ⌊ weaken j ⌋≡ k
  ⌊⌋≡-weaken ⌊j⌋≡k = ⌊⌋≡-/Var ⌊j⌋≡k

  ⌊⌋≡-weaken⋆ : ∀ m {n k} {j : Kind T n} → ⌊ j ⌋≡ k → ⌊ weaken⋆ m j ⌋≡ k
  ⌊⌋≡-weaken⋆ zero    ⌊j⌋≡k = ⌊j⌋≡k
  ⌊⌋≡-weaken⋆ (suc m) ⌊j⌋≡k = ⌊⌋≡-weaken (⌊⌋≡-weaken⋆ m ⌊j⌋≡k)

module KindSimpSubstApp {T} {l : Lift T Term} where
  open SubstApp l

  -- Kind simplification as a relation commutes with substitution.

  ⌊⌋≡-Kind/ : ∀ {m n j k} {σ : Sub T m n} → ⌊ j ⌋≡ k → ⌊ j Kind/ σ ⌋≡ k
  ⌊⌋≡-Kind/ is-★                   = is-★
  ⌊⌋≡-Kind/ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) =
    is-⇒ (⌊⌋≡-Kind/ ⌊j₁⌋≡k₁) (⌊⌋≡-Kind/ ⌊j₂⌋≡k₂)

  ⌊⌋≡-Kind′/ : ∀ {m n j k} {σ : Sub T m n} → ⌊ j ⌋≡ k → ⌊ j Kind′/ σ ⌋≡ k
  ⌊⌋≡-Kind′/ is-★                   = is-★
  ⌊⌋≡-Kind′/ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) =
    is-⇒ (⌊⌋≡-Kind′/ ⌊j₁⌋≡k₁) (⌊⌋≡-Kind′/ ⌊j₂⌋≡k₂)

simpLemmasKind : KindSimpLemmas Term
simpLemmasKind = record
  { lemmas   = termLikeLemmasKind
  ; ⌊⌋≡-/    = KindSimpSubstApp.⌊⌋≡-Kind/
  ; ⌊⌋≡-/Var = KindSimpSubstApp.⌊⌋≡-Kind/
  }
  where open Substitution

simpLemmasKind′ : KindSimpLemmas Elim
simpLemmasKind′ = record
  { lemmas   = termLikeLemmasKind′
  ; ⌊⌋≡-/    = KindSimpSubstApp.⌊⌋≡-Kind′/
  ; ⌊⌋≡-/Var = KindSimpSubstApp.⌊⌋≡-Kind′/
  }
  where open Substitution

module SimpHSubstLemmas where
  open KindSimpLemmas simpLemmasKind′ public

  -- Kind simplification as a relation commutes with hereditary
  -- substitution.

  ⌊⌋≡-/⟨⟩ : ∀ {m n j k l} {σ : SVSub m n} → ⌊ j ⌋≡ k → ⌊ j Kind/⟨ l ⟩ σ ⌋≡ k
  ⌊⌋≡-/⟨⟩ is-★                   = is-★
  ⌊⌋≡-/⟨⟩ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) = is-⇒ (⌊⌋≡-/⟨⟩ ⌊j₁⌋≡k₁) (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)

open SimpHSubstLemmas

----------------------------------------------------------------------
-- Untyped η-expansion of neutral terms.

module TrackSimpleKindsEtaExp where
  open Substitution hiding (_↑; sub)

  -- NOTE. The definition of the function η-exp in this module is
  -- structurally recursive in the *shape* parameter k, but *not* in
  -- the kind (j : Kind Elim n) because we need to weaken the domain
  -- j₁ of the dependent kind (j = Π j₁ j₂) in the arrow case.  The
  -- additional hypothesis ⌊ j ⌋≡ k ensures that k is indeed the shape
  -- of the kind j.

  -- Kind-driven untyped η-expansion of eliminations.
  --
  -- NOTE.  We only expand neutral types since these are the only
  -- non-lambda forms of arrow kind, and thus the only ones that
  -- require expansion to reach η-long β-normal forms.

  η-exp : ∀ {n k} (j : Kind Elim n) → ⌊ j ⌋≡ k → Elim n → Elim n
  η-exp (c ⋯ d)   (is-★)                 a = a
  η-exp (Π j₁ j₂) (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) a =
    Λ∙ j₁ (η-exp j₂ ⌊j₂⌋≡k₂ a·ηz)
    where
      a·ηz = weakenElim a ⌜·⌝
               η-exp (weakenKind′ j₁) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero)

  -- A helper lemma.

  η-exp-⌊⌋≡ : ∀ {n j₁ j₂ k₁ k₂} {a : Elim n}
              (hyp₁ : ⌊ j₁ ⌋≡ k₁) (hyp₂ : ⌊ j₂ ⌋≡ k₂) → j₁ ≡ j₂ → k₁ ≡ k₂ →
              η-exp j₁ hyp₁ a ≡ η-exp j₂ hyp₂ a
  η-exp-⌊⌋≡ hyp₁ hyp₂ refl refl =
    cong (λ hyp → η-exp _ hyp _) (⌊⌋≡-pirr hyp₁ hyp₂)

  -- η-expansion commutes with renaming.

  η-exp-/Var : ∀ {m n j k} (hyp : ⌊ j ⌋≡ k) a {ρ : Sub Fin m n} →
               η-exp j hyp a Elim/Var ρ ≡
                 η-exp (j Kind′/Var ρ) (⌊⌋≡-/Var hyp) (a Elim/Var ρ)
  η-exp-/Var is-★ a = refl
  η-exp-/Var (is-⇒ {j₁} {j₂} ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) a {ρ} = begin
      η-exp _ (is-⇒ ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) a Elim/Var ρ
    ≡⟨ cong (Λ∙ (j₁ Kind′/Var ρ)) (η-exp-/Var ⌊j₂⌋≡k₂ _) ⟩
      Λ∙ (j₁ Kind′/Var ρ) (η-exp (j₂ Kind′/Var ρ V.↑) (⌊⌋≡-/Var ⌊j₂⌋≡k₂)
        ((weakenElim a ⌜·⌝
          η-exp (weakenKind′ j₁) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero)) Elim/Var
            ρ V.↑))
    ≡⟨ cong (λ c → Λ∙ (j₁ Kind′/Var ρ)
                      (η-exp (j₂ Kind′/Var ρ V.↑) (⌊⌋≡-/Var ⌊j₂⌋≡k₂) c))
            (begin
                weakenElim a ⌜·⌝
                  η-exp (weakenKind′ j₁) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero)
                    Elim/Var ρ V.↑
              ≡⟨ ⌜·⌝-/Var (weakenElim a) _ ⟩
                (weakenElim a Elim/Var ρ V.↑) ⌜·⌝
                  (η-exp (weakenKind′ j₁) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero)
                    Elim/Var ρ V.↑)
              ≡⟨ cong₂ _⌜·⌝_ (sym (EVL.wk-commutes a))
                       (η-exp-/Var (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero)) ⟩
                (weakenElim (a Elim/Var ρ)) ⌜·⌝
                  (η-exp (weakenKind′ j₁ Kind′/Var ρ V.↑)
                         (⌊⌋≡-/Var (⌊⌋≡-weaken ⌊j₁⌋≡k₁))
                         ((var∙ zero) Elim/Var ρ V.↑))
              ≡⟨ cong ((weakenElim (a Elim/Var ρ)) ⌜·⌝_)
                      (η-exp-⌊⌋≡ (⌊⌋≡-/Var (⌊⌋≡-weaken ⌊j₁⌋≡k₁))
                                 (⌊⌋≡-weaken (⌊⌋≡-/Var ⌊j₁⌋≡k₁))
                                 (sym (KVL.wk-commutes j₁)) refl) ⟩
                (weakenElim (a Elim/Var ρ)) ⌜·⌝
                  (η-exp (weakenKind′ (j₁ Kind′/Var ρ))
                         (⌊⌋≡-weaken (⌊⌋≡-/Var ⌊j₁⌋≡k₁))
                         (var∙ zero))
              ∎) ⟩
      η-exp _ (is-⇒ (⌊⌋≡-/Var ⌊j₁⌋≡k₁) (⌊⌋≡-/Var ⌊j₂⌋≡k₂)) (a Elim/Var ρ)
    ∎
    where
      open ≡-Reasoning
      module V  = VarSubst
      module EL = TermLikeLemmas termLikeLemmasElim
      module KL = TermLikeLemmas termLikeLemmasKind′
      module EVL = LiftAppLemmas EL.varLiftAppLemmas
      module KVL = LiftAppLemmas KL.varLiftAppLemmas

  -- η-expansion of neutrals commutes with hereditary substitutions
  -- that miss the head of the neutral.

  η-exp-ne-Miss-/⟨⟩ : ∀ {l m n j k} x y {as} {σ : SVSub m n}
                      (hyp : ⌊ j ⌋≡ k) → Miss σ x y →
                      η-exp j hyp (var x ∙ as) /⟨ l ⟩ σ  ≡
                        η-exp (j Kind/⟨ l ⟩ σ) (⌊⌋≡-/⟨⟩ hyp)
                              (var y ∙ (as //⟨ l ⟩ σ))
  η-exp-ne-Miss-/⟨⟩ x y is-★ missP = cong (_?∙∙⟨ _ ⟩ _) (lookup-Miss missP)
  η-exp-ne-Miss-/⟨⟩ {l} x y {as} {σ} (is-⇒ {j₁} {j₂} ⌊j₁⌋≡k₁ ⌊j₂⌋≡k₂) missP =
    cong (Λ∙ (j₁ Kind/⟨ l ⟩ σ)) (begin
       η-exp j₂ ⌊j₂⌋≡k₂ ((weakenElim (var x ∙ as)) ⌜·⌝ ηz) /⟨ l ⟩ σ ↑
      ≡⟨ cong (λ x → η-exp _ ⌊j₂⌋≡k₂ (var x ∙ weakenSpine as ⌜·⌝ _) /⟨ l ⟩ σ ↑)
              (VarLemmas.lookup-wk x) ⟩
       η-exp j₂ ⌊j₂⌋≡k₂ (var (suc x) ∙ (weakenSpine as) ⌜·⌝ ηz) /⟨ l ⟩ σ ↑
      ≡⟨ η-exp-ne-Miss-/⟨⟩ (suc x) (suc y) ⌊j₂⌋≡k₂ (missP ↑) ⟩
       η-exp (j₂ Kind/⟨ l ⟩ σ ↑) (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂) (var (suc y) ∙
         (((weakenSpine as) ∷ʳ ηz) //⟨ l ⟩ σ ↑))
      ≡⟨ cong (λ bs → η-exp _ (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂) (var _ ∙ bs))
              (++-//⟨⟩ (weakenSpine as) (_ ∷ [])) ⟩
       η-exp (j₂ Kind/⟨ l ⟩ σ ↑) (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)
         (var (suc y) ∙ ((weakenSpine as) //⟨ l ⟩ σ ↑) ⌜·⌝ (ηz /⟨ l ⟩ σ ↑))
      ≡⟨ cong₂ (λ a b → η-exp (j₂ Kind/⟨ l ⟩ σ ↑) (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂) (a ⌜·⌝ b))
               (cong₂ (λ x as → var x ∙ as)
                      (sym (VarLemmas.lookup-wk y)) (wk-//⟨⟩-↑⋆ 0 as))
               (η-exp-ne-Miss-/⟨⟩ zero zero (⌊⌋≡-weaken ⌊j₁⌋≡k₁) under) ⟩
       η-exp (j₂ Kind/⟨ l ⟩ σ ↑) (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)
         (weakenElim (var y ∙ (as //⟨ l ⟩ σ)) ⌜·⌝
           η-exp ((weakenKind′ j₁) Kind/⟨ l ⟩ σ ↑)
                 (⌊⌋≡-/⟨⟩ (⌊⌋≡-weaken ⌊j₁⌋≡k₁)) (var∙ zero))
      ≡⟨ cong (λ a → η-exp _ (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)
                       (weakenElim (var y ∙ (as //⟨ l ⟩ σ)) ⌜·⌝ a))
              (η-exp-⌊⌋≡ (⌊⌋≡-/⟨⟩ (⌊⌋≡-weaken ⌊j₁⌋≡k₁))
                         (⌊⌋≡-weaken (⌊⌋≡-/⟨⟩ ⌊j₁⌋≡k₁))
                         (wk-Kind/⟨⟩-↑⋆ 0 j₁) refl) ⟩
       η-exp (j₂ Kind/⟨ l ⟩ σ ↑) (⌊⌋≡-/⟨⟩ ⌊j₂⌋≡k₂)
         ((weakenElim (var y ∙ (as //⟨ l ⟩ σ))) ⌜·⌝
           η-exp (weakenKind′ (j₁ Kind/⟨ l ⟩ σ))
                 (⌊⌋≡-weaken (⌊⌋≡-/⟨⟩ ⌊j₁⌋≡k₁)) (var∙ zero))
      ∎)
      where
        open ≡-Reasoning
        open RenamingCommutes
        ηz = η-exp (weakenKind′ j₁) (⌊⌋≡-weaken ⌊j₁⌋≡k₁) (var∙ zero)

private module TK = TrackSimpleKindsEtaExp

-- Kind-driven untyped η-expansion.

η-exp : ∀ {n} → Kind Elim n → Elim n → Elim n
η-exp k a = TK.η-exp k (⌊⌋-⌊⌋≡ k) a

module _ where
  open Substitution
  open ≡-Reasoning

  -- η-expansion commutes with renaming.

  η-exp-/Var : ∀ {m n} k a {ρ : Sub Fin m n} →
               η-exp k a Elim/Var ρ ≡ η-exp (k Kind′/Var ρ) (a Elim/Var ρ)
  η-exp-/Var k a {ρ} = begin
      η-exp k a Elim/Var ρ
    ≡⟨ TK.η-exp-/Var (⌊⌋-⌊⌋≡ k) a ⟩
      TK.η-exp (k Kind′/Var ρ) (⌊⌋≡-/Var (⌊⌋-⌊⌋≡ k)) (a Elim/Var ρ)
    ≡⟨ TK.η-exp-⌊⌋≡ (⌊⌋≡-/Var (⌊⌋-⌊⌋≡ k)) (⌊⌋-⌊⌋≡ (k Kind′/Var ρ))
                    refl (sym (⌊⌋-Kind′/Var k)) ⟩
      η-exp (k Kind′/Var ρ) (a Elim/Var ρ)
    ∎

  -- A corollary: η-expansion commutes with weakening.

  η-exp-weaken : ∀ {n} k (a : Elim n) →
                 weakenElim (η-exp k a) ≡ η-exp (weakenKind′ k) (weakenElim a)
  η-exp-weaken k a = η-exp-/Var k a

  -- η-expansion of neutrals commutes with hereditary substitutions
  -- that miss the head of the neutral.

  η-exp-ne-Miss-/⟨⟩ : ∀ {l m n} x y as k {σ : SVSub m n} → Miss σ x y →
                      η-exp k (var x ∙ as) /⟨ l ⟩ σ  ≡
                        η-exp (k Kind/⟨ l ⟩ σ) (var y ∙ (as //⟨ l ⟩ σ))
  η-exp-ne-Miss-/⟨⟩ {l} x y as k {σ} missP = begin
      η-exp k (var x ∙ as) /⟨ l ⟩ σ
    ≡⟨ TK.η-exp-ne-Miss-/⟨⟩ x y (⌊⌋-⌊⌋≡ k) missP ⟩
      TK.η-exp (k Kind/⟨ l ⟩ σ) (⌊⌋≡-/⟨⟩ (⌊⌋-⌊⌋≡ k)) (var y ∙ (as //⟨ l ⟩ σ))
    ≡⟨ TK.η-exp-⌊⌋≡ (⌊⌋≡-/⟨⟩ (⌊⌋-⌊⌋≡ k)) (⌊⌋-⌊⌋≡ (k Kind/⟨ l ⟩ σ)) refl
                    (sym (⌊⌋-Kind/⟨⟩ k)) ⟩
      η-exp (k Kind/⟨ l ⟩ σ) (var y ∙ (as //⟨ l ⟩ σ))
    ∎

----------------------------------------------------------------------
-- Untyped normalization.

open ElimCtx

-- Normalize an raw type or kind into η-long β-normal form if
-- possible.  Degenerate cases are marked "!".

mutual

  nf : ∀ {n} → Ctx n → Term n → Elim n
  nf Γ (var x) with lookup Γ x
  nf Γ (var x) | kd k = η-exp k (var∙ x)
  nf Γ (var x) | tp a = var∙ x                    -- ! a not a kind
  nf Γ ⊥       = ⊥∙
  nf Γ ⊤       = ⊤∙
  nf Γ (Π k a) = let k′ = nfKind Γ k in ∀∙ k′ (nf (kd k′ ∷ Γ) a)
  nf Γ (a ⇒ b) = (nf Γ a ⇒ nf Γ b) ∙ []
  nf Γ (Λ k a) = let k′ = nfKind Γ k in Λ∙ k′ (nf (kd k′ ∷ Γ) a)
  nf Γ (ƛ a b) = ƛ∙ ⌜ a ⌝ ⌜ b ⌝                   -- ! ƛ a b not a type
  nf Γ (a · b) = nf Γ a ↓⌜·⌝ nf Γ b
  nf Γ (a ⊡ b) = ⌜ a ⌝ ⊡∙ ⌜ b ⌝                   -- ! a ⊡ b not a type

  nfKind : ∀ {n} → Ctx n → Kind Term n → Kind Elim n
  nfKind Γ (a ⋯ b) = nf Γ a ⋯ nf Γ b
  nfKind Γ (Π j k) = let j′ = nfKind Γ j in Π j′ (nfKind (kd j′ ∷ Γ) k)

-- Normalization extended to contexts.

nfAsc : ∀ {n} → Ctx n → TermAsc n → ElimAsc n
nfAsc Γ (kd k) = kd (nfKind Γ k)
nfAsc Γ (tp a) = tp (nf Γ a)

nfCtx : ∀ {n} → TermCtx.Ctx n → Ctx n
nfCtx []      = []
nfCtx (a ∷ Γ) = let Γ′ = nfCtx Γ in nfAsc Γ′ a ∷ Γ′

nfCtxExt : ∀ {m n} → Ctx m → TermCtx.CtxExt m n → CtxExt m n
nfCtxExt Γ []      = []
nfCtxExt Γ (a ∷ Δ) = let Δ′ = nfCtxExt Γ Δ in nfAsc (Δ′ ++ Γ) a ∷ Δ′

-- Shapes are stable w.r.t. normalization.

⌊⌋-nf : ∀ {n} {Γ : Ctx n} k → ⌊ nfKind Γ k ⌋ ≡ ⌊ k ⌋
⌊⌋-nf (a ⋯ b) = refl
⌊⌋-nf (Π j k) = cong₂ _⇒_ (⌊⌋-nf j) (⌊⌋-nf k)

open SimpleCtx using (⌊_⌋Asc; kd; tp)
open ContextConversions using (⌊_⌋Ctx)

-- Simple contexts are stable w.r.t. normalization.

⌊⌋Asc-nf : ∀ {n} {Γ : Ctx n} a → ⌊ nfAsc Γ a ⌋Asc ≡ ⌊ a ⌋Asc
⌊⌋Asc-nf (kd k) = cong kd (⌊⌋-nf k)
⌊⌋Asc-nf (tp a) = refl

⌊⌋Ctx-nf : ∀ {n} (Γ : TermCtx.Ctx n) → ⌊ nfCtx Γ ⌋Ctx ≡ ⌊ Γ ⌋Ctx
⌊⌋Ctx-nf []      = refl
⌊⌋Ctx-nf (a ∷ Γ) = cong₂ _∷_ (⌊⌋Asc-nf a) (⌊⌋Ctx-nf Γ)

-- Normalization commutes with context concatenation.

nf-++ : ∀ {m n} (Δ : TermCtx.CtxExt m n) Γ →
        nfCtx (Δ ++ Γ) ≡ nfCtxExt (nfCtx Γ) Δ ++ nfCtx Γ
nf-++ []      Γ = refl
nf-++ (a ∷ Δ) Γ = cong₂ _∷_ (cong (λ Δ → nfAsc Δ a) (nf-++ Δ Γ)) (nf-++ Δ Γ)

-- A helper lemma about normalization of variables.

nf-var-kd : ∀ {n} (Γ : Ctx n) {k} x →
            lookup Γ x ≡ kd k → nf Γ (var x) ≡ η-exp k (var∙ x)
nf-var-kd Γ x Γ[x]≡kd-k with lookup Γ x
nf-var-kd Γ x refl | kd k = refl
nf-var-kd Γ x ()   | tp _

module RenamingCommutesNorm where
  open Substitution hiding (subst; varLiftAppLemmas)
  open TermLikeLemmas termLikeLemmasElimAsc
    using (varApplication; varLiftAppLemmas)
  open RenamingCommutes
  open ⊤-WellFormed weakenOps
  open ≡-Reasoning

  private
    module V  = VarSubst
    module AL = LiftAppLemmas varLiftAppLemmas

  -- Well-formed renamings.
  --
  -- A renaming `ρ' is well-formed `Δ ⊢/ ρ ∈ Γ' if it maps ascriptions
  -- from the source contxt `Γ' to the target context `Δ' in a manner
  -- that is consistent with the renaming, i.e. such that we have
  -- `Δ(ρ(x)) = Γ(x)ρ'.

  kindedVarSubst : TypedVarSubst ElimAsc _
  kindedVarSubst = record
    { _⊢_wf              = _⊢_wf
    ; typeExtension      = weakenOps
    ; typeVarApplication = varApplication
    ; wf-wf              = λ _ → ctx-wf _
    ; /-wk               = refl
    ; id-vanishes        = AL.id-vanishes
    ; /-⊙                = AL./-⊙
    }
  open TypedVarSubst kindedVarSubst renaming (lookup to /∈-lookup)

  -- Extract a "consistency" proof from a well-formed renaming, i.e. a
  -- proof that `Δ(ρ(x)) = Γ(x)ρ'.

  lookup-≡ : ∀ {m n Δ Γ} {ρ : Sub Fin m n} → Δ ⊢/Var ρ ∈ Γ → ∀ x →
             lookup Δ (Vec.lookup ρ x) ≡ lookup Γ x ElimAsc/Var ρ
  lookup-≡ {_} {_} {Δ} {Γ} {ρ} ρ∈Γ x
    with Vec.lookup ρ x | lookup Γ x ElimAsc/Var ρ | /∈-lookup ρ∈Γ x
  lookup-≡ ρ∈Γ x | y | _ | VarTyping.∈-var .y _ = refl

  mutual

    -- A helper.

    ∈-↑′ : ∀ {m n Δ Γ} {ρ : Sub Fin m n} k → Δ ⊢/Var ρ ∈ Γ →
           kd (nfKind Δ (k Kind/Var ρ)) ∷ Δ ⊢/Var ρ V.↑ ∈ (nfAsc Γ (kd k) ∷ Γ)
    ∈-↑′ k ρ∈Γ =
      subst (λ k → kd k ∷ _ ⊢/Var _ ∈ _) (nfKind-/Var k ρ∈Γ) (∈-↑ _ ρ∈Γ)

    -- Normalization commutes with renaming.

    nf-/Var : ∀ {m n Δ Γ} {ρ : Sub Fin m n} a → Δ ⊢/Var ρ ∈ Γ →
              nf Γ a Elim/Var ρ ≡ nf Δ (a /Var ρ)
    nf-/Var {_} {_} {Δ} {Γ} {ρ} (var x) ρ∈Γ
      with lookup Γ x | lookup Δ (Vec.lookup ρ x) | lookup-≡ ρ∈Γ x
    nf-/Var (var x) ρ∈Γ | kd k | _ | refl = η-exp-/Var k (var∙ x)
    nf-/Var (var x) ρ∈Γ | tp a | _ | refl = refl
    nf-/Var ⊥       ρ∈Γ = refl
    nf-/Var ⊤       ρ∈Γ = refl
    nf-/Var (Π k a) ρ∈Γ = cong₂ ∀∙ (nfKind-/Var k ρ∈Γ) (nf-/Var a (∈-↑′ k ρ∈Γ))
    nf-/Var (a ⇒ b) ρ∈Γ = cong₂ _⇒∙_ (nf-/Var a ρ∈Γ) (nf-/Var b ρ∈Γ)
    nf-/Var (Λ j a) ρ∈Γ = cong₂ Λ∙ (nfKind-/Var j ρ∈Γ) (nf-/Var a (∈-↑′ j ρ∈Γ))
    nf-/Var (ƛ a b) ρ∈Γ = cong₂ ƛ∙ (sym (⌜⌝-/Var a)) (sym (⌜⌝-/Var b))
    nf-/Var {m} {_} {Δ} {Γ} {ρ} (a · b) ρ∈Γ = begin
        (nf Γ a ↓⌜·⌝ nf Γ b) Elim/Var ρ
      ≡⟨ ↓⌜·⌝-/Var (nf Γ a) (nf Γ b) ⟩
        (nf Γ a Elim/Var ρ) ↓⌜·⌝ (nf Γ b Elim/Var ρ)
      ≡⟨ cong₂ (_↓⌜·⌝_) (nf-/Var a ρ∈Γ) (nf-/Var b ρ∈Γ) ⟩
        nf Δ (a · b /Var ρ)
      ∎
    nf-/Var (a ⊡ b) ρ∈Γ = cong₂ _⊡∙_ (sym (⌜⌝-/Var a)) (sym (⌜⌝-/Var b))

    nfKind-/Var : ∀ {m n Δ Γ} {ρ : Sub Fin m n} k → Δ ⊢/Var ρ ∈ Γ →
                  nfKind Γ k Kind′/Var ρ ≡ nfKind Δ (k Kind/Var ρ)
    nfKind-/Var (a ⋯ b) ρ∈Γ = cong₂ _⋯_ (nf-/Var a ρ∈Γ) (nf-/Var b ρ∈Γ)
    nfKind-/Var (Π j k) ρ∈Γ =
      cong₂ Π (nfKind-/Var j ρ∈Γ) (nfKind-/Var k (∈-↑′ j ρ∈Γ))

  -- Normalization of ascriptions commutes with renaming.

  nfAsc-/Var : ∀ {m n Δ Γ} {ρ : Sub Fin m n} a → Δ ⊢/Var ρ ∈ Γ →
               nfAsc Γ a ElimAsc/Var ρ ≡ nfAsc Δ (a TermAsc/Var ρ)
  nfAsc-/Var (kd k) ρ∈Γ = cong kd (nfKind-/Var k ρ∈Γ)
  nfAsc-/Var (tp a) ρ∈Γ = cong tp (nf-/Var a ρ∈Γ)

  -- Corollaries: normalization commutes with weakening.

  nf-weaken : ∀ {n} {Γ : Ctx n} a b →
              weakenElim (nf Γ b) ≡ nf (a ∷ Γ) (weaken b)
  nf-weaken a b = nf-/Var b (∈-wk _)

  nfKind-weaken : ∀ {n} {Γ : Ctx n} a k →
                  weakenKind′ (nfKind Γ k) ≡ nfKind (a ∷ Γ) (weakenKind k)
  nfKind-weaken a k = nfKind-/Var k (∈-wk _)

  nfAsc-weaken : ∀ {n} {Γ : Ctx n} a b →
                 weakenElimAsc (nfAsc Γ b) ≡ nfAsc (a ∷ Γ) (weakenTermAsc b)
  nfAsc-weaken a b = nfAsc-/Var b (∈-wk _)

open RenamingCommutesNorm

module _ where
  open Substitution hiding (sub; _↑; subst)
  open ≡-Reasoning
  open VecProps using (map-cong; map-∘)

  -- Normalization extended to single-variable substitutions

  nfSVSub : ∀ {m n} → Ctx n → SVSub m n → SVSub m n
  nfSVSub      Γ  (sub a) = sub (nf Γ (⌞ a ⌟))
  nfSVSub (_ ∷ Γ) (σ ↑)   = (nfSVSub Γ σ) ↑

  nf-Hit : ∀ {m n} Γ {σ : SVSub m n} {x a} → Hit σ x a →
           Hit (nfSVSub Γ σ) x (nf Γ ⌞ a ⌟)
  nf-Hit      Γ        here                  = here
  nf-Hit (a ∷ Γ) {σ ↑} (_↑ {x = x} {b} hitP) =
    subst (Hit (nfSVSub Γ σ ↑) (suc x))
          (trans (nf-weaken a ⌞ b ⌟) (cong (nf _) (sym (⌞⌟-/Var b))))
          (nf-Hit Γ hitP ↑)

  nf-Miss : ∀ {m n} Γ {σ : SVSub m n} {x y} → Miss σ x y → Miss (nfSVSub Γ σ) x y
  nf-Miss      Γ  over      = over
  nf-Miss (a ∷ Γ) under     = under
  nf-Miss (a ∷ Γ) (missP ↑) = (nf-Miss Γ missP) ↑

  -- Normalization commutes conversion from context to vector representation.

  nfCtx-toVec : ∀ {n} (Γ : TermCtx.Ctx n) →
                toVec (nfCtx Γ) ≡ Vec.map (nfAsc (nfCtx Γ)) (TermCtx.toVec Γ)
  nfCtx-toVec []      = refl
  nfCtx-toVec (a ∷ Γ) =
    cong₂ _∷_ (nfAsc-weaken (nfAsc (nfCtx Γ) a) a) (begin
        Vec.map weakenElimAsc (toVec (nfCtx Γ))
      ≡⟨ cong (Vec.map weakenElimAsc) (nfCtx-toVec Γ) ⟩
        Vec.map weakenElimAsc (Vec.map (nfAsc (nfCtx Γ)) (TermCtx.toVec Γ))
      ≡⟨ sym (map-∘ weakenElimAsc (nfAsc (nfCtx Γ)) (TermCtx.toVec Γ)) ⟩
        Vec.map (weakenElimAsc ∘ nfAsc (nfCtx Γ)) (TermCtx.toVec Γ)
      ≡⟨ map-cong (nfAsc-weaken (nfAsc (nfCtx Γ) a)) (TermCtx.toVec Γ) ⟩
        Vec.map (nfAsc (nfCtx (a ∷ Γ)) ∘ weakenTermAsc) (TermCtx.toVec Γ)
      ≡⟨ map-∘ (nfAsc (nfCtx (a ∷ Γ))) weakenTermAsc (TermCtx.toVec Γ) ⟩
        Vec.map (nfAsc (nfCtx (a ∷ Γ)))
                (Vec.map weakenTermAsc (TermCtx.toVec Γ))
      ∎)

  -- Normalization commutes with context lookup.

  nfCtx-lookup : ∀ {n} (Γ : TermCtx.Ctx n) x →
                 lookup (nfCtx Γ) x ≡ nfAsc (nfCtx Γ) (TermCtx.lookup Γ x)
  nfCtx-lookup Γ x = begin
      lookup (nfCtx Γ) x
    ≡⟨ cong (flip Vec.lookup x) (nfCtx-toVec Γ) ⟩
      Vec.lookup (Vec.map (nfAsc (nfCtx Γ)) (TermCtx.toVec Γ)) x
    ≡⟨ VecProps.lookup-map x _ (TermCtx.toVec Γ) ⟩
      nfAsc (nfCtx Γ) (TermCtx.lookup Γ x)
    ∎

  -- A corollary of the above (specialized for type variable lookup).

  nfCtx-lookup-kd : ∀ {n k} x (Γ : TermCtx.Ctx n) → TermCtx.lookup Γ x ≡ kd k →
                    lookup (nfCtx Γ) x ≡ kd (nfKind (nfCtx Γ) k)
  nfCtx-lookup-kd x Γ Γ[x]≡kd-k with TermCtx.lookup Γ x | nfCtx-lookup Γ x
  nfCtx-lookup-kd x Γ refl | kd k | nf-Γ[x]≡kd-nf-k = nf-Γ[x]≡kd-nf-k
  nfCtx-lookup-kd x Γ ()   | tp t | _