import Lean
import Std.Data.HashMap
import LeanCodePrompts.ConstDeps
import LeanCodePrompts.VerboseDelabs

/-!
# Premise data

Here we extract premise data from all definitions in the environment. This includes proofs in the environment as well as sub-proofs in proofs/definitions. The main technique for working with subproofs is the use of the custom *verbose* delaborators that rewrite the syntax tree to include the statements of the proof terms, in the syntax `proof =: prop`.

We are using premises is a broad sense, including:

- identifiers
- propositions that are proved by sub-terms (lemmas)
- terms that are arguments of functions (instantiations)

As theorems are equivalent to others where we trade `∀` with context terms, we associate groups. Further, we exclude statements derived in this way (i.e., by `intro`) from the list of lemmas.
-/

open Lean Meta Elab Parser PrettyPrinter

universe u v w u_1 u_2 u_3 u₁ u₂ u₃

open LeanAide.Meta
/-- All constants in the environment with value and type. -/
def constantNameValueTypes  : MetaM (Array (Name × Expr ×   Expr)) := do
  let env ← getEnv
  let decls := env.constants.map₁.toArray
  let allNames := decls.filterMap <|
    fun (name, dfn) => dfn.value? |>.map fun t => (name, t, dfn.type)
  let names ← allNames.filterM (fun (name, _) => isWhiteListed name)
  let names := names.filter <|
    fun (name, _, _)  ↦ !(excludePrefixes.any (fun pfx => pfx.isPrefixOf name)) && !(excludeSuffixes.any (fun pfx => pfx.isSuffixOf name))
  return names

set_option pp.unicode.fun true

/-- Syntax as json -/
instance : ToJson Syntax := ⟨fun (d: Syntax) ↦ d.reprint.get!⟩

/-- Subterms in a premise -/
structure TermData where
    context : Array Syntax
    value : Syntax
    size : Nat
    depth: Nat
deriving Repr, ToJson

/-- Increase depth of a subterm (for recursion) -/
def TermData.increaseDepth (d: Nat) : TermData → TermData :=
fun data ↦
    ⟨data.context, data.value, data.size, data.depth + d⟩

/-- Lemma data with proofs -/
structure PropProofData where
    context : Array Syntax
    prop : Syntax
    proof: Syntax
    propSize: Nat
    proofSize: Nat
    depth: Nat
deriving Repr, ToJson

/-- Increase depth for a lemma (for recursion) -/
def PropProofData.increaseDepth (d: Nat) : PropProofData → PropProofData :=
fun data ↦
    ⟨data.context, data.prop, data.proof, data.propSize, data.proofSize, data.depth + d⟩

/-- Full premise data for a proposition -/
structure PremiseData  where
 context : (Array Syntax) -- variables, types, binders
 name? :       Option Name  -- name
 defnName: Name -- name of definition from which it arose
 type :       Syntax  -- proposition
 typeGroup : Syntax  -- proposition group
 proof: Syntax  -- proof
 typeSize : Nat
 proofSize : Nat
 terms :       Array (TermData)  -- instantiations
 propProofs :       Array (PropProofData)  -- sub-proofs
 ids :       Array (Name ×  Nat)  -- proof identifiers used
 deriving Repr, ToJson

namespace PremiseData

def filterIds (pd: PremiseData)(p: Name → Bool) : PremiseData :=
    ⟨pd.context, pd.name?, pd.defnName,  pd.type, pd.typeGroup, pd.proof, pd.typeSize, pd.proofSize, pd.terms, pd.propProofs, pd.ids.filter (fun (n, _) => p n)⟩

def increaseDepth (d: Nat) : PremiseData → PremiseData :=
fun data ↦
    ⟨data.context, data.name?, data.defnName, data.type, data.typeGroup, data.proof, data.typeSize, data.proofSize, (data.terms.map (fun td => td.increaseDepth d)), (data.propProofs.map (fun p => p.increaseDepth d)),
        (data.ids.map (fun (n,  m) => (n,  m + d))) ⟩

end PremiseData

/-- Remove the added `=: prop` from syntax -/
partial def Lean.Syntax.purge: Syntax → Syntax := fun stx ↦
  match stx with
  | Syntax.node info k args =>
    match stx with
    | `(($pf:term =: $_:term)) =>
      pf.raw.purge
    | _ =>
      Syntax.node info k (args.map Syntax.purge)
  | s => s

def termKinds : MetaM <| SyntaxNodeKindSet :=  do
    let env ← getEnv
    let categories := (parserExtension.getState env).categories
    let termCat? := getCategory categories `term
    return termCat?.get!.kinds

def termKindList : MetaM <| List (SyntaxNodeKind × Unit) := do
    let s ← termKinds
    pure <| s.toList

partial def Lean.Syntax.size (stx: Syntax) : Nat :=
    match stx with
    | Syntax.ident _ _ _ _ => 1
    | Syntax.node _ _ args => args.foldl (fun acc x => acc + x.size) 0
    | _ => 1

/-- Compute recursively premise-data of sublemmas as well as the identifiers, instantiations and subproofs. These are used at the top level recursively.

The parameter `isArg` specifies whether the term is an argument of a function. This is used to determine whether to add the term to the list of instantiations.

