-- PARTITIONS

import syntax
import tableau
import semantics
import soundness
import vocabulary

open hasVocabulary has_sat

def partition := finset formula × finset formula

-- Definition 24
def partInterpolant (X1 X2 : finset formula) (θ : formula) :=
  voc θ ⊆ (voc X1 ∩ voc X2)  ∧  ¬ satisfiable ( X1 ∪ {~θ} )  ∧  ¬ satisfiable ( X2 ∪ {θ} )

-- Lemma 14
lemma botInter {X1 X2} : ⊥ ∈ (X1 ∪ X2) → ∃ θ, partInterpolant X1 X2 θ :=
begin
  intro bot_in_X,
  refine if side : ⊥ ∈ X1 then _ else _,
  { -- case ⊥ ∈ X1
    use ⊥,
    split,
    { unfold voc, unfold vocabOfFormula, simp, },
    split,
    all_goals { by_contradiction h, rcases h with ⟨W,M,w1,sat⟩, specialize sat ⊥, simp at *, tauto, },
  },
  { -- case ⊥ ∈ X2
    have : ⊥ ∈ X2, { simp at *, tauto, },
    use ~⊥,
    split,
    { unfold voc, unfold vocabOfFormula, simp, },
    split,
    all_goals { by_contradiction h, rcases h with ⟨W,M,w1,sat⟩, },
    { specialize sat (~~⊥), simp at *, unfold evaluate at sat, tauto, },
    { specialize sat ⊥, simp at *, tauto, },
  }
end
lemma notInter {X1 X2 ϕ} : ϕ ∈ (X1 ∪ X2) ∧ ~ϕ ∈ (X1 ∪ X2) → ∃ θ, partInterpolant X1 X2 θ :=
begin
  intro in_both, cases in_both with pIn nIn,
  by_cases pSide : ϕ ∈ X1, all_goals { by_cases nSide :~ϕ ∈ X1 }, -- four cases
  { use ⊥, -- both in X1
    split,
    { unfold voc, unfold vocabOfFormula, simp, },
    split,
    all_goals { by_contradiction h, rcases h with ⟨W,M,w1,sat⟩, },
    { have h1 := sat ϕ, have h2 := sat (~ϕ), simp at *, tauto, },
    { specialize sat ⊥, simp at *, tauto, },
  },
  { use ϕ, -- ϕ ∈ X1 and ~ϕ ∈ X2
    split,
    { unfold voc, intros a aIn, simp, split,
      exact vocElem_subs_vocSet pSide aIn,
      have h : ~ϕ ∈ X2 , { rw finset.mem_union at nIn, tauto, },
      have := vocElem_subs_vocSet h,
      simp at *,
      tauto,
    },
    split,
    all_goals { by_contradiction h, rcases h with ⟨W,M,w1,sat⟩, },
    { simp at *, tauto, },
    { have h1 := sat (~ϕ), simp at *, tauto, },
  },
  { use ~ϕ, -- ~ϕ ∈ X1 and ϕ ∈ X2
    split,
    { unfold voc, intros a aIn, simp, split,
      exact vocElem_subs_vocSet nSide aIn,
      have h : ϕ ∈ X2 , { rw finset.mem_union at pIn, tauto, },
      have := vocElem_subs_vocSet h,
      simp at *,
      tauto,
    },
    split,
    all_goals { by_contradiction h, rcases h with ⟨W,M,w1,sat⟩, },
    { have h1 := sat (~ϕ), simp at *, tauto, },
    { simp at *, tauto, },
  },
  { use ~⊥, -- both in X2
    split,
    { unfold voc, unfold vocabOfFormula, simp, },
    split,
    all_goals { by_contradiction h, rcases h with ⟨W,M,w1,sat⟩, },
    { specialize sat (~~⊥), simp at *, unfold evaluate at sat, tauto, },
    { have h1 := sat ϕ, have h2 := sat (~ϕ), simp at *, tauto, },
  },
end

lemma notnotInterpolantX1 {X1 X2 ϕ θ} : (~~ϕ) ∈ X1 → partInterpolant (X1 \ {~~ϕ} ∪ {ϕ}) (X2 \ {~~ϕ}) θ → partInterpolant X1 X2 θ :=
begin
  intros notnotphi_in_X1 theta_is_chInt,
  rcases theta_is_chInt with ⟨vocSub,noSatX1,noSatX2⟩,
  unfold partInterpolant,
  split,
  { rw vocPreserved X1 (~~ϕ) ϕ notnotphi_in_X1 (by {unfold voc, simp, }),
    change voc θ ⊆ voc (X1 \ {~~ϕ} ∪ {ϕ}) ∩ voc X2,
    have : voc (X2 \ {~~ϕ}) ⊆ voc X2 := vocErase,
    intros a aInVocTheta,
    simp at *,
    rw finset.subset_inter_iff at vocSub,
    tauto,
  },
  split,
  all_goals { by_contradiction hyp, unfold satisfiable at hyp, rcases hyp with ⟨W,M,w,sat⟩, },
  { have : satisfiable ((X1 \ {~~ϕ} ∪ {ϕ}) ∪ {~θ}), {
      unfold satisfiable,
      use [W,M,w],
      intros ψ psi_in_newX_u_notTheta,
      simp at psi_in_newX_u_notTheta,
      cases psi_in_newX_u_notTheta,
      { apply sat, rw psi_in_newX_u_notTheta, simp at *, },
      cases psi_in_newX_u_notTheta,
      { rw psi_in_newX_u_notTheta, apply of_not_not,
        change evaluate (M, w) (~~ϕ),
        apply sat (~~ϕ), simp, right, assumption,
      },
      { apply sat, simp at *, tauto, },
    },
    tauto,
  },
  { have : satisfiable ( (X2 \ {~~ϕ}) ∪ {θ}), {
      unfold satisfiable at *,
      use [W,M,w],
      intros ψ psi_in_newX2cupTheta,
      apply sat, simp at *, tauto,
    },
    tauto,
  },
end

lemma notnotInterpolantX2 {X1 X2 ϕ θ} : (~~ϕ) ∈ X2 → partInterpolant (X1 \ {~~ϕ}) (X2 \ {~~ϕ} ∪ {ϕ}) θ → partInterpolant X1 X2 θ :=
begin
  intros notnotphi_in_X2 theta_is_chInt,
  rcases theta_is_chInt with ⟨vocSub,noSatX1,noSatX2⟩,
  unfold partInterpolant,
  split,
  { rw vocPreserved X2 (~~ϕ) ϕ notnotphi_in_X2 (by {unfold voc, simp, }),
    change voc θ ⊆ voc X1 ∩ voc (X2 \ {~~ϕ} ∪ {ϕ}),
    have : voc (X1 \ {~~ϕ}) ⊆ voc X1 := vocErase,
    intros a aInVocTheta,
    simp at *,
    rw finset.subset_inter_iff at vocSub,
    tauto,
  },
  split,
  all_goals { by_contradiction hyp, unfold satisfiable at hyp, rcases hyp with ⟨W,M,w,sat⟩, },
  { apply noSatX1,
    unfold satisfiable,
    use [W,M,w],
    intros ψ psi_in_newX_u_notTheta,
    simp at psi_in_newX_u_notTheta,
    cases psi_in_newX_u_notTheta,
    { apply sat, rw psi_in_newX_u_notTheta, simp at *, },
    cases psi_in_newX_u_notTheta,
    { apply sat, simp at *, tauto, },
  },
  { apply noSatX2,
    unfold satisfiable at *,
    use [W,M,w],
    intros ψ psi_in_newX2cupTheta,
    simp at psi_in_newX2cupTheta,
    cases psi_in_newX2cupTheta, -- ! changed from here onwards
    { apply sat, simp at *, tauto, },
    cases psi_in_newX2cupTheta,
    { rw psi_in_newX2cupTheta, apply of_not_not,
      change evaluate (M, w) (~~ϕ),
      apply sat (~~ϕ), simp, right, assumption,
    },
    { apply sat, simp at *, tauto, },
  },
end

lemma conInterpolantX1 {X1 X2 ϕ ψ θ} : ϕ⋏ψ ∈ X1 → partInterpolant (X1 \ {ϕ⋏ψ} ∪ {ϕ,ψ}) (X2 \ {ϕ⋏ψ}) θ → partInterpolant X1 X2 θ :=
begin
  intros con_in_X1 theta_is_chInt,
  rcases theta_is_chInt with ⟨vocSub, noSatX1, noSatX2⟩,
  unfold partInterpolant,
  split,
  { rw vocPreservedTwo (ϕ⋏ψ) ϕ ψ con_in_X1 (by {unfold voc vocabOfFormula vocabOfSetFormula, simp, }),
    have : voc (X2 \ {ϕ⋏ψ}) ⊆ voc X2 := vocErase,
    intros a aInVocTheta,
    rw finset.subset_inter_iff at vocSub,
    simp at *,
    tauto,
  },
  split,
  all_goals { by_contradiction hyp, unfold satisfiable at hyp, rcases hyp with ⟨W,M,w,sat⟩, },
  { apply noSatX1,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in, apply sat (~θ), simp, },
    cases pi_in,
    { rw pi_in, specialize sat (ϕ⋏ψ) (by {simp, exact con_in_X1,}), unfold evaluate at sat, tauto, },
    cases pi_in,
    { rw pi_in, specialize sat (ϕ⋏ψ) (by {simp, exact con_in_X1,}), unfold evaluate at sat, tauto, },
    { exact sat π (by {simp,tauto,}), },
  },
  { apply noSatX2,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in, apply sat θ, simp, },
    { apply sat, simp at *, tauto, },
  },
end

lemma conInterpolantX2 {X1 X2 ϕ ψ θ} : ϕ⋏ψ ∈ X2 → partInterpolant (X1 \ {ϕ⋏ψ}) (X2 \ {ϕ⋏ψ} ∪ {ϕ,ψ}) θ → partInterpolant X1 X2 θ :=
begin
  intros con_in_X2 theta_is_chInt,
  rcases theta_is_chInt with ⟨vocSub, noSatX1, noSatX2⟩,
  unfold partInterpolant,
  split,
  { rw vocPreservedTwo (ϕ⋏ψ) ϕ ψ con_in_X2 (by {unfold voc vocabOfFormula vocabOfSetFormula, simp, }),
    have : voc (X1 \ {ϕ⋏ψ}) ⊆ voc X1 := vocErase,
    intros a aInVocTheta,
    rw finset.subset_inter_iff at vocSub,
    simp at *,
    tauto,
  },
  split,
  all_goals { by_contradiction hyp, unfold satisfiable at hyp, rcases hyp with ⟨W,M,w,sat⟩, },
  { apply noSatX1,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in, apply sat (~θ), simp, },
    { apply sat, simp at *, tauto, },
  },
  { apply noSatX2,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in, apply sat θ, simp, },
    cases pi_in,
    { rw pi_in, specialize sat (ϕ⋏ψ) (by {simp, right, exact con_in_X2,}), unfold evaluate at sat, tauto, },
    cases pi_in,
    { rw pi_in, specialize sat (ϕ⋏ψ) (by {simp, right, exact con_in_X2,}), unfold evaluate at sat, tauto, },
    { exact sat π (by {simp,tauto,}), },
  },
end

lemma nCoInterpolantX1 {X1 X2 ϕ ψ θa θb} :
  ~(ϕ⋏ψ) ∈ X1 →
    partInterpolant (X1 \ {~(ϕ⋏ψ)} ∪ {~ϕ}) (X2 \ {~(ϕ⋏ψ)}) θa →
      partInterpolant (X1 \ {~(ϕ⋏ψ)} ∪ {~ψ}) (X2 \ {~(ϕ⋏ψ)}) θb →
        partInterpolant X1 X2 (~(~θa ⋏ ~θb)) :=
begin
  intros nCo_in_X1 tA_is_chInt tB_is_chInt,
  rcases tA_is_chInt with ⟨a_vocSub, a_noSatX1, a_noSatX2⟩,
  rcases tB_is_chInt with ⟨b_vocSub, b_noSatX1, b_noSatX2⟩,
  unfold partInterpolant,
  split,
  { unfold voc vocabOfFormula,
    rw finset.subset_inter_iff,
    split , all_goals { rw finset.union_subset_iff ; split ; intros a aIn, },
    { have sub : voc (~ϕ) ⊆ voc (~(ϕ⋏ψ)), { unfold voc vocabOfFormula, apply finset.subset_union_left, },
      have claim := vocPreservedSub (~(ϕ⋏ψ)) (~ϕ) nCo_in_X1 sub,
      rw finset.subset_iff at claim,
      specialize @claim a,
      rw finset.subset_iff at a_vocSub,
      specialize a_vocSub aIn,
      finish,
    },
    { have sub : voc (~ψ) ⊆ voc (~(ϕ⋏ψ)), { unfold voc vocabOfFormula, apply finset.subset_union_right, },
      have claim := vocPreservedSub (~(ϕ⋏ψ)) (~ψ) nCo_in_X1 sub,
      rw finset.subset_iff at claim,
      specialize @claim a,
      rw finset.subset_iff at b_vocSub,
      specialize b_vocSub aIn,
      finish,
    },
    { rw finset.subset_iff at a_vocSub,
      specialize a_vocSub aIn,
      have : voc (X2 \ {~(ϕ⋏ψ)}) ⊆ voc X2 := vocErase,
      unfold voc at *,
      simp at *,
      tauto,
    },
    { rw finset.subset_iff at b_vocSub,
      specialize b_vocSub aIn,
      have : voc (X2 \ {~(ϕ⋏ψ)}) ⊆ voc X2 := vocErase,
      unfold voc at *,
      simp at *,
      tauto,
    },
  },
  split,
  all_goals { by_contradiction hyp, unfold satisfiable at hyp, rcases hyp with ⟨W,M,w,sat⟩, },
  { apply a_noSatX1,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in, specialize sat (~~(~θa⋏~θb)), simp at sat, unfold evaluate at *, simp at sat, tauto, },
    cases pi_in,
    { rw pi_in,
      by_contradiction, apply b_noSatX1,
      unfold satisfiable,
      use [W,M,w],
      intros χ chi_in,
      simp at chi_in,
      cases chi_in,
      { rw chi_in, specialize sat (~~(~θa⋏~θb)), simp at sat, unfold evaluate at *, simp at sat, tauto, },
      cases chi_in,
      { rw chi_in, specialize sat (~(ϕ⋏ψ)) (by {simp, exact nCo_in_X1,}), unfold evaluate at *, simp at *, tauto, },
      { apply sat, simp, tauto, },
    },
    { apply sat, simp, tauto, },
  },
  { apply a_noSatX2,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in,
      by_contradiction, apply b_noSatX2,
      unfold satisfiable,
      use [W,M,w],
      intros χ chi_in,
      simp at chi_in,
      cases chi_in,
      { rw chi_in, specialize sat (~(~θa⋏~θb)), simp at sat, unfold evaluate at *, simp at sat, tauto, },
      { apply sat, simp, tauto, },
    },
    { apply sat, simp, tauto, },
  },
end

lemma nCoInterpolantX2 {X1 X2 ϕ ψ θa θb} :
  ~(ϕ⋏ψ) ∈ X2 →
    partInterpolant (X1 \ {~(ϕ⋏ψ)}) (X2 \ {~(ϕ⋏ψ)} ∪ {~ϕ}) θa →
      partInterpolant (X1 \ {~(ϕ⋏ψ)}) (X2 \ {~(ϕ⋏ψ)} ∪ {~ψ}) θb →
        partInterpolant X1 X2 (θa ⋏ θb) :=