The parameter `propHead?` specifies the head of the group of propositions, where groups are related by `intro`, i.e., moving from `∀` to context variables. This is used to determine whether to add the proposition to the list of lemmas.
-/
partial def Lean.Syntax.premiseDataAuxM (context : Array Syntax)(defnName: Name)(stx: Syntax)(propHead? : Option Syntax)(isArg: Bool)(maxDepth? : Option Nat := none) :
    MetaM (
        Array (TermData) ×
        Array (PropProofData) ×
        Array (Name × Nat) ×
        List PremiseData
        )  := do
    if maxDepth? = some 0 then
        pure (#[], #[], #[], [])
    else
    let tks ← termKindList
    let tks := tks.map (·.1)
    match ← namedArgument? stx with
    | some (arg, _) => -- named argument of a function, name ignored
        arg.premiseDataAuxM context defnName none  true (maxDepth?.map (· -1))
    | none =>
    -- the special `proof =: prop` syntax
    match ← proofWithProp? stx with
    | some (proof, prop) =>
        -- start a group if not in a group
        let newPropHead :=
            match propHead? with
            | some p => p
            | none => prop
        /- compute the data for the subproof;
        subproof not an instantiation, is part of a new/old group.
        -/
        let prev ←
            proof.premiseDataAuxM context defnName (some newPropHead) false (maxDepth?.map (· -1))
        let (ts, pfs, ids, ps) := prev
        let prop := prop.purge
        let proof := proof.purge
        let newPfs :=
            if propHead?.isSome then -- exclude lemma if in prior group
                pfs
            else
                let headPf : PropProofData :=
                    ⟨context, prop, proof, prop.size, proof.size, 0⟩
                pfs.map (fun s ↦ s.increaseDepth 1) |>.push headPf
        let head : PremiseData :=
            ⟨context, none, defnName, prop, newPropHead, proof, prop.size, proof.size, ts, pfs, ids⟩
        return (ts.map (fun t ↦ t.increaseDepth 1),
                newPfs,
                ids.map (fun (s, m) => (s, m + 1)),
                head :: ps)
    | none =>
    match ← lambdaStx? stx with -- term is a lambda
    | some (body, args) =>
        let prev ←  /- data for subterm; not an instantiation;
        inherits proposition group: if this is a proof, so would the previous term and hence we will have a group.  -/
            body.premiseDataAuxM (context ++ args) defnName propHead? false (maxDepth?.map (· -1))
        let (ts, pfs, ids, ps) := prev
        return (ts.map (fun s => (s.increaseDepth args.size)),
                pfs.map (fun s => (s.increaseDepth args.size)),
                ids.map (fun (s, m) => (s, m + args.size)),
                ps)
    | none =>
    match ← appStx? stx with
    | some (f, arg) =>
        let prev ←  f.premiseDataAuxM context defnName none false (maxDepth?.map (· -1))
        let (ts, pfs, ids, ps) := prev
        let prev ←  arg.premiseDataAuxM context defnName none true (maxDepth?.map (· -1))
        let (ts', pfs', ids', ps') := prev
        let ts'' :=
            if isArg then -- this is an instantiation
            let head : TermData :=
                ⟨context, stx.purge, stx.purge.size, 0⟩
            (ts ++ ts').map (fun s => s.increaseDepth 1) |>.push head
            else
            (ts ++ ts').map (fun s => s.increaseDepth 1)
        return (ts'',
                (pfs ++ pfs').map (fun s => s.increaseDepth 1),
                (ids ++ ids').map (fun (s, m) => (s, m + 1)),
                ps ++ ps')
    | none =>
        match stx with
        | Syntax.node _ k args =>
            let prevs ← args.mapM (
                premiseDataAuxM context defnName · none false (maxDepth?.map (· -1)))
            let mut ts: Array (TermData) := #[]
            let mut pfs: Array (PropProofData) := #[]
            let mut ids: Array (Name × Nat) := #[]
            let mut ps: List PremiseData := []
            for prev in prevs do
                let (ts', pfs', ids', ps') := prev
                ts := ts ++ ts'.map (fun s => s.increaseDepth 1)
                pfs := pfs ++ pfs'.map (fun s => s.increaseDepth 1)
                ids := ids ++ ids'.map (fun (s, m) => (s, m + 1))
                ps := ps ++ ps'
            let head : TermData :=
                ⟨context, stx.purge, stx.purge.size, 0⟩
            if isArg && tks.contains k then
                ts := ts.push (head)
            return (ts, pfs, ids, ps)
        | Syntax.ident _ _ name .. =>
            let contextVars := context.filterMap getVar
            if  !(contextVars.contains name) &&
                !(excludePrefixes.any (fun pfx => pfx.isPrefixOf name)) && !(excludeSuffixes.any (fun pfx => pfx.isSuffixOf name)) then
                pure (#[], #[], #[(name, 0)], [])
            else pure (#[], #[], #[], [])
        | _ => pure (#[], #[], #[], [])

def Lean.Syntax.premiseDataM (context : Array Syntax)
    (proof prop: Syntax)(includeHead: Bool)(name? : Option Name)(defnName : Name)(maxDepth? : Option Nat := none) :
    MetaM (List PremiseData) := do
    let (ts, pfs, ids, ps) ← proof.premiseDataAuxM context defnName (some prop) false maxDepth?
    if includeHead then
        let head : PremiseData := ⟨context, name?, defnName, prop.purge, prop.purge, proof.purge, prop.purge.size, proof.purge.size, ts, pfs, ids⟩
        return head :: ps
    else return ps

structure DefData where
    name : Name
    type : Syntax
    value : Syntax
    isProp : Bool
    typeDepth : Nat
    valueDepth : Nat
    premises : List PremiseData -- empty if depth exceeds bound
    deriving Inhabited, ToJson

def DefData.getM? (name: Name)(term type: Expr) : MetaM (Option  DefData) := do
    if term.approxDepth > (← getDelabBound) || type.approxDepth > (← getDelabBound) then return none
    else
    let (stx, _) ←  delabCore term {} (delabVerbose)
    let (tstx, _) ←  delabCore type {} (delabVerbose)
    let isProp ← Meta.isProof term
    let premises ←
        Lean.Syntax.premiseDataM #[] stx tstx isProp (some name) name
    let typeDepth := type.approxDepth
    let valueDepth := term.approxDepth
    return some {name := name, type := tstx.raw.purge, value := stx.raw.purge, isProp := isProp, typeDepth := typeDepth.toNat, valueDepth := valueDepth.toNat, premises := premises}

structure IdentData where
    context : Array Syntax
    type : Syntax
    ids : List Name
    deriving Inhabited, ToJson

def IdentData.filter (d: IdentData)(p : Name → Bool) : IdentData :=
    {context:= d.context, type := d.type, ids := d.ids.filter p}

def DefData.identData (d: DefData) : List IdentData :=
    d.premises.map (fun p =>
        {context:= p.context, type := p.type, ids := p.ids.map (·.1) |>.toList.eraseDups})

def nameSize : MetaM <| Nat × Nat := do
    let cs ← constantNameValueTypes
    let cs' ← cs.filterM <| fun (_, term, _) =>
        Meta.isProof term
    return (cs.size, cs'.size)

-- #check Json.pretty

-- #eval nameSize

def nameSample (n: Nat) : MetaM (Array Name) := do
    let cs ← constantNameValueTypes
    let mut out : Array Name := #[]
    let mut count := 0
    for (name, _, _) in cs do
        if count % n = 0 then
            out := out.push name
        count := count + 1
    return out

-- #eval nameSample 100

def batchDefns (start batch : Nat) : MetaM (Array Json) := do
    let cs ← constantNameValueTypes
    let mut out : Array Json := #[]
    let mut count := 0
    for (name, term, type) in cs do
        if count >= start && count < start + batch then
            let defData? ← DefData.getM? name term type
            match defData? with
            | none => pure ()
            | some defData => out := out.push <| toJson defData
        count := count + 1
    return out

def writeBatchDefnsM (start batch : Nat) : MetaM Nat  := do
    let cs ← constantNameValueTypes
    let names := cs.map (·.1)
    IO.println <| s!"{start}; {batch} from {cs.size}"
    let mut count := 0
    let defnsFile := System.mkFilePath ["rawdata", s!"defns.jsonl"]
    let h ← IO.FS.Handle.mk defnsFile IO.FS.Mode.append Bool.false
    let idsFile := System.mkFilePath ["rawdata", s!"idents.jsonl"]
    let h' ← IO.FS.Handle.mk idsFile IO.FS.Mode.append Bool.false
    for (name, term, type) in cs do
        if count >= start && count < start + batch then
            IO.println <| s!"{count} {name}"
            let defData? ← DefData.getM? name term type
            match defData? with
            | none =>
                IO.println <| s!"{count} {name} omitted"
                pure ()
            | some defData =>
                IO.println <| s!"{count} {name} written"
                let idData := defData.identData
                let idData :=
                    idData.map (fun d ↦ d.filter
                        (names.contains · ))
                let l := (toJson defData).pretty 10000000
                if l.length < 9000000 then
                    h.putStrLn  l
                for d in idData do
                    let l := (toJson d).pretty 10000000
                    if l.length < 9000000 then
                    h'.putStrLn l
        count := count + 1
    return start + batch

def writePremisesM  : MetaM Nat  := do
    let cs ← constantNameValueTypes
    let names := cs.map (·.1)
    let namesFile := System.mkFilePath ["rawdata", s!"names.txt"]
    IO.FS.writeFile namesFile <|
        names.map toString |>.foldl (fun a b ↦ a  ++ b ++ "\n") ""
    let defIdsFile := System.mkFilePath ["rawdata", s!"def_ids.jsonl"]
    IO.FS.writeFile defIdsFile ""
    let hId ← IO.FS.Handle.mk defIdsFile IO.FS.Mode.append Bool.false
    IO.println <| s!"Processing {cs.size} definitions"
    let mut count := 0
    let mut premisesDone : Array <| (Array Syntax) × Syntax := #[]
    let premisesFile := System.mkFilePath ["rawdata", s!"premises.jsonl"]
    IO.FS.writeFile premisesFile ""
    let h ← IO.FS.Handle.mk premisesFile IO.FS.Mode.append Bool.false
    let trainPremisesFile := System.mkFilePath ["rawdata", s!"train_premises.jsonl"]
    IO.FS.writeFile trainPremisesFile ""
    let hTrain ← IO.FS.Handle.mk trainPremisesFile IO.FS.Mode.append Bool.false
    let testPremisesFile := System.mkFilePath ["rawdata", s!"test_premises.jsonl"]
    let hTest ← IO.FS.Handle.mk testPremisesFile IO.FS.Mode.append Bool.false
    let validPremisesFile := System.mkFilePath ["rawdata", s!"valid_premises.jsonl"]
    IO.FS.writeFile validPremisesFile ""
    let hValid ← IO.FS.Handle.mk validPremisesFile IO.FS.Mode.append Bool.false
    let mut testNum := 0
    let mut validNum := 0
    let mut trainNum := 0
    for (name, term, type) in cs do
        IO.println <| s!"{count} {name} (of {cs.size})"
        let defData? ← DefData.getM? name term type
        match defData? with
        | none =>
            IO.println <| s!"{count} {name} omitted"
            pure ()
        | some defData =>
            IO.println <| s!"{count} {name} written"
            let gh ←  match ← IO.rand 0 9 with
                | 0 => do
                    testNum := testNum + 1
                    IO.println s!"writing to test; now :{testNum}"
                    pure hTest
                | 1 =>
                    validNum := validNum + 1
                    IO.println s!"writing to valid; now :{validNum}"
                    pure hValid
                | _ =>
                    trainNum := trainNum + 1
                    IO.println s!"writing to train; now :{trainNum}"
                    pure hTrain
            let premises := defData.premises
            for premise in premises do
                let premiseHead := (premise.context, premise.type)
                if premisesDone.contains premiseHead then
                    IO.print "premise seen previously; "
                    pure ()
                else
                    premisesDone := premisesDone.push premiseHead
                    IO.print "premise new; "
                    let premise := premise.filterIds (names.contains · )
                    let l := (toJson premise).pretty 10000000
                    if l.length < 9000000 then
                        h.putStrLn  l
                        gh.putStrLn l
            IO.println ""
            let idData := defData.identData.bind (fun d ↦ d.ids)
            let idData := idData.filter (names.contains · ) |>.eraseDups
            let idData := Json.mkObj [
                ("name", toJson defData.name),
                ("ids", toJson idData),
                ("is_prop", toJson defData.isProp),
                ("type", toJson defData.type.purge)
            ]
            let l := idData.pretty 10000000
            if l.length < 9000000 then
                hId.putStrLn l
        count := count + 1
    return count

def writeBatchDefnsCore (start batch : Nat) : CoreM Nat :=
    (writeBatchDefnsM start batch).run' {}

def writePremisesCore : CoreM Nat :=
    writePremisesM.run' {}

-- #eval batchDefns 0 5


import category_theory.morphism_property
import for_mathlib.category_theory.limits.comm_sq_misc

open category_theory.limits

universes w v u

namespace category_theory

variables {C : Type u} [category.{v} C] {D : Type*} [category D]

namespace morphism_property

/-instance : has_subset (morphism_property C) :=
⟨λ P₁ P₂, ∀ ⦃X Y : C⦄ (f : X ⟶ Y) (hf : P₁ f), P₂ f⟩
instance : has_inter (morphism_property C) :=
⟨λ P₁ P₂ X Y f, P₁ f ∧ P₂ f⟩

@[simp] def op (P : morphism_property C) : morphism_property Cᵒᵖ := λ X Y f, P f.unop
@[simp] def unop (P : morphism_property Cᵒᵖ) : morphism_property C := λ X Y f, P f.op
@[simp] lemma unop_op (P : morphism_property C) : P.op.unop = P := rfl
@[simp] lemma op_unop (P : morphism_property Cᵒᵖ) : P.unop.op = P := rfl

/-- A morphism property is `stable_under_cobase_change` if the cobase change of such a morphism
still falls in the class. -/
def stable_under_cobase_change (P : morphism_property C) : Prop :=
∀ ⦃A A' B B' : C⦄ ⦃f : A ⟶ A'⦄ ⦃g : A ⟶ B⦄ ⦃f' : B ⟶ B'⦄ ⦃g' : A' ⟶ B'⦄
  (sq : is_pushout g f f' g') (hf : P f), P f'

lemma stable_under_cobase_change.mk {P : morphism_property C} [has_pushouts C]
  (hP₁ : respects_iso P)
  (hP₂ : ∀ (A B A' : C) (f : A ⟶ A') (g : A ⟶ B) (hf : P f), P (pushout.inr : B ⟶ pushout f g)) :
  stable_under_cobase_change P := λ A A' B B' f g f' g' sq hf,
begin
  let e := sq.flip.iso_pushout,
  rw [← hP₁.cancel_right_is_iso _ e.hom, sq.flip.inr_iso_pushout_hom],
  exact hP₂ _ _ _ f g hf,
end

lemma stable_under_cobase_change.respects_iso {P : morphism_property C}
  (hP : stable_under_cobase_change P) : respects_iso P :=
begin
  apply respects_iso.of_respects_arrow_iso,
  intros f g e,
  exact hP (is_pushout.of_horiz_is_iso (comm_sq.mk e.hom.w)),
end

lemma stable_under_cobase_change.inl {P : morphism_property C}
  (hP : stable_under_cobase_change P) {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [has_pushout f g]
  (H : P g) : P (pushout.inl : A' ⟶ pushout f g) :=
hP (is_pushout.of_has_pushout f g) H

lemma stable_under_cobase_change.inr {P : morphism_property C}
  (hP : stable_under_cobase_change P) {A B A' : C} (f : A ⟶ A') (g : A ⟶ B) [has_pushout f g]
  (H : P f) : P (pushout.inr : B ⟶ pushout f g) :=
hP (is_pushout.of_has_pushout f g).flip H

lemma stable_under_cobase_change.op {P : morphism_property C}
  (hP : stable_under_cobase_change P) : stable_under_base_change P.op :=
λ X Y Y' S f g f' g' sq hg, hP sq.unop hg

lemma stable_under_cobase_change.unop {P : morphism_property Cᵒᵖ}
  (hP : stable_under_cobase_change P) : stable_under_base_change P.unop :=
λ X Y Y' S f g f' g' sq hg, hP sq.op hg

lemma stable_under_base_change.op {P : morphism_property C}
  (hP : stable_under_base_change P) : stable_under_cobase_change P.op :=
λ A A' B B' f g f' g' sq hf, hP sq.unop hf

lemma stable_under_base_change.unop {P : morphism_property Cᵒᵖ}
  (hP : stable_under_base_change P) : stable_under_cobase_change P.unop :=
λ A A' B B' f g f' g' sq hf, hP sq.op hf

def inverse_image (P : morphism_property D) (F : C ⥤ D) : morphism_property C :=
λ X Y f, P (F.map f)

variable (C)
def isomorphisms : morphism_property C := λ X Y f, is_iso f
def monomorphisms : morphism_property C := λ X Y f, mono f
def epimorphisms : morphism_property C := λ X Y f, epi f

variable {C}

section
variables {X Y : C} (f : X ⟶ Y)
@[simp] lemma isomorphisms.iff : (isomorphisms C) f ↔ is_iso f := by refl
@[simp] lemma monomorphisms.iff : (monomorphisms C) f ↔ mono f := by refl
@[simp] lemma epimorphisms.iff : (epimorphisms C) f ↔ epi f := by refl

lemma isomorphisms.infer_property [hf : is_iso f] : (isomorphisms C) f := hf
lemma monomorphisms.infer_property [hf : mono f] : (monomorphisms C) f := hf
lemma epimorphisms.infer_property [hf : epi f] : (epimorphisms C) f := hf

end-/

variable (C)
@[simp]
lemma op_epimorphisms : (epimorphisms C).op = monomorphisms Cᵒᵖ :=
begin
  ext X Y f,
  simp only [morphism_property.op, epimorphisms.iff, monomorphisms.iff],
  split,
  { introI,
    exact category_theory.op_mono_of_epi f.unop, },
  { introI,
    exact category_theory.unop_epi_of_mono f, },
end

@[simp]
lemma op_monomorphisms : (monomorphisms C).op = epimorphisms Cᵒᵖ :=
begin
  ext X Y f,
  simp only [morphism_property.op, epimorphisms.iff, monomorphisms.iff],
  split,
  { introI,
    exact category_theory.op_epi_of_mono f.unop, },
  { introI,
    exact category_theory.unop_mono_of_epi f, },
end

@[simp]
lemma unop_epimorphisms : (epimorphisms Cᵒᵖ).unop = monomorphisms C :=
by rw [← (monomorphisms C).unop_op, op_monomorphisms]

@[simp]
lemma unop_monomorphisms : (monomorphisms Cᵒᵖ).unop = epimorphisms C :=
by rw [← (epimorphisms C).unop_op, op_epimorphisms]

namespace stable_under_composition

variable {C}
/-
lemma op {P : morphism_property C} (h : P.stable_under_composition) :
  P.op.stable_under_composition :=
λ X Y Z f g hf hg, h g.unop f.unop hg hf

lemma unop {P : morphism_property Cᵒᵖ} (h : P.stable_under_composition) :
  P.unop.stable_under_composition :=
λ X Y Z f g hf hg, h g.op f.op hg hf

lemma inverse_image {P : morphism_property D} (h : P.stable_under_composition)
  (F : C ⥤ D) : (P.inverse_image F).stable_under_composition :=
λ X Y Z f g hf hg, by simpa only [← F.map_comp] using h (F.map f) (F.map g) hf hg-/

variable (C)

/-lemma for_isomorphisms : (isomorphisms C).stable_under_composition :=
λ X Y Z f g hf hg, begin
  dsimp [isomorphisms] at hf hg ⊢,
  haveI := hf,
  haveI := hg,
  apply_instance,
end

lemma for_monomorphisms : (monomorphisms C).stable_under_composition :=
λ X Y Z f g hf hg, begin
  dsimp [monomorphisms] at hf hg ⊢,
  haveI := hf,
  haveI := hg,
  apply mono_comp,
end

lemma for_epimorphisms : (epimorphisms C).stable_under_composition :=
λ X Y Z f g hf hg, begin
  dsimp [epimorphisms] at hf hg ⊢,
  haveI := hf,
  haveI := hg,
  apply epi_comp,
end-/

end stable_under_composition

namespace respects_iso

/-lemma op {P : morphism_property C} (h : P.respects_iso) :
  P.op.respects_iso :=
⟨λ X Y Z e f, h.2 e.unop f.unop, λ X Y Z e f, h.1 e.unop f.unop⟩

lemma unop {P : morphism_property Cᵒᵖ} (h : P.respects_iso) :
  P.unop.respects_iso :=
⟨λ X Y Z e f, h.2 e.op f.op, λ X Y Z e f, h.1 e.op f.op⟩

lemma for_monomorphisms : (monomorphisms C).respects_iso :=
by { split; { intros X Y Z e f, simp only [monomorphisms.iff], introI, apply mono_comp, }, }

lemma for_epimorphisms : (epimorphisms C).respects_iso :=
by { split; { intros X Y Z e f, simp only [epimorphisms.iff], introI, apply epi_comp, }, }

lemma for_isomorphisms : (isomorphisms C).respects_iso :=
by { split; { intros X Y Z e f, simp only [isomorphisms.iff], introI, apply_instance, }, }
-/
end respects_iso

variable {C}

lemma respects_iso.of_stable_under_composition_and_contains_iso
  {P : morphism_property C} (h₁ : P.stable_under_composition) (h₂ : isomorphisms C ⊆ P) :
  respects_iso P :=
begin
  split,
  { intros X Y Z e f hf,
    exact h₁ e.hom f (h₂ e.hom (isomorphisms.infer_property _)) hf, },
  { intros X Y Z e f hf,
    exact h₁ f e.hom hf (h₂ e.hom (isomorphisms.infer_property _)), },
end

def stable_under_products (P : morphism_property C) : Prop :=
P.respects_iso ∧
∀ (I : Type w) (X : I → C) (Y : I → C) [hX : has_product X] [hY : has_product Y]
(f : Π (i : I), X i ⟶ Y i) (hf : ∀ (i : I), P (f i)), P (@limits.pi.map _ _ _ X Y hX hY f)

namespace stable_under_products

lemma property {P : morphism_property C} (h : morphism_property.stable_under_products.{w} P)
  {I : Type w} (X : I → C) (Y : I → C) [hX : has_product X] [hY : has_product Y]
(f : Π (i : I), X i ⟶ Y i) (hf : ∀ (i : I), P (f i)) :
  P (@limits.pi.map _ _ _ X Y hX hY f) :=
h.2 I X Y f hf

lemma binary {P : morphism_property C} (h : morphism_property.stable_under_products.{0} P)
  {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (h₁ : P f₁) (f₂ : X₂ ⟶ Y₂) (h₂ : P f₂)
  [hX : has_binary_product X₁ X₂] [hY : has_binary_product Y₁ Y₂] :
  P (limits.prod.map f₁ f₂) :=
begin
  haveI : has_product (pair_function X₁ X₂) := hX,
  haveI : has_product (pair_function Y₁ Y₂) := hY,
  convert h.property (pair_function X₁ X₂) (pair_function Y₁ Y₂)
    (λ i, by { cases i, exacts [f₁, f₂], })
    (λ i, by { cases i, exacts [h₁, h₂], }),
  ext,
  { erw [limits.prod.map_fst, lim_map_π], refl, },
  { erw [limits.prod.map_snd, lim_map_π], refl, },
end

end stable_under_products

def stable_under_coproducts (P : morphism_property C) : Prop :=
P.respects_iso ∧
∀ (I : Type w) (X : I → C) (Y : I → C) [hX : has_coproduct X] [hY : has_coproduct Y]
(f : Π (i : I), X i ⟶ Y i) (hf : ∀ (i : I), P (f i)), P (@limits.sigma.map _ _ _ X Y hX hY f)

namespace stable_under_coproducts

lemma property {P : morphism_property C} (h : morphism_property.stable_under_coproducts.{w} P)
  (I : Type w) (X : I → C) (Y : I → C) [hX : has_coproduct X] [hY : has_coproduct Y]
  (f : Π (i : I), X i ⟶ Y i) (hf : ∀ (i : I), P (f i)) :
  P (@limits.sigma.map _ _ _ X Y hX hY f) :=
h.2 I X Y f hf

lemma binary {P : morphism_property C} (h : morphism_property.stable_under_coproducts.{0} P)
  {X₁ X₂ Y₁ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (h₁ : P f₁) (f₂ : X₂ ⟶ Y₂) (h₂ : P f₂)
  [hX : has_binary_coproduct X₁ X₂] [hY : has_binary_coproduct Y₁ Y₂] :
  P (coprod.map f₁ f₂) :=
begin
  haveI : has_coproduct (pair_function X₁ X₂) := hX,
  haveI : has_coproduct (pair_function Y₁ Y₂) := hY,
  convert h.property _ (pair_function X₁ X₂) (pair_function Y₁ Y₂)
    (λ i, by { cases i, exacts [f₁, f₂], })
    (λ i, by { cases i, exacts [h₁, h₂], }),
  tidy,
end

end stable_under_coproducts
/-
lemma is_inverted_by.of_comp {C₁ C₂ C₃ : Type*} [category C₁] [category C₂] [category C₃]
  (W : morphism_property C₁) (F : C₁ ⥤ C₂) (hF : W.is_inverted_by F) (G : C₂ ⥤ C₃) :
  W.is_inverted_by (F ⋙ G) :=
λ X Y f hf, by { haveI := hF f hf, dsimp, apply_instance, }-/

/- better as .of_iso rather that iff_of_iso -/

/-
lemma is_inverted_by.iff_of_iso (W : morphism_property C) {F₁ F₂ : C ⥤ D} (e : F₁ ≅ F₂) :
  W.is_inverted_by F₁ ↔ W.is_inverted_by F₂ :=
begin
  suffices : ∀ (X Y : C) (f : X ⟶ Y), is_iso (F₁.map f) ↔ is_iso (F₂.map f),
  { split,
    exact λ h X Y f hf, by { rw ← this, exact h f hf, },
    exact λ h X Y f hf, by { rw this, exact h f hf, }, },
  intros X Y f,
  apply (respects_iso.isomorphisms D).arrow_mk_iso_iff,
  exact arrow.iso_mk (e.app X) (e.app Y) (by simp),
end-/

end morphism_property

end category_theory


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.opposites
import category_theory.hom_functor

/-!
# The Yoneda embedding

The Yoneda embedding as a functor `yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁)`,
along with an instance that it is `fully_faithful`.

Also the Yoneda lemma, `yoneda_lemma : (yoneda_pairing C) ≅ (yoneda_evaluation C)`.
-/

namespace category_theory
open opposite

universes v₁ u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

variables {C : Type u₁} [𝒞 : category.{v₁} C]
include 𝒞

@[simps] def yoneda : C ⥤ (Cᵒᵖ ⥤ Type v₁) :=
{ obj := λ X,
  { obj := λ Y, unop Y ⟶ X,
    map := λ Y Y' f g, f.unop ≫ g,
    map_comp' := λ _ _ _ f g, begin ext, dsimp, erw [category.assoc] end,
    map_id' := λ Y, begin ext, dsimp, erw [category.id_comp] end },
  map := λ X X' f, {

  app := λ Y g, g ≫ f } }

@[simps] def coyoneda : Cᵒᵖ ⥤ (C ⥤ Type v₁) :=
{ obj := λ A : Cᵒᵖ,
  { obj := λ R, unop A ⟶ R,                 --- Hom(X,Y)
           map := λ R R': C, λ f : R ⟶ R',
              λ ζ : unop A ⟶ R, ζ ≫ f,        ---   Hom(X,Y) → Hom(X,Y')
           map_comp' := λ R R' R'' : C,λ f : R ⟶ R',λ g : R' ⟶ R'',
                begin
                  apply funext,
                  intro x,
                  rw ← category.assoc (C) (x) f g,
                  exact rfl,
                end,
    map_id' := λ R : C,
          begin
            apply funext,
            intro x,
            rw category.comp_id,
            exact rfl,
          end
    },
map := λ A B : Cᵒᵖ, λ f :  A ⟶ B, {
  app := λ R g, f.unop ≫ g }
}

namespace yoneda

lemma obj_map_id {X Y : C} (f : op X ⟶ op Y) :
  ((@yoneda C _).obj X).map f (𝟙 X) = ((@yoneda C _).map f.unop).app (op Y) (𝟙 Y) :=
by obviously

@[simp] lemma naturality {X Y : C} (α : yoneda.obj X ⟶ yoneda.obj Y)
  {Z Z' : C} (f : Z ⟶ Z') (h : Z' ⟶ X) : f ≫ α.app (op Z') h = α.app (op Z) (f ≫ h) :=
begin erw [functor_to_types.naturality], refl end

instance yoneda_full : full (@yoneda C _) :=
{ preimage := λ X Y f, (f.app (op X)) (𝟙 X) }
instance yoneda_faithful : faithful (@yoneda C _) :=
{ injectivity' := λ X Y f g p,
  begin
    injection p with h,
    convert (congr_fun (congr_fun h (op X)) (𝟙 X)); dsimp; simp,
  end }

/-- Extensionality via Yoneda. The typical usage would be
```
-- Goal is `X ≅ Y`
apply yoneda.ext,
-- Goals are now functions `(Z ⟶ X) → (Z ⟶ Y)`, `(Z ⟶ Y) → (Z ⟶ X)`, and the fact that these
functions are inverses and natural in `Z`.
```
-/
def ext (X Y : C)
  (p : Π {Z : C}, (Z ⟶ X) → (Z ⟶ Y)) (q : Π {Z : C}, (Z ⟶ Y) → (Z ⟶ X))
  (h₁ : Π {Z : C} (f : Z ⟶ X), q (p f) = f) (h₂ : Π {Z : C} (f : Z ⟶ Y), p (q f) = f)
  (n : Π {Z Z' : C} (f : Z' ⟶ Z) (g : Z ⟶ X), p (f ≫ g) = f ≫ p g) : X ≅ Y :=
@preimage_iso _ _ _ _ yoneda _ _ _ _
  (nat_iso.of_components (λ Z, { hom := p, inv := q, }) (by tidy))

def is_iso {X Y : C} (f : X ⟶ Y) [is_iso (yoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful yoneda f

end yoneda

namespace coyoneda

@[simp] lemma naturality {X Y : Cᵒᵖ} (α : coyoneda.obj X ⟶ coyoneda.obj Y)
  {Z Z' : C} (f : Z' ⟶ Z) (h : unop X ⟶ Z') : (α.app Z' h) ≫ f = α.app Z (h ≫ f) :=
begin erw [functor_to_types.naturality], refl end

instance coyoneda_full : full (@coyoneda C _) :=
{ preimage := λ X Y f, ((f.app (unop X)) (𝟙 _)).op }
instance coyoneda_faithful : faithful (@coyoneda C _) :=
{ injectivity' := λ X Y f g p,
  begin
    injection p with h,
    have t := (congr_fun (congr_fun h (unop X)) (𝟙 _)),
    simpa using congr_arg has_hom.hom.op t,
  end }

def is_iso {X Y : Cᵒᵖ} (f : X ⟶ Y) [is_iso (coyoneda.map f)] : is_iso f :=
is_iso_of_fully_faithful coyoneda f

end coyoneda

class representable (F : Cᵒᵖ ⥤ Type v₁) :=
(X : C)
(w : yoneda.obj X ≅ F)

end category_theory

namespace category_theory
-- For the rest of the file, we are using product categories,
-- so need to restrict to the case morphisms are in 'Type', not 'Sort'.

universes v₁ u₁ u₂ -- declare the `v`'s first; see `category_theory.category` for an explanation

open opposite

variables (C : Type u₁) [𝒞 : category.{v₁} C]
include 𝒞

-- We need to help typeclass inference with some awkward universe levels here.
instance prod_category_instance_1 : category ((Cᵒᵖ ⥤ Type v₁) × Cᵒᵖ) :=
category_theory.prod.{(max u₁ v₁) v₁} (Cᵒᵖ ⥤ Type v₁) Cᵒᵖ

instance prod_category_instance_2 : category (Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) :=
category_theory.prod.{v₁ (max u₁ v₁)} Cᵒᵖ (Cᵒᵖ ⥤ Type v₁)

open yoneda

def yoneda_evaluation : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
evaluation_uncurried Cᵒᵖ (Type v₁) ⋙ ulift_functor.{u₁}

@[simp] lemma yoneda_evaluation_map_down
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (x : (yoneda_evaluation C).obj P) :
  ((yoneda_evaluation C).map α x).down = α.2.app Q.1 (P.2.map α.1 x.down) := rfl

def yoneda_pairing : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁) ⥤ Type (max u₁ v₁) :=
functor.prod yoneda.op (𝟭 (Cᵒᵖ ⥤ Type v₁)) ⋙ functor.hom (Cᵒᵖ ⥤ Type v₁)

@[simp] lemma yoneda_pairing_map
  (P Q : Cᵒᵖ × (Cᵒᵖ ⥤ Type v₁)) (α : P ⟶ Q) (β : (yoneda_pairing C).obj P) :
  (yoneda_pairing C).map α β = yoneda.map α.1.unop ≫ β ≫ α.2 := rfl

def yoneda_lemma : yoneda_pairing C ≅ yoneda_evaluation C :=
{ hom :=
  { app := λ F x, ulift.up ((x.app F.1) (𝟙 (unop F.1))),
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      erw [category.id_comp,
           ←functor_to_types.naturality,
           obj_map_id,
           functor_to_types.naturality,
           functor_to_types.map_id]
    end },
  inv :=
  { app := λ F x,
    { app := λ X a, (F.2.map a.op) x.down,
      naturality' :=
      begin
        intros X Y f, ext, dsimp,
        rw [functor_to_types.map_comp]
      end },
    naturality' :=
    begin
      intros X Y f, ext, dsimp,
      rw [←functor_to_types.naturality, functor_to_types.map_comp]
    end },
  hom_inv_id' :=
  begin
    ext, dsimp,
    erw [←functor_to_types.naturality,
         obj_map_id,
         functor_to_types.naturality,
         functor_to_types.map_id],
    refl,
  end,
  inv_hom_id' :=
  begin
    ext, dsimp,
    rw [functor_to_types.map_id]
  end }.

variables {C}

@[simp] def yoneda_sections (X : C) (F : Cᵒᵖ ⥤ Type v₁) :
  (yoneda.obj X ⟶ F) ≅ ulift.{u₁} (F.obj (op X)) :=
(yoneda_lemma C).app (op X, F)

omit 𝒞
@[simp] def yoneda_sections_small {C : Type u₁} [small_category C] (X : C) (F : Cᵒᵖ ⥤ Type u₁) :
  (yoneda.obj X ⟶ F) ≅ F.obj (op X) :=
yoneda_sections X F ≪≫ ulift_trivial _

end category_theory


import Utils

namespace Dec3

universe u

def Common {α : Type u} (e : α) (a : List α) (b : List α) := e ∈ a ∧ e ∈ b

example : Common 1 [2, 1] [1, 3] :=
  by
    simp [Common]

-- inductive Unique (α : Type u) where

-- A rucksack has a designated element `e`. To add something to the rucksack
-- you have to show that this element is not equal to the designated element
inductive Rucksack {α : Type u} : (e : α) -> Type u where
| nil : Rucksack e
| cons : (x : α × α) -> (x.fst ≠ e ∧ x.snd ≠ e) -> Rucksack e -> Rucksack e

def Rucksack.toList {α : Type u} {e : α} (rs : Rucksack e) : List α × List α :=
  match rs with
  | Rucksack.nil => ([e], [e])
  | Rucksack.cons (x, y) _ rs' => let (l, r) := rs'.toList
                                  (x :: l, y :: r)

/-- if α is decidable, then we can automatically syntehsize the proof
we need to construct the element of the rucksack -/
def Rucksack.consDec [DecidableEq α] {e : α}
    (rs : Rucksack e) (new : α × α) : Option (Rucksack e)
  :=
    match (decEq new.fst e), (decEq new.snd e) with
    | isFalse hl, isFalse hr => Rucksack.cons new (And.intro hl hr) rs
    | _, _ => none

inductive EvenList (α : Type u) where
| even_nil : EvenList α
| even_cons (x y : α) (tl : EvenList α) : EvenList α
deriving Repr

def EvenList.length {α : Type u} (l : EvenList α) : Nat :=
  match l with
  | EvenList.even_nil => 0
  | EvenList.even_cons _ _ tl => 2 + tl.length

def EvenList.toList {α : Type u} (l : EvenList α) : List α :=
  match l with
  | EvenList.even_nil => []
  | EvenList.even_cons x y tl => x :: y :: tl.toList

def EvenList.split {α : Type u} (l : EvenList α) : List α × List α :=
  h (l.length / 2) l
where h len l :=
  match l with
  | EvenList.even_nil => ([], [])
  | EvenList.even_cons x y tl =>
    let (ll, lr) := h len tl
    if lr.length >= len then
      (x :: y :: ll, lr)
    else if lr.length + 1 == len then
      (x :: ll, y :: lr)
    else
      (ll, x :: y :: lr)

def EvenList.mk {α : Type u} (l : List α) : Option (EvenList α) :=
  match l with
  | x :: y :: tl => EvenList.even_cons x y <$> (EvenList.mk tl)
  | [] => some EvenList.even_nil
  | _ => none

def findCommon [BEq α] (l₁ : List α) (l₂ : List α) : Option α :=
  match l₁ with
  | [] => none
  | x :: tl => match l₂.find? (· == x) with
               | some e => e
               | none => findCommon tl l₂

def test : List String := [
    "vJrwpWtwJgWrhcsFMMfFFhFp",
    "jqHRNqRjqzjGDLGLrsFMfFZSrLrFZsSL",
    "PmmdzqPrVvPwwTWBwg",
    "wMqvLMZHhHMvwLHjbvcjnnSBnvTQFn",
    "ttgJtRGJQctTZtZT",
    "CrZsJsPPZsGzwwsLwLmpwMDw"
  ]

def Rucksack.mk [BEq α] [DecidableEq α] (l₁ l₂ : List α) (e : α) : Option (Rucksack e) := do
  match l₁, l₂ with
  | [], [] => some Rucksack.nil
  | x :: l₁' , y :: l₂' =>
    let rs <- Rucksack.mk l₁' l₂' e
    match rs.consDec (x, y) with
    | some x => x
    | none => rs
  | _, _ => none

def Rucksack.fromStr (input : String) : Option ((e : Char) × Rucksack e) := do
  let el <- EvenList.mk input.data
  let (l₁, l₂) := el.split
  let dist <- findCommon l₁ l₂
  let rs <- Rucksack.mk l₁ l₂ dist
  pure ⟨dist, rs⟩

def Char.priority (e : Char) : Nat :=
  if e.isLower then
    e.toNat - 96
  else
    e.toNat - 38

def Rucksack.priority {e : Char} (_ : Rucksack e) : Nat := Char.priority e

def findBadgeHelp [BEq α] (l₁ l₂ l₃ : List α) : Option α :=
  match l₁ with
  | [] => none
  | x :: tl => match l₂.find? (· == x), l₃.find? (· == x) with
               | some _, some _ => some x
               | _, _ => findBadgeHelp tl l₂ l₃

def Rucksack.findBadge [BEq α] {e₁ e₂ e₃ : α}
    (rs₁ : Rucksack e₁)
    (rs₂ : Rucksack e₂)
    (rs₃ : Rucksack e₃)
    : Option α :=
  let (ll₁, lr₁) := rs₁.toList
  let (ll₂, lr₂) := rs₂.toList
  let (ll₃, lr₃) := rs₃.toList
  findBadgeHelp (ll₁ ++ lr₁) (ll₂ ++ lr₂) (ll₃ ++ lr₃)

def Rucksack.findBadgeList [BEq α] : List ((e : α) × Rucksack e) -> Option α
  | [rs₁, rs₂, rs₃] => Rucksack.findBadge rs₁.snd rs₂.snd rs₃.snd
  | _ => none

def parse : IO (List String) := do
  let text <- IO.FS.readFile "data/dec3.txt"
  let lines := String.split text (· = '\n')
  let lines' := List.filter (· ≠ "") lines
  pure lines'

def List.windows (n : Nat) (l : List α) : List (List α) :=
  l |> List.enum
    |> List.map (λ (i, x) => (i / n, x))
    |> List.groupBy (λ (i, _) (j, _) => i = j)
    |> List.map (List.map Prod.snd)

def run : IO Unit := do

  let lines <- parse
  let sacks := lines.filterMap Rucksack.fromStr

  let part1 := sacks |> List.map (λ x => Rucksack.priority (Sigma.snd x))
                     |> List.foldl (· + ·) 0

  let part2 := lines |> List.map String.data
               |> List.windows 3
               |> List.filterMap (λ x => match x with
                                         | [l1, l2, l3] => findBadgeHelp l1 l2 l3
                                         | _ => none)
               |> List.map Char.priority
               |> List.foldl (· + ·) 0

  let stdout <- IO.getStdout
  stdout.putStrLn s!"Part 1: {part1}"
  stdout.putStrLn s!"Part 2: {part2}"

#eval run

end Dec3


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.bitraversable.basic
import Mathlib.PostPort

universes u l_1 u_1

namespace Mathlib

/-!
# Bitraversable Lemmas

## Main definitions
  * tfst - traverse on first functor argument
  * tsnd - traverse on second functor argument

## Lemmas

Combination of
  * bitraverse
  * tfst
  * tsnd

with the applicatives `id` and `comp`

## References

 * Hackage: <https://hackage.haskell.org/package/base-4.12.0.0/docs/Data-Bitraversable.html>

## Tags

traversable bitraversable functor bifunctor applicative

-/

namespace bitraversable

/-- traverse on the first functor argument -/
def tfst {t : Type u → Type u → Type u} [bitraversable t] {β : Type u} {F : Type u → Type u} [Applicative F] {α : Type u} {α' : Type u} (f : α → F α') : t α β → F (t α' β) :=
  bitraverse f pure

/-- traverse on the second functor argument -/
def tsnd {t : Type u → Type u → Type u} [bitraversable t] {β : Type u} {F : Type u → Type u} [Applicative F] {α : Type u} {α' : Type u} (f : α → F α') : t β α → F (t β α') :=
  bitraverse pure f

theorem id_tfst {t : Type u → Type u → Type u} [bitraversable t] [is_lawful_bitraversable t] {α : Type u} {β : Type u} (x : t α β) : tfst id.mk x = id.mk x :=
  id_bitraverse

theorem id_tsnd {t : Type u → Type u → Type u} [bitraversable t] [is_lawful_bitraversable t] {α : Type u} {β : Type u} (x : t α β) : tsnd id.mk x = id.mk x :=
  id_bitraverse

theorem tfst_comp_tfst {t : Type l_1 → Type l_1 → Type l_1} [bitraversable t] {F : Type l_1 → Type l_1} {G : Type l_1 → Type l_1} [Applicative F] [Applicative G] [is_lawful_bitraversable t] [is_lawful_applicative F] [is_lawful_applicative G] {α₀ : Type l_1} {α₁ : Type l_1} {α₂ : Type l_1} {β : Type l_1} (f : α₀ → F α₁) (f' : α₁ → G α₂) : functor.comp.mk ∘ Functor.map (tfst f') ∘ tfst f = tfst (functor.comp.mk ∘ Functor.map f' ∘ f) :=
  funext fun (x : t α₀ β) => comp_tfst f f' x

theorem tfst_tsnd {t : Type u → Type u → Type u} [bitraversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_bitraversable t] [is_lawful_applicative F] [is_lawful_applicative G] {α₀ : Type u} {α₁ : Type u} {β₀ : Type u} {β₁ : Type u} (f : α₀ → F α₁) (f' : β₀ → G β₁) (x : t α₀ β₀) : functor.comp.mk (tfst f <$> tsnd f' x) =
  bitraverse (functor.comp.mk ∘ pure ∘ f) (functor.comp.mk ∘ Functor.map pure ∘ f') x := sorry

theorem tsnd_tfst {t : Type u → Type u → Type u} [bitraversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_bitraversable t] [is_lawful_applicative F] [is_lawful_applicative G] {α₀ : Type u} {α₁ : Type u} {β₀ : Type u} {β₁ : Type u} (f : α₀ → F α₁) (f' : β₀ → G β₁) (x : t α₀ β₀) : functor.comp.mk (tsnd f' <$> tfst f x) =
  bitraverse (functor.comp.mk ∘ Functor.map pure ∘ f) (functor.comp.mk ∘ pure ∘ f') x := sorry

theorem comp_tsnd {t : Type u → Type u → Type u} [bitraversable t] {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_bitraversable t] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u} {β₀ : Type u} {β₁ : Type u} {β₂ : Type u} (g : β₀ → F β₁) (g' : β₁ → G β₂) (x : t α β₀) : functor.comp.mk (tsnd g' <$> tsnd g x) = tsnd (functor.comp.mk ∘ Functor.map g' ∘ g) x := sorry

theorem tfst_eq_fst_id {t : Type u → Type u → Type u} [bitraversable t] [is_lawful_bitraversable t] {α : Type u} {α' : Type u} {β : Type u} (f : α → α') (x : t α β) : tfst (id.mk ∘ f) x = id.mk (bifunctor.fst f x) := sorry

theorem tsnd_eq_snd_id {t : Type u → Type u → Type u} [bitraversable t] [is_lawful_bitraversable t] {α : Type u} {β : Type u} {β' : Type u} (f : β → β') (x : t α β) : tsnd (id.mk ∘ f) x = id.mk (bifunctor.snd f x) := sorry


import Runtime.Network.Graph.Path.Succ

namespace Network.Graph.Path

def Child (path : Path graph start) := { child // child ≻ path }

namespace Child

theorem parent_eq_nil_class {path : Path graph start} {child : Child path} : (child.val = cons c nil) → start = path.class := by
  intro h
  have h' := child.property
  simp [Succ, h, prefix?] at h'
  simp [←h']

-- TODO: This could also be expressed in `Subpaths.lean` using `prefix?`.
theorem split_fst_eq_parent (child : Child path) :
  (child.val.split child.property.isCons).fst = path := by
  sorry

def «class» (child : Child path) : Class.Child path.class :=
  have h := by rw [split_fst_eq_parent child]
  (child.val.split child.property.isCons).snd |> cast h

@[simp]
theorem class_eq_class {child : Child path} : child.class.class = child.val.class := by
  sorry

end Child
end Network.Graph.Path


import free_pfpng.main
import invpoly.functor
import condensed.condensify
import laurent_measures.thm69
import normed_free_pfpng.compare
import Lbar.ses
import laurent_measures.ses2

universe u

noncomputable theory

open category_theory

open_locale nnreal big_operators

namespace invpoly
open ProFiltPseuNormGrpWithTinv₁

variables (p : ℝ≥0) [fact (0 < p)] [fact (p < 1)]

local notation `r` := @r p

/-- The "evaluate at 2" function, sending an S-indexed family of elements of `ℤ[T⁻¹]`
  to an S-indexed family of integers, via the assignment `T⁻¹ ↦ 2`. Note that
  this is a strict (i.e. norm-nonincreasing) morphism of normed groups,
  with the norm on a polynomial `∑aₙT⁻ⁿ` being `∑ₙ∥aₙ∥₊r⁻ⁿ` and the norm
  on an integer `z` being `∥z∥₊ᵖ`; this works because `r = 2⁻ᵖ`, the crucial
  points being that `(∑∥cₙ∥)ᵖ ≤ ∑(∥cₙ∥ᵖ)` as `0 < p ≤ 1`, and `∥z∥ᵖ ≤ ∥z∥` for an integer `z`.   -/
@[simps] def eval2 (S : Fintype.{u}) :
  strict_comphaus_filtered_pseudo_normed_group_hom (invpoly r S) (normed_free_pfpng p S) :=
{ to_fun := λ F s, (F s).eval 2,
  map_zero' := by { ext, simp only [polynomial.eval_zero, pi.zero_apply], },
  map_add' := by { intros, ext, simp only [polynomial.eval_add, pi.add_apply], },
  strict' := λ c F hF, begin
    refine (finset.sum_le_sum _).trans hF,
    rintro s -,
    have h0p : 0 < p := fact.out _,
    have hp1 : p ≤ 1 := fact.out _,
    have h0pinv : 0 ≤ p⁻¹, { rw ← nnreal.inv_pos at h0p, exact h0p.le },
    calc ∥(F s).eval 2∥₊ ^ (p:ℝ)
        = ∥∑ n in finset.range ((F s).nat_degree + 1), (F s).coeff n * 2 ^ n∥₊ ^ (p:ℝ) : _
    ... ≤ (∑ n in finset.range ((F s).nat_degree + 1), ∥(F s).coeff n * 2 ^ n∥₊) ^ (p:ℝ) : _
    ... ≤ ∑ n in finset.range ((F s).nat_degree + 1), (∥(F s).coeff n * 2 ^ n∥₊ ^ (p:ℝ)) : _
    ... ≤ ∑ n in finset.range ((F s).nat_degree + 1), (∥(F s).coeff n∥₊ * r ^ (-n:ℤ)) : _
    ... ≤ ∑' n, (∥(F s).coeff n∥₊ * r ^ (-n:ℤ)) : _,
    { rw polynomial.eval_eq_sum_range, },
    { refine nnreal.rpow_le_rpow (nnnorm_sum_le _ _) h0p.le, },
    { refine nnreal.rpow_sum_le_sum_rpow _ _ h0p hp1, },
    { refine finset.sum_le_sum _,
      intros n hn,
      rw [int.nnnorm_mul, nnreal.mul_rpow],
      refine mul_le_mul' _ (le_of_eq _),
      { exact nnnorm_int_rpow_le p _ },
      { have h2n : (2 ^ n : ℤ) = (2 ^ n : ℕ), { norm_cast, },
        simp only [h2n, ← nnreal.coe_nat_abs, int.nat_abs_of_nat],
        rw [zpow_neg, ← inv_zpow, zpow_coe_nat],
        calc ((2 ^ n : ℕ) : ℝ≥0) ^ (p:ℝ)
            = (2 ^ (n:ℝ) : ℝ≥0) ^ (p:ℝ) : _
        ... = (2⁻¹ ^ (p:ℝ) : ℝ≥0)⁻¹ ^ (n:ℝ) : _
        ... = r⁻¹ ^ n : _,
        { norm_cast },
        { rw [← nnreal.rpow_mul, mul_comm, nnreal.rpow_mul, ← nnreal.inv_rpow, inv_inv], },
        { rw [nnreal.rpow_nat_cast], refl, } } },
    { refine sum_le_tsum _ _ _,
      { intros, exact zero_le' },
      { exact F.nnreal_summable s } },
  end,
  continuous' := λ c, continuous_of_discrete_topology }

/-- The "evaluate a polynomial in `T⁻¹` by mapping `T⁻¹` to `2`" functor
 from `ℤ[T⁻¹]` to `ℤ`. -/
def eval2_nat_trans :
  (Fintype_invpoly.{u} r ⋙ PFPNGT₁_to_CHFPNG₁ₑₗ.{u} r) ⟶
  (normed_free_pfpng_functor.{u} p ⋙ PFPNG₁_to_CHFPNG₁ₑₗ) :=
{ app := λ S, eval2 p S,
  naturality' := λ S T f, begin
    ext x t,
    show (map f x t).eval 2 = _,
    dsimp only [functor.comp_map, normed_free_pfpng_functor_map,
      CompHausFiltPseuNormGrp₁.comp_apply, map],
    erw [polynomial.eval_finset_sum], refl, recover, exact 0,
  end }
.

section ses

open CompHausFiltPseuNormGrp₁

-- move this
instance (M N : Type*)
  [comphaus_filtered_pseudo_normed_group M] [comphaus_filtered_pseudo_normed_group N] :
  add_monoid_hom_class (comphaus_filtered_pseudo_normed_group_hom M N) M N :=
{ coe := λ f, f,
  coe_injective' := λ f g h, by { ext, dsimp at h, rw h },
  map_add := λ f, f.map_add,
  map_zero := λ f, f.map_zero }

lemma Tinv2_injective (S : Fintype) :
  function.injective ((Tinv2_nat_trans (Fintype_invpoly r)).app S) :=
begin
  rw injective_iff_map_eq_zero,
  intros f hf,
  ext s n,
  apply_fun (λ φ, φ s) at hf,
  simp only [Tinv2_nat_trans, Tinv_nat_trans, nat_trans.app_nsmul, nat_trans.id_app, sub_apply,
    nat_trans.app_sub, comphaus_filtered_pseudo_normed_group_hom.sub_apply,
    pi.smul_apply, comphaus_filtered_pseudo_normed_group_hom.nsmul_apply,
    pi.sub_apply, pi.zero_apply] at hf,
  simp only [pi.zero_apply, polynomial.coeff_zero],
  induction n with n ih,
  { apply_fun (λ φ, φ.coeff 0) at hf,
    simp only [polynomial.coeff_zero, polynomial.coeff_sub, polynomial.coeff_smul] at hf,
    erw [invpoly.Tinv_zero, zero_sub, neg_eq_zero, two_nsmul_eq_zero ℤ ℤ] at hf, exact hf, },
  { apply_fun (λ φ, φ.coeff (n+1)) at hf,
    simp only [polynomial.coeff_zero, polynomial.coeff_sub, polynomial.coeff_smul] at hf,
    erw [invpoly.Tinv_succ, ih, zero_sub, neg_eq_zero, two_nsmul_eq_zero ℤ ℤ] at hf, exact hf }
end

lemma Tinv2_comp_eval2_eq_zero (S : Fintype) :
  (Tinv2_nat_trans (Fintype_invpoly r)).app S ≫
    (whisker_right (eval2_nat_trans p) CHFPNG₁_to_CHFPNGₑₗ).app S = 0 :=
begin
  ext f s,
  show (polynomial.X * (f s) - _).eval 2 = (0 : ℤ),
  simp only [nat_trans.app_nsmul, nat_trans.id_app, comphaus_filtered_pseudo_normed_group_hom.nsmul_apply,
  category_theory.id_apply, pi.smul_apply, nsmul_eq_mul, nat.cast_bit0, nat.cast_one, polynomial.eval_sub,
  polynomial.eval_mul, polynomial.eval_X, polynomial.eval_bit0, polynomial.eval_one, sub_self],
end
.

lemma theta_eval2_aux {S : Fintype} (s : S) (c : ℝ≥0) {f : invpoly r S} :
  ∑' (n : ℤ), (to_laurent_measures_fun r S f s n : ℝ) * ((2 : ℝ) ^ n)⁻¹ = ↑(polynomial.eval 2 (f s)) :=
begin
  rw polynomial.eval_eq_sum_range,
  have this : ∀ (n : ℤ),
  n ∉ finset.Icc (-(f s).nat_degree : ℤ) 0 →
  (λ (b : ℤ), ↑(to_laurent_measures_fun «r» S f s b) * ((2 : ℝ) ^ b)⁻¹) n = 0,
  { rintros n hn,
    rw [finset.mem_Icc, not_and_distrib] at hn,
    push_neg at hn,
    dsimp only,
    convert zero_mul _,
    norm_cast,
    cases hn with hn hn,
    { have : ∃ m : ℕ, n = - m,
      { use n.nat_abs,
        rw int.nat_abs_of_nonpos,
        { simp },
        exact le_trans hn.le (by simp), },
      rcases this with ⟨m, rfl⟩,
      rw to_laurent_measures_fun_nonpos,
      rw polynomial.coeff_eq_zero_of_nat_degree_lt,
      simpa using hn },
    { have : ∃ m : ℕ, n = m + 1,
      { use (n - 1).nat_abs,
        rw int.nat_abs_of_nonneg,
        ring, linarith, },
      rcases this with ⟨m, rfl⟩,
      apply to_laurent_measures_fun_pos' } },
  rw tsum_eq_sum this, clear this,
  push_cast,
  apply finset.sum_bij (λ (n : ℤ) hn, n.nat_abs),
  -- this is supposed to be the easy one! all that remains
  -- is four boring pieces of easy nonsense e.g.
  --2^{-n}=2^{n.nat_abs} if n < 0 is probably the hardest one
  { intros a ha,
    suffices : a.nat_abs < (f s).nat_degree + 1,
    { simpa },
    rw finset.mem_Icc at ha,
    rw [nat.lt_succ_iff, ← int.coe_nat_le, int.nat_abs_of_nonpos ha.2],
    linarith [ha.1] },
  { intros a ha,
    rw finset.mem_Icc at ha,
    simp only,
    congr,
    { have : ∃ m : ℕ, a = - m,
      { use a.nat_abs,
        rw int.nat_abs_of_nonpos ha.2,
        simp, },
      rcases this with ⟨m, rfl⟩,
      rw to_laurent_measures_fun_nonpos,
      congr,
      rw [← int.coe_nat_eq_coe_nat_iff, int.nat_abs_of_nonpos ha.2, neg_neg], },
    { rw [← zpow_neg, ← int.nat_abs_of_nonpos ha.2, zpow_coe_nat], } },
  { rintros a b ha hb (habs : a.nat_abs = b.nat_abs),
    rw finset.mem_Icc at ha hb,
    rw [← int.coe_nat_eq_coe_nat_iff, int.nat_abs_of_nonpos ha.2,
      int.nat_abs_of_nonpos hb.2] at habs,
    exact neg_inj.mp habs },
  { intros a ha,
    rw [finset.mem_range_succ_iff] at ha,
    refine ⟨-(a : ℤ), _, _⟩,
    { rw [finset.mem_Icc, neg_le_neg_iff, neg_le, neg_zero],
      simp [ha], },
    { simp } },
end

lemma theta_zero_of_eval2_zero {S : Fintype} (c : ℝ≥0) {f : invpoly r S} (hf1 : eval2 p S f = 0) :
(laurent_measures.Θ p S) ((to_laurent_measures_addhom r S) f) = 0 :=
begin
  ext s,
  replace hf1 := congr_fun hf1 s,
  suffices : ∑' (n : ℤ), ↑(to_laurent_measures_fun «r» S f s n) * ((2 : ℝ) ^ n)⁻¹ = 0,
  { simpa [laurent_measures.Θ, laurent_measures_ses.θ_to_add, θ, theta.ϑ,
    to_laurent_measures_addhom], },
  simp only [theta_eval2_aux p s c, int.cast_eq_zero],
  exact hf1,
end
.

lemma _root_.int.eq_neg_nat_or_succ_nat (n : ℤ) : ∃ m : ℕ, n = -m ∨ n = m + 1 :=
begin
  cases le_or_lt n 0,
  { use n.nat_abs,
    left,
    rw [int.nat_abs_of_nonpos h, neg_neg] },
  { use (n - 1).nat_abs,
    right,
    rw [int.nat_abs_of_nonneg],
    ring, linarith },
end

lemma phi_eq_mul_Tinv_sub_two {S : Fintype} (g : invpoly r S) :
  ϕ ((to_laurent_measures_addhom r S) (λ (s : ↥S), g s)) =
    (to_laurent_measures_addhom r S) (λ (s : ↥S), (polynomial.X - 2) * g s) :=
begin
  ext s n,
  delta ϕ,
  simp only [laurent_measures.sub_apply, laurent_measures.shift_to_fun_to_fun,
    laurent_measures.nsmul_apply, nsmul_eq_mul, int.coe_nat_zero, zero_add],
  obtain ⟨m, (rfl | rfl)⟩ := n.eq_neg_nat_or_succ_nat,
  { simp only [to_laurent_measures_addhom, to_laurent_measures_fun_nonpos, add_monoid_hom.mk'_apply,
      to_laurent_measures_to_fun],
    cases m,
    { simp only [nat.nat_zero_eq_zero, int.coe_nat_zero, neg_zero', zero_add,
        polynomial.mul_coeff_zero, polynomial.coeff_sub,
        polynomial.coeff_X_zero, zero_sub, neg_mul],
      rw [to_laurent_measures_fun_pos'' r S g s (show (0 : ℤ) < 1, by norm_num)],
      simp only [zero_sub, neg_inj, mul_eq_mul_right_iff,
        show (2 : polynomial ℤ) = polynomial.C 2, by simp, polynomial.coeff_C_zero],
      left,
      norm_num, },
    { simp only [to_laurent_measures_fun_nonpos, sub_mul, int.coe_nat_succ, neg_add_rev,
        neg_add_cancel_comm, int.coe_nat_bit0, int.coe_nat_zero, zero_add, polynomial.coeff_sub,
        polynomial.coeff_X_mul, sub_right_inj, show (2 : polynomial ℤ) = polynomial.C 2, by simp,
        polynomial.coeff_C_mul],
    } },
  { norm_cast }, -- didn't expect that to close it!
end

lemma psi_eq_div_X_sub_two {S : Fintype} (c : ℝ≥0) {f : invpoly r S}
  (hf1 : ((eval2_nat_trans p).app S) f = 0) :
(to_laurent_measures_addhom r S) (λ (s : ↥S), f s /ₘ (polynomial.X - 2)) =
  ψ ((to_laurent_measures_addhom «r» S) f) (theta_zero_of_eval2_zero p c hf1) :=
begin
  apply injective_ϕ',
  rw θ_ϕ_split_exact,
  have hf3 : ∀ s : S, (polynomial.X - 2) * ((f s) /ₘ (polynomial.X - 2)) = f s,
  { intro s,
    replace hf1 := congr_fun hf1 s,
    rw (show (2 : polynomial ℤ) = polynomial.C (2 : ℤ), by simp),
    rwa polynomial.mul_div_by_monic_eq_iff_is_root, },
  suffices : (to_laurent_measures_addhom r S)
    (λ s, (polynomial.X - 2) * ((f s) /ₘ (polynomial.X - 2))) =
    (to_laurent_measures_addhom r S) (λ s, f s),
  { rw ← this,
    apply phi_eq_mul_Tinv_sub_two, },
  simp [hf3],
end

theorem short_exact (S : Profinite) :
  short_exact ((condensify_Tinv2 _).app S) ((condensify_map $ eval2_nat_trans p).app S) :=
begin
  let κ : ℝ≥0 → ℝ≥0 := λ c, max c (c ^ (↑p⁻¹ : ℝ)),
  have hκ : id ≤ κ := λ c, le_max_left _ _,
  have h0p : 0 < p := fact.out _,
  have hp1 : p ≤ 1 := fact.out _,
  have h0pinv : 0 ≤ p⁻¹, { rw ← nnreal.inv_pos at h0p, exact h0p.le },
  refine condensify_nonstrict_exact _ _ (r⁻¹ + 2) (Tinv2_bound_by _)
    -- next line can be simplified because 1/2 < r < 1 so the max is always on the right.
    (λ c, max c (c * (2 - r⁻¹)⁻¹ * (r⁻¹ + 2))) κ
    (λ c, le_max_left _ _) hκ
    (Tinv2_injective p) (Tinv2_comp_eval2_eq_zero p) _ _ _,
  { rintros S c f ⟨hf1, hf2⟩,
    have hf3 : ∀ s : S, (polynomial.X - 2) * ((f s) /ₘ (polynomial.X - 2)) = f s,
    { intro s,
      replace hf1 := congr_fun hf1 s,
      rw (show (2 : polynomial ℤ) = polynomial.C (2 : ℤ), by simp),
      rwa polynomial.mul_div_by_monic_eq_iff_is_root, },
    refine ⟨λ s, (f s) /ₘ (polynomial.X - 2), _, _⟩,
    { change ∥_∥₊ ≤ c at hf2,
      change ∥_∥₊ ≤ _,
      have hf1' : ((eval2_nat_trans p).app S) f = 0,
      { simpa using hf1 },
      rw ← to_laurent_measures_addhom_isometry at ⊢ hf2,
      refine le_trans _ (nnreal.mul_le_mul_right (le_max_right _ _) _),
      rw mul_inv_cancel_right₀ (lt_of_lt_of_le (zero_lt_two : (0 : ℝ≥0) < 2) le_add_self).ne',
      convert laurent_measures.psi_bound p S c (theta_zero_of_eval2_zero p c hf1') hf2,
      exact psi_eq_div_X_sub_two p c hf1,
    },
    { ext1 s,
      convert hf3 s,
      simp [sub_mul, Tinv2_nat_trans, Tinv_nat_trans],
      refl } },
  { rintro S c g (hg : _ ≤ _),
    let f : invpoly r S := λ s, polynomial.C (g s),
    refine ⟨f, _, _⟩,
    { show _ ≤ _,
      replace hg := nnreal.rpow_le_rpow hg h0pinv,
      refine le_trans _ (le_max_right _ _),
      refine le_trans _ hg,
      refine le_trans _ (nnreal.rpow_le_rpow (nnreal.rpow_sum_le_sum_rpow _ _ h0p hp1) h0pinv),
      rw [← nnreal.rpow_mul, ← nnreal.coe_mul, mul_inv_cancel h0p.ne', nnreal.coe_one,
        nnreal.rpow_one, invpoly.nnnorm_def],
      refine finset.sum_le_sum _,
      rintro s -,
      simp only [f, zpow_neg, zpow_coe_nat, id.def, polynomial.coeff_C],
      rw tsum_eq_single 0,
      { rw [if_pos rfl, pow_zero, inv_one, mul_one], },
      { intros n hn, rw [if_neg hn, nnnorm_zero, zero_mul], },
      { apply_instance }, },
    { ext s, apply polynomial.eval_C } },
end

end ses

end invpoly


import implementation.model.predicate
import implementation.model.sys_state
import implementation.spec.main
import implementation.proof.misc
import implementation.proof.proposer

-- This file contains proofs about voters (or what can be associated with
-- them in our co-located Paxos implementation).
--
-- NOTE(gnanabit): comments are omitted for facts that are "obvious" or not
-- particularly revealing about paxos.

variables {pid_t : Type} [linear_order pid_t] [fintype pid_t] {value_t : Type}
          {is_quorum : finset pid_t → Prop} [decidable_pred is_quorum]
          [quorum_assumption is_quorum] {vals : pid_t → value_t}

-- A server's ballot is always larger than or equal to the ballot in the
-- proposal it has stored in `accepted` (if such a proposal exists).
--
-- Similarly, the ballot in a p1b is always larger than the proposal stored in
-- the p1b.
lemma current_ge_accepted_ballot : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    (∀ (p : pid_t) (prop : proposal pid_t value_t),
      (s.procs p).accepted = some prop → prop.bal ≤ (s.procs p).curr) ∧
    (∀ (p : pid_t) (e ∈ s.network p) (b : ballot pid_t) (prop : proposal pid_t value_t),
      (envelope.msg e) = message.p1b b (option.some prop) → prop.bal ≤ b)) :=
begin
suffices : predicate.inductive_invariant _,
by { exact predicate.ind_inv_is_inv this },
split,
{ intros s hs,
  split;
  intro p;
  specialize hs p;
  unfold protocol.init at hs;
  injection hs with start_proc start_network,
  { rw ← start_proc,
    intro prop,
    trivial },
  rw ← start_network,
  intros e he b prop contradicts_he,
  cases he,
  { rw he at contradicts_he, injection contradicts_he },
  rw set.mem_singleton_iff at he,
  rw he at contradicts_he, injection contradicts_he },
intros u v,
rintros ⟨servers_satisfy, promises_satisfy⟩,
intro u_pn_v,
have to_split := u_pn_v,
rcases to_split with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, same⟩,
split;
intro p;
cases decidable.em (p = receiver),
{ clear same,
  intro prop,
  rw h, clear h p,
  rw proc_change,
  have delta := state_change receiver (u.procs receiver) e.msg sender,
  cases delta,
  { rw delta, exact servers_satisfy receiver prop },
  cases e,
  cases e_msg,
    case p1a : b {
      cases delta with new_ballot_larger b_is_new_ballot,
      rw b_is_new_ballot,
      intro hyp,
      apply le_of_lt,
      calc prop.bal ≤ (u.procs receiver).curr : servers_satisfy receiver prop hyp
                ... < b                       : new_ballot_larger
    },
    case p1b : b p_or {
      cases delta,
      { cases delta with new_ballot_larger b_is_new_ballot,
        rw b_is_new_ballot,
        intro hyp,
        apply le_of_lt,
        calc prop.bal ≤ (u.procs receiver).curr : servers_satisfy receiver prop hyp
                  ... < b : new_ballot_larger },
      cases delta,
      { rw delta.right.right.right.right,
        intro hyp,
        have key : prop.bal = (u.procs receiver).curr,
        by {
          injection hyp with key,
          rw ← key
        },
        rw key },
      rw delta.right.right.right.right.right,
      intro hyp,
      cases proposal.merge_is_one_of (u.procs receiver).accepted p_or,
      { rw h at hyp,
        exact servers_satisfy receiver prop hyp },
      rw h at hyp,
      rw delta.left,
      apply promises_satisfy sender {msg := message.p1b b p_or, sent_to := e_sent_to} he b prop,
      rw ← hyp
    },
    case p2a : p {
      cases delta with new_ballot_larger b_is_new_ballot,
      rw b_is_new_ballot,
      intro hyp,
      have key : p = prop, by { injection hyp },
      rw key
    },
    case p2b : b acc {
      cases delta with new_ballot_larger b_is_new_ballot,
      rw b_is_new_ballot,
      intro hyp,
      apply le_of_lt,
      calc prop.bal ≤ (u.procs receiver).curr : servers_satisfy receiver prop hyp
                ... < b : new_ballot_larger
    },
    case preempt : {
      cases delta with ballot_not_from_self ballot_is_next,
      rw ballot_is_next,
      intro hyp,
      apply le_of_lt,
      calc prop.bal ≤ (u.procs receiver).curr : servers_satisfy receiver prop hyp
                ... < ballot.next receiver (u.procs receiver).curr : ballot.next_larger receiver (u.procs receiver).curr,
    }},
{ rw same.left p h, exact servers_satisfy p },
{ rw h, clear h p,
  intros e' he' b prop e'_msg_eq,
  rw ntwk_change at he',
  cases he',
  { exact promises_satisfy receiver e' he' b prop e'_msg_eq },
  rcases p1b_emitted e'_msg_eq he' with ⟨b', e_msg_is, accepted_unchanged, b_is_max⟩,
  calc prop.bal ≤ (u.procs receiver).curr : servers_satisfy receiver prop accepted_unchanged
            ... ≤ b                       : by { rw ← b_is_max,
                                                 exact le_max_left (u.procs receiver).curr b'} },
rw same.right p h, exact promises_satisfy p
end

-- Any stored proposal has been proposed in some p2a (a stored proposal is one in either a p1b
-- or in a server's `accepted` field).
lemma accepted_means_issued : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    (∀ (p : pid_t) (prop : proposal pid_t value_t),
      (s.procs p).accepted = some prop → proposed s prop.bal prop.val) ∧
    (∀ (p : pid_t) (e ∈ s.network p) (b : ballot pid_t) (prop : proposal pid_t value_t),
      (envelope.msg e) = message.p1b b (option.some prop) → proposed s prop.bal prop.val))
  :=
begin
suffices : predicate.inductive_invariant _,
by { exact predicate.ind_inv_is_inv this },
split,
{ intros s hs,
  split;
  intro p;
  specialize hs p;
  unfold protocol.init at hs;
  injection hs with start_proc start_network,
  { rw ← start_proc,
    intro prop,
    trivial },
  rw ← start_network,
  intros e he b prop contradicts_he,
  cases he,
  { rw he at contradicts_he, injection contradicts_he },
  rw set.mem_singleton_iff at he,
  rw he at contradicts_he, injection contradicts_he },
intros u v,
rintros ⟨accepted_satisfies, promises_satisfy⟩,
intro u_pn_v,
have to_split := u_pn_v,
rcases to_split with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, same⟩,
split;
intro p;
cases decidable.em (p = receiver),
{ rw h,
  clear h p,
  rw proc_change,
  intros prop h_prop,
  suffices key : proposed u prop.bal prop.val ∨
    (∃ e' ∈ (protocol.handler receiver (u.procs receiver) e.msg sender).snd,
       envelope.msg e' = message.p2a prop),
  by {
    cases key,
    { exact proposed_stable prop.bal prop.val u v key u_pn_v },
    { rcases key with ⟨e', he', e'_msg_is⟩,
      use [receiver, e'],
      split,
      { rw ntwk_change, right, exact he' },
      rw e'_msg_is, cases prop, refl },
  },
  have acc_unchanged_enough : (protocol.handler receiver (u.procs receiver) e.msg sender).fst.accepted = (u.procs receiver).accepted → proposed u prop.bal prop.val ∨
    (∃ e' ∈ (protocol.handler receiver (u.procs receiver) e.msg sender).snd,
       envelope.msg e' = message.p2a prop), by {
    intro hyp, left, rw hyp at h_prop, exact accepted_satisfies receiver prop h_prop
  },
  have key := state_change receiver (u.procs receiver) e.msg sender,
  cases key,
  { left, rw key at h_prop, exact accepted_satisfies receiver prop h_prop  },
  cases e,
  cases e_msg,
    case p1a : b { apply acc_unchanged_enough, rw key.right },
    case p1b : b p_or {
      cases key,
      { apply acc_unchanged_enough, rw key.right },
      cases key,
      { right,
        clear acc_unchanged_enough,
        rcases key with ⟨same_bal, bal_from_self, u_no_qrm, v_has_qrm, state_change⟩,
        have prop_eq: { proposal . bal := (u.procs receiver).curr,
                            val := proposal.value_or_default
                                     (proposal.merge (u.procs receiver).accepted p_or)
                                     (vals receiver)} = prop, by {
          rw state_change at h_prop, injection h_prop
        },
        use {envelope . msg := message.p2a prop,
                      sent_to := target.exclude receiver},
        split,
        { rw ← prop_eq,
          unfold protocol.handler server.handle_p1b,
          rw if_neg (show ¬(u.procs receiver).curr < b, by { rw same_bal, exact lt_irrefl b }),
          rw if_neg (show ¬(u.procs receiver).curr.address ≠ receiver,
                     by { rw decidable.not_not, rw same_bal, exact bal_from_self }),
          rw if_neg (show ¬(u.procs receiver).curr > b, by { rw same_bal, exact lt_irrefl b }),
          rw if_neg (show ¬(is_quorum (u.procs receiver).followers ∨
                     sender ∈ (u.procs receiver).followers),
                     by {
                       rw not_or_distrib,
                       split,
                       { exact u_no_qrm },
                       intro cond,
                       have fact : (u.procs receiver).followers ∪ {sender} = (u.procs receiver).followers,
                       by {
                         rw finset.union_eq_left_iff_subset,
                         rw finset.singleton_subset_iff,
                         exact cond
                       },
                       apply u_no_qrm,
                       rw ← fact,
                       exact v_has_qrm
                     }),
          rw if_pos v_has_qrm,
          left, refl },
      refl },
      rw key.right.right.right.right.right at h_prop,
      clear key acc_unchanged_enough,
      left,
      cases proposal.merge_is_one_of (u.procs receiver).accepted p_or;
      rw h at h_prop,
      { exact accepted_satisfies receiver prop h_prop },
      apply promises_satisfy sender {msg := message.p1b b p_or, sent_to := e_sent_to} he b prop,
      rw ← h_prop
    },
    case p2a : p {
      clear acc_unchanged_enough,
      rw key.right at h_prop, clear key,
      left,
      have key : prop = p, by { injection h_prop with fact, exact eq.symm fact },
      rw key,
      use [sender, {msg := message.p2a p, sent_to := e_sent_to}, he],
      cases p, refl
    },
    case p2b : b acc { apply acc_unchanged_enough, rw key.right  },
    case preempt : { apply acc_unchanged_enough, rw key.right },
  },
{ rw same.left p h,
  have ind_hyp := accepted_satisfies p,
  intros prop key,
  exact proposed_stable prop.bal prop.val u v (accepted_satisfies p prop key) u_pn_v },
{ rw h, clear same h p,
  rw ntwk_change, clear ntwk_change proc_change,
  intros e' he' b p e'_is_1b,
  cases he',
  { exact proposed_stable p.bal p.val u v
          (promises_satisfy receiver e' he' b p e'_is_1b) u_pn_v },
  rcases p1b_emitted e'_is_1b he' with ⟨b', e_msg_is, accepted_unchanged, b_is_max⟩,
  exact proposed_stable p.bal p.val u v
        (accepted_satisfies receiver p accepted_unchanged) u_pn_v },
rw same.right p h,
intros e' he' b prop e'_is_promise,
have ind_hyp := promises_satisfy p e' he' b prop e'_is_promise,
exact proposed_stable prop.bal prop.val u v ind_hyp u_pn_v
end

-- The ballot in a server's `accepted` field only ever increases. That is, if at
-- some point a server has accepted a proposal, then it will always have a
-- proposal in `accepted` and moreover the proposal ballot will be at least as
-- large as what's currently stored.
lemma accepted_ballot_nondecreasing {p : pid_t} {prop_u : proposal pid_t value_t}
  (u v : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (u_r : u.reachable) (h_uv : u.possible_next v)
  (h_u : (u.procs p).accepted = some prop_u) :
  ∃ (prop_v : proposal pid_t value_t), (v.procs p).accepted = some prop_v ∧ prop_u.bal ≤ prop_v.bal :=
begin
rcases h_uv with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, same⟩,
cases decidable.em (p = receiver),
swap,
{ exact ⟨prop_u, by { rw same.left p h, exact h_u }, by refl⟩ },
rw h at h_u ⊢,
clear h p,
rw proc_change,
have key := state_change receiver (u.procs receiver) e.msg sender,
cases key,
{ exact ⟨prop_u, by { rw key, exact h_u }, by refl⟩ },
cases e.msg,
  case p1a : b {
    rw key.right,
    exact ⟨prop_u, h_u, by refl⟩
  },
  case p1b : b p_or {
    cases key,
    { rw key.right,
      exact ⟨prop_u, h_u, by refl⟩ },
    cases key,
    { rw key.right.right.right.right,
      use { bal := (u.procs receiver).curr,
            val := proposal.value_or_default (proposal.merge (u.procs receiver).accepted p_or)
                                 (vals receiver) },
      exact ⟨by refl, (current_ge_accepted_ballot u u_r).left receiver prop_u h_u⟩ },
    rw key.right.right.right.right.right,
    rw h_u,
    exact proposal.merge_ballot_ge_left prop_u p_or
  },
  case p2a : pr {
    cases key with pr_bal_ge_curr update_w_pr,
    exact ⟨pr, by { rw update_w_pr }, by { exact le_trans
      ((current_ge_accepted_ballot u u_r).left receiver prop_u h_u)
      pr_bal_ge_curr }⟩,
  },
  case p2b : b accepted {
    rw key.right,
    exact ⟨prop_u, h_u, by refl⟩
  },
  case preempt : {
    rw key.right,
    exact ⟨prop_u, h_u, by refl⟩
  }
end

-- If a server issued a p1b promising not to accept anything with ballot less
-- than b, then its `curr` ballot will always be at least b.
lemma ballot_ge_any_promised (voter : pid_t)
  (b_promised : ballot pid_t) (p_or : option (proposal pid_t value_t)) : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    (∃ e ∈ s.network voter, envelope.msg e = message.p1b b_promised p_or) →
      (s.procs voter).curr ≥ b_promised) :=
begin
suffices : predicate.inductive_invariant _,
by { exact predicate.ind_inv_is_inv this},
split,
{ intros s hs,
  rintros ⟨e, he, e_is_promise⟩,
  specialize hs voter,
  injection hs with __ key, clear_, rw ← key at he,
  cases he,
  { rw he at e_is_promise, injection e_is_promise },
  rw set.mem_singleton_iff at he,
  rw he at e_is_promise, injection e_is_promise },
intros u v hu u_pn_v,
rintros ⟨e, he, e_is_promise⟩,
rcases (show _, by exact u_pn_v) with ⟨receiver, sender, e', he', deliverable, proc_change, ntwk_change, rest_same⟩,
cases decidable.em (voter = receiver),
swap,
{ rw rest_same.left voter h,
  rw rest_same.right voter h at he,
  exact hu ⟨e, he, e_is_promise⟩ },
clear rest_same,
rw ← h at proc_change ntwk_change deliverable, clear h receiver,
rw ntwk_change at he,
cases he,
{ apply le_trans (hu ⟨e, he, e_is_promise⟩),
  exact ballot_nondecreasing voter u_pn_v },
rcases p1b_emitted e_is_promise he with ⟨b', e'_is, accepted_is, is_max⟩,
rw e'_is at proc_change, rw proc_change,
unfold protocol.handler server.handle_p1a,
cases decidable.em ((u.procs voter).curr < b'),
{ rw if_pos h,
  unfold max max_default at is_max,
  rw if_neg (not_le_of_gt h) at is_max,
  rw is_max, exact le_refl _ },
rw if_neg h,
unfold max max_default at is_max,
rw if_pos (le_of_not_gt h) at is_max,
rw is_max,
exact le_refl _
end

def voted_ballot
  (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t))
  (voter : pid_t) (b : ballot pid_t) :=
  ∃ e ∈ s.network voter, (envelope.msg e) = message.p2b b tt

lemma voted_imp_proposed (voter : pid_t) (b : ballot pid_t) : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    voted_ballot s voter b → ∃ v, proposed s b v) :=
begin
suffices : predicate.inductive_invariant _,
by { exact predicate.ind_inv_is_inv this },
split,
{ intros s hs, rintros ⟨ev, h_ev, ev_vote⟩,
  specialize hs voter,
  injection hs with __ key, clear_,
  rw ← key at h_ev,
  cases h_ev,
  { rw h_ev at ev_vote, injection ev_vote },
  rw set.mem_singleton_iff at h_ev,
  rw h_ev at ev_vote, injection ev_vote },
intros u w hu u_pn_w,
rcases (show _, by exact u_pn_w) with ⟨receiver, sender, e, he, deliverable, proc_change, ntwk_change, proc_same, ntwk_same⟩, clear deliverable proc_same,
intro h_voted,
unfold voted_ballot at h_voted,
cases decidable.em (voter = receiver),
swap,
{ rw ntwk_same voter h at h_voted,
  rcases hu h_voted with ⟨v, proposed_at_u⟩,
  exact ⟨v, proposed_stable b v u w proposed_at_u u_pn_w⟩ },
clear ntwk_same,
rw ← h at ntwk_change proc_change, clear h receiver,
rw ntwk_change at h_voted,
rcases h_voted with ⟨e', he', e'_msg_is_vote⟩,
cases he',
{ rcases hu ⟨e', he', e'_msg_is_vote⟩ with ⟨v, proposed_at_u⟩,
  exact ⟨v, proposed_stable b v u w proposed_at_u u_pn_w⟩ },
have event := p2b_emitted e'_msg_is_vote he',
cases event,
{ rcases event with ⟨p_or, e_msg_is, bal_from_self, u_no_qrm, v_has_qrm, rest⟩,
  have ntwk_delta_eq : (protocol.handler voter (u.procs voter) e.msg sender).snd = {{msg := message.p2a
                {bal := (u.procs voter).curr,
                 val := proposal.value_or_default (proposal.merge (u.procs voter).accepted p_or) (vals voter)},
       sent_to := target.exclude voter},
        {msg := message.p2b (u.procs voter).curr tt, sent_to := target.just voter}},
  by {
    rw e_msg_is,
    unfold protocol.handler server.handle_p1b,
    rw if_neg (lt_irrefl _),
    rw if_neg (show ¬(u.procs voter).curr.address ≠ voter,
               by { rw decidable.not_not, exact bal_from_self }),
    rw if_neg (lt_irrefl _),
    rw if_neg (show ¬(is_quorum (u.procs voter).followers ∨
               sender ∈ (u.procs voter).followers),
               by {
                 rw not_or_distrib,
                 split,
                 { exact u_no_qrm },
                 intro cond,
                 have fact : (u.procs voter).followers ∪ {sender} = (u.procs voter).followers,
                 by {
                   rw finset.union_eq_left_iff_subset,
                   rw finset.singleton_subset_iff,
                   exact cond
                 },
                 apply u_no_qrm,
                 rw ← fact,
                 exact v_has_qrm
               }),
      rw if_pos v_has_qrm },
  use proposal.value_or_default (proposal.merge (u.procs voter).accepted p_or) (vals voter),
  use voter,
  use {msg := message.p2a
                {bal := (u.procs voter).curr,
                 val := proposal.value_or_default (proposal.merge (u.procs voter).accepted p_or) (vals voter)},
       sent_to := target.exclude voter},
  split,
  { rw ntwk_change, right,
    rw ntwk_delta_eq, left, refl },
  suffices : (u.procs voter).curr = b, by { rw this },
  rw rest at e'_msg_is_vote, injection e'_msg_is_vote },
rcases event with ⟨⟨p_bal, p_val⟩, e_msg_is, p_bal_larger⟩,
use [p_val, sender, e, sys_state.ntwk_subset he u_pn_w],
rw e_msg_is,
suffices : p_bal = b, by { rw this },
rw e_msg_is at he',
unfold protocol.handler server.handle_p2a at he',
rw if_pos p_bal_larger at he',
rw set.mem_singleton_iff at he',
rw he' at e'_msg_is_vote,
injection e'_msg_is_vote
end

-- In a same vein to `ballot_ge_any_promised`, if a server voted for a ballot b,
-- then it will always have a proposal stored where the proposal's ballot is at
-- least b.
lemma accepted_ge_any_voted (voter : pid_t) (b : ballot pid_t): predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    voted_ballot s voter b →
      ∃ p, (s.procs voter).accepted = some p ∧ p.bal ≥ b) :=
begin
rw predicate.use_any_invariant,
split,
{ intros s hs,
  rintros ⟨e, he, e_is_vote⟩,
  specialize hs voter,
  unfold protocol.init at hs,
  injection hs with __ network, clear_,
  rw ← network at he,
  cases he,
  { rw he at e_is_vote, injection e_is_vote },
  rw set.mem_singleton_iff at he,
  rw he at e_is_vote, injection e_is_vote },
intros u v u_r hu u_pn_v v_r,
rcases (show _, by exact u_pn_v) with ⟨receiver, sender, e', he', deliverable, proc_change, ntwk_change, rest_same⟩,
rintros ⟨ev, h_ev, ev_vote⟩,
cases decidable.em (voter = receiver),
swap,
{ rw rest_same.left voter h,
  rw rest_same.right voter h at h_ev,
  exact hu ⟨ev, h_ev, ev_vote⟩ },
rw ← h at proc_change ntwk_change deliverable,
clear rest_same h receiver,
rw ntwk_change at h_ev,
cases h_ev,
{ rcases hu ⟨ev, h_ev, ev_vote⟩ with ⟨p, hp, p_ge_b⟩,
  rcases accepted_ballot_nondecreasing u v u_r u_pn_v hp with ⟨prop_v, middle, right_for_trans⟩,
  exact ⟨prop_v, middle, le_trans p_ge_b right_for_trans⟩ },
cases p2b_emitted ev_vote h_ev,
{ rcases h with ⟨p_or, e'_msg_is, active, no_start_quorum, end_w_quorum, ev_is⟩,
  use {bal := (u.procs voter).curr,
       val := proposal.value_or_default (proposal.merge (u.procs voter).accepted p_or) (vals voter)},
  rw e'_msg_is at proc_change, clear e'_msg_is,
  rw proc_change,
  unfold protocol.handler server.handle_p1b,
  rw if_neg (lt_irrefl _),
  rw if_neg (decidable.not_not.mpr active),
  rw if_neg (lt_irrefl _),
  rw if_neg (show ¬(is_quorum (u.procs voter).followers ∨ sender ∈ (u.procs voter).followers),
    by {
      rw not_or_distrib,
      split,
      { exact no_start_quorum },
      intro cond,
      have fact : (u.procs voter).followers ∪ {sender} = (u.procs voter).followers,
      by {
        rw finset.union_eq_left_iff_subset,
        rw finset.singleton_subset_iff,
        exact cond
      },
      apply no_start_quorum,
      rw ← fact,
      exact end_w_quorum
    }),
  rw if_pos end_w_quorum,
  split,
  { refl },
  apply ge_of_eq,
  rw ev_is at ev_vote,
  injection ev_vote },
rcases h with ⟨p, e'_msg_is, p_bal_larger⟩,
rw e'_msg_is at proc_change h_ev, clear e'_msg_is,
use p,
rw proc_change,
unfold protocol.handler server.handle_p2a,
rw if_pos p_bal_larger,
split,
{ refl },
unfold protocol.handler server.handle_p2a at h_ev,
rw if_pos p_bal_larger at h_ev,
rw set.mem_singleton_iff at h_ev,
rw h_ev at ev_vote,
injection ev_vote with key __,
exact ge_of_eq key
end

-- If a server sent a p1b with ballot b and wrote that no ballot was stored,
-- then it will never vote for any proposal with ballot less than b.
--
-- If a server sent a p1b with ballot b and wrote that its highest stored was
-- (some p), then it will never vote for any proposal with a ballot larger than
-- p.bal and less than b.
theorem none_voted_between_p1b : predicate.invariant
  (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
    ∀ (voter : pid_t) (b_voted b_promised : ballot pid_t)
      (p_or : option (proposal pid_t value_t)),
      voted_ballot s voter b_voted →
        (∃ e ∈ s.network voter, envelope.msg e = message.p1b b_promised p_or) →
          b_voted ≥ b_promised ∨
          ∃ p, p_or = some p ∧ b_voted ≤ p.bal) :=
begin
suffices intros_before :
  ∀ (voter : pid_t) (b_voted b_promised : ballot pid_t) (p_or : option (proposal pid_t value_t)),
    predicate.invariant
    (λ (s : sys_state pid_t (server pid_t value_t is_quorum vals) (message pid_t value_t)),
       voted_ballot s voter b_voted →
         (∃ (e ∈ s.network voter), envelope.msg e = message.p1b b_promised p_or) →
           (b_voted ≥ b_promised ∨
             ∃ p, p_or = some p ∧ b_voted ≤ p.bal)),
by { intros u u_r voter b_voted b_promised p_or,
     exact intros_before voter b_voted b_promised p_or u u_r },
intros voter b_voted b_promised p_or,
rw predicate.use_any_invariant,
split,
{ intros s hs,
  rintros ⟨e, he, e_is_vote⟩,
  specialize hs voter,
  unfold protocol.init at hs,
  injection hs with __ network, clear_,
  rw ← network at he,
  cases he,
  { rw he at e_is_vote, injection e_is_vote },
  rw set.mem_singleton_iff at he,
  rw he at e_is_vote, injection e_is_vote },
intros u w u_r hu u_pn_w w_r,
rintros ⟨ev, h_ev, ev_vote⟩,
rintros ⟨ep, h_ep, ep_promise⟩,
rcases (by exact u_pn_w) with ⟨receiver, sender, e', he', deliverable, proc_change, ntwk_change, rest_same⟩,
cases decidable.em (voter = receiver),
swap,
{ rw rest_same.right voter h at h_ev h_ep,
  exact hu ⟨ev, h_ev, ev_vote⟩ ⟨ep, h_ep, ep_promise⟩ },
clear rest_same,
rw ← h at proc_change ntwk_change deliverable, clear h receiver,
rw ntwk_change at h_ev h_ep,
cases h_ep; cases h_ev,
{ exact hu ⟨ev, h_ev, ev_vote⟩ ⟨ep, h_ep, ep_promise⟩ },
{ left,
  have key := ballot_ge_any_promised voter b_promised p_or u u_r ⟨ep, h_ep, ep_promise⟩,
  cases p2b_emitted ev_vote h_ev,
  { rcases h with ⟨p_or, _, _, _, _, ev_is⟩,
    rw ev_is at ev_vote,
    have fact : (u.procs voter).curr = b_voted, by { injection ev_vote },
    rw fact at key, exact key },
  rcases h with ⟨p, e'_is, p_larger⟩,
  rw e'_is at h_ev,
  unfold protocol.handler server.handle_p2a at h_ev,
  rw if_pos p_larger at h_ev,
  rw set.mem_singleton_iff at h_ev,
  rw h_ev at ev_vote,
  injection ev_vote with fact __, clear_,
  rw ← fact,
  exact le_trans key p_larger },
{ right,
  rcases p1b_emitted ep_promise h_ep with ⟨b', _, key, _⟩,
  rcases accepted_ge_any_voted voter b_voted u u_r ⟨ev, h_ev, ev_vote⟩ with ⟨p, fact, p_bal_ge⟩,
  use p,
  split,
  { rw ← key, exact fact },
  exact p_bal_ge
  },
rcases p1b_emitted ep_promise h_ep with ⟨b', e'_msg_is, _, _⟩,
rw e'_msg_is at h_ev,
unfold protocol.handler server.handle_p1a at h_ev,
cases decidable.em ((u.procs voter).curr < b'),
{ rw if_pos h at h_ev,
  rw set.mem_singleton_iff at h_ev,
  rw h_ev at ev_vote,
  injection ev_vote },
rw if_neg h at h_ev,
rw set.mem_singleton_iff at h_ev,
rw h_ev at ev_vote,
injection ev_vote
end