begin
  intros nCo_in_X2 tA_is_chInt tB_is_chInt,
  rcases tA_is_chInt with ⟨a_vocSub, a_noSatX1, a_noSatX2⟩,
  rcases tB_is_chInt with ⟨b_vocSub, b_noSatX1, b_noSatX2⟩,
  unfold partInterpolant,
  split,
  { unfold voc vocabOfFormula,
    rw finset.subset_inter_iff,
    split , all_goals { rw finset.union_subset_iff ; split ; intros a aIn, },
    { rw finset.subset_iff at a_vocSub,
      specialize a_vocSub aIn,
      have claim : voc (X1 \ {~(ϕ⋏ψ)}) ⊆ voc X1 := vocErase,
      unfold voc at claim,
      simp at *,
      tauto,
    },
    { rw finset.subset_iff at b_vocSub,
      specialize b_vocSub aIn,
      have claim : voc (X1 \ {~(ϕ⋏ψ)}) ⊆ voc X1 := vocErase,
      unfold voc at claim,
      simp at *,
      tauto,
    },
    { have sub : voc (~ϕ) ⊆ voc (~(ϕ⋏ψ)), { unfold voc vocabOfFormula, apply finset.subset_union_left, },
      have claim := vocPreservedSub (~(ϕ⋏ψ)) (~ϕ) nCo_in_X2 sub,
      rw finset.subset_iff at claim,
      specialize @claim a,
      rw finset.subset_iff at a_vocSub,
      specialize a_vocSub aIn,
      finish,
    },
    { have sub : voc (~ψ) ⊆ voc (~(ϕ⋏ψ)), { unfold voc vocabOfFormula, apply finset.subset_union_right, },
      have claim := vocPreservedSub (~(ϕ⋏ψ)) (~ψ) nCo_in_X2 sub,
      rw finset.subset_iff at claim,
      specialize @claim a,
      rw finset.subset_iff at b_vocSub,
      specialize b_vocSub aIn,
      finish,
    },
  },
  split,
  all_goals { by_contradiction hyp, unfold satisfiable at hyp, rcases hyp with ⟨W,M,w,sat⟩, },
  { apply a_noSatX1,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in,
      by_contradiction, apply b_noSatX1,
      unfold satisfiable,
      use [W,M,w],
      intros χ chi_in,
      simp at chi_in,
      cases chi_in,
      { rw chi_in, specialize sat (~(θa⋏θb)), simp at sat, unfold evaluate at *, simp at sat, simp at h, tauto, },
      { apply sat, simp, tauto, },
    },
    { apply sat, simp, tauto, },
  },
  { apply a_noSatX2,
    unfold satisfiable,
    use [W,M,w],
    intros π pi_in,
    simp at pi_in,
    cases pi_in,
    { rw pi_in, specialize sat (θa⋏θb), simp at sat, unfold evaluate at *, tauto, },
    cases pi_in,
    { rw pi_in,
      by_contradiction, apply b_noSatX2,
      unfold satisfiable,
      use [W,M,w],
      intros χ chi_in,
      simp at chi_in,
      cases chi_in,
      { rw chi_in, specialize sat (θa⋏θb), simp at sat, unfold evaluate at *, tauto, },
      cases chi_in,
      { rw chi_in, specialize sat (~(ϕ⋏ψ)), simp at sat, unfold evaluate at *, simp at sat, simp at h, tauto, },
      { apply sat, simp, tauto, },
    },
    { apply sat, simp, tauto, },
  },
end

lemma localTabToInt : Π n X,
  n = lengthOfSet X →
    ∀ {X1 X2}, X = X1 ∪ X2 →
      (∃ ltX : localTableau X, (∀ Y1 Y2, Y1 ∪ Y2 ∈ endNodesOf ⟨X, ltX⟩ → ∃ θ, partInterpolant Y1 Y2 θ)) →
        ∃ θ, partInterpolant X1 X2 θ :=
begin
  intro N,
  apply nat.strong_induction_on N,
  intros n IH,
  intros X lenX_is_n X1 X2 defX pt,
  rcases pt with ⟨pt,nextInter⟩,
  cases pt,
  case byLocalRule : X B lr next {
    cases lr,
      -- The bot and not cases use Lemma 14
      case bot : X bot_in_X { rw defX at bot_in_X, exact botInter bot_in_X, },
      case not : X ϕ in_both { rw defX at in_both, exact notInter in_both },
      case neg : X ϕ notnotphi_in {
        have notnotphi_in_union : ~~ϕ ∈ X1 ∪ X2, { rw defX at notnotphi_in, assumption, },
        simp at *,
        cases notnotphi_in_union,
        { -- case ~~ϕ ∈ X1
          subst defX,
          let newX1 := X1 \ {~~ϕ} ∪ {ϕ},
          let newX2 := X2 \ {~~ϕ}, -- to deal with possible overlap
          have yclaim : newX1 ∪ newX2 ∈ { (X1 ∪ X2) \ {~~ϕ} ∪ {ϕ} }, {
            rw finset.mem_singleton,
            change (X1 \ {~~ϕ} ∪ {ϕ}) ∪ (X2 \ {~~ϕ}) = (X1 ∪ X2) \ {~~ϕ} ∪ {ϕ},
            ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, },
          },
          set m := lengthOfSet (newX1 ∪ newX2),
          have m_lt_n : m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.neg notnotphi_in) (newX1 ∪ newX2) yclaim,
          },
          have nextNextInter : (∀ (Y1 Y2 : finset formula), Y1 ∪ Y2 ∈ endNodesOf ⟨newX1 ∪ newX2, (next (newX1 ∪ newX2) yclaim)⟩ → Exists (partInterpolant Y1 Y2)), {
            intros Y1 Y2, apply nextInter Y1 Y2 (newX1 ∪ newX2), finish,
          },
          have childInt : Exists (partInterpolant newX1 newX2) :=
            IH m m_lt_n (newX1 ∪ newX2) (refl _) (refl _) (next (newX1 ∪ newX2) yclaim) nextNextInter,
          cases childInt with θ theta_is_chInt,
          use θ,
          exact notnotInterpolantX1 notnotphi_in_union theta_is_chInt,
        },
        { -- case ~~ϕ ∈ X2
          ---- based on copy-paste from previous case, changes marked with "!" ---
          subst defX,
          let newX1 := X1 \ {~~ϕ}, -- to deal with possible overlap -- !
          let newX2 := X2 \ {~~ϕ} ∪ {ϕ}, -- !
          have yclaim : newX1 ∪ newX2 ∈ { (X1 ∪ X2) \ {~~ϕ} ∪ {ϕ} }, {
            rw finset.mem_singleton,
            change (X1 \ {~~ϕ}) ∪ (X2 \ {~~ϕ} ∪ {ϕ}) = (X1 ∪ X2) \ {~~ϕ} ∪ {ϕ}, -- !
            ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, },
          },
          set m := lengthOfSet (newX1 ∪ newX2),
          have m_lt_n : m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.neg notnotphi_in) (newX1 ∪ newX2) yclaim,
          },
          have nextNextInter : (∀ (Y1 Y2 : finset formula), Y1 ∪ Y2 ∈ endNodesOf ⟨newX1 ∪ newX2, (next (newX1 ∪ newX2) yclaim)⟩ → Exists (partInterpolant Y1 Y2)), {
            intros Y1 Y2, apply nextInter Y1 Y2 (newX1 ∪ newX2), finish,
          },
          have childInt : Exists (partInterpolant newX1 newX2) :=
            IH m m_lt_n (newX1 ∪ newX2) (refl _) (refl _) (next (newX1 ∪ newX2) yclaim) nextNextInter,
          cases childInt with θ theta_is_chInt,
          use θ,
          exact notnotInterpolantX2 notnotphi_in_union theta_is_chInt,
        },
      },
      case con : X ϕ ψ con_in_X {
        have con_in_union : ϕ⋏ψ ∈ X1 ∨ ϕ⋏ψ ∈ X2, { rw defX at con_in_X, simp at con_in_X, assumption, },
        cases con_in_union,
        { -- case ϕ⋏ψ ∈ X1
          subst defX,
          let newX1 := X1 \ {ϕ⋏ψ} ∪ {ϕ,ψ},
          let newX2 := X2 \ {ϕ⋏ψ},
          have yclaim : newX1 ∪ newX2 ∈ { (X1 ∪ X2) \ {ϕ⋏ψ} ∪ {ϕ, ψ} }, {
            rw finset.mem_singleton,
            change (X1 \ {ϕ⋏ψ} ∪ {ϕ, ψ}) ∪ (X2 \ {ϕ⋏ψ}) = (X1 ∪ X2) \ {ϕ⋏ψ} ∪ {ϕ,ψ},
            ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, },
          },
          set m := lengthOfSet (newX1 ∪ newX2),
          have m_lt_n : m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.con con_in_X) (newX1 ∪ newX2) yclaim,
          },
          have nextNextInter : (∀ (Y1 Y2 : finset formula), Y1 ∪ Y2 ∈ endNodesOf ⟨newX1 ∪ newX2, (next (newX1 ∪ newX2) yclaim)⟩ → Exists (partInterpolant Y1 Y2)), {
            intros Y1 Y2 Y_in, apply nextInter, unfold endNodesOf,
            simp only [endNodesOf, finset.mem_bUnion, finset.mem_attach, exists_true_left, subtype.exists],
            exact ⟨newX1 ∪ newX2, yclaim, Y_in⟩,
          },
          have childInt : Exists (partInterpolant newX1 newX2), {
            apply IH m m_lt_n (newX1 ∪ newX2) (refl _) (refl _),
            fconstructor,
            apply next (newX1 ∪ newX2) yclaim, exact nextNextInter,
          },
          cases childInt with θ theta_is_chInt,
          use θ,
          exact conInterpolantX1 con_in_union theta_is_chInt,
        },
        { -- case ϕ⋏ψ ∈ X2
          subst defX,
          let newX1 := X1 \ {ϕ⋏ψ},
          let newX2 := X2 \ {ϕ⋏ψ} ∪ {ϕ,ψ},
          have yclaim : newX1 ∪ newX2 ∈ { (X1 ∪ X2) \ {ϕ⋏ψ} ∪ {ϕ, ψ} }, {
            rw finset.mem_singleton,
            change (X1 \ {ϕ⋏ψ}) ∪ (X2 \ {ϕ⋏ψ} ∪ {ϕ, ψ}) = (X1 ∪ X2) \ {ϕ⋏ψ} ∪ {ϕ,ψ},
            ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, },
          },
          set m := lengthOfSet (newX1 ∪ newX2),
          have m_lt_n : m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.con con_in_X) (newX1 ∪ newX2) yclaim,
          },
          have nextNextInter : (∀ (Y1 Y2 : finset formula), Y1 ∪ Y2 ∈ endNodesOf ⟨newX1 ∪ newX2, (next (newX1 ∪ newX2) yclaim)⟩ → Exists (partInterpolant Y1 Y2)), {
            intros Y1 Y2 Y_in, apply nextInter, unfold endNodesOf,
            simp only [endNodesOf, finset.mem_bUnion, finset.mem_attach, exists_true_left, subtype.exists],
            exact ⟨newX1 ∪ newX2, yclaim, Y_in⟩,
          },
          have childInt : Exists (partInterpolant newX1 newX2), {
            apply IH m m_lt_n (newX1 ∪ newX2) (refl _) (refl _),
            fconstructor,
            apply next (newX1 ∪ newX2) yclaim, exact nextNextInter,
          },
          cases childInt with θ theta_is_chInt,
          use θ,
          exact conInterpolantX2 con_in_union theta_is_chInt,
        },
      },
      case nCo : X ϕ ψ nCo_in_X {
        have nCo_in_union : ~(ϕ⋏ψ) ∈ X1 ∨ ~(ϕ⋏ψ) ∈ X2, { rw defX at nCo_in_X, simp at nCo_in_X, assumption, },
        cases nCo_in_union,
        { -- case ~(ϕ⋏ψ) ∈ X1
          subst defX,
          -- splitting rule!
          -- first get an interpolant for the ~ϕ branch:
          let a_newX1 := X1 \ {~(ϕ⋏ψ)} ∪ {~ϕ},
          let a_newX2 := X2 \ {~(ϕ⋏ψ)},
          have a_yclaim : a_newX1 ∪ a_newX2 ∈ ({ (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ϕ},  (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ψ} } : finset (finset formula)),
            { simp, left, ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, }, },
          set a_m := lengthOfSet (a_newX1 ∪ a_newX2),
          have a_m_lt_n : a_m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.nCo nCo_in_X) (a_newX1 ∪ a_newX2) a_yclaim,
          },
          have a_childInt : Exists (partInterpolant a_newX1 a_newX2), {
            apply IH a_m a_m_lt_n (a_newX1 ∪ a_newX2) (refl _) (refl _),
            fconstructor,
            apply next (a_newX1 ∪ a_newX2) a_yclaim, -- remains to show nextNextInter
            intros Y1 Y2 Y_in, apply nextInter, unfold endNodesOf,
            simp only [endNodesOf, finset.mem_bUnion, finset.mem_attach, exists_true_left, subtype.exists],
            exact ⟨a_newX1 ∪ a_newX2, a_yclaim, Y_in⟩,
          },
          cases a_childInt with θa a_theta_is_chInt,
          -- now get an interpolant for the ~ψ branch:
          let b_newX1 := X1 \ {~(ϕ⋏ψ)} ∪ {~ψ},
          let b_newX2 := X2 \ {~(ϕ⋏ψ)},
          have b_yclaim : b_newX1 ∪ b_newX2 ∈ ({ (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ϕ},  (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ψ} } : finset (finset formula)),
            { simp, right, ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, }, },
          set b_m := lengthOfSet (b_newX1 ∪ b_newX2),
          have b_m_lt_n : b_m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.nCo nCo_in_X) (b_newX1 ∪ b_newX2) b_yclaim,
          },
          have b_childInt : Exists (partInterpolant b_newX1 b_newX2), {
            apply IH b_m b_m_lt_n (b_newX1 ∪ b_newX2) (refl _) (refl _),
            fconstructor,
            apply next (b_newX1 ∪ b_newX2) b_yclaim, -- remains to show nextNextInter
            intros Y1 Y2 Y_in, apply nextInter, unfold endNodesOf,
            simp only [endNodesOf, finset.mem_bUnion, finset.mem_attach, exists_true_left, subtype.exists],
            exact ⟨b_newX1 ∪ b_newX2, b_yclaim, Y_in⟩,
          },
          cases b_childInt with θb b_theta_is_chInt,
          -- finally, combine the two interpolants using disjunction:
          use ~(~θa ⋏ ~θb),
          exact nCoInterpolantX1 nCo_in_union a_theta_is_chInt b_theta_is_chInt,
        },
        { -- case ~(ϕ⋏ψ) ∈ X2
          subst defX,
          -- splitting rule!
          -- first get an interpolant for the ~ϕ branch:
          let a_newX1 := X1 \ {~(ϕ⋏ψ)},
          let a_newX2 := X2 \ {~(ϕ⋏ψ)} ∪ {~ϕ},
          have a_yclaim : a_newX1 ∪ a_newX2 ∈ ({ (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ϕ},  (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ψ} } : finset (finset formula)),
            { simp, left, ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, }, },
          set a_m := lengthOfSet (a_newX1 ∪ a_newX2),
          have a_m_lt_n : a_m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.nCo nCo_in_X) (a_newX1 ∪ a_newX2) a_yclaim,
          },
          have a_childInt : Exists (partInterpolant a_newX1 a_newX2), {
            apply IH a_m a_m_lt_n (a_newX1 ∪ a_newX2) (refl _) (refl _),
            fconstructor,
            apply next (a_newX1 ∪ a_newX2) a_yclaim, -- remains to show nextNextInter
            intros Y1 Y2 Y_in, apply nextInter, unfold endNodesOf,
            simp only [endNodesOf, finset.mem_bUnion, finset.mem_attach, exists_true_left, subtype.exists],
            exact ⟨a_newX1 ∪ a_newX2, a_yclaim, Y_in⟩,
          },
          cases a_childInt with θa a_theta_is_chInt,
          -- now get an interpolant for the ~ψ branch:
          let b_newX1 := X1 \ {~(ϕ⋏ψ)},
          let b_newX2 := X2 \ {~(ϕ⋏ψ)} ∪ {~ψ},
          have b_yclaim : b_newX1 ∪ b_newX2 ∈ ({ (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ϕ},  (X1 ∪ X2) \ {~(ϕ⋏ψ)} ∪ {~ψ} } : finset (finset formula)),
            { simp, right, ext1 a, split ; { intro hyp, simp at hyp, simp, tauto, }, },
          set b_m := lengthOfSet (b_newX1 ∪ b_newX2),
          have b_m_lt_n : b_m < n, {
            rw lenX_is_n,
            exact localRulesDecreaseLength (localRule.nCo nCo_in_X) (b_newX1 ∪ b_newX2) b_yclaim,
          },
          have b_childInt : Exists (partInterpolant b_newX1 b_newX2), {
            apply IH b_m b_m_lt_n (b_newX1 ∪ b_newX2) (refl _) (refl _),
            fconstructor,
            apply next (b_newX1 ∪ b_newX2) b_yclaim, -- remains to show nextNextInter
            intros Y1 Y2 Y_in, apply nextInter, unfold endNodesOf,
            simp only [endNodesOf, finset.mem_bUnion, finset.mem_attach, exists_true_left, subtype.exists],
            exact ⟨b_newX1 ∪ b_newX2, b_yclaim, Y_in⟩,
          },
          cases b_childInt with θb b_theta_is_chInt,
          -- finally, combine the two interpolants using conjunction:
          use θa ⋏ θb,
          exact nCoInterpolantX2 nCo_in_union a_theta_is_chInt b_theta_is_chInt,
        },
      },
  },
  case sim : X X_is_simple {
    apply nextInter,
    unfold endNodesOf,
    rw defX, simp,
  }
end

lemma vocProj (X) : voc (projection X) ⊆ voc X :=
begin
  unfold voc vocabOfFormula vocabOfSetFormula,
  simp,
  intros ϕ phi_in_proj,
  rw proj at phi_in_proj,
  intros a aInVocPhi,
  simp,
  tauto,
end

lemma projUnion {X Y} : projection (X ∪ Y) = projection X ∪ projection Y :=
begin
  unfold projection finset.bUnion,
  ext1,
  split ; finish,
end

open hasLength

-- tableau interpolation -- IDEA: similar to almostCompleteness
-- part of this is part of Lemma 15
lemma almostTabToInt {X} (ctX : closedTableau X) : Π X1 X2, X = X1 ∪ X2 → ∃ θ, partInterpolant X1 X2 θ :=
begin
  induction ctX,
  case loc: X ltX next IH {
    intros X1 X2 defX,
    have nextLtAndInter : (∃ ltX : localTableau X, (∀ Y1 Y2, Y1 ∪ Y2 ∈ endNodesOf ⟨X, ltX⟩ → ∃ θ, partInterpolant Y1 Y2 θ)), {
      use ltX,
      intros Y1 Y2 y_is_endOfX,
      specialize next (Y1 ∪ Y2) y_is_endOfX,
      exact IH (Y1 ∪ Y2) y_is_endOfX Y1 Y2 (refl _),
    },
    exact localTabToInt _ X (refl _) defX nextLtAndInter,
  },
  case atm: X ϕ notBoxPhi_in_X simpleX ctProjNotPhi IH {
    intros X1 X2 defX,
    subst defX,
    simp at *,
    cases notBoxPhi_in_X,
    { -- case ~□ϕ ∈ X1
      let newX1 := projection X1 ∪ { ~ϕ },
      let newX2 := projection X2,
      have yclaim : newX1 ∪ newX2 = projection (X1 ∪ X2) ∪ {~ϕ}, { rw projUnion, ext1, simp, tauto, },
      rw ← yclaim at ctProjNotPhi,
      have nextInt : ∃ θ, partInterpolant newX1 newX2 θ :=
        IH newX1 newX2 (by {rw yclaim, simp,}),
      rcases nextInt with ⟨θ,vocSub,unsat1,unsat2⟩,
      use ~□~θ,
      repeat { split, },
      -- it remains to show the three properties of the interpolant
      { change voc θ ⊆ voc X1 ∩ voc X2,
        have inc1 : voc newX1 ⊆ voc X1, {
          intros a aIn, unfold voc vocabOfSetFormula finset.bUnion at *, simp at *,
          rcases aIn with ⟨ψ,psi_in_projX1|psi_is_notPhi⟩,
          { use □ψ, change □ψ ∈ X1 ∧ a ∈ voc □ψ, rw ← proj, tauto, },
          { use ~□ϕ, subst psi_is_notPhi, tauto, }
        },
        have inc2 : voc newX2 ⊆ voc X2, {
          intros a aIn, unfold voc vocabOfSetFormula finset.bUnion at *, simp at *,
          rcases aIn with ⟨ψ,psi_in_projX2⟩,
          { use □ψ, change □ψ ∈ X2 ∧ a ∈ voc □ψ, rw ← proj, tauto, },
        },
        intros a aIn, norm_num,
        specialize vocSub aIn, simp at vocSub,
        split,
        apply inc1, tauto,
        apply inc2, tauto,
      },
      all_goals { unfold satisfiable at *, },
      { by_contradiction hyp,
        rcases hyp with ⟨W,M,w,sat⟩,
        apply unsat1,
        use [W,M],
        --- we use ~□ϕ to get a different world:
        let othersat := sat (~□ϕ) (by {simp, apply notBoxPhi_in_X, }),
        unfold evaluate at othersat,
        simp at othersat,
        rcases othersat with ⟨v,rel_w_v,v_not_phi⟩,
        use v,
        intros ψ psi_in_newX1,
        simp at psi_in_newX1,
        cases psi_in_newX1,
        { subst psi_in_newX1, specialize sat (~~□~θ), unfold evaluate at *, simp at sat, exact sat v rel_w_v, },
        cases psi_in_newX1,
        { rw proj at psi_in_newX1, specialize sat □ψ, unfold evaluate at sat, apply sat, simp, assumption, assumption, },
        { subst psi_in_newX1, unfold evaluate, assumption, },
      },
      { by_contradiction hyp,
        rcases hyp with ⟨W,M,w,sat⟩,
        apply unsat2,
        use [W,M],
        --- we use ~□~θ to get a different world:
        let othersat := sat (~□~θ) (by simp),
        unfold evaluate at othersat,
        simp at othersat,
        rcases othersat with ⟨v,rel_w_v,v_not_phi⟩,
        use v,
        intros ψ psi_in_newX2,
        simp at psi_in_newX2,
        cases psi_in_newX2,
        { subst psi_in_newX2, assumption, },
        { rw proj at psi_in_newX2, specialize sat □ψ, unfold evaluate at sat, apply sat, simp, assumption, assumption, },
      },
    },
    {  -- case ~□ϕ ∈ X2
      let newX1 := projection X1,
      let newX2 := projection X2 ∪ { ~ϕ },
      ---- what follows is *based* on copying the previous case ----
      have yclaim : newX1 ∪ newX2 = projection (X1 ∪ X2) ∪ {~ϕ}, { rw projUnion, ext1, simp, tauto, },
      rw ← yclaim at ctProjNotPhi,
      have nextInt : ∃ θ, partInterpolant newX1 newX2 θ :=
        IH newX1 newX2 (by {rw yclaim, simp,}),
      rcases nextInt with ⟨θ,vocSub,unsat1,unsat2⟩,
      use □θ, -- !!
      repeat { split, },
      -- it remains to show the three properties of the interpolant
      { change voc θ ⊆ voc X1 ∩ voc X2,
        have inc1 : voc newX1 ⊆ voc X1, {
          intros a aIn, unfold voc vocabOfSetFormula finset.bUnion at *, simp at *,
          rcases aIn with ⟨ψ,psi_in_projX1⟩,
          { use □ψ, change □ψ ∈ X1 ∧ a ∈ voc □ψ, rw ← proj, tauto, },
        },
        have inc2 : voc newX2 ⊆ voc X2, {
          intros a aIn, unfold voc vocabOfSetFormula finset.bUnion at *, simp at *,
          rcases aIn with ⟨ψ,psi_in_projX1|psi_is_notPhi⟩,
          { use □ψ, change □ψ ∈ X2 ∧ a ∈ voc □ψ, rw ← proj, tauto, },
          { use ~□ϕ, subst psi_is_notPhi, tauto, }
        },
        intros a aIn, norm_num,
        specialize vocSub aIn, simp at vocSub,
        split,
        apply inc1, tauto,
        apply inc2, tauto,
      },
      all_goals { unfold satisfiable at *, },
      { by_contradiction hyp,
        rcases hyp with ⟨W,M,w,sat⟩,
        apply unsat1,
        use [W,M],
        --- we use ~□θ to get a different world:
        let othersat := sat (~□θ) (by simp ),
        unfold evaluate at othersat,
        simp at othersat,
        rcases othersat with ⟨v,rel_w_v,v_not_phi⟩,
        use v,
        intros ψ psi_in_newX1,
        simp at psi_in_newX1,
        cases psi_in_newX1,
        { subst psi_in_newX1, specialize sat (~□θ), unfold evaluate at *, simp at sat, tauto, },
        { rw proj at psi_in_newX1, specialize sat □ψ, unfold evaluate at sat, apply sat, simp, assumption, assumption, },
      },
      { by_contradiction hyp,
        rcases hyp with ⟨W,M,w,sat⟩,
        apply unsat2,
        use [W,M],
        --- we use ~□ϕ to get a different world:
        let othersat := sat (~□ϕ) (by { simp, assumption, }),
        unfold evaluate at othersat,
        simp at othersat,
        rcases othersat with ⟨v,rel_w_v,v_not_phi⟩,
        use v,
        intros ψ psi_in_newX2,
        simp at psi_in_newX2,
        cases psi_in_newX2,
        { rw psi_in_newX2, specialize sat □θ, simp at sat, unfold evaluate at sat, apply sat, assumption, },
        cases psi_in_newX2,
        { rw proj at psi_in_newX2, specialize sat □ψ, simp at sat, unfold evaluate at sat, apply sat, right, assumption, assumption, },
        { rw psi_in_newX2, unfold evaluate, assumption, },
      },
    },
  },
end

lemma tabToInt {X1 X2} : closedTableau (X1 ∪ X2) → ∃ θ, partInterpolant X1 X2 θ
| ctX := almostTabToInt ctX X1 X2 (refl _)


example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  repeat (first | constructor) <;> repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r s : Prop) (hp : p) : (p ∨ q ∨ r ∨ s) ∧ (q ∨ s ∨ p ∨ r) ∧ (s ∨ q ∨ r ∨ p) := by
  repeat (first | constructor) <;> repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  constructor
  . apply Or.inl
    assumption
  . constructor
    . apply Or.inr
      apply Or.inl
      assumption
    . apply Or.inr
      apply Or.inr
      assumption

example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  constructor
  any_goals constructor
  any_goals (repeat (first | apply Or.inl; assumption | apply Or.inr | assumption))

example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  constructor <;> try constructor <;> repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  repeat (first | constructor) <;> repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) ∧ (q ∨ p ∨ r) ∧ (q ∨ r ∨ p) := by
  constructor
  . repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)
  . constructor
    . repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)
    . repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r : Prop) (hp : p) : (p ∨ q ∨ r) := by
  repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r : Prop) (hp : p) : (q ∨ p ∨ r) := by
  repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)

example (p q r : Prop) (hp : p) : (q ∨ r ∨ p) := by
  repeat (first | apply Or.inl; assumption | apply Or.inr | assumption)


/-
Copyright (c) 2022 Floris van Doorn, Heather Macbeth. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Heather Macbeth

! This file was ported from Lean 3 source module geometry.manifold.vector_bundle.basic
! leanprover-community/mathlib commit 0187644979f2d3e10a06e916a869c994facd9a87
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Geometry.Manifold.VectorBundle.FiberwiseLinear
import Mathbin.Topology.VectorBundle.Constructions

/-! # Smooth vector bundles

This file defines smooth vector bundles over a smooth manifold.

Let `E` be a topological vector bundle, with model fiber `F` and base space `B`.  We consider `E` as
carrying a charted space structure given by its trivializations -- these are charts to `B × F`.
Then, by "composition", if `B` is itself a charted space over `H` (e.g. a smooth manifold), then `E`
is also a charted space over `H × F`

Now, we define `smooth_vector_bundle` as the `Prop` of having smooth transition functions.
Recall the structure groupoid `smooth_fiberwise_linear` on `B × F` consisting of smooth, fiberwise
linear local homeomorphisms.  We show that our definition of "smooth vector bundle" implies
`has_groupoid` for this groupoid, and show (by a "composition" of `has_groupoid` instances) that
this means that a smooth vector bundle is a smooth manifold.

Since `smooth_vector_bundle` is a mixin, it should be easy to make variants and for many such
variants to coexist -- vector bundles can be smooth vector bundles over several different base
fields, they can also be C^k vector bundles, etc.

## Main definitions and constructions

* `fiber_bundle.charted_space`: A fiber bundle `E` over a base `B` with model fiber `F` is naturally
  a charted space modelled on `B × F`.

* `fiber_bundle.charted_space'`: Let `B` be a charted space modelled on `HB`.  Then a fiber bundle
  `E` over a base `B` with model fiber `F` is naturally a charted space modelled on `HB.prod F`.

* `smooth_vector_bundle`: Mixin class stating that a (topological) `vector_bundle` is smooth, in the
  sense of having smooth transition functions.

* `smooth_fiberwise_linear.has_groupoid`: For a smooth vector bundle `E` over `B` with fiber
  modelled on `F`, the change-of-co-ordinates between two trivializations `e`, `e'` for `E`,
  considered as charts to `B × F`, is smooth and fiberwise linear, in the sense of belonging to the
  structure groupoid `smooth_fiberwise_linear`.

* `bundle.total_space.smooth_manifold_with_corners`: A smooth vector bundle is naturally a smooth
  manifold.

* `vector_bundle_core.smooth_vector_bundle`: If a (topological) `vector_bundle_core` is smooth, in
  the sense of having smooth transition functions, then the vector bundle constructed from it is a
  smooth vector bundle.

* `bundle.prod.smooth_vector_bundle`: The direct sum of two smooth vector bundles is a smooth vector
  bundle.
-/

assert_not_exists mfderiv

open Bundle Set LocalHomeomorph

open Function (id_def)

open Filter

open Manifold Bundle Topology

variable {𝕜 B B' F M : Type _} {E : B → Type _}

/-! ### Charted space structure on a fiber bundle -/

section

variable [TopologicalSpace F] [TopologicalSpace (TotalSpace E)] [∀ x, TopologicalSpace (E x)]
  {HB : Type _} [TopologicalSpace HB] [TopologicalSpace B] [ChartedSpace HB B] [FiberBundle F E]

/-- A fiber bundle `E` over a base `B` with model fiber `F` is naturally a charted space modelled on
`B × F`. -/
instance FiberBundle.chartedSpace : ChartedSpace (B × F) (TotalSpace E)
    where
  atlas := (fun e : Trivialization F (π E) => e.toLocalHomeomorph) '' trivializationAtlas F E
  chartAt x := (trivializationAt F E x.proj).toLocalHomeomorph
  mem_chart_source x :=
    (trivializationAt F E x.proj).mem_source.mpr (mem_baseSet_trivializationAt F E x.proj)
  chart_mem_atlas x := mem_image_of_mem _ (trivialization_mem_atlas F E _)
#align fiber_bundle.charted_space FiberBundle.chartedSpace

section

attribute [local reducible] ModelProd

/-- Let `B` be a charted space modelled on `HB`.  Then a fiber bundle `E` over a base `B` with model
fiber `F` is naturally a charted space modelled on `HB.prod F`. -/
instance FiberBundle.chartedSpace' : ChartedSpace (ModelProd HB F) (TotalSpace E) :=
  ChartedSpace.comp _ (ModelProd B F) _
#align fiber_bundle.charted_space' FiberBundle.chartedSpace'

end

theorem FiberBundle.chartedSpace_chartAt (x : TotalSpace E) :
    chartAt (ModelProd HB F) x =
      (trivializationAt F E x.proj).toLocalHomeomorph ≫ₕ
        (chartAt HB x.proj).Prod (LocalHomeomorph.refl F) :=
  by
  dsimp only [FiberBundle.chartedSpace', ChartedSpace.comp, FiberBundle.chartedSpace,
    prodChartedSpace, chartedSpaceSelf]
  rw [Trivialization.coe_coe, Trivialization.coe_fst' _ (mem_base_set_trivialization_at F E x.proj)]
#align fiber_bundle.charted_space_chart_at FiberBundle.chartedSpace_chartAt

theorem FiberBundle.chartedSpace_chartAt_symm_fst (x : TotalSpace E) (y : ModelProd HB F)
    (hy : y ∈ (chartAt (ModelProd HB F) x).target) :
    ((chartAt (ModelProd HB F) x).symm y).proj = (chartAt HB x.proj).symm y.1 :=
  by
  simp only [FiberBundle.chartedSpace_chartAt, mfld_simps] at hy⊢
  exact (trivialization_at F E x.proj).proj_symm_apply hy.2
#align fiber_bundle.charted_space_chart_at_symm_fst FiberBundle.chartedSpace_chartAt_symm_fst

end

section

variable [NontriviallyNormedField 𝕜] [NormedAddCommGroup F] [NormedSpace 𝕜 F]
  [TopologicalSpace (TotalSpace E)] [∀ x, TopologicalSpace (E x)] {EB : Type _}
  [NormedAddCommGroup EB] [NormedSpace 𝕜 EB] {HB : Type _} [TopologicalSpace HB]
  (IB : ModelWithCorners 𝕜 EB HB) (E' : B → Type _) [∀ x, Zero (E' x)] {EM : Type _}
  [NormedAddCommGroup EM] [NormedSpace 𝕜 EM] {HM : Type _} [TopologicalSpace HM]
  {IM : ModelWithCorners 𝕜 EM HM} [TopologicalSpace M] [ChartedSpace HM M]
  [Is : SmoothManifoldWithCorners IM M] {n : ℕ∞}

variable [TopologicalSpace B] [ChartedSpace HB B] [FiberBundle F E]

protected theorem FiberBundle.extChartAt (x : TotalSpace E) :
    extChartAt (IB.Prod 𝓘(𝕜, F)) x =
      (trivializationAt F E x.proj).toLocalEquiv ≫
        (extChartAt IB x.proj).Prod (LocalEquiv.refl F) :=
  by
  simp_rw [extChartAt, FiberBundle.chartedSpace_chartAt, extend]
  simp only [LocalEquiv.trans_assoc, mfld_simps]
#align fiber_bundle.ext_chart_at FiberBundle.extChartAt

/-! ### Smoothness of maps in/out fiber bundles

Note: For these results we don't need that the bundle is a smooth vector bundle, or even a vector
bundle at all, just that it is a fiber bundle over a charted base space.
-/

namespace Bundle

variable {F E IB}

/-- Characterization of C^n functions into a smooth vector bundle. -/
theorem contMdiffWithinAt_totalSpace (f : M → TotalSpace E) {s : Set M} {x₀ : M} :
    ContMdiffWithinAt IM (IB.Prod 𝓘(𝕜, F)) n f s x₀ ↔
      ContMdiffWithinAt IM IB n (fun x => (f x).proj) s x₀ ∧
        ContMdiffWithinAt IM 𝓘(𝕜, F) n (fun x => (trivializationAt F E (f x₀).proj (f x)).2) s x₀ :=
  by
  simp (config := { singlePass := true }) only [contMdiffWithinAt_iff_target]
  rw [and_and_and_comm, ← continuous_within_at_total_space, and_congr_right_iff]
  intro hf
  simp_rw [modelWithCornersSelf_prod, FiberBundle.extChartAt, Function.comp, LocalEquiv.trans_apply,
    LocalEquiv.prod_coe, LocalEquiv.refl_coe, extChartAt_self_apply, modelWithCornersSelf_coe,
    id_def]
  refine' (contMdiffWithinAt_prod_iff _).trans _
  -- rw doesn't do this?
  have h1 : (fun x => (f x).proj) ⁻¹' (trivialization_at F E (f x₀).proj).baseSet ∈ 𝓝[s] x₀ :=
    ((continuous_proj F E).ContinuousWithinAt.comp hf (maps_to_image f s)).preimage_mem_nhdsWithin
      ((Trivialization.open_baseSet _).mem_nhds (mem_base_set_trivialization_at F E _))
  refine'
    and_congr (eventually_eq.cont_mdiff_within_at_iff (eventually_of_mem h1 fun x hx => _) _)
      Iff.rfl
  · simp_rw [Function.comp, LocalHomeomorph.coe_coe, Trivialization.coe_coe]
    rw [Trivialization.coe_fst']
    exact hx
  · simp only [mfld_simps]
#align bundle.cont_mdiff_within_at_total_space Bundle.contMdiffWithinAt_totalSpace

/-- Characterization of C^n functions into a smooth vector bundle. -/
theorem contMdiffAt_totalSpace (f : M → TotalSpace E) (x₀ : M) :
    ContMdiffAt IM (IB.Prod 𝓘(𝕜, F)) n f x₀ ↔
      ContMdiffAt IM IB n (fun x => (f x).proj) x₀ ∧
        ContMdiffAt IM 𝓘(𝕜, F) n (fun x => (trivializationAt F E (f x₀).proj (f x)).2) x₀ :=
  by
  simp_rw [← contMdiffWithinAt_univ]
  exact cont_mdiff_within_at_total_space f
#align bundle.cont_mdiff_at_total_space Bundle.contMdiffAt_totalSpace

variable (E)

theorem contMdiff_proj : ContMdiff (IB.Prod 𝓘(𝕜, F)) IB n (π E) :=
  by
  intro x
  rw [ContMdiffAt, contMdiffWithinAt_iff']
  refine' ⟨(continuous_proj F E).ContinuousWithinAt, _⟩
  simp_rw [(· ∘ ·), FiberBundle.extChartAt]
  apply cont_diff_within_at_fst.congr
  · rintro ⟨a, b⟩ hab
    simp only [mfld_simps] at hab
    have : ((chart_at HB x.1).symm (IB.symm a), b) ∈ (trivialization_at F E x.fst).target := by
      simp only [hab, mfld_simps]
    simp only [Trivialization.proj_symm_apply _ this, hab, mfld_simps]
  · simp only [mfld_simps]
#align bundle.cont_mdiff_proj Bundle.contMdiff_proj

theorem smooth_proj : Smooth (IB.Prod 𝓘(𝕜, F)) IB (π E) :=
  contMdiff_proj E
#align bundle.smooth_proj Bundle.smooth_proj

theorem contMdiffOn_proj {s : Set (TotalSpace E)} : ContMdiffOn (IB.Prod 𝓘(𝕜, F)) IB n (π E) s :=
  (Bundle.contMdiff_proj E).ContMdiffOn
#align bundle.cont_mdiff_on_proj Bundle.contMdiffOn_proj

theorem smoothOn_proj {s : Set (TotalSpace E)} : SmoothOn (IB.Prod 𝓘(𝕜, F)) IB (π E) s :=
  contMdiffOn_proj E
#align bundle.smooth_on_proj Bundle.smoothOn_proj

theorem contMdiffAt_proj {p : TotalSpace E} : ContMdiffAt (IB.Prod 𝓘(𝕜, F)) IB n (π E) p :=
  (Bundle.contMdiff_proj E).ContMdiffAt
#align bundle.cont_mdiff_at_proj Bundle.contMdiffAt_proj

theorem smoothAt_proj {p : TotalSpace E} : SmoothAt (IB.Prod 𝓘(𝕜, F)) IB (π E) p :=
  Bundle.contMdiffAt_proj E
#align bundle.smooth_at_proj Bundle.smoothAt_proj

theorem contMdiffWithinAt_proj {s : Set (TotalSpace E)} {p : TotalSpace E} :
    ContMdiffWithinAt (IB.Prod 𝓘(𝕜, F)) IB n (π E) s p :=
  (Bundle.contMdiffAt_proj E).ContMdiffWithinAt
#align bundle.cont_mdiff_within_at_proj Bundle.contMdiffWithinAt_proj

theorem smoothWithinAt_proj {s : Set (TotalSpace E)} {p : TotalSpace E} :
    SmoothWithinAt (IB.Prod 𝓘(𝕜, F)) IB (π E) s p :=
  Bundle.contMdiffWithinAt_proj E
#align bundle.smooth_within_at_proj Bundle.smoothWithinAt_proj

variable (𝕜 E) [∀ x, AddCommMonoid (E x)] [∀ x, Module 𝕜 (E x)] [VectorBundle 𝕜 F E]

theorem smooth_zeroSection : Smooth IB (IB.Prod 𝓘(𝕜, F)) (zeroSection E) :=
  by
  intro x
  rw [Bundle.contMdiffAt_totalSpace]
  refine' ⟨contMdiffAt_id, cont_mdiff_at_const.congr_of_eventually_eq _⟩
  · exact 0
  refine'
    eventually_of_mem
      ((trivialization_at F E x).open_baseSet.mem_nhds (mem_base_set_trivialization_at F E x))
      fun x' hx' => _
  simp_rw [zero_section_proj, (trivialization_at F E x).zeroSection 𝕜 hx']
#align bundle.smooth_zero_section Bundle.smooth_zeroSection

end Bundle

end

/-! ### Smooth vector bundles -/

variable [NontriviallyNormedField 𝕜] [∀ x, AddCommMonoid (E x)] [∀ x, Module 𝕜 (E x)]
  [NormedAddCommGroup F] [NormedSpace 𝕜 F] [TopologicalSpace (TotalSpace E)]
  [∀ x, TopologicalSpace (E x)] {EB : Type _} [NormedAddCommGroup EB] [NormedSpace 𝕜 EB]
  {HB : Type _} [TopologicalSpace HB] (IB : ModelWithCorners 𝕜 EB HB) [TopologicalSpace B]
  [ChartedSpace HB B] [SmoothManifoldWithCorners IB B] {EM : Type _} [NormedAddCommGroup EM]
  [NormedSpace 𝕜 EM] {HM : Type _} [TopologicalSpace HM] {IM : ModelWithCorners 𝕜 EM HM}
  [TopologicalSpace M] [ChartedSpace HM M] [Is : SmoothManifoldWithCorners IM M] {n : ℕ∞}

variable (F E) [FiberBundle F E] [VectorBundle 𝕜 F E]

/-- When `B` is a smooth manifold with corners with respect to a model `IB` and `E` is a
topological vector bundle over `B` with fibers isomorphic to `F`, then `smooth_vector_bundle F E IB`
registers that the bundle is smooth, in the sense of having smooth transition functions.
This is a mixin, not carrying any new data`. -/
class SmoothVectorBundle : Prop where
  smoothOn_coord_change :
    ∀ (e e' : Trivialization F (π E)) [MemTrivializationAtlas e] [MemTrivializationAtlas e'],
      SmoothOn IB 𝓘(𝕜, F →L[𝕜] F) (fun b : B => (e.coordChangeL 𝕜 e' b : F →L[𝕜] F))
        (e.baseSet ∩ e'.baseSet)
#align smooth_vector_bundle SmoothVectorBundle

export SmoothVectorBundle (smoothOn_coord_change)

variable [SmoothVectorBundle F E IB]

/-- For a smooth vector bundle `E` over `B` with fiber modelled on `F`, the change-of-co-ordinates
between two trivializations `e`, `e'` for `E`, considered as charts to `B × F`, is smooth and
fiberwise linear. -/
instance : HasGroupoid (TotalSpace E) (smoothFiberwiseLinear B F IB)
    where compatible := by
    rintro _ _ ⟨e, he, rfl⟩ ⟨e', he', rfl⟩
    haveI : MemTrivializationAtlas e := ⟨he⟩
    haveI : MemTrivializationAtlas e' := ⟨he'⟩
    skip
    rw [mem_smoothFiberwiseLinear_iff]
    refine' ⟨_, _, e.open_base_set.inter e'.open_base_set, smooth_on_coord_change e e', _, _, _⟩
    · rw [inter_comm]
      apply ContMdiffOn.congr (smooth_on_coord_change e' e)
      · intro b hb
        rw [e.symm_coord_changeL e' hb]
      · infer_instance
      · infer_instance
    ·
      simp only [e.symm_trans_source_eq e', FiberwiseLinear.localHomeomorph, trans_to_local_equiv,
        symm_to_local_equiv]
    · rintro ⟨b, v⟩ hb
      have hb' : b ∈ e.base_set ∩ e'.base_set := by
        simpa only [trans_to_local_equiv, symm_to_local_equiv, e.symm_trans_source_eq e',
          coe_coe_symm, prod_mk_mem_set_prod_eq, mem_univ, and_true_iff] using hb
      exact e.apply_symm_apply_eq_coord_changeL e' hb' v

/-- A smooth vector bundle `E` is naturally a smooth manifold. -/
instance : SmoothManifoldWithCorners (IB.Prod 𝓘(𝕜, F)) (TotalSpace E) :=
  by
  refine' { StructureGroupoid.HasGroupoid.comp (smoothFiberwiseLinear B F IB) _ with }
  intro e he
  rw [mem_smoothFiberwiseLinear_iff] at he
  obtain ⟨φ, U, hU, hφ, h2φ, heφ⟩ := he
  rw [is_local_structomorph_on_contDiffGroupoid_iff]
  refine' ⟨ContMdiffOn.congr _ heφ.eq_on, ContMdiffOn.congr _ heφ.symm'.eq_on⟩
  · rw [heφ.source_eq]
    apply smooth_on_fst.prod_mk
    exact (hφ.comp contMdiffOn_fst <| prod_subset_preimage_fst _ _).clm_apply contMdiffOn_snd
  · rw [heφ.target_eq]
    apply smooth_on_fst.prod_mk
    exact (h2φ.comp contMdiffOn_fst <| prod_subset_preimage_fst _ _).clm_apply contMdiffOn_snd

/-! ### Core construction for smooth vector bundles -/

namespace VectorBundleCore

variable {ι : Type _} {F} (Z : VectorBundleCore 𝕜 B F ι)

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`smoothOn_coord_change] [] -/
/-- Mixin for a `vector_bundle_core` stating smoothness (of transition functions). -/
class IsSmooth (IB : ModelWithCorners 𝕜 EB HB) : Prop where
  smoothOn_coord_change :
    ∀ i j, SmoothOn IB 𝓘(𝕜, F →L[𝕜] F) (Z.coordChange i j) (Z.baseSet i ∩ Z.baseSet j)
#align vector_bundle_core.is_smooth VectorBundleCore.IsSmooth

/- ./././Mathport/Syntax/Translate/Command.lean:234:13: unsupported: advanced export style -/
export IsSmooth ()

variable [Z.IsSmooth IB]

/-- If a `vector_bundle_core` has the `is_smooth` mixin, then the vector bundle constructed from it
is a smooth vector bundle. -/
instance smoothVectorBundle : SmoothVectorBundle F Z.Fiber IB
    where smoothOn_coord_change := by
    rintro - - ⟨i, rfl⟩ ⟨i', rfl⟩
    refine' (Z.smooth_on_coord_change IB i i').congr fun b hb => _
    ext v
    exact Z.local_triv_coord_change_eq i i' hb v
#align vector_bundle_core.smooth_vector_bundle VectorBundleCore.smoothVectorBundle

end VectorBundleCore

/-! ### The trivial smooth vector bundle -/

/-- A trivial vector bundle over a smooth manifold is a smooth vector bundle. -/
instance Bundle.Trivial.smoothVectorBundle : SmoothVectorBundle F (Bundle.Trivial B F) IB
    where smoothOn_coord_change := by
    intro e e' he he'
    obtain rfl := Bundle.Trivial.eq_trivialization B F e
    obtain rfl := Bundle.Trivial.eq_trivialization B F e'
    simp_rw [Bundle.Trivial.trivialization.coordChangeL]
    exact smooth_const.smooth_on
#align bundle.trivial.smooth_vector_bundle Bundle.Trivial.smoothVectorBundle

/-! ### Direct sums of smooth vector bundles -/

section Prod

variable (F₁ : Type _) [NormedAddCommGroup F₁] [NormedSpace 𝕜 F₁] (E₁ : B → Type _)
  [TopologicalSpace (TotalSpace E₁)] [∀ x, AddCommMonoid (E₁ x)] [∀ x, Module 𝕜 (E₁ x)]

variable (F₂ : Type _) [NormedAddCommGroup F₂] [NormedSpace 𝕜 F₂] (E₂ : B → Type _)
  [TopologicalSpace (TotalSpace E₂)] [∀ x, AddCommMonoid (E₂ x)] [∀ x, Module 𝕜 (E₂ x)]

variable [∀ x : B, TopologicalSpace (E₁ x)] [∀ x : B, TopologicalSpace (E₂ x)] [FiberBundle F₁ E₁]
  [FiberBundle F₂ E₂] [VectorBundle 𝕜 F₁ E₁] [VectorBundle 𝕜 F₂ E₂] [SmoothVectorBundle F₁ E₁ IB]
  [SmoothVectorBundle F₂ E₂ IB]

/-- The direct sum of two smooth vector bundles over the same base is a smooth vector bundle. -/
instance Bundle.Prod.smoothVectorBundle : SmoothVectorBundle (F₁ × F₂) (E₁ ×ᵇ E₂) IB
    where smoothOn_coord_change :=
    by
    rintro _ _ ⟨e₁, e₂, i₁, i₂, rfl⟩ ⟨e₁', e₂', i₁', i₂', rfl⟩
    skip
    rw [SmoothOn]
    refine' ContMdiffOn.congr _ (e₁.coord_changeL_prod 𝕜 e₁' e₂ e₂')
    refine' ContMdiffOn.clm_prodMap _ _
    · refine' (smooth_on_coord_change e₁ e₁').mono _
      simp only [Trivialization.baseSet_prod, mfld_simps]
      mfld_set_tac
    · refine' (smooth_on_coord_change e₂ e₂').mono _
      simp only [Trivialization.baseSet_prod, mfld_simps]
      mfld_set_tac
#align bundle.prod.smooth_vector_bundle Bundle.Prod.smoothVectorBundle

end Prod


/-
Copyright (c) 2022 Joël Riou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joël Riou
-/

import algebra.homology.homotopy
import for_mathlib.dold_kan.notations

/-!

# Construction of homotopies for the Dold-Kan correspondence

TODO (@joelriou) continue adding the various files referenced below

(The general strategy of proof of the Dold-Kan correspondence is explained
in `equivalence.lean`.)

The purpose of the files `homotopies.lean`, `faces.lean`, `projections.lean`
and `p_infty.lean` is to construct an idempotent endomorphism
`P_infty : K[X] ⟶ K[X]` of the alternating face map complex
for each `X : simplicial_object C` when `C` is a preadditive category.
In the case `C` is abelian, this `P_infty` shall be the projection on the
normalized Moore subcomplex of `K[X]` associated to the decomposition of the
complex `K[X]` as a direct sum of this normalized subcomplex and of the
degenerate subcomplex.

In `p_infty.lean`, this endomorphism `P_infty` shall be obtained by
passing to the limit idempotent endomorphisms `P q` for all `(q : ℕ)`.
These endomorphisms `P q` are defined by induction. The idea is to
start from the identity endomorphism `P 0` of `K[X]` and to ensure by
induction that the `q` higher face maps (except $d_0$) vanish on the
image of `P q`. Then, in a certain degree `n`, the image of `P q` for
a big enough `q` will be contained in the normalized subcomplex. This
construction is done in `projections.lean`.

It would be easy to define the `P q` degreewise (similarly as it is done
in *Simplicial Homotopy Theory* by Goerrs-Jardine p. 149), but then we would
have to prove that they are compatible with the differential (i.e. they
are chain complex maps), and also that they are homotopic to the identity.
These two verifications are quite technical. In order to reduce the number
of such technical lemmas, the strategy that is followed here is to define
a series of null homotopic maps `Hσ q` (attached to families of maps `hσ`)
and use these in order to construct `P q` : the endomorphisms `P q`
shall basically be obtained by altering the identity endomorphism by adding
null homotopic maps, so that we get for free that they are morphisms
of chain complexes and that they are homotopic to the identity. The most
technical verifications that are needed about the null homotopic maps `Hσ`
are obtained in `faces.lean`.

In this file `homotopies.lean`, we define the null homotopic maps
`Hσ q : K[X] ⟶ K[X]`, show that they are natural (see `nat_trans_Hσ`) and
compatible the application of additive functors (see `map_Hσ`).

## References
* [Albrecht Dold, *Homology of Symmetric Products and Other Functors of Complexes*][dold1958]
* [Paul G. Goerss, John F. Jardine, *Simplical Homotopy Theory*][goerss-jardine-2009]

-/

open category_theory
open category_theory.category
open category_theory.limits
open category_theory.preadditive
open category_theory.simplicial_object
open homotopy
open opposite
open_locale simplicial dold_kan

noncomputable theory

namespace algebraic_topology

namespace dold_kan

variables {C : Type*} [category C] [preadditive C]
variables {X : simplicial_object C}

/-- As we are using chain complexes indexed by `ℕ`, we shall need the relation
`c` such `c m n` if and only if `n+1=m`. -/
abbreviation c := complex_shape.down ℕ

/-- Helper when we need some `c.rel i j` (i.e. `complex_shape.down ℕ`),
e.g. `c_mk n (n+1) rfl` -/
lemma c_mk (i j : ℕ) (h : j+1 = i) : c.rel i j :=
complex_shape.down_mk i j h

/-- This lemma is meant to be used with `null_homotopic_map'_f_of_not_rel_left` -/
lemma cs_down_0_not_rel_left (j : ℕ) : ¬c.rel 0 j :=
begin
  intro hj,
  dsimp at hj,
  apply nat.not_succ_le_zero j,
  rw [nat.succ_eq_add_one, hj],
end

/-- The sequence of maps which gives the null homotopic maps `Hσ` that shall be in
the inductive construction of the projections `P q : K[X] ⟶ K[X]` -/
def hσ (q : ℕ) (n : ℕ) : X _[n] ⟶ X _[n+1] :=
if n<q
  then 0
  else (-1 : ℤ)^(n-q) • X.σ ⟨n-q, nat.sub_lt_succ n q⟩

/-- We can turn `hσ` into a datum that can be passed to `null_homotopic_map'`. -/
def hσ' (q : ℕ) : Π n m, c.rel m n → (K[X].X n ⟶ K[X].X m) :=
λ n m hnm, (hσ q n) ≫ eq_to_hom (by congr')

lemma hσ'_eq_zero {q n m : ℕ} (hnq : n<q) (hnm : c.rel m n) :
  (hσ' q n m hnm : X _[n] ⟶ X _[m])= 0 :=
by { simp only [hσ', hσ], split_ifs, exact zero_comp, }

lemma hσ'_eq {q n a m : ℕ} (ha : n=a+q) (hnm : c.rel m n) :
  (hσ' q n m hnm : X _[n] ⟶ X _[m]) =
  ((-1 : ℤ)^a • X.σ ⟨a, nat.lt_succ_iff.mpr (nat.le.intro (eq.symm ha))⟩) ≫
      eq_to_hom (by congr') :=
begin
  simp only [hσ', hσ],
  split_ifs,
  { exfalso, linarith, },
  { have h' := tsub_eq_of_eq_add ha,
    congr', }
end

lemma hσ'_eq' {q n a : ℕ} (ha : n=a+q) :
  (hσ' q n (n+1) rfl : X _[n] ⟶ X _[n+1]) =
  (-1 : ℤ)^a • X.σ ⟨a, nat.lt_succ_iff.mpr (nat.le.intro (eq.symm ha))⟩ :=
by rw [hσ'_eq ha rfl, eq_to_hom_refl, comp_id]

/-- The null homotopic map $(hσ q) ∘ d + d ∘ (hσ q)$ -/
def Hσ (q : ℕ) : K[X] ⟶ K[X] := null_homotopic_map' (hσ' q)

/-- `Hσ` is null homotopic -/
def homotopy_Hσ_to_zero (q : ℕ) : homotopy (Hσ q : K[X] ⟶ K[X]) 0 :=
null_homotopy' (hσ' q)

/-- In degree `0`, the null homotopic map `Hσ` is zero. -/
lemma Hσ_eq_zero (q : ℕ) : (Hσ q : K[X] ⟶ K[X]).f 0 = 0  :=
begin
  unfold Hσ,
  rw null_homotopic_map'_f_of_not_rel_left (c_mk 1 0 rfl) cs_down_0_not_rel_left,
  cases q,
  { rw hσ'_eq (show 0=0+0, by refl) (c_mk 1 0 rfl),
    simp only [pow_zero, fin.mk_zero, one_zsmul, eq_to_hom_refl, category.comp_id],
    erw chain_complex.of_d,
    simp only [alternating_face_map_complex.obj_d, fin.sum_univ_two,
      fin.coe_zero, pow_zero, one_zsmul, fin.coe_one, pow_one, comp_add,
      neg_smul, one_zsmul, comp_neg, add_neg_eq_zero],
    erw [δ_comp_σ_self, δ_comp_σ_succ], },
  { rw [hσ'_eq_zero (nat.succ_pos q) (c_mk 1 0 rfl), zero_comp], },
end

/-- The maps `hσ' q n m hnm` are natural on the simplicial object -/
lemma hσ'_naturality (q : ℕ) (n m : ℕ) (hnm : c.rel m n)
  {X Y : simplicial_object C} (f : X ⟶ Y) :
  f.app (op [n]) ≫ hσ' q n m hnm = hσ' q n m hnm ≫ f.app (op [m]) :=
begin
  have h : n+1 = m := hnm,
  subst h,
  simp only [hσ', eq_to_hom_refl, comp_id],
  unfold hσ,
  split_ifs,
  { rw [zero_comp, comp_zero], },
  { simp only [zsmul_comp, comp_zsmul],
    erw f.naturality,
    refl, },
end

/-- For each q, `Hσ q` is a natural transformation. -/
def nat_trans_Hσ (q : ℕ) :
  alternating_face_map_complex C ⟶ alternating_face_map_complex C :=
{ app := λ X, Hσ q,
  naturality' := λ X Y f, begin
    unfold Hσ,
    rw [null_homotopic_map'_comp, comp_null_homotopic_map'],
    congr,
    ext n m hnm,
    simp only [alternating_face_map_complex_map_f, hσ'_naturality],
  end, }

/-- The maps `hσ' q n m hnm` are compatible with the application of additive functors. -/
lemma map_hσ' {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C)
  (q n m : ℕ) (hnm : c.rel m n) :
  (hσ' q n m hnm : K[((whiskering _ _).obj G).obj X].X n ⟶ _) =
    G.map (hσ' q n m hnm : K[X].X n ⟶ _) :=
begin
  unfold hσ' hσ,
  split_ifs,
  { simp only [functor.map_zero, zero_comp], },
  { simpa only [eq_to_hom_map, functor.map_comp, functor.map_zsmul], },
end

/-- The null homotopic maps `Hσ` are compatible with the application of additive functors. -/
lemma map_Hσ {D : Type*} [category D] [preadditive D]
  (G : C ⥤ D) [G.additive] (X : simplicial_object C) (q n : ℕ) :
  (Hσ q : K[((whiskering C D).obj G).obj X] ⟶ _).f n =
    G.map ((Hσ q : K[X] ⟶ _).f n) :=
begin
  unfold Hσ,
  have eq := homological_complex.congr_hom (map_null_homotopic_map' G (hσ' q)) n,
  simp only [functor.map_homological_complex_map_f, ← map_hσ'] at eq,
  rw eq,
  let h := (functor.congr_obj (map_alternating_face_map_complex G) X).symm,
  congr',
end

end dold_kan

end algebraic_topology


section transport
universes u v
def eq.transport {A : Type u} (B : A → Type v) {a a' : A}
  : a = a' → B a → B a' := by { intros, cases a_1, assumption, }
lemma heq_transport {A : Type u} (B : A → Type v) {a b : A} (p : a = b)
  : ∀ b : B a, b == eq.transport B p b := by { intros, cases p, refl }
end transport
section transport_inj
universes u v w

lemma inj_implies_transport_inj {A : Type u} (B : A → Type v)
                                (C : A → Type w) {a a' : A}
                                (p : a = a')
  : ∀ f : B a → C a,
    function.injective f
    → function.injective (eq.transport (λ x, B x → C x) p f) :=
by { cases p, simp [eq.transport], intro, exact id }

lemma heq.funext1 {A : Type u} (B : Type v)
                               (C : A → Type w) {a a' : A}
                               (p : a = a')
  : ∀ (f : B → C a) (g : B → C a'), (∀ x, f x == g x) → f == g :=
by { cases p, intros, apply heq_of_eq, funext, apply eq_of_heq (a_1 x) }

lemma dep_fn_eq_of_heq
  {A : Type u} (B : A → Type v)
  (C : Type w) (f : Π x : A, B x → C)
  {a a' : A} {b : B a} {b' : B a'}
  : a = a' → b == b' → f a b = f a' b' :=
by { intro p, cases p, intro p', cases eq_of_heq p', refl }

lemma fin.funext (C : Type w) {n k : nat}
                 (p : n = k)
  : ∀ (f : fin n → C) (g : fin k → C),
      (∀ x : fin n, f x = g ⟨x.val, p ▸ x.is_lt⟩) → f == g :=
by { cases p, intros, apply heq_of_eq, funext, rw a x, congr, apply fin.eq_of_veq, refl }

lemma heq.funext {A : Type u} (B : A → Type v)
                              (C : Type w) {a a' : A}
                              (p : a = a')
  : (B a → false) → ∀ (f : B a → C) (g : B a' → C), f == g :=
by { cases p, intros,
     rw (_ : f = (λ b, false.elim (a_1 b))),
     rw (_ : g = (λ b, false.elim (a_1 b))),
     all_goals { funext, exfalso, exact a_1 x }, }

lemma sigma_eq_of_heq {A : Type u} (B : A → Type v)
                    : ∀ (a a' : A) (p : a = a')
                        (b : B a) (b' : B a'),
                      b == b' → sigma.mk a b = sigma.mk a' b' :=
by { intros, congr; assumption }
end transport_inj


import Src.Prover.Pair

namespace prover
noncomputable section

def fn (A : Set) (f : Set → Set) : Set :=
image A # λ b => pair b (f b)

section open Lean
macro "FN " "(" a:explicitBinders "∈" b:term ")" "," f:term : term =>
expandExplicitBinders ``id a f >>= λ v => `(fn $b $v) end

def app (f a : Set) : Set :=
someu # λ b => pair a b ∈ f

infixl:100 (priority := high) " ~ " => app

theorem exiu_fn_ret {A : Set} {f : Set → Set} {a : Set} (h : a ∈ A) :
  ∃! b, pair a b ∈ FN (x ∈ A), f x :=
exiu_intro (f a) (mpr mem_image # exi_intro a # and_intro h rfl)
(λ b h₁ => exi_elim (mp mem_image h₁) # λ c h₂ =>
and_elim (mp pair_ext # and_right h₂) # λ h₃ h₄ =>
eq_rec (λ x => b = f x) h₃ # eq_symm h₄)

theorem fn_app {A : Set} {f : Set → Set} {a : Set} (h : a ∈ A) :
  (FN (x ∈ A), f x) ~ a = f a :=
hv (@someu_spec _ _ (λ b => pair a b ∈ FN (x ∈ A), f x) # exiu_fn_ret h) #
λ h₁ => exi_elim (mp mem_image h₁) # λ x h₂ =>
and_elim (mp pair_ext # and_right h₂) # λ h₃ h₄ =>
eq_rec (λ x => fn A f ~ a = f x) h₃ # eq_symm h₄


import rnd_var

import to_mathlib_maybe.Hilbert_space
import to_mathlib_maybe.pTrace
import state

variables
{ι : Type} [fintype ι] [decidable_eq ι]
{ℋ : Type} [complex_hilbert_space ℋ]
{ρ : module.End ℂ ℋ} [quantum_state ρ]
{n m d : ℕ} -- dim S, S' and R
{V : ι → unitary_group ℋ}
{p : ι → ℝ} [rnd_var p]

open_locale tensor_product big_operators

def E (i j : ι) : module.End ℂ ℋ := sorry -- d×d matrix with 1 at (i j) and 0 otherwise
notation `|`i`⟩⟨`j`|` := E i j

def V' := ∑ i : ι, (V i) ⊗ |i⟩⟨i|

def σ := ∑ i : ι, (p i) • |i⟩⟨i|

def C (ρ) := Tr₂(V' ∘ ρ ⊗ σ ∘ V†)
-- def C (ρ) : ∑ i, (p i) * (V i) ∘ ρ ∘ (V i)† -- double check this

-- TODO partial trace is undefined for entangled states

/--
"The final Lemma that we require provides a way to us to
get rid of unwanted coherences (arising from Lemma 4) in the
final state without correlating the catalyst internally (which
would spoil the catalyst"
-/
lemma correlations_dont_propagate :
Tr₁ ((V ⊗ 1) ∘ ρ ⊗ σ ∘ (V ⊗ 1)†) = Tr₁(ρ) ⊗ σ :=
begin
    -- nice, the proof is short.
    calc _
         ... = ∑ i, (p i) * Tr₁ ((V ⊗ 1) ∘ ρ_SS' ∘ (V ⊗ 1)†) ⊗ |i⟩⟨i| : by sorry
         ... = ∑ i, (p i) * ρ_S' ⊗ |i⟩⟨i| : by sorry
         ... = _ : by sorry,
end


/-
Copyright (c) 2022 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang, Eric Wieser

From: https://github.com/leanprover-community/mathlib/blob/6b93ea7e4bbe7822960e821141e5a931537cd755/src/ring_theory/graded_algebra/radical.lean
-/

import .homogeneous_ideal

/-!

This file contains a proof that the radical of any homogeneous ideal is a homogeneous ideal

## Main statements

* `ideal.is_homogeneous.is_prime_iff`: for any `I : ideal A`, if `I` is homogeneous, then
  `I` is prime if and only if `I` is homogeneously prime, i.e. `I ≠ ⊤` and if `x, y` are
  homogeneous elements such that `x * y ∈ I`, then at least one of `x,y` is in `I`.
* `ideal.is_prime.homogeneous_core`: for any `I : ideal A`, if `I` is prime, then
  `I.homogeneous_core 𝒜` (i.e. the largest homogeneous ideal contained in `I`) is also prime.
* `ideal.is_homogeneous.radical`: for any `I : ideal A`, if `I` is homogeneous, then the
  radical of `I` is homogeneous as well.
* `homogeneous_ideal.radical`: for any `I : homogeneous_ideal 𝒜`, `I.radical` is the the
  radical of `I` as a `homogeneous_ideal 𝒜`

## Implementation details

Throughout this file, the indexing type `ι` of grading is assumed to be a
`linear_ordered_cancel_add_comm_monoid`. This might be stronger than necessary but cancelling
property is strictly necessary; for a counterexample of how `ideal.is_homogeneous.is_prime_iff`
fails for a non-cancellative set see `counterexample/homogeneous_prime_not_prime.lean`.

## Tags

homogeneous, radical
-/

open graded_ring direct_sum set_like finset
open_locale big_operators

variables {ι σ A : Type*}
variables [comm_ring A]
variables [linear_ordered_cancel_add_comm_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] {𝒜 : ι → σ} [graded_ring 𝒜]
include A

lemma ideal.is_homogeneous.is_prime_of_homogeneous_mem_or_mem
  {I : ideal A} (hI : I.is_homogeneous 𝒜) (I_ne_top : I ≠ ⊤)
  (homogeneous_mem_or_mem : ∀ {x y : A},
    is_homogeneous 𝒜 x → is_homogeneous 𝒜 y → (x * y ∈ I → x ∈ I ∨ y ∈ I)) :
  ideal.is_prime I :=
⟨I_ne_top, begin
  intros x y hxy,
  by_contradiction rid,
  obtain ⟨rid₁, rid₂⟩ := not_or_distrib.mp rid,
  /-
  The idea of the proof is the following :
  since `x * y ∈ I` and `I` homogeneous, then `proj i (x * y) ∈ I` for any `i : ι`.
  Then consider two sets `{i ∈ x.support | xᵢ ∉ I}` and `{j ∈ y.support | yⱼ ∉ J}`;
  let `max₁, max₂` be the maximum of the two sets, then `proj (max₁ + max₂) (x * y) ∈ I`.
  Then, `proj max₁ x ∉ I` and `proj max₂ j ∉ I`
  but `proj i x ∈ I` for all `max₁ < i` and `proj j y ∈ I` for all `max₂ < j`.
  `  proj (max₁ + max₂) (x * y)`
  `= ∑ {(i, j) ∈ supports | i + j = max₁ + max₂}, xᵢ * yⱼ`
  `= proj max₁ x * proj max₂ y`
  `  + ∑ {(i, j) ∈ supports \ {(max₁, max₂)} | i + j = max₁ + max₂}, xᵢ * yⱼ`.
  This is a contradiction, because both `proj (max₁ + max₂) (x * y) ∈ I` and the sum on the
  right hand side is in `I` however `proj max₁ x * proj max₂ y` is not in `I`.
  -/
  classical,
  set set₁ := (decompose 𝒜 x).support.filter (λ i, proj 𝒜 i x ∉ I) with set₁_eq,
  set set₂ := (decompose 𝒜 y).support.filter (λ i, proj 𝒜 i y ∉ I) with set₂_eq,
  have nonempty :
    ∀ (x : A), (x ∉ I) → ((decompose 𝒜 x).support.filter (λ i, proj 𝒜 i x ∉ I)).nonempty,
  { intros x hx,
    rw filter_nonempty_iff,
    contrapose! hx,
    simp_rw proj_apply at hx,
    rw ← sum_support_decompose 𝒜 x,
    exact ideal.sum_mem _ hx, },
  set max₁ := set₁.max' (nonempty x rid₁) with max₁_eq,
  set max₂ := set₂.max' (nonempty y rid₂) with max₂_eq,
  have mem_max₁ : max₁ ∈ set₁ := max'_mem set₁ (nonempty x rid₁),
  have mem_max₂ : max₂ ∈ set₂ := max'_mem set₂ (nonempty y rid₂),
  replace hxy : proj 𝒜 (max₁ + max₂) (x * y) ∈ I := hI _ hxy,

  have mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∈ I,
  { set antidiag :=
      ((decompose 𝒜 x).support.product (decompose 𝒜 y).support)
        .filter (λ z : ι × ι, z.1 + z.2 = max₁ + max₂) with ha,
    have mem_antidiag : (max₁, max₂) ∈ antidiag,
    { simp only [add_sum_erase, mem_filter, mem_product],
      exact ⟨⟨mem_of_mem_filter _ mem_max₁, mem_of_mem_filter _ mem_max₂⟩, rfl⟩ },
    have eq_add_sum :=
      calc  proj 𝒜 (max₁ + max₂) (x * y)
          = ∑ ij in antidiag, proj 𝒜 ij.1 x * proj 𝒜 ij.2 y
          : by simp_rw [ha, proj_apply, direct_sum.decompose_mul,
                        direct_sum.coe_mul_apply 𝒜]
      ... = proj 𝒜 max₁ x * proj 𝒜 max₂ y + ∑ ij in antidiag.erase (max₁, max₂),
                                              proj 𝒜 ij.1 x * proj 𝒜 ij.2 y
          : (add_sum_erase _ _ mem_antidiag).symm,
    rw eq_sub_of_add_eq eq_add_sum.symm,
    refine ideal.sub_mem _ hxy (ideal.sum_mem _ (λ z H, _)),
    rcases z with ⟨i, j⟩,
    simp only [mem_erase, prod.mk.inj_iff, ne.def, mem_filter, mem_product] at H,
    rcases H with ⟨H₁, ⟨H₂, H₃⟩, H₄⟩,
    have max_lt : max₁ < i ∨ max₂ < j,
    { rcases lt_trichotomy max₁ i with h | rfl | h,
      { exact or.inl h },
      { refine false.elim (H₁ ⟨rfl, add_left_cancel H₄⟩), },
      { apply or.inr,
        have := add_lt_add_right h j,
        rw H₄ at this,
        exact lt_of_add_lt_add_left this, }, },
    cases max_lt,
    { -- in this case `max₁ < i`, then `xᵢ ∈ I`; for otherwise `i ∈ set₁` then `i ≤ max₁`.
      have not_mem : i ∉ set₁ := λ h, lt_irrefl _
        ((max'_lt_iff set₁ (nonempty x rid₁)).mp max_lt i h),
      rw set₁_eq at not_mem,
      simp only [not_and, not_not, ne.def, mem_filter] at not_mem,
      exact ideal.mul_mem_right _ I (not_mem H₂), },
    { -- in this case  `max₂ < j`, then `yⱼ ∈ I`; for otherwise `j ∈ set₂`, then `j ≤ max₂`.
      have not_mem : j ∉ set₂ := λ h, lt_irrefl _
        ((max'_lt_iff set₂ (nonempty y rid₂)).mp max_lt j h),
      rw set₂_eq at not_mem,
      simp only [not_and, not_not, ne.def, mem_filter] at not_mem,
      exact ideal.mul_mem_left I _ (not_mem H₃), }, },

  have not_mem_I : proj 𝒜 max₁ x * proj 𝒜 max₂ y ∉ I,
  { have neither_mem : proj 𝒜 max₁ x ∉ I ∧ proj 𝒜 max₂ y ∉ I,
    { rw mem_filter at mem_max₁ mem_max₂,
      exact ⟨mem_max₁.2, mem_max₂.2⟩, },
    intro rid,
    cases homogeneous_mem_or_mem ⟨max₁, set_like.coe_mem _⟩ ⟨max₂, set_like.coe_mem _⟩ mem_I,
    { apply neither_mem.1 h },
    { apply neither_mem.2 h }, },

  exact not_mem_I mem_I,
end⟩

lemma ideal.is_homogeneous.is_prime_iff {I : ideal A} (h : I.is_homogeneous 𝒜) :
  I.is_prime ↔
  (I ≠ ⊤) ∧
    ∀ {x y : A}, set_like.is_homogeneous 𝒜 x → set_like.is_homogeneous 𝒜 y
      → (x * y ∈ I → x ∈ I ∨ y ∈ I) :=
⟨λ HI,
  ⟨ne_of_apply_ne _ HI.ne_top, λ x y hx hy hxy, ideal.is_prime.mem_or_mem HI hxy⟩,
  λ ⟨I_ne_top, homogeneous_mem_or_mem⟩,
    h.is_prime_of_homogeneous_mem_or_mem I_ne_top @homogeneous_mem_or_mem⟩

lemma ideal.is_prime.homogeneous_core {I : ideal A} (h : I.is_prime) :
  (I.homogeneous_core 𝒜).to_ideal.is_prime :=
begin
  apply (ideal.homogeneous_core 𝒜 I).is_homogeneous.is_prime_of_homogeneous_mem_or_mem,
  { exact ne_top_of_le_ne_top h.ne_top (ideal.to_ideal_homogeneous_core_le 𝒜 I) },
  rintros x y hx hy hxy,
  have H := h.mem_or_mem (ideal.to_ideal_homogeneous_core_le 𝒜 I hxy),
  refine H.imp _ _,
  { exact ideal.mem_homogeneous_core_of_is_homogeneous_of_mem hx, },
  { exact ideal.mem_homogeneous_core_of_is_homogeneous_of_mem hy, },
end

lemma ideal.is_homogeneous.radical_eq {I : ideal A} (hI : I.is_homogeneous 𝒜) :
  I.radical = Inf { J | J.is_homogeneous 𝒜 ∧ I ≤ J ∧ J.is_prime } :=
begin
  rw ideal.radical_eq_Inf,
  apply le_antisymm,
  { exact Inf_le_Inf (λ J, and.right), },
  { refine Inf_le_Inf_of_forall_exists_le _,
    rintros J ⟨HJ₁, HJ₂⟩,
    refine ⟨(J.homogeneous_core 𝒜).to_ideal, _, J.to_ideal_homogeneous_core_le _⟩,
    refine ⟨homogeneous_ideal.is_homogeneous _, _, HJ₂.homogeneous_core⟩,
    refine hI.to_ideal_homogeneous_core_eq_self.symm.trans_le (ideal.homogeneous_core_mono _ HJ₁), }
end

lemma ideal.is_homogeneous.radical {I : ideal A} (h : I.is_homogeneous 𝒜)  :
  I.radical.is_homogeneous 𝒜 :=
by { rw h.radical_eq, exact ideal.is_homogeneous.Inf (λ _, and.left) }

/-- The radical of a homogenous ideal, as another homogenous ideal. -/
def homogeneous_ideal.radical (I : homogeneous_ideal 𝒜) : homogeneous_ideal 𝒜 :=
⟨I.to_ideal.radical, I.is_homogeneous.radical⟩

@[simp]
lemma homogeneous_ideal.coe_radical (I : homogeneous_ideal 𝒜) :
  I.radical.to_ideal = I.to_ideal.radical := rfl


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

! This file was ported from Lean 3 source module tactic.fin_cases
! leanprover-community/mathlib commit 82a53736b96112a948cb35faa4ab72aa705d56f8
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Basic
import Mathbin.Tactic.NormNum

/-!
# Case bash

This file provides the tactic `fin_cases`. `fin_cases x` performs case analysis on `x`, that is
creates one goal for each possible value of `x`, where either:
* `x : α`, where `[fintype α]`
* `x ∈ A`, where `A : finset α`, `A : multiset α` or `A : list α`.
-/

namespace Tactic

open Expr

open Conv.Interactive

/-- Checks that the expression looks like `x ∈ A` for `A : finset α`, `multiset α` or `A : list α`,
    and returns the type α. -/
unsafe def guard_mem_fin (e : expr) : tactic expr := do
  let t ← infer_type e
  let α ← mk_mvar
  to_expr ``(_ ∈ (_ : Finset $(α))) tt ff >>= unify t <|>
      to_expr ``(_ ∈ (_ : Multiset $(α))) tt ff >>= unify t <|>
        to_expr ``(_ ∈ (_ : List $(α))) tt ff >>= unify t
  instantiate_mvars α
#align tactic.guard_mem_fin tactic.guard_mem_fin

/-- `expr_list_to_list_expr` converts an `expr` of type `list α`
to a list of `expr`s each with type `α`.

TODO: this should be moved, and possibly duplicates an existing definition.
-/
unsafe def expr_list_to_list_expr : ∀ e : expr, tactic (List expr)
  | q(List.cons $(h) $(t)) => List.cons h <$> expr_list_to_list_expr t
  | q([]) => return []
  | _ => failed
#align tactic.expr_list_to_list_expr tactic.expr_list_to_list_expr

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
private unsafe def fin_cases_at_aux : ∀ (with_list : List expr) (e : expr), tactic Unit
  | with_list, e => do
    let result ← cases_core e
    match result with
      |-- We have a goal with an equation `s`, and a second goal with a smaller `e : x ∈ _`.
        [(_, [s], _), (_, [e], _)] =>
        do
        let sn := local_pp_name s
        let ng ← num_goals
        -- tidy up the new value
          match with_list 0 with
          |-- If an explicit value was specified via the `with` keyword, use that.
              some
              h =>
            tactic.interactive.conv (some sn) none (to_rhs >> conv.interactive.change (to_pexpr h))
          |-- Otherwise, call `norm_num`. We let `norm_num` unfold `max` and `min`
            -- because it's helpful for the `interval_cases` tactic.
            _ =>
            try <|
              tactic.interactive.conv (some sn) none <|
                to_rhs >>
                  conv.interactive.norm_num
                    [simp_arg_type.expr ``(max_def'), simp_arg_type.expr ``(min_def)]
        let s ← get_local sn
        try sorry
        let ng' ← num_goals
        when (ng = ng') (rotate_left 1)
        fin_cases_at_aux with_list e
      |-- No cases; we're done.
        [] =>
        skip
      | _ => failed
#align tactic.fin_cases_at_aux tactic.fin_cases_at_aux

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `fin_cases_at with_list e` performs case analysis on `e : α`, where `α` is a fintype.
      The optional list of expressions `with_list` provides descriptions for the cases of `e`,
      for example, to display nats as `n.succ` instead of `n+1`.
      These should be defeq to and in the same order as the terms in the enumeration of `α`.
      -/
    unsafe
  def
    fin_cases_at
    ( nm : Option Name ) : ∀ ( with_list : Option pexpr ) ( e : expr ) , tactic Unit
    |
      with_list , e
      =>
      focus1
        do
          let ty ← try_core <| guard_mem_fin e
            match
              ty
              with
              |
                  none
                  =>
                  do
                    let ty ← infer_type e
                      let
                        i
                          ←
                          to_expr ` `( Fintype $ ( ty ) ) >>= mk_instance
                            <|>
                            fail "Failed to find `fintype` instance."
                      let t ← to_expr ` `( $ ( e ) ∈ @ Fintype.elems $ ( ty ) $ ( i ) )
                      let v ← to_expr ` `( @ Fintype.complete $ ( ty ) $ ( i ) $ ( e ) )
                      let h ← assertv ( nm `this ) t v
                      fin_cases_at with_list h
                |
                  some ty
                  =>
                  do
                    let
                        with_list
                          ←
                          match
                            with_list
                            with
                            |
                                some e
                                =>
                                do
                                  let e ← to_expr ` `( ( $ ( e ) : List $ ( ty ) ) )
                                    expr_list_to_list_expr e
                              | none => return [ ]
                      fin_cases_at_aux with_list e
#align tactic.fin_cases_at tactic.fin_cases_at

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
private unsafe def hyp :=
  tk "*" *> return none <|> some <$> ident
#align tactic.interactive.hyp tactic.interactive.hyp

/-- `fin_cases h` performs case analysis on a hypothesis of the form
`h : A`, where `[fintype A]` is available, or
`h : a ∈ A`, where `A : finset X`, `A : multiset X` or `A : list X`.

`fin_cases *` performs case analysis on all suitable hypotheses.

As an example, in
```
example (f : ℕ → Prop) (p : fin 3) (h0 : f 0) (h1 : f 1) (h2 : f 2) : f p.val :=
begin
  fin_cases *; simp,
  all_goals { assumption }
end
```
after `fin_cases p; simp`, there are three goals, `f 0`, `f 1`, and `f 2`.

`fin_cases h with l` takes a list of descriptions for the cases of `h`.
These should be definitionally equal to and in the same order as the
default enumeration of the cases.

For example,
```
example (x y : ℕ) (h : x ∈ [1, 2]) : x = y :=
begin
  fin_cases h with [1, 1+1],
end
```
produces two cases: `1 = y` and `1 + 1 = y`.

When using `fin_cases a` on data `a` defined with `let`,
the tactic will not be able to clear the variable `a`,
and will instead produce hypotheses `this : a = ...`.
These hypotheses can be given a name using `fin_cases a using ha`.

For example,
```
example (f : ℕ → fin 3) : true :=
begin
  let a := f 3,
  fin_cases a using ha,
end
```
produces three goals with hypotheses
`ha : a = 0`, `ha : a = 1`, and `ha : a = 2`.
-/
unsafe def fin_cases :
    parse hyp → parse (tk "with" *> texpr)? → parse (tk "using" *> ident)? → tactic Unit
  | none, none, nm => do
    let ctx ← local_context
    ctx (fin_cases_at nm none) <|>
        fail
          ("No hypothesis of the forms `x ∈ A`, where " ++
            "`A : finset X`, `A : list X`, or `A : multiset X`, or `x : A`, with `[fintype A]`.")
  | none, some _, _ => fail "Specify a single hypothesis when using a `with` argument."
  | some n, with_list, nm => do
    let h ← get_local n
    fin_cases_at nm with_list h
#align tactic.interactive.fin_cases tactic.interactive.fin_cases

end Interactive

add_tactic_doc
  { Name := "fin_cases"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.fin_cases]
    tags := ["case bashing"] }

end Tactic


import GMLInit.Data.Basic
import GMLInit.Meta.Basic
import GMLInit.Meta.Relation

class EquivBEq (α) [BEq α] extends PartialEquivBEq α : Prop where
  protected refl (x : α) : (x == x) = true

instance (α) [BEq α] [LawfulBEq α] : EquivBEq α where
  refl _ := LawfulBEq.rfl
  symm h := eq_of_beq h ▸ LawfulBEq.rfl
  trans h₁ h₂ := eq_of_beq h₁ ▸ h₂

namespace BEq
variable {α} [BEq α]

protected theorem refl [EquivBEq α] (x : α) : x == x := EquivBEq.refl x

protected theorem rfl [EquivBEq α] {x : α} : x == x := EquivBEq.refl x

protected theorem symm [PartialEquivBEq α] {x y : α} : x == y → y == x := PartialEquivBEq.symm

protected theorem trans [PartialEquivBEq α] {x y z : α} : x == y → y == z → x == z := PartialEquivBEq.trans

protected theorem comm [PartialEquivBEq α] (x y : α) : (x == y) = (y == x) := by
  match hxy : x == y, hyx : y == x with
  | true, true => rfl
  | true, false => rw [BEq.symm hxy] at hyx; contradiction
  | false, true => rw [BEq.symm hyx] at hxy; contradiction
  | false, false => rfl

theorem subst_left [PartialEquivBEq α] {x y z : α} : (x == y) = true → (x == z) = (y == z) := by
  intro hxy
  match hxz : x == z, hyz : y == z with
  | true, true => rfl
  | true, false => rw [BEq.trans (BEq.symm hxy) hxz] at hyz; contradiction
  | false, true => rw [BEq.trans hxy hyz] at hxz; contradiction
  | false, false => rfl

theorem subst_right [PartialEquivBEq α] {x y z : α} : (x == y) = true → (z == x) = (z == y) := by
  intro hxy
  match hzx : z == x, hzy : z == y with
  | true, true => rfl
  | true, false => rw [BEq.trans hzx hxy] at hzy; contradiction
  | false, true => rw [BEq.trans hzy (BEq.symm hxy)] at hzx; contradiction
  | false, false => rfl

theorem beq_of_eq [EquivBEq α] {x y : α} : x = y → (x == y) = true := fun | rfl => BEq.rfl

theorem eq_of_beq [LawfulBEq α] {x y : α} : (x == y) = true → x = y := LawfulBEq.eq_of_beq

theorem eq_iff_beq [LawfulBEq α] {x y : α} : (x == y) ↔ x = y := ⟨eq_of_beq, beq_of_eq⟩

theorem ne_of_bne [EquivBEq α] {x y : α} : (x != y) → x ≠ y :=
  by intro | h, rfl => rw [bne, BEq.refl] at h; contradiction

theorem bne_of_ne [LawfulBEq α] {x y : α} : x ≠ y → x != y := by
  intro h
  rw [bne, Bool.not_eq_true']
  match hb : x == y with
  | true => absurd h; exact BEq.eq_of_beq hb
  | false => rfl

theorem ne_iff_bne [LawfulBEq α] {x y : α} : (x != y) ↔ x ≠ y := ⟨ne_of_bne, bne_of_ne⟩

theorem comp [PartialEquivBEq α] {x y : α} : (x != y) = true → ∀ z, (x != z) = true ∨ (z != y) = true := by
  clean unfold bne
  intro hxy z
  match hxz : x == z, hyz : z == y with
  | true, true => rw [BEq.subst_right hyz] at hxz; rw [hxz] at hxy; contradiction
  | false, _ => left; rfl
  | _, false => right; rfl

instance (α) [BEq α] [EquivBEq α] : Relation.Reflexive (α:=α) (.==.) := ⟨BEq.refl⟩
instance (α) [BEq α] [PartialEquivBEq α] : Relation.Symmetric (α:=α) (.==.) := ⟨BEq.symm⟩
instance (α) [BEq α] [PartialEquivBEq α] : Relation.Transitive (α:=α) (.==.) := ⟨BEq.trans⟩

end BEq


import fundamental_groupoid_product
import topology.homotopy.equiv
import category_theory.equivalence

noncomputable theory

namespace continuous_map.homotopy

variables {X : Type*} {Y : Type*} [topological_space X] [topological_space Y] {f g : C(X, Y)}
          (H : continuous_map.homotopy f g)

def to_path (x : X) : path (f x) (g x) :=
{ to_fun := λ t, H (t, x),
  source' := H.apply_zero x,
  target' := H.apply_one x, }

end continuous_map.homotopy

namespace category_theory.groupoid
open category_theory
section
universe u
variables {G H I : Groupoid.{u u}} (f : G.α ⥤ H.α) (g : H.α ⥤ I.α)

lemma grpd_id_eq : (𝟭 G.α) = (𝟙 G) := rfl

@[reducible]
def func_to_hom : G ⟶ H := f

lemma grpd_comp_eq : f ⋙ g = (func_to_hom f : G ⟶ H) ≫ (g : H ⟶ I) := rfl

end
end category_theory.groupoid

namespace continuous_map
universe u
variables {G : Top.{u}}

lemma top_id_eq : (continuous_map.id : C(G, G)) = (𝟙 G) := rfl

end continuous_map

namespace fundamental_groupoid

local attribute [reducible] fundamental_groupoid

/-- Help the typechecker by converting point in groupoid back to point in Top -/
@[reducible]
def to_top {X : Top} (x : (fundamental_groupoid_functor.obj X).α) : X := x

/-- Help the typechecker by converting point in Top to a point in the fundamental groupoid -/
@[reducible]
def from_top {X : Top} (x : X) : (fundamental_groupoid_functor.obj X).α := x

/-- Help the typechecker by converting a path in groupoid back to path.homotopic.quotient -/
@[reducible]
def to_path {X : Top} {x₀ x₁ : (fundamental_groupoid_functor.obj X).α} (p : x₀ ⟶ x₁) :
  path.homotopic.quotient x₀ x₁ := p

/-- Help the typechecker by convering a path.homotopic.quotient to an arrow in the
    fundamental groupoid -/
@[reducible]
def from_path {X : Top} {x₀ x₁ : X} (p : path.homotopic.quotient x₀ x₁) : (x₀ ⟶ x₁) := p

lemma map_map_eq {X Y : Top} {x₀ x₁ : X} (f : C(X, Y)) (p : path.homotopic.quotient x₀ x₁) :
  (fundamental_groupoid_functor.map f).map p = p.map_fn f := rfl

end fundamental_groupoid

section
open fundamental_groupoid
private abbreviation π := fundamental_groupoid_functor
universes u v
open_locale unit_interval
local attribute [instance] path.homotopic.setoid

section htop_maps_induce_iso_funcs

section casts

lemma path_cast_left {X : Top} {x₀ x₁ x₀' : X} (p : path x₀ x₁) (hx₀ : x₀ = x₀') :
  (category_theory.eq_to_hom hx₀.symm : (from_top x₀') ⟶ x₀) ≫ ⟦p⟧ = ⟦p.cast hx₀.symm rfl⟧ :=
by { subst hx₀, simp only [category_theory.category.id_comp, category_theory.eq_to_hom_refl],
  congr, ext, simp, }

lemma path_cast_right {X : Top} {x₀ x₁ x₁' : X} (p : path x₀ x₁) (hx₁ : x₁ = x₁') :
  ((⟦p⟧ ≫ (category_theory.eq_to_hom hx₁ : (from_top x₁) ⟶ x₁')) : from_top x₀ ⟶ x₁') = ⟦p.cast rfl hx₁.symm⟧ :=
by { subst hx₁, simp only [category_theory.category.comp_id, category_theory.eq_to_hom_refl],
  congr, ext, simp, }

parameters {X₁ X₂ Y : Top.{u}} (f : C(X₁, Y)) (g : C(X₂, Y))
  {x₀ x₁ : X₁} {x₂ x₃ : X₂} (p : path x₀ x₁) (q : path x₂ x₃) (hfg : ∀ t : I, f (p t) = g (q t))

include hfg
private lemma start_path : f x₀ = g x₂ := by { convert hfg 0; simp only [path.source], }
private lemma end_path : f x₁ = g x₃ := by { convert hfg 1; simp only [path.target], }

lemma function_image_of_path  :
  (π.map f).map ⟦p⟧ = category_theory.eq_to_hom start_path ≫ (π.map g).map ⟦q⟧ ≫ category_theory.eq_to_hom end_path.symm :=
begin
  simp only [map_map_eq, ← path.homotopic.map_lift, path_cast_right],
  rw path_cast_left _ (start_path f g p q hfg).symm,
  congr, ext, simp only [path.map_coe, hfg, function.comp_app, path.cast_coe],
end

end casts

parameters {X : Top.{u}} {Y : Top.{u}} {f g : C(X, Y)} (H : continuous_map.homotopy f g)
variables {x₀ x₁ : X} (p : path.homotopic.quotient x₀ x₁)

def straight_path : path (0 : I) (1 : I) := { to_fun := id, source' := rfl, target' := rfl }

def diagonal_path : from_top (H (0, x₀)) ⟶ from_top (H (1, x₁)) :=
(path.homotopic.prod ⟦straight_path⟧ p).map_fn H.to_continuous_map

def diagonal_path' : from_top (f x₀) ⟶ from_top (g x₁) :=
(category_theory.eq_to_hom (H.apply_zero x₀).symm) ≫
  (diagonal_path p) ≫
  (category_theory.eq_to_hom (H.apply_one x₁))

abbreviation H_map : C(Top.of (I × X), Y) := H.to_continuous_map

lemma up_is_f : (π.map f).map p = (category_theory.eq_to_hom (H.apply_zero x₀).symm)
  ≫ ((π.map H_map).map (path.homotopic.prod ⟦path.refl (0 : I)⟧ p))
  ≫ (category_theory.eq_to_hom (H.apply_zero x₁)) :=
begin
  apply quotient.induction_on p,
  intro p',
  rw path.homotopic.prod_lift,
  apply function_image_of_path f H_map,
  simp,
end

lemma down_is_g : (π.map g).map p = (category_theory.eq_to_hom (H.apply_one x₀).symm)
  ≫ ((π.map H_map).map (path.homotopic.prod ⟦path.refl (1 : I)⟧ p))
  ≫ (category_theory.eq_to_hom (H.apply_one x₁)) :=
begin
  apply quotient.induction_on p,
  intro p',
  rw path.homotopic.prod_lift,
  apply function_image_of_path g H_map,
  simp,
end

lemma H_to_path (x : X) : ⟦H.to_path x⟧ =
  (category_theory.eq_to_hom (H.apply_zero x).symm : from_top (f x) ⟶ H (0, x)) ≫
  (π.map H_map).map (path.homotopic.prod ⟦straight_path⟧ ⟦path.refl x⟧) ≫
  (category_theory.eq_to_hom (H.apply_one x)) :=
by { rw path.homotopic.prod_lift, simp only [map_map_eq, ← path.homotopic.map_lift, path_cast_left, path_cast_right], refl, }

lemma eq_diag :
  (π.map f).map p ≫ ⟦H.to_path x₁⟧ = diagonal_path' p ∧
  (⟦H.to_path x₀⟧ ≫ (π.map g).map p : from_top (f x₀) ⟶ from_top (g x₁)) = diagonal_path' p :=
begin
  rw [up_is_f, down_is_g, H_to_path, H_to_path],
  split;
  simp only [category_theory.category.id_comp, category_theory.eq_to_hom_refl,
    category_theory.category.assoc, category_theory.eq_to_hom_trans_assoc,
    ← category_theory.functor.map_comp_assoc];
  simp only [comp_eq, path.homotopic.comp_prod_eq_prod_comp];
  simp [← comp_eq, ← id_eq_path_refl]; refl,
end

def homotopic_maps_equivalent : category_theory.nat_trans (π.map f) (π.map g) :=
{ app := λ x, ⟦H.to_path x⟧,
  naturality' := by { intros x y p, rw [(eq_diag p).1, (eq_diag p).2],  } }

include H
lemma homotopic_maps_isomorphic : (π.map f) ≅ (π.map g) :=
begin
  refine category_theory.as_iso (_ : (π.map f) ⟶ (π.map g)),
  { exact homotopic_maps_equivalent, },
  apply category_theory.nat_iso.is_iso_of_is_iso_app,
end

end htop_maps_induce_iso_funcs

section

open_locale continuous_map
variables (X Y : Top.{u})

theorem equivalent_fundamental_groupoids (hequiv : X ≃ₕ Y) : (π.obj X).α ≌ (π.obj Y).α :=
begin
  apply category_theory.equivalence.mk (π.map hequiv.to_fun : (π.obj X) ⟶ (π.obj Y)) (π.map hequiv.inv_fun);
  simp only [category_theory.groupoid.grpd_comp_eq, ← category_theory.functor.map_comp, category_theory.groupoid.grpd_id_eq],
  { convert (nonempty.map homotopic_maps_isomorphic hequiv.left_inv).some.symm, simp [continuous_map.top_id_eq], },
  { convert (nonempty.map homotopic_maps_isomorphic hequiv.right_inv).some, simp [continuous_map.top_id_eq], }
end

end
end


-- authorship note: we pulled things from mathlib:hedetniemi without looking carefully at authorship.
-- we'll have to backsolve for the author list later
import michael.simple_graph

universes u
variables {V : Type u}

section list

lemma list.cons_nth_le_succ
  {α : Type*} {hd : α} (tl : list α)
  (n : ℕ) (hn : n + 1 < (tl.cons hd).length)
  (h_auto : n < tl.length := by tidy)
  :
(tl.cons hd).nth_le (n + 1) hn = tl.nth_le n h_auto := rfl

lemma list.cons_nth_le_succ'
  {α : Type*} (l : list α)
  (n : ℕ) (hn : n + 1 < l.length)
  (h_auto : n < l.tail.length)
  :
l.nth_le (n + 1) hn = l.tail.nth_le n h_auto :=
by { cases l, { cases hn }, simp; refl }

@[simp] lemma list.nth_le_succ_tail
  {α : Type*} (l : list α)
  (n : ℕ) (hn : n < l.tail.length)
  (h_auto : n + 1 < l.length)
  -- (h_auto : n + 1 < l.length := by { simp at hn, omega })
   :
l.nth_le (n + 1) h_auto = l.tail.nth_le n hn :=
by { cases l, tidy }

@[simp] lemma list.tail_nth_le_zero
  {α : Type*} (l : list α) [inhabited α]
  (h_auto : 0 < l.length) :
list.nth_le l 0 h_auto = l.head :=
by { cases l, { cases h_auto }, tidy, }

end list

namespace simple_graph
variables (G : simple_graph V) [inhabited V]

/-- Morally, a path is an alternating list of vertices and edges,
  with incidences between adjacent objects -/
@[ext] structure path :=
(head : V)
(tail : list V)
(edges : list G.E)
(length_eq : edges.length = tail.length)
(adj : ∀ (n : ℕ) (hn : n < edges.length),
  let u := (list.cons head tail).nth_le n (by { simp; omega }) in
  let v := (list.cons head tail).nth_le (n + 1) (by { simp, cc }) in
  u ≠ v ∧ u ∈ edges.nth_le n hn ∧ v ∈ edges.nth_le n hn)

namespace path
variables {G}
variables (p : G.path)

section classical
open_locale classical
/-- The last vertex in p. -/
noncomputable def last : V := if h : p.tail = list.nil then p.head else p.tail.last h

end classical

/-- The ordered list of all vertices in p, starting at p.head and ending at p.sink. -/
def vertices : list V := p.head :: p.tail

/-- The number of edges in p. -/
def length : ℕ := p.tail.length

@[simp] lemma tail_length_eq : p.tail.length = p.length := rfl
@[simp] lemma edges_length_eq : p.edges.length = p.length :=  by simp [p.length_eq]
@[simp] lemma vertices_tail : p.vertices.tail = p.tail := by simp [path.vertices]
@[simp] lemma vertices_length : p.vertices.length = p.length + 1 := by simp [path.vertices]

lemma vertices_ne_nil : p.vertices ≠ list.nil := by simp [vertices]
@[simp] lemma last_eq_vertices_last : p.last = p.vertices.last p.vertices_ne_nil :=
by { dsimp [last, vertices], split_ifs with h; simp [h] }

#check list.nth_eq_some
lemma head_ne_tail_head  (h : p.tail ≠ list.nil) : p.head ≠ p.tail.head :=
begin
  rcases p.adj 0 _ with ⟨hp, _⟩, dsimp at hp, convert hp,
  cases hp1 : p.tail,
  { contradiction },
  { simp [hp1] },
  { revert h, rw ← list.length_pos_iff_ne_nil, simp },
end

-- begin

-- end

-- variables {s t : V}

variables {p}
/-- p.edge_mem e holds if e is an edge along path p. -/
def edge_mem (e : G.E) (p : G.path) : Prop := e ∈ p.edges
-- this instance doesn't fire and I don't know why
instance has_mem_edge : has_mem G.E G.path :=
{ mem := edge_mem }

/-- p.vertex_mem v holds if v is a vertex along path p. -/
def vertex_mem (v : V) (p : G.path) : Prop := v ∈ p.vertices
instance has_mem_vertices : has_mem V G.path :=
{ mem := vertex_mem }
variables (p)

/-- The empty path based at vertex v. -/
def empty (G : simple_graph V) (v : V) : G.path :=
{ head := v,
  tail := list.nil,
  edges := list.nil,
  length_eq := rfl,
  adj := by rintros _ ⟨_⟩ }

instance : inhabited G.path := { default := empty G (arbitrary V) }

@[simp]
lemma empty_length (v : V) : (empty G v).length = 0 := by refl

lemma edge_mem_empty {v : V} (e : G.E) : ¬ (empty G v).edge_mem e :=
by simp [empty, edge_mem]

lemma vertex_mem_empty {u v : V} : u ∈ (empty G v) ↔ u = v :=
by { unfold has_mem.mem vertex_mem, simp [empty, vertices], apply or_false }

/-- p.cons e hp hs is the path extending `p` by edge `e`. -/
@[simps]
def cons {s : V} (e : G.E) (hp : p.head ∈ e) (hs : s ∈ e) (hsp : s ≠ p.head) : G.path :=
{ head := s,
  tail := p.vertices,
  edges := list.cons e p.edges,
  length_eq := by { simp [vertices] },
  adj := begin
    intros n hn _ _,
    cases n, { simp, tauto },
    simp; apply p.adj,
  end }

@[simp] lemma edge_mem_cons {s : V} (hd e : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).edge_mem e ↔ e = hd ∨ p.edge_mem e :=
by simp [path.cons, path.vertices, edge_mem]

@[simp] lemma vertex_mem_cons {v s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  v ∈ (p.cons hd hp hs hsp) ↔ v = s ∨ v ∈ p :=
by refl

@[simp] lemma cons_length {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).length = p.length + 1 :=
by { unfold cons length, simp [vertices] }

@[simp] lemma cons_vertices {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head) :
  (p.cons hd hp hs hsp).vertices = list.cons s p.vertices :=
by { dsimp [vertices, cons], simp }

-- @[simp]
lemma cons_last {s : V} (hd : G.E) (hp : p.head ∈ hd) (hs : s ∈ hd) (hsp : s ≠ p.head)
: last (p.cons hd hp hs hsp) = p.last :=
by { simp only [cons_vertices, last_eq_vertices_last], apply list.last_cons }

lemma edges_eq_nil_iff : p.edges = list.nil ↔ p.tail = list.nil :=
by rw [← list.length_eq_zero, p.length_eq, list.length_eq_zero]

lemma length_eq_zero_iff_eq_empty : p.length = 0 ↔ p = empty G p.head :=
begin
  erw list.length_eq_zero,
  split; intro h, swap, rw h, simp [empty],
  ext, work_on_goal 2 {rw ← edges_eq_nil_iff at h},
  any_goals {simp [empty, h]},
end

lemma cases_on' :
  (∃ v, p = empty G v) ∨
  ∃ (tl : G.path) v e (hs : tl.head ∈ e) (hv : v ∈ e) (hvp : v ≠ tl.head), p = tl.cons e hs hv hvp :=
begin
  cases hp : p.edges with hd tl,
  { left, use p.head, ext, { simp [empty] },
    { suffices : p.tail = list.nil, { simp [empty, this] },
      rwa edges_eq_nil_iff at hp },
    simp [hp, empty] },
  have hp_nil : ¬ p.edges = list.nil, { simp [hp] },
  rw edges_eq_nil_iff at hp_nil,

  rcases p.adj 0 _ with ⟨hvs, hv, hs⟩, simp only [list.nth_le, zero_add] at hs,
  repeat { rw list.nth_le_zero at * },
  set q : G.path := { head := p.tail.head,
    tail := list.tail p.tail,
    edges := list.tail p.edges,
    length_eq := by simp [p.length_eq],
    adj := _},
  swap, { intros, have := p.adj (n + 1) (by { simp only [list.length_tail] at hn, exact nat.add_lt_of_lt_sub_right hn, }),
    simp only [list.nth_le] at this ⊢,
    cases this with huv this,
    cases hp_tail : p.tail with p_hd p_tl, { contradiction },
    dsimp [u,v], simp [hp_tail],   split,
    { contrapose! huv, symmetry, convert huv using 1; simp [hp_tail, huv]; refl },
    -- simp [hp_tail, this],
    -- rw list.tail_nth_le,
    convert this using 2,
    any_goals { simp [hp_tail]; refl },
    -- { rw list.cons_head_tail hp_nil, refl },
    iterate 2 { rwa list.cons_nth_le_succ' },
    },
  right, use [q, p.head, hd],
  simp only [hp, list.head] at hs hv, swap, { simp [hp] },
  dsimp, use [hs, hv], split,
  ext,
  { simp [path.cons] },
  { dsimp [q, path.cons, path.vertices], rwa list.cons_head_tail, },
  { dsimp [q, path.cons], simp [hp] },
  revert hvs, simp,
end

@[elab_as_eliminator]
lemma induction_on
  (P : G.path → Prop)
  (P_empty : ∀ v, P $ empty G v)
  (P_inductive : ∀ p e hs {v} (hv : v ∈ e) (hsv), P p → P (p.cons e hs hv hsv)) :
P p :=
begin
  suffices : ∀ k (q : G.path), q.length = k → P q, { apply this p.length, refl },
  intro k, induction k with k hk, { intros, convert P_empty _, rwa ← length_eq_zero_iff_eq_empty },
  intro q, rcases q.cases_on' with ⟨_,rfl⟩|⟨_,_,_,_,_,_,rfl⟩, { intro, apply P_empty },
  intro, apply P_inductive, apply hk, simp at a, omega,
end

-- @[no_lint]
lemma consecutive_vertex_ne {n} (h : n < p.length) :
p.vertices.nth_le n (by { simp, linarith }) ≠
p.vertices.nth_le (n+1) (by { simp, linarith }) :=
begin
  revert n,
  convert p.induction_on (λ q, ∀ n (h : n < q.length), q.vertices.nth_le n _ ≠ q.vertices.nth_le (n+1) _) _ _,
  { simp }, iterate 2 { simp, omega },
  { rintros _ _ ⟨⟩ },
  clear p, intros _ _ _ _ _ _ h n hn,
  cases n, { simpa },
  convert h _ _,
  simp at hn, omega,
end

@[ext] lemma eq_of_vertices_eq (q : G.path) :  p = q ↔ p.vertices = q.vertices :=
{ mp := by tidy,
  mpr := begin
    intro h, have h_tail : p.tail = q.tail,
    { dsimp [vertices] at h, simp only [] at h, tauto },
    have h_length : p.length = q.length := by rw [← tail_length_eq, h_tail, tail_length_eq],
    ext, { tidy }, { simp [h_tail] },
    by_cases hn : n < p.length; have hnq := by { rw h_length at hn, exact hn },
    swap, { simp [hn, hnq, list.nth_eq_some] },
    suffices : p.edges.nth_le n _ = q.edges.nth_le n _,
    { simp [hn, hnq, list.nth_eq_some]; refine eq.congr this rfl },
    rw edge_eq_iff,
    set u := p.vertices.nth_le n (by { simp [path.vertices], linarith }),
    set v := p.vertices.nth_le (n+1) (by { simp [path.vertices], linarith }),
    use [u, v],
    split, symmetry, apply consecutive_vertex_ne,
    rcases p.adj n _ with ⟨_, hpu, hpv⟩,
    rcases q.adj n _ with ⟨_, hqu, hqv⟩,
    split, { exact hpu },
    split, { convert hqu, dsimp [u], simp_rw h, refl },
    split, { exact hpv },
    { convert hqv, dsimp [v], simp_rw h, refl },
  end }

/-- p.is_cycle if p starts and ends in the same place. -/
def is_cycle : Prop := p.head = p.last

/-- p.is_trail if p has no repeated edges. -/
def is_trail : Prop := list.nodup p.edges

/-- p.is_Eulerian if p hits each edge exactly once. -/
def is_Eulerian : Prop := p.is_trail ∧ ∀ e : G.E, p.edge_mem e

end path

end simple_graph
#lint-