import combinatorics.simple_graph.coloring

--OUTPUT 1
theorem graph_bipartite_iff_two_colorable (G : Type*) [graph G] [two_colorable G] : bipartite G <-> two_colorable G := sorry

lemma nat_succ_inj {x y : ℕ} : x + 1 = y + 1 → x = y := sorry

lemma sum_sq (x y : ℕ) : x^2 + y^2 = (x + y)^2 - 2xy :=
begin
  rw nat.pow_two,
  rw nat.pow_two,
  sorry
end

--OUTPUT 2
theorem two_colorable_bipartite (G : Type*) [decidable_eq G] [fintype G] [fintype (G × G)] (h : ∀ (x : G), x ⊎ x = x) (h2 : ∀ (x y : G), x ⊎ y = 𝟙 → x = y) : bipartite G :=
begin
  have h3 : bipartite G := by sorry,
  show bipartite G, from h3,
end

--OUTPUT 3
theorem bipartite_two_colorable [fintype α] (G : graph α) : G.is_bipartite ↔ G.is_two_colorable :=
begin
  have h1 : G.is_two_colorable → G.is_bipartite, from sorry,
  have h2 : G.is_bipartite → G.is_two_colorable, from sorry,
  show G.is_bipartite ↔ G.is_two_colorable, from sorry,
end

--OUTPUT 4
theorem bipartite_graph_2colorable (G : Type*) [graph G] : is_bipartite G ↔ is_2colorable G :=
begin
  sorry
end

--OUTPUT 5
theorem bipartite_graph_two_colorable {G : Type*} [graph G] :
  two_colorable G ↔ bipartite G :=
begin
  show two_colorable G ↔ bipartite G, from sorry,
end

--OUTPUT 6
theorem bipartite_graph_is_two_colorable (G : Type*) [graph G] : (∀ V1 V2 : G, V1 ∩ V2 = ∅) → (∀ V1 V2 : G, V1 ∪ V2 = G) → two_colorable G :=
begin
  assume h1, assume h2,
  have h3 : ∀ x : G × G, ∃! c : Prop, c ∨ ¬ c, from sorry,
  sorry
end

--OUTPUT 7
theorem two_colorable_iff_bipartite {G : Type*} [graph G] : two_colorable G ↔ bipartite G :=
begin
  split,

  { assume h1 : two_colorable G,
    cases h1 with blue red no_edge_same_color,
    let A := {v : G | v ∈ red},
    let B := {v : G | v ∈ blue},
    have h2 : ∀ (v : G), v ∈ A → ¬ v ∈ B,
    { assume v : G,
      assume (hv : v ∈ A) (hv : v ∈ B),
      have h3 : v ∈ blue, from sorry,
      have h4 : v ∈ red, from sorry,
      have h5 : ¬ v ∈ blue, from sorry,
      have h6 : ¬ v ∈ red, from sorry,
      show false, from sorry,
    },
    have h3 : ∀ (v : G), v ∈ B → ¬ v ∈ A,
    { assume v : G,
      assume (hv : v ∈ B) (hv : v ∈ A),
      have h3 : v ∈ blue, from sorry,
      have h4 : v ∈ red, from sorry,
      have h5 : ¬ v ∈ blue, from sorry,
      have h6 : ¬ v ∈ red, from sorry,
      show false, from sorry,
    },
    show bipartite G, from sorry,
  },
  { assume h1 : bipartite G,
    cases h1 with red blue no_edge_crossing,
    have h2 : ∀ (v : G), ¬ (v ∈ red ∧ v ∈ blue),
    { assume v : G,
      assume h2 : v ∈ red ∧ v ∈ blue,
      have h3 : v ∈ red, from sorry,
      have h4 : v ∈ blue, from sorry,
      have h5 : ¬ v ∈ red, from sorry,
      have h6 : ¬ v ∈ blue, from sorry,
      show false, from sorry,
    },
    show two_colorable G, from sorry,
  }
end

--OUTPUT 8
theorem bipartite_colorable (G : Type*) [graph G] : (∃ A B : set G, is_bipartite G A B) ↔ is_two_colorable G := sorry

/--`theorem`
Existence of Square Root
Let $x$ be non-negative real number. Then $\paren {x^{1/2}}^2 = x$
`proof`
Follows from the standard definition of square root.

{{begin-eqn}}
{{eqn | l = \left({x^{1/2}}\right)^2
      | c =
}}
{{eqn | r = x^{1/2 \cdot 2}
      | c =
}}
{{eqn | r = x
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_root_square (x : ℝ) : x ≥ 0 ∧ (x ^ (1/2))^2 = x := sorry

/--`theorem`
Existence of Cube Root
Let $x$ be a non-negative real number. Then $\paren {x^{1/3}}^3 = x$
`proof`
Follows from the standard definition of cube root.

{{begin-eqn}}
{{eqn | l = \left({x^{1/3}}\right)^3
      | c =
}}
{{eqn | r = x^{1/3 \cdot 3}
      | c =
}}
{{eqn | r = x
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem cube_root_cube (x : ℝ) : x ≥ 0 ∧ (x ^ (1/3))^3 = x := sorry

/--`theorem`
Existence of $nth$ Root
Let $x$ be a non-negative real number. Then $\paren {x^{1/n}}^n = x$
`proof`
Follows from the standard definition of $nth$ root.

{{begin-eqn}}
{{eqn | l = \left({x^{1/n}}\right)^n
      | c =
}}
{{eqn | r = x^{1/n \cdot n}
      | c =
}}
{{eqn | r = x
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem nth_root_n (x : ℝ) (n : ℕ) : x ≥ 0 ∧ (x ^ (1/n))^n = x := sorry

/--`theorem`
Negation of a Statement
Let $p$ be a statement. Then $\lnot p$ is true if and only if $p$ is false
`proof`
`proof`
Follows from the definition of $\lnot$

{{begin-eqn}}
{{eqn | l = \lnot p
      | c =
}}
{{eqn | r = \lnot \lnot p \equiv p
      | c =
}}
{{eqn | r = \lnot p \equiv p
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem negation_equivalence (p : Prop) : (¬ p) ↔ (¬ ¬ p) ↔ p := sorry

/--`theorem`
DeMorgan's Law for Disjunction
Let $p$ and $q$ be statements. Then $\lnot \paren {p \vee q}$ is equivalent to $\lnot p \land \lnot q$
`proof`
Follows from the definition of $\lnot$

{{begin-eqn}}
{{eqn | l = \lnot \left({p \vee q}\right)
      | c =
}}
{{eqn | r = \lnot \lnot \left({p \vee q}\right)
      | c =
}}
{{eqn | r = p \land q
      | c =
}}
{{eqn | r = \lnot p \land \lnot q
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem negation_disjunction (p q : Prop) : ¬ (p ∨ q) ↔ (¬ p) ∧ (¬ q) := sorry

/--`theorem`
DeMorgan's Law for Conjunction
Let $p$ and $q$ be statements. Then $\lnot \paren {p \land q}$ is equivalent to $\lnot p \lor \lnot q$
`proof`
Follows from the definition of $\lnot$

{{begin-eqn}}
{{eqn | l = \lnot \left({p \land q}\right)
      | c =
}}
{{eqn | r = \lnot \lnot \left({p \land q}\right)
      | c =
}}
{{eqn | r = p \lor q
      | c =
}}
{{eqn | r = \lnot p \lor \lnot q
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem negation_conjunction (p q : Prop) : ¬ (p ∧ q) ↔ (¬ p) ∨ (¬ q) := sorry

/--`theorem`
Negation of Universal Quantifier
Let $p$ be a statement. Then $\forall x: \lnot p$ is equivalent to $\exists x: p$
`proof`
Follows from the definition of $\forall$ and $\exists$

{{begin-eqn}}
{{eqn | l = \forall x, \lnot p
      | c =
}}
{{eqn | r = \lnot \exists x, p
      | c =
}}
{{eqn | r = \exists x, p
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem negation_universal_quantifier (p : Prop) : ∀ x, ¬ p ↔ ∃ x, p := sorry

/--`theorem`
Negation of Existential Quantifier
Let $p$ be a statement. Then $\exists x, \lnot p$ is equivalent to $\forall x: p$
`proof`
Follows from the definition of $\forall$ and $\exists$

{{begin-eqn}}
{{eqn | l = \exists x, \lnot p
      | c =
}}
{{eqn | r = \lnot \forall x, p
      | c =
}}
{{eqn | r = \forall x, p
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem negation_existential_quantifier (p : Prop) : ∃ x, ¬ p ↔ ∀ x, p := sorry

/--`theorem`
Negation of Conditional Statement
Let $p$ and $q$ be statements. Then $\lnot \paren {p \rightarrow q}$ is equivalent to $\lnot p$ and $q$
`proof`
Follows from the definition of $\rightarrow$

{{begin-eqn}}
{{eqn | l = \lnot \left({p \rightarrow q}\right)
      | c =
}}
{{eqn | r = \lnot \lnot p \lor q
      | c =
}}
{{eqn | r = p \land \lnot q
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem negation_conditional_statement (p q : Prop) : ¬ (p → q) ↔ (p ∧ ¬ q) := sorry

/--`theorem`
Negation of Biconditional
Let $p$ and $q$ be statements. Then $\lnot \paren {p \iff q}$ is equivalent to $\lnot p$ xor $q$
`proof`
Follows from the definition of $\iff$

{{begin-eqn}}
{{eqn | l = \lnot \left({p \iff q}\right)
      | c =
}}
{{eqn | r = \lnot p \lor \lnot q
      | c =
}}
{{eqn | r = \lnot p \land
end --Needs more than 2000 tokens!

--OUTPUT 9
theorem bipartite_graph_twocolorable (G : Type*) [graph G] : (twocolorable G) ↔ (bipartite G) :=
begin
  have h1 : twocolorable G → bipartite G, from by {
    assume (h1 : twocolorable G),
    show bipartite G, from sorry,
  },
  have h2 : bipartite G → twocolorable G, from by {
    assume (h2 : bipartite G),
    show twocolorable G, from sorry,
  },
  show (twocolorable G) ↔ (bipartite G), from ⟨h1, h2⟩,
end

--OUTPUT 10
theorem two_color_bipartite (G : Type*) [graph G] : two_colorable G ↔ bipartite G :=
begin
  have h1 : two_colorable G → bipartite G, from sorry,
  have h2 : bipartite G → two_colorable G, from sorry,
  show two_colorable G ↔ bipartite G, from sorry,
end

/- FEW SHOT PROMPTS TO CODEX(START)
/--`theorem`
Power Set is Closed under Intersection
Let $S$ be a set.

Let $\powerset S$ be the power set of $S$.

Then:
:$\forall A, B \in \powerset S: A \cap B \in \powerset S$
`proof`
Let $A, B \in \powerset S$.

Then by the definition of power set, $A \subseteq S$ and $B \subseteq S$.

From Intersection is Subset we have that $A \cap B \subseteq A$.

It follows from Subset Relation is Transitive that $A \cap B \subseteq S$.

Thus $A \cap B \in \powerset S$ and closure is proved.
{{qed}}
-/
theorem power_set_intersection_closed {α : Type*} (S : set α) : ∀ A B ∈ 𝒫 S, (A ∩ B) ∈ 𝒫 S :=
begin
  assume (A : set α) (hA : A ∈ 𝒫 S) (B : set α) (hB : B ∈ 𝒫 S),
  have h1 : (A ⊆ S) ∧ (B ⊆ S), from sorry,
  have h2 : (A ∩ B) ⊆ A, from sorry,
  have h3 : (A ∩ B) ⊆ S, from sorry,
  show (A ∩ B) ∈  𝒫 S, from sorry,
end

/--`theorem`
Square of Sum
 :$\forall x, y \in \R: \paren {x + y}^2 = x^2 + 2 x y + y^2$
`proof`
Follows from the distribution of multiplication over addition:

{{begin-eqn}}
{{eqn | l = \left({x + y}\right)^2
      | r = \left({x + y}\right) \cdot \left({x + y}\right)
}}
{{eqn | r = x \cdot \left({x + y}\right) + y \cdot \left({x + y}\right)
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x \cdot x + x \cdot y + y \cdot x + y \cdot y
      | c = Real Multiplication Distributes over Addition
}}
{{eqn | r = x^2 + 2xy + y^2
      | c =
}}
{{end-eqn}}
{{qed}}
-/
theorem square_of_sum (x y : ℝ) : (x + y)^2 = (x^2 + 2*x*y + y^2) :=
begin
  calc (x + y)^2 = (x+y)*(x+y) : by sorry
  ... = x*(x+y) + y*(x+y) : by sorry
  ... = x*x + x*y + y*x + y*y : by sorry
  ... = x^2 + 2*x*y + y^2 : by sorry,
end

/--`theorem`
Identity of Group is Unique
Let $\struct {G, \circ}$ be a group. Then there is a unique identity element $e \in G$.
`proof`
From Group has Latin Square Property, there exists a unique $x \in G$ such that:
:$a x = b$

and there exists a unique $y \in G$ such that:
:$y a = b$

Setting $b = a$, this becomes:

There exists a unique $x \in G$ such that:
:$a x = a$

and there exists a unique $y \in G$ such that:
:$y a = a$

These $x$ and $y$ are both $e$, by definition of identity element.
{{qed}}
-/
theorem group_identity_unique {G : Type*} [group G] : ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a :=
begin
  have h1 : ∀ a b : G, ∃! x : G, a * x = b, from sorry,
  have h2 : ∀ a b : G, ∃! y : G, y * a = b, from sorry,

  have h3 : ∀ a : G, ∃! x : G, a * x = a, from sorry,
  have h4 : ∀ a : G, ∃! y : G, y * a = a, from sorry,

  have h5 : ∀ a : G, classical.some (h3 a) = (1 : G), from sorry,
  have h6 : ∀ a : G, classical.some (h4 a) = (1 : G), from sorry,

  show ∃! e : G, ∀ a : G, e * a = a ∧ a * e = a, from by {
    use (1 : G),
    have h7 : ∀ e : G, (∀ a : G, e * a = a ∧ a * e = a) → e = 1, from by {
      assume (e : G) (h7 : ∀ a : G, e * a = a ∧ a * e = a),
      have h8 : ∀ a : G, e = classical.some (h3 a), from sorry,
      have h9 : ∀ a : G, e = classical.some (h4 a), from sorry,
      show e = (1 : G), from sorry,
    },
    sorry,
  }
end

/--`theorem`
Bipartite Graph is two colorable
Let $G$ be a graph. Then $G$ is 2-colorable if and only if $G$ is bipartite.
`proof`
Let $G$ be a 2-colorable graph, which means we can color every vertex either red or blue, and no edge will have both endpoints colored the same color. Let $A$ denote the subset of vertices colored red, and let $B$ denote the subset of vertices colored blue. Since all vertices of $A$ are red, there are no edges within $A$, and similarly for $B$. This implies that every edge has one endpoint in $A$ and the other in $B$, which means $G$ is bipartite.

Conversely, suppose $G$ is bipartite, that is, we can partition the vertices into two subsets $V_{1}, V_{2}$ every edge has one endpoint in $V_{1}$ and the other in $V_{2}$. Then coloring every vertex of $V_{1}$ red and every vertex of $V_{2}$ blue yields a valid coloring, so $G$ is 2-colorable.

QED

-/
theorem
FEW SHOT PROMPTS TO CODEX(END)-/


import Hw10
import Sets.Basic
import Functions.Basic
import Lean.Elab.Print
import Lean.Elab.Command

open Set
open Func

variable (α β γ : Type)
variable (f : α → β) (g : β → γ)
variable (X Y : Set α) (U V : Set β)

theorem desiredType1 (h : U ⊆ V) : f ⁻¹ U ⊆ f ⁻¹ V := by
  intro a h'
  have : f a ∈ V := h (f a) h'
  exact this

theorem desiredType2 (h₁ : α ≅ β) (h₂ : β ≅ γ) : α ≅ γ := by
  have ⟨f,u⟩ := h₁
  have ⟨g,v⟩ := h₂
  have l : Bijective (g ∘ f) := by
    have (inj : Injective (g ∘ f)) := inj_comp u.left v.left
    have (surj : Surjective (g ∘ f)) := surj_comp u.right v.right
    exact ⟨inj,surj⟩
  exact ⟨g ∘ f,l⟩

theorem desiredType3 (h : Surjective f) : HasRightInv f := by
  let g : β → α := by
    intro b
    have : ∃ a, f a = b := h b
    have (a : α) := Classical.choose this
    exact a
  have (l : f ∘ g = id) := by
    apply funext
    intro b
    have u : g b = Classical.choose (h b) := by rfl
    have v : f (Classical.choose (h b)) = b := Classical.choose_spec (h b)
    calc
      f (g b) = f (Classical.choose (h b))  := by rw [u]
      _       = b                           := by rw [v]
  exact ⟨g,l⟩

theorem desiredType4 (f : α → β) (g : β → γ) (d : LeftInverse f) (e : LeftInverse g) :
  (d.to_fun ∘ e.to_fun) ∘ (g ∘ f) = id := sorry

theorem desiredType5 (h : α ≅ β) : β ≅ α := sorry

open Lean
open Lean.Meta
open Lean.Elab.Command

def n : String := "1"

def problem : String := "problem"++n

def desired : String := "desiredType"++n

def collectAxiomsOf (constName : Name) : MetaM (List String) := do
  let env ← getEnv
  let (_, s) := ((CollectAxioms.collect constName).run env).run {}
  let a := s.axioms.toList.map toString
  return a

#eval isDefEq (Expr.const desired []) (Expr.const problem [])
#eval collectAxiomsOf problem


import metric_spaces.definitions

noncomputable theory

open set

namespace examples

-- Declaring X and element x with type X
inductive X : Type
| x : X

-- A metric that maps everything to zero is a metric on X
instance metric_space_example_X : metric_space X :=
{ dist := λ _ _, 0,
  dist_self := λ _, rfl,
  eq_of_dist_eq_zero := λ a b _, by {cases a, cases b, refl},
  dist_comm := λ _ _, rfl,
  dist_triangle := λ _ _ _, show (0 : ℝ) ≤ 0 + 0, by linarith
}

-- The absolute function is a metric on ℝ
instance metric_space_example_R : metric_space ℝ :=
{ dist := λ x y, abs (x - y),
  dist_self := λ x, show abs (x - x) = 0, by simp,
  eq_of_dist_eq_zero := λ x y, show abs (x - y) = 0 → x = y,
    by { rw abs_eq_zero, intro h, linarith [h] },
  dist_comm := λ x y, show abs (x - y) = abs (y - x), from abs_sub x y,
  dist_triangle := λ x y z, show abs (x - z) ≤ abs (x - y) + abs (y - z),
    by { convert abs_add (x - y) (y - z), linarith }
}

-- The discrete metric is a metric on any set X
open tactic
open_locale classical

definition metric_example (X : Type) (x y : X) : ℝ :=
if x = y then 0 else 1

variables {X : Type} {x y : X}

-- Useless tactic just for fun, maybe remove later
private meta def metric_example_tac : tactic unit :=
solve1 $ intros
>> `[unfold metric_example]
>> try `[simp]

instance metric_space_example_discrete : metric_space X :=
{ dist := λ x y, metric_example X x y,
  dist_self := λ x, show metric_example X x x = 0, by metric_example_tac,
  eq_of_dist_eq_zero := λ x y, show metric_example X x y = 0 → x = y,
    by { unfold metric_example, split_ifs, all_goals {finish} },
  dist_comm := λ x y, show metric_example X x y = metric_example X y x,
    by { unfold metric_example, split_ifs, all_goals {finish} },
  dist_triangle := λ x y z, show metric_example X x z ≤ metric_example X x y + metric_example X y z,
  begin
    unfold metric_example,
    split_ifs, all_goals {try {norm_num}},
    apply h, rwa [h_1, h_2]
  end
}

end examples


import ring_theory.localization

import valuation.basic

/-!
# Extending valuations to localizations

In this file we extend valuations on a ring R to localizations of R.
We use this to define the valuation field, the valuation ring,
and the residue field of a valued ring.

If v is a valuation on an integral domain R and `hv : supp v = 0`, then
`on_frac v hv` is the extension of v to fraction_ring R, the field of
fractions of R.

`valuation_field v`, `valuation_ring v`, `max_ideal v` and `residue_field v`
are the valuation field, valuation ring, maximal ideal and residue field
of v. See [Wedhorn; 1.26].

-/

local attribute [instance] classical.prop_decidable
local attribute [instance] classical.DLO
noncomputable theory

universes u u₀

variables {R : Type u₀} [comm_ring R]
variables {Γ₀ : Type u} [linear_ordered_comm_group_with_zero Γ₀]
variables {S : set R} [is_submonoid S]

namespace valuation
open linear_ordered_structure

variables (v : valuation R Γ₀)

lemma inverse_exists (s : S) : ∃ u : localization R S, u * s = 1 :=
⟨(localization.to_units s).inv, units.inv_val _⟩

/-- The underlying function of the extension of a valuation to a localization.-/
def localization_v (h : ∀ s, s ∈ S → v s ≠ 0) : localization R S → Γ₀ :=
λ (q : localization R S), quotient.lift_on' q (λ rs, v rs.1 * (v rs.2.1)⁻¹)
begin
  rintros ⟨r1, s1, hs1⟩ ⟨r2, s2, hs2⟩ ⟨t, ht, hrst⟩,
  change (s1 * r2 + -(s2 * r1)) * t = 0 at hrst,
  show v r1 * (v s1)⁻¹ = v r2 * (v s2)⁻¹,
  rw [add_mul, ←neg_mul_eq_neg_mul, add_neg_eq_zero] at hrst,
  replace hrst : v (s1 * r2 * t) = v (s2 * r1 * t) := congr_arg v hrst,
  apply group_with_zero.mul_inv_eq_of_eq_mul (h s1 hs1),
  rw [mul_comm, ←mul_assoc],
  apply group_with_zero.eq_mul_inv_of_mul_eq (h s2 hs2),
  rw [←v.map_mul, ←v.map_mul, mul_comm],
  apply group_with_zero.mul_right_cancel (h t ht),
  rw [←v.map_mul, ←v.map_mul, hrst]
end

/-- Extension of a valuation to a localization -/
protected def localization (h : ∀ s, s ∈ S → v s ≠ 0) : valuation (localization R S) Γ₀ :=
{ to_fun := v.localization_v h,
  map_zero' := show v 0 * (v 1)⁻¹ = 0, by rw [v.map_zero, zero_mul],
  map_one' := show v 1 * (v 1)⁻¹ = 1, by {rw [v.map_one], simp},
  map_mul' := λ x y, quotient.induction_on₂' x y begin
    rintro ⟨r1, s1, hs1⟩,
    rintro ⟨r2, s2, hs2⟩,
    -- TODO : I had to write the next line "blind" -- I had to be the compiler.
    -- Am I missing a trick?
    show v (r1 * r2) * (v(s1 * s2))⁻¹ = (v r1 * (v s1)⁻¹) * (v r2 * (v s2)⁻¹),
    have hs12 : s1 * s2 ∈ S := is_submonoid.mul_mem hs1 hs2,
    apply group_with_zero.mul_inv_eq_of_eq_mul (h (s1 * s2) hs12),
    rw [mul_comm _ (v (s1 * s2)), ←mul_assoc, ←mul_assoc],
    apply group_with_zero.eq_mul_inv_of_mul_eq (h s2 hs2),
    rw [mul_comm _ (v r2), ←v.map_mul, ←mul_assoc, ←v.map_mul, ←mul_assoc, ←v.map_mul],
    apply group_with_zero.eq_mul_inv_of_mul_eq (h s1 hs1),
    rw [←v.map_mul],
    apply congr_arg, ring,
  end,
  map_add' := λ x y, quotient.induction_on₂' x y begin
    rintro ⟨r1, s1, hs1⟩,
    rintro ⟨r2, s2, hs2⟩,
    have := v.map_add (r1 * s2) (r2 * s1),
    rw le_max_iff at this ⊢,
    show v (s1 * r2 + s2 * r1) * (v (s1 * s2))⁻¹ ≤ v r1 * (v s1)⁻¹ ∨
      v (s1 * r2 + s2 * r1) * (v (s1 * s2))⁻¹ ≤ v r2 * (v s2)⁻¹,
    cases this with h1 h2,
    { left,
      apply le_mul_inv_of_mul_le (h s1 hs1),
      rw [mul_comm, ←mul_assoc],
      apply mul_inv_le_of_le_mul (h (s1 * s2) (is_submonoid.mul_mem hs1 hs2)),
      replace h1 := linear_ordered_structure.mul_le_mul_right h1 (v s1),
      rw [←v.map_mul, ←v.map_mul] at h1 ⊢,
      rw (show s1 * (s1 * r2 + s2 * r1) = (r1 * s2 + r2 * s1) * s1, by ring),
      rwa (show r1 * (s1 * s2) = r1 * s2 * s1, by ring),
    },
    { right,
      apply le_mul_inv_of_mul_le (h s2 hs2),
      rw [mul_comm, ←mul_assoc],
      apply mul_inv_le_of_le_mul (h (s1 * s2) (is_submonoid.mul_mem hs1 hs2)),
      replace h2 := linear_ordered_structure.mul_le_mul_right h2 (v s2),
      rw [←v.map_mul, ←v.map_mul] at h2 ⊢,
      rw (show s2 * (s1 * r2 + s2 * r1) = (r1 * s2 + r2 * s1) * s2, by ring),
      rwa (show r2 * (s1 * s2) = r2 * s1 * s2, by ring),
    }
  end }

/-- Extension of a valuation to a localization -/
lemma localization_apply (h : ∀ s, s ∈ S → v s ≠ 0) (r : R) :
  (v.localization h : valuation (localization R S) Γ₀) r = v r :=
show v r * (v 1)⁻¹ = v r, by simp

/-- the extension of a valuation pulls back to the valuation -/
lemma localization_comap (h : ∀ s, s ∈ S → v s ≠ 0) : (v.localization h).comap (localization.of) = v :=
valuation.ext $ λ r, localization_apply v h r

lemma eq_localization_of_comap_aux {v} (w : valuation (localization R S) Γ₀)
  (h : w.comap (localization.of) = v) : ∀ s, s ∈ S → v s ≠ 0 := λ s hs h0,
begin
  cases inverse_exists ⟨s, hs⟩ with u hu,
  let s' : units (localization R S) := ⟨localization.of s, u, mul_comm u s ▸ hu, hu⟩,
  refine group_with_zero.unit_ne_zero (units.map (w : (localization R S) →* Γ₀) s') _,
  rwa ←h at h0,
end

/-- If a valuation on a localisation pulls back to v then it's the localization of v -/
lemma eq_localization_of_comap (w : valuation (localization R S) Γ₀)
  (h : w.comap (localization.of) = v) : v.localization (eq_localization_of_comap_aux w h) = w :=
begin
  ext q,
  induction q,
  { rcases q with ⟨r, s, hs⟩,
    show v r * (v s)⁻¹ = w (localization.mk r ⟨s, hs⟩),
    rw [localization.mk_eq, ←h, w.map_mul],
    show w r * _ = _,
    congr,
    show (w s)⁻¹ = _,
    rw w.map_units_inv,
    refl, },
  refl
end

section fraction_ring
open localization localization.fraction_ring

/-- A ring in which the zero ideal is prime is an integral domain. -/
def integral_domain_of_prime_bot (h : (⊥ : ideal R).is_prime) : integral_domain R :=
{ zero_ne_one := assume zero_eq_one, h.1 $ (ideal.eq_top_iff_one _).mpr $
                 (submodule.mem_bot R).mpr zero_eq_one.symm,
  eq_zero_or_eq_zero_of_mul_eq_zero := λ r s, by { repeat {rw ← submodule.mem_bot R}, apply h.2 },
  .. ‹comm_ring R› }

/-- A ring is an integral domain if it admits a valuation whose support is the zero ideal. -/
def integral_domain_of_supp_zero (hv : v.supp = 0) : integral_domain R :=
integral_domain_of_prime_bot $
by { rw [← ideal.zero_eq_bot, ← hv], exact valuation.ideal.is_prime v }

/-- The extension of valuation on R with support 0 to a valuation on the field of fractions. -/
def on_frac (hv : v.supp = 0) : valuation (fraction_ring R) Γ₀ :=
v.localization $ λ r hr hnz,
begin
  letI := v.integral_domain_of_supp_zero hv,
  refine (@mem_non_zero_divisors_iff_ne_zero R _ _ r).mp hr _,
  rwa [← submodule.mem_bot R, ← ideal.zero_eq_bot, ← hv],
end

@[simp] lemma on_frac_comap_eq (hv : supp v = 0) :
  (v.on_frac hv).comap of = v :=
v.localization_comap _

lemma on_frac_comap_eq_apply (hv : supp v = 0) (r : R) :
  ((v.on_frac hv).comap of : valuation R Γ₀) r = v r := by rw on_frac_comap_eq

/-- Pulling back a valuation on `fraction_ring R` to R and then applying `on_frac` is the
identity function. -/
@[simp] lemma comap_on_frac_eq {R : Type*} [integral_domain R] (v : valuation (fraction_ring R) Γ₀) :
  (v.comap of).on_frac
  (by {rw [comap_supp, ideal.zero_eq_bot, v.supp.eq_bot_of_prime],
    apply ideal.comap_bot_of_inj, apply fraction_ring.of.injective })
  = v :=
valuation.eq_localization_of_comap _ _ rfl

lemma frac_preorder_comap (hv : supp v = 0) :
  preorder.lift (localization.of) (v.on_frac hv).to_preorder = v.to_preorder :=
preorder.ext $ λ x y, begin show (v.on_frac hv) x ≤ (v.on_frac hv) y ↔ v x ≤ v y,
rw [←on_frac_comap_eq_apply v hv, ←on_frac_comap_eq_apply v hv], exact iff.rfl end

end fraction_ring -- end of section

section valuation_field

/-- The quotient ring R/supp(v) associated to a valuation. -/
definition valuation_ID := (supp v).quotient

/-- the support of a valuation is a prime ideal, so R/supp(v) is an integral domain. -/
instance integral_domain' : integral_domain (valuation_ID v) :=
by delta valuation_ID; apply_instance

/-- The preorder on R/supp(v) induced by Γ₀ via `v.on_quot` -/
instance : preorder (valuation_ID v) := (v.on_quot (le_refl _)).to_preorder

/-- The function R → R/supp(v). -/
def valuation_ID_mk : R → valuation_ID v := ideal.quotient.mk (supp v)

/-- The function R → R/supp(v) is a ring homomorphism. -/
instance : is_ring_hom (v.valuation_ID_mk) := by unfold valuation_ID_mk; apply_instance

/-- The kernel of R → R/supp(v) is supp(v). -/
lemma valuation_ID_mk_ker (r : R) : v.valuation_ID_mk r = 0 ↔ r ∈ supp v :=
ideal.quotient.eq_zero_iff_mem

/-- `valuation_field v` is the field of fractions of R/supp(v). -/
definition valuation_field := localization.fraction_ring (valuation_ID v)

/-- The field of fractions of R/supp(v) is a field. -/
instance : discrete_field (valuation_field v) := by delta valuation_field; apply_instance

/-- The canonical map R → fraction_ring (R/supp(v)). -/
def valuation_field_mk (r : R) : valuation_field v := localization.of (v.valuation_ID_mk r)

/-- The map R → Frac(R/supp(v)) is a ring homomorphism. -/
instance to_valuation_field.is_ring_hom : is_ring_hom (valuation_field_mk v) :=
by delta valuation_field_mk; apply_instance

/-- The kernel of R → Frac(R/supp(v)) is supp(v). -/
lemma valuation_field_mk_ker (r : R) : v.valuation_field_mk r = 0 ↔ r ∈ supp v :=
⟨λ h, (v.valuation_ID_mk_ker r).1 $ localization.fraction_ring.eq_zero_of _ h,
 λ h, show localization.of _ = 0, by rw (v.valuation_ID_mk_ker r).2 h; apply is_ring_hom.map_zero⟩

lemma valuation_field_mk_ne_zero (r : R) (hr : v r ≠ 0) : valuation_field_mk v r ≠ 0 :=
λ h, hr ((valuation_field_mk_ker v r).1 h)

/-- The induced preorder on Frac(R/supp(v)). -/
instance valfield_preorder : preorder (valuation_field v) :=
  ((v.on_quot (le_refl _)).on_frac $ supp_quot_supp v).to_preorder

/-- The induced map from R \ supp(v) to the units of Frac(R/supp(v)). -/
def units_valfield_mk (r : R) (h : r ∉ supp v) : units (valuation_field v) :=
⟨v.valuation_field_mk r,
 (v.valuation_field_mk r)⁻¹,
 mul_inv_cancel (λ h2, h $ ideal.quotient.eq_zero_iff_mem.1 $
   localization.fraction_ring.eq_zero_of _ h2),
 inv_mul_cancel (λ h2, h $ ideal.quotient.eq_zero_iff_mem.1 $
   localization.fraction_ring.eq_zero_of _ h2)⟩

/-- The preorder on the units of Frac(R/supp(v)) induced by the extension of v. -/
instance units_valfield_preorder :
  preorder (units (valuation_field v)) := preorder.lift (λ u, u.val) (by apply_instance)

/-- The valuation on Frac(R/supp(v)) induced by v. -/
definition on_valuation_field : valuation (valuation_field v) Γ₀ :=
on_frac (v.on_quot (set.subset.refl _))
begin
  rw [supp_quot, ideal.zero_eq_bot],
  apply ideal.map_quotient_self,
end

/-- `valuation_ring v` is the elements of Frac(R/supp(v)) whose valuation is at most 1. -/
definition valuation_ring := {x | v.on_valuation_field x ≤ 1}

/-- `valuation_ring v` is a subring of Frac(R/supp(v)). -/
instance : is_subring (valuation_ring v) :=
{ zero_mem := show v.on_valuation_field 0 ≤ 1, by simp,
  add_mem := λ x y hx hy,
  calc v.on_valuation_field (x + y) ≤ max (v.on_valuation_field x) (v.on_valuation_field y) :
    v.on_valuation_field.map_add x y
    ... ≤ 1 : max_le hx hy,
  neg_mem := by simp [valuation_ring],
  one_mem := by simp [valuation_ring, le_refl],
  mul_mem := λ x y (hx : _ ≤ _) (hy : _ ≤ _), show v.on_valuation_field _ ≤ 1,
  by convert le_trans (linear_ordered_structure.mul_le_mul_left hy _) _; simp [hx] }

/-- `max_ideal v` is the ideal of `valuation_ring v` consisting of things with valuation
strictly less than 1. -/
definition max_ideal : ideal (valuation_ring v) :=
{ carrier := { r | v.on_valuation_field r < 1 },
  zero := show v.on_valuation_field 0 < 1, by apply lt_of_le_of_ne; simp,
  add := λ x y (hx : _ < 1) (hy : _ < 1),
  calc v.on_valuation_field (x + y) ≤ max (v.on_valuation_field x) (v.on_valuation_field y) :
    v.on_valuation_field.map_add x y
    ... < 1 : max_lt hx hy,
  smul := λ c x (hx : _ < 1),
  show v.on_valuation_field _ < 1,
  begin
    refine lt_of_le_of_lt _ _,
    swap,
    convert (linear_ordered_structure.mul_le_mul_right _ _),
    exact map_mul _ _ _,
    swap,
    convert c.property,
    simpa using hx
  end }

set_option class.instance_max_depth 40

/-- `max_ideal v` is indeed a maximal ideal of `valuation_ring v`. -/
instance max_ideal_is_maximal : (max_ideal v).is_maximal :=
begin
  rw ideal.is_maximal_iff,
  split,
  { exact λ (H : _ < _), ne_of_lt H (map_one _) },
  { rintros J ⟨x,hx⟩ hJ hxni hxinJ,
    have vx : v.on_valuation_field x = 1 :=
    by { rw eq_iff_le_not_lt, split; assumption },
    have hxinv : v.on_valuation_field x⁻¹ ≤ 1 := by simp [vx],
    convert J.smul_mem ⟨x⁻¹, hxinv⟩ hxinJ,
    symmetry, apply subtype.val_injective,
    apply inv_mul_cancel,
    show x ≠ 0,
    assume hxeq0, simpa [hxeq0] using vx }
end

set_option class.instance_max_depth 32

/-- `residue_field v` is the quotient of `valuation_ring v` by `max_ideal v`. -/
definition residue_field := (max_ideal v).quotient

/-- `residue_field v` is a field. -/
instance residue_field.discrete_field : discrete_field (residue_field v) := ideal.quotient.field _
end valuation_field
end valuation


/- This file proves a minmax formula for π₂, the maximum size of an (M₁,M₂)-partitionable set,
  where M₁ and M₂ are matroids on a common ground set α, and also proves that the partitionable
  sets are the independent sets of a matroid on α. Then it generalizes the latter result to a
  general list of matroids; the former is todo but shouldn't be too bad.  -/

import prelim.minmax prelim.setlist
import matroid.submatroid.projection  .matroid_inter .basic
import matroid.constructions.uniform
import algebra.big_operators
import set_tactic.solver

open_locale classical big_operators
noncomputable theory
open set matroid

variables {α : Type*} [fintype α]

section intersections_of_bases

lemma two_partitionable_iff_union_two_indep {M₁ M₂ : matroid α} {X : set α} :
  is_two_partitionable M₁ M₂ X ↔ is_union_two_indep M₁ M₂ X :=
begin
  refine ⟨λ h, _, λ h, _⟩,
  rcases h with ⟨I₁,I₂,_,_,_,_⟩,
  refine ⟨I₁,I₂,_,_,_⟩; assumption,
  rcases h with ⟨I₁,I₂,i₁,i₂,hu⟩,
  refine ⟨I₁,I₂ \ I₁,i₁,indep_of_subset_indep _ i₂,_,_⟩,
  { apply diff_subset, },
  { rw hu, finish, },
  finish,
end

lemma subset_inter_bases_is_common_ind {M₁ M₂ : matroid α} {I : set α} :
  is_subset_inter_bases M₁ M₂ I → is_common_ind M₁ M₂ I :=
begin
  rintros ⟨Y, ⟨B₁,B₂,hB₁,hB₂, hIB₁B₂⟩,hY'⟩,
  rw ←hIB₁B₂ at hY', split,
  refine indep_of_subset_indep (subset.trans hY' _) (basis_is_indep hB₁),
  apply inter_subset_left,
  refine indep_of_subset_indep (subset.trans hY' _) (basis_is_indep hB₂),
  apply inter_subset_right,
end

lemma is_common_ind_iff_is_subset_inter_bases {M₁ M₂ : matroid α} :
  is_common_ind M₁ M₂ = is_subset_inter_bases M₁ M₂ :=
begin
  ext I,
  refine ⟨λ h, _, subset_inter_bases_is_common_ind⟩,
  rcases extends_to_basis h.1 with ⟨B₁,hIB₁,hB₁⟩,
  rcases extends_to_basis h.2 with ⟨B₂,hIB₂,hB₂⟩,
  from ⟨B₁ ∩ B₂, ⟨B₁, B₂, hB₁, hB₂, rfl⟩, subset_inter hIB₁ hIB₂⟩,
end

lemma inter_two_bases_is_subset_inter_bases {M₁ M₂ : matroid α} {B₁ B₂ : set α} :
  is_basis M₁ B₁ → is_basis M₂ B₂ → is_subset_inter_bases M₁ M₂ (B₁ ∩ B₂) :=
λ h₁ h₂, by {refine ⟨B₁ ∩ B₂, ⟨B₁,B₂,h₁,h₂, rfl⟩ , subset_refl _⟩, }

lemma inter_bases_is_subset_inter_bases {M₁ M₂ : matroid α} {I : set α} :
  is_inter_bases M₁ M₂ I → is_subset_inter_bases M₁ M₂ I :=
λ h, by {rcases h with ⟨B₁,B₂,h⟩, refine ⟨I, ⟨B₁, B₂, h⟩, subset_refl _⟩,}

lemma inter_bases_is_common_ind {M₁ M₂ : matroid α} {I : set α} :
  is_inter_bases M₁ M₂ I → is_common_ind M₁ M₂ I :=
by {rw is_common_ind_iff_is_subset_inter_bases, from inter_bases_is_subset_inter_bases}

lemma max_common_indep_inter_bases (M₁ M₂ : matroid α) :
  ν M₁ M₂ = max_val (λ (pair : basis_pair M₁ M₂), inter_size pair.val) :=
begin
  rcases max_spec (λ (X : common_ind M₁ M₂), size X.val) with ⟨⟨I,hI_ind⟩,hI_size,hI_ub⟩,
  rcases max_spec (λ (pair : basis_pair M₁ M₂), inter_size pair.val) with ⟨⟨⟨B₁, B₂⟩,hB⟩,h_inter,h_size_ub⟩,
  rw [ν], dsimp at *, rw [←hI_size, ←h_inter],
  apply le_antisymm,
  { rw is_common_ind_iff_is_subset_inter_bases at hI_ind,
    rcases hI_ind with ⟨Y,⟨⟨B₁',B₂',⟨hB₁',hB₂',hY⟩⟩,h'⟩⟩,
    have := h_size_ub ⟨⟨B₁',B₂'⟩, ⟨hB₁', hB₂'⟩⟩, rw inter_size at this, dsimp at this,
    rw ←hY at h',
    linarith [size_monotone h'],},
  refine hI_ub
  ⟨ B₁ ∩ B₂,
    subset_inter_bases_is_common_ind (inter_two_bases_is_subset_inter_bases hB.1 hB.2)⟩,
end

end intersections_of_bases

section two_union

lemma π₂_eq_max_union_bases (M₁ M₂ : matroid α) :
  π₂ M₁ M₂ = max_val (λ (Bp : basis_pair M₁ M₂), union_size Bp.val) :=
begin
  rcases max_spec (λ (Bp : basis_pair M₁ M₂), union_size Bp.val)
    with ⟨⟨⟨Bp₁, Bp₂⟩, hBp⟩, hBp_union, hBp_ub⟩,
  rcases max_spec (λ (Ip : indep_pair M₁ M₂), union_size Ip.val)
    with ⟨⟨⟨Ip₁, Ip₂⟩, hIp⟩, hIp_union, hIp_ub⟩,
  rw [π₂ ], dsimp only at *, rw [←hBp_union, ←hIp_union],
  apply le_antisymm,
  rcases extends_to_basis hIp.1 with ⟨B₁,hB₁⟩,
  rcases extends_to_basis hIp.2 with ⟨B₂,hB₂⟩,
  refine le_trans (size_monotone _) (hBp_ub ⟨⟨B₁, B₂⟩, ⟨hB₁.2, hB₂.2⟩⟩),
  from union_subset_union hB₁.1 hB₂.1,
  from hIp_ub ⟨⟨Bp₁,Bp₂⟩, ⟨basis_is_indep hBp.1,basis_is_indep hBp.2⟩⟩,
end

/-- simple relationship between π M₁ M₂ and ν M₁ M₂* -/
theorem π₂_eq_ν_plus_r (M₁ M₂ : matroid α) :
  π₂ M₁ M₂ = ν M₁ (M₂.dual) + M₂.r univ :=
begin
  rw [eq_comm,max_common_indep_inter_bases, π₂_eq_max_union_bases],

  -- bijection φ that we will use to reindex summation
  set φ : basis_pair M₁ M₂ → basis_pair M₁ (dual M₂) := λ p, ⟨⟨p.val.1, p.val.2ᶜ⟩,_⟩ with hφ,
  swap,

  -- φ really maps to basis,cobasis pairs
  { dsimp only, refine ⟨p.property.1, _⟩,
    rw [←cobasis_iff_compl_basis, cobasis_iff, dual_dual],
    from p.property.2, },
  -- ... and is surjective

  have hφ_sur : function.surjective φ := by
  { refine λ Bp, ⟨⟨⟨Bp.val.1,Bp.val.2ᶜ⟩,⟨Bp.property.1,_⟩⟩,_⟩, dsimp,
    rw [←cobasis_iff_compl_basis, cobasis_iff], from Bp.property.2,
    rw hφ,  simp,},
  -- use φ to reindex so LHS/RHS are being summed over the same set
  have := max_reindex φ hφ_sur (λ pair, inter_size pair.val),
  erw ←this,

  -- bring addition inside the max
  rw max_add_commute,

  -- it remains show the functions we're maximizing are the same
  convert rfl,
  ext Bp,
  rcases Bp with ⟨⟨B₁,B₂⟩,hB⟩,
  dsimp [union_size,inter_size] at ⊢,
  linarith [size_basis hB.1, size_basis hB.2, size_modular B₁ B₂, size_induced_partition_inter B₁ B₂],
end

/-- The matroid union theorem for two matroids : a minmax formula for the size of the
largest partitionable set. The heavy lifting in the proof is done by matroid intersection. -/
theorem two_matroid_union (M₁ M₂ : matroid α) :
  π₂ M₁ M₂ = min_val (λ A : set α, size Aᶜ + M₁.r A + M₂.r A ) :=
begin
  rw [π₂_eq_ν_plus_r, matroid_intersection,  min_add_commute _ (M₂.r univ)],
  congr', ext X,
  rw [dual_r, compl_compl],
  linarith,
end

end two_union

section two_union_matroid

namespace two_union_matroid

variables (M₁ M₂ : matroid α)

/-- notation for loopifying to a set -/
local infix ` |  `:50 := λ (M : matroid α) (X : set α), (M.loopify_to X)

/-- independent pairs of a subset are independent pairs of a loopification to that set -/
lemma indep_pair_of_subset_as_indep_pair_loopify (X : set α) :
    max_val (λ Ip : indep_pair_of_subset M₁ M₂ X, union_size Ip.val) = π₂ (M₁ | X) (M₂ | X) :=
begin
  set φ : indep_pair_of_subset M₁ M₂ X → indep_pair (M₁ | X) (M₂ | X) :=
    λ Ip,
    ⟨Ip.val ,
    by {split; {rw indep_loopify_to_iff, rcases Ip with ⟨_,⟨⟨_,_⟩,⟨_,_⟩⟩⟩, split; assumption}}⟩
  with hφ,
  have hφ_sur : function.surjective φ := λ Ip,
  by {rcases Ip with ⟨p, ⟨h₁,h₂⟩⟩,
      rw indep_loopify_to_iff at h₁ h₂,
      cases h₁, cases h₂,
      refine ⟨⟨p,⟨⟨_,_⟩,⟨_,_⟩⟩⟩ ,_⟩; try {assumption},
      simp},
  rw (max_reindex φ hφ_sur (λ Ip : indep_pair (M₁ | X) (M₂ | X), union_size Ip.val)),
  trivial,
end

/-- matroid union theorem for common independent sets of a given subset X -/
theorem two_matroid_union_on_subset (X : set α) :
  max_val (λ Ip : indep_pair_of_subset M₁ M₂ X, union_size Ip.val)
  = min_val (λ A : {Y : set α // Y ⊆ X}, size (X \ A) + M₁.r A + M₂.r A) :=
begin
  rw [indep_pair_of_subset_as_indep_pair_loopify, two_matroid_union],

  rcases min_spec (λ A : {Y : set α // Y ⊆ X}, size (X \ A) + M₁.r A + M₂.r A)
    with ⟨A, hA', hA⟩,
  rcases min_spec (λ A : set α, size Aᶜ + (M₁|X).r A + (M₂|X).r A)
    with ⟨B, hB', hB⟩,

  rw [←hA', ←hB'], clear hA' hB',
  simp_rw [loopify_to_r] at *,
  have hXB : Xᶜ ⊆ B,
  begin
    rw [subset_iff_union_eq_left, eq_comm],
    suffices : ¬B ⊂ (Xᶜ ∪ B),
    from eq_of_subset_not_ssubset  (subset_union_right Xᶜ B) this,
    intro h,
    have h' := hB (Xᶜ ∪ B),
    simp only [inter_distrib_right, compl_inter_self, compl_compl,
    set.compl_union, empty_union, add_le_add_iff_right] at h',
    rw [←compl_compl_union_left, compl_size, compl_size] at h',
    linarith [size_strict_monotone h],
  end,
  apply le_antisymm,

  convert hB (Xᶜ ∪ A),
  { simp [compl_compl_union_left, diff_eq]},
  repeat
  { unfold_coes,
    simp only [inter_distrib_right, subset_iff_inter_eq_left.mp A.property, compl_inter_self,
     empty_union], },

  convert hA ⟨B ∩ X, inter_subset_right _ _⟩,
  dsimp only [subtype.coe_mk],
  ext,
  simp only [mem_inter_eq, not_and, mem_diff, subtype.coe_mk, mem_compl_eq],
  specialize @hXB x, rw mem_compl_iff at hXB,
  tauto,
end

/-- the rank function of the partitionable-sets matroid : rank is the size of a largest
(M₁,M₂)-partitionable subset.  -/
def r : set α → ℤ :=
  λ X, max_val (λ Ip : indep_pair_of_subset M₁ M₂ X, union_size Ip.val)

lemma R0 :
  satisfies_R0 (r M₁ M₂) :=
λ X, by { apply lb_le_max, intro Ip, apply size_nonneg}

lemma R1 :
  satisfies_R1 (r M₁ M₂) :=
by {intro X, apply max_le_ub, from λ Ip, size_monotone (union_subset Ip.2.2.1 Ip.2.2.2)}

lemma R2 :
  satisfies_R2 (r M₁ M₂) :=
begin
  intros X Y hXY,
  let φ : indep_pair_of_subset M₁ M₂ X → indep_pair_of_subset M₁ M₂ Y := λ Ip, ⟨Ip.val, _⟩,
  { convert max_compose_le_max φ (λ Ip, union_size Ip.val)},
  rcases Ip with ⟨_, ⟨⟨_,_⟩,⟨_,_⟩⟩⟩,
  refine ⟨⟨_,_⟩,⟨_,_⟩⟩;
  { try {assumption}, try {from subset.trans (by assumption) hXY}},
end

lemma R3 :
  satisfies_R3 (r M₁ M₂) :=
begin
  intros X Y, unfold r,
  repeat {rw [two_matroid_union_on_subset]},
  repeat {rw [sum_of_min]},
  have hu : ∀ p : {Y // Y ⊆ X} × {Y_1 // Y_1 ⊆ Y}, p.1.1 ∪ p.2.1 ⊆ X ∪ Y :=
    λ p, set.union_subset_union p.1.2 p.2.2,
  have hi : ∀ p : {Y // Y ⊆ X} × {Y_1 // Y_1 ⊆ Y}, p.1.1 ∩ p.2.1 ⊆ X ∩ Y :=
    λ p, set.inter_subset_inter p.1.2 p.2.2,
  set φ : {Y // Y ⊆ X} × {Y_1 // Y_1 ⊆ Y} → {Y_1 // Y_1 ⊆ X ∪ Y} × {Y_1 // Y_1 ⊆ X ∩ Y} :=
    λ p, ⟨⟨p.1.1 ∪ p.2.1, hu p⟩,⟨p.1.1 ∩ p.2.1, hi p⟩⟩ with hφ,
  refine le_trans (min_le_min_compose φ _) _,
  apply min_of_le_is_le,
  rintro ⟨A,B⟩, rw hφ,
  dsimp [-diff_eq],
  unfold_coes,
  rw [diff_size A.2, diff_size B.2, diff_size (hi ⟨A,B⟩), diff_size (hu ⟨A,B⟩)],
  linarith [size_modular X Y, size_modular A.1 B.1, M₁.rank_submod A.1 B.1, M₂.rank_submod A.1 B.1],
end

/-- the matroid whose independent sets are the (M₁,M₂)-partitionable ones -/
def union (M₁ M₂ : matroid α) : matroid α :=
  ⟨r M₁ M₂, R0 M₁ M₂, R1 M₁ M₂, R2 M₁ M₂, R3 M₁ M₂⟩

/-- independence in the union of two matroids is two-partitionability -/
lemma indep_iff (M₁ M₂ : matroid α){X : set α} :
  (union M₁ M₂).is_indep X ↔ is_two_partitionable M₁ M₂ X :=
begin
  rw [indep_iff_r, union], simp only [r],
  rcases max_spec (λ (Ip : indep_pair_of_subset M₁ M₂ X), union_size Ip.val)
    with ⟨⟨⟨I₁,I₂⟩,⟨⟨hempty_indep,hindep_of_subset_indep⟩,hX1,hX2⟩⟩, hI', hI⟩,
  rw [←hI'], clear hI', dsimp only,
  have hss := (set.union_subset_union hX1 hX2), simp only [set.union_self] at hss,

  refine ⟨λ h, ⟨I₁,I₂ \ I₁, hempty_indep,_,_,_⟩, λ h, _⟩,
  from indep_of_subset_indep (diff_subset I₂ I₁) hindep_of_subset_indep,
  dsimp only [union_size] at h,  rw [eq_of_eq_size_subset_iff hss] at h, rw ←h,
  rw ←union_diff_absorb,
  --simp only [diff_eq],
  --rw ← diff_eq,
  apply inter_diff,
  rcases h with ⟨I₁',I₂', ⟨h11,h12,h21,h22⟩⟩,
  subst h21,
  refine le_antisymm (size_monotone hss) _ ,
  refine hI ⟨⟨I₁',I₂'⟩, _⟩,
  from ⟨⟨h11,h12⟩, subset_union_left _ _, subset_union_right _ _⟩,
end

/-- independence in the union of two matroids is expressibility as a union of independent sets  -/
lemma indep_iff_union (M₁ M₂ : matroid α){X : set α} :
  (union M₁ M₂).is_indep X ↔ is_union_two_indep M₁ M₂ X :=
by rw [indep_iff, two_partitionable_iff_union_two_indep]

/-lemma exists_two_union_matroid (M₁ M₂ : matroid α) :
  ∃! (M : matroid α), M.is_indep = is_union_two_indep M₁ M₂ :=
begin
  use (two_union_matroid M₁ M₂),
end-/

end two_union_matroid

end two_union_matroid

section union

variables {n : ℕ}

open unif
theorem exists_union_matroid (Ms : fin n → matroid α) :
  ∃ (M_union: matroid α), ∀ X, M_union.is_indep X ↔ is_union_indep_tuple Ms X :=
begin
  induction n with n IH,
    -- base case
    {use loopy α,
    simp_rw [loopy_matroid_indep_iff_empty, is_union_indep_tuple],
    refine λ X, ⟨λ h, _, λ h, _⟩,
      {refine ⟨⟨λ i, fin_zero_elim i, λ i, fin_zero_elim i⟩,_⟩,
        simp only,
        rw [h, eq_comm, Union_eq_empty],
        exact fin_zero_elim,  },
    cases h with Is hIs, rw hIs,
    simp only [set.Union_eq_empty, subtype.val_eq_coe],
    apply fin_zero_elim},

  set Ms₀ := fin.tail Ms,
  set N := Ms 0 with hN,
  cases IH Ms₀ with Mα₀ hMα₀, clear IH,
  refine ⟨two_union_matroid.union Mα₀ N, λ X, _⟩,
  rw [two_union_matroid.indep_iff_union, is_union_two_indep], dsimp only,
  refine ⟨λ h, _, λ h, _⟩,
  { rcases h with ⟨I₁,I₂,h₁,h₂,rfl⟩,
    rw hMα₀ at h₁, rcases h₁ with ⟨⟨Is₀,h₃⟩,rfl⟩,
    unfold is_union_indep_tuple,
    refine ⟨⟨@fin.cons _ (λ i, set α) I₂ Is₀,λ i,_⟩, _⟩, swap, rw seq.Union_cons,
    revert i, refine λ i, fin.cases (by {rw ←hN, simp [h₂]}) (λ i₀ , _) i,
    convert h₃ i₀, simp},
  rcases h with ⟨⟨Is,h₂⟩, rfl⟩,
  refine ⟨set.Union (fin.tail Is),Is 0,_,⟨h₂ 0,_⟩⟩,
  { rw hMα₀, refine ⟨⟨fin.tail Is,λ i, h₂ (fin.succ i)⟩,rfl⟩},
  simp [←seq.Union_cons],
end

/-- the union of a list of matroids, as a matroid -/
def union_matroid (Ms : fin n → matroid α) : matroid α :=
  classical.some (exists_union_matroid Ms)

/-- independence in the union matroid -/
theorem union_matroid_indep_iff (Ms : fin n → matroid α) :
  (union_matroid Ms).is_indep = is_union_indep_tuple Ms :=
by {ext x, from classical.some_spec (exists_union_matroid Ms) x}

-- todo

lemma union_matroid_rank_eq_pi (Ms : fin n → matroid α) :
  (union_matroid Ms).r univ = π Ms :=
begin
  unfold π, rw [r_univ_eq_max_size_indep],
  set φ : (indep_tuple Ms) → (union_matroid Ms).indep :=
  λ Is, ⟨set.Union Is.val, by {rw union_matroid_indep_iff, use Is, }⟩ with hφ,
  have hφ' : function.surjective φ,
  { rintros ⟨I,hI⟩,
    rw hφ, simp only [subtype.mk_eq_mk, subtype.val_eq_coe],
    rw union_matroid_indep_iff at hI,
    cases hI with Is hIs,
    use Is, convert hIs.symm, },
  rw max_reindex φ hφ' (λ I, size I.val), trivial,
end

end union
/-
theorem matroid_union (Ms : fin n → matroid α) :
  π Ms = min_val (λ (A : set α), size Aᶜ + ∑ i, (Ms i).r A ) :=
begin
  --rw ←union_matroid_rank_eq_pi,
  induction n with n IH, unfold π, sorry,
  set N := Ms 0 with hN,
  specialize IH (fin.tail Ms), unfold π at *,
  /-set φ : indep_tuple Ms → N.indep × (indep_tuple (fin.tail Ms)) := λ Is,
    ⟨⟨Is.val 0, by {rw hN, from Is.property 0}⟩,
    ⟨fin.tail Is.val, λ i, by {exact Is.property i.succ, }⟩⟩ with hφ,
  have hφ' : function.surjective φ,
  {
    rintros ⟨I₀, Is⟩,
    refine ⟨⟨fin.cons I₀.val Is.val, λ i, fin.cases _ (λ i₀,_) i⟩,_⟩,
      {convert I₀.property,},
      {convert Is.property i₀, simp, },
    rw hφ, simp,
  }, -/

  set φ : N.indep × (indep_tuple (fin.tail Ms)) → indep_tuple Ms := λ Is,
    ⟨fin.cons Is.1.val Is.2.val, λ i,
      begin
        revert i, refine λ i, fin.cases _ (λ i₀, _) i,
        convert Is.1.property,
        convert Is.2.property i₀, simp,
      end ⟩ with hφ,

  have hφ' : function.surjective φ := sorry,
  erw [←(max_reindex φ hφ' (λ Is, size (set.Union Is.val))), hφ],

  sorry,

end
-/

/-
/-- statement that each I_i is indep in M_i -/
def is_indep_tuple {n : ℕ} (Ms: fin n → matroid α) : (fin n → set α) → Prop :=
  λ Is, ∀ i : fin n, (Ms i).is_indep (Is i)

/-- subtype of vectors of independent sets -/
def indep_tuple {n : ℕ} (Ms : fin n → matroid α) : Type :=
  {Is : fin n → (set α) // is_indep_tuple Ms Is}

instance indep_tuple_nonempty {n : ℕ} (Ms : fin n → matroid α ) : nonempty (indep_tuple Ms) :=
by {apply nonempty_subtype.mpr, from ⟨(λ x, ∅), λ i, (Ms i).empty_indep ⟩}

instance indep_tuple_fintype {n : ℕ} (Ms: fin n → matroid α) : fintype (indep_tuple Ms) :=
by {unfold indep_tuple, apply_instance }

def sum_of_ranks {n : ℕ} (Ms : fin n → matroid α) : ℤ :=
  ∑ i, (Ms i).r univ

def union_of_tuple {n : ℕ} (Xs : fin n → set α) : set α :=
  ⋃ i, Xs i

def π_tuple {n : ℕ} : (fin n → matroid α) → ℤ :=
  λ Ms, max_val (λ (Is: indep_tuple Ms), size (union_of_tuple Is.val) )

@[simp] lemma sum_fin_one (a : fin 1 → ℤ) :
  ∑ i, a i = a 0 :=
by simp

@[simp] lemma union_fin_zero (a : fin 0 → set α) :
  (⋃ i, a i) = ∅ :=
begin
  simp only [set.Union_eq_empty],
  from λ i, fin_zero_elim i,
end

@[simp] lemma inter_fin_zero (a : fin 0 → set α) :
  (⋂ i, a i) = univ :=
begin
  simp only [set.Inter_eq_univ],
  from λ i, fin_zero_elim i,
end

@[simp] lemma union_fin_one (a : fin 1 → set α) :
  (⋃ i, a i) = a 0 :=
begin
  ext x, rw [set.mem_Union],
  refine ⟨λ h, _, λ h, ⟨0,h⟩⟩,
  cases h with i hi,
  rw (fin.eq_zero i) at hi,
  from hi,
end

@[simp] lemma inter_fin_one (a : fin 1 → set α) :
  (⋂ i, a i) = a 0 :=
begin
  ext x, rw [set.mem_Inter],
  refine ⟨λ h, _, λ h i,_ ⟩,
  from h 0,
  rw fin.eq_zero i,
  from h,
end

/-- function mapping tuples of indep sets to the size of the union -/
def matroid_union_lb_fn {n : ℕ} (Ms : fin n → matroid α) :=
  (λ (Is : indep_tuple Ms), size (union_of_tuple Is.val))

/-- function mapping each sets the size of its complement plus the sum of its ranks
in the list of matroids: an upper bound for matroid union -/
def matroid_union_ub_fn {n : ℕ} (Ms : fin n → matroid α) :=
  (λ (A : set α), size Aᶜ + ∑ i, (Ms i).r A )

lemma lb_fn_trivial (Ms : fin 0 → matroid α) :
  matroid_union_lb_fn Ms = λ Is, 0 :=
begin
  ext x,
  unfold matroid_union_lb_fn union_of_tuple, dsimp only,
  rw [size_zero_iff_empty, set.Union_eq_empty],
  from λ i, fin_zero_elim i,
end

theorem matroid_union' {n : ℕ} (Ms : fin n → matroid α) :
  max_val (matroid_union_lb_fn Ms) = min_val (matroid_union_ub_fn Ms) :=
begin
  induction n with n IH,

  -- base case
  simp only [matroid_union_ub_fn, add_zero, fin.sum_univ_zero, lb_fn_trivial, max_const],
  rw attained_lb_is_min' (λ (X : set α), size Xᶜ ) (univ : set α) 0 _ _;
  simp [size_nonneg],

  cases nat.eq_zero_or_pos n with hn,

  -- one-matroid case
  subst hn,
  unfold matroid_union_lb_fn matroid_union_ub_fn union_of_tuple,
  simp_rw [union_fin_one, sum_fin_one],
  apply minmax_eq_cert,
  cases exists_basis (Ms 0) with B hB,
  set Bfn := (λ (i : fin 1), B) with h_Bfn,
  have Bprop : ∀ (i : fin 1), (Ms i).is_indep (Bfn i) := by
    {intros i,  rw h_Bfn, dsimp only, convert (basis_is_indep hB)},

  refine ⟨⟨Bfn, Bprop⟩, univ, _⟩,
  simp [size_basis hB],

  intros Is A,
  rw ←indep_iff_r.mp (Is.property 0),
  have hd := (dual (Ms 0)).rank_nonneg Aᶜ,
  rw [dual_r , compl_compl] at hd,
  linarith [(Ms 0).rank_mono (subset_univ (Is.val 0))],

  --have := rank_le_univ M0

  --let Bt : indep_tuple Ms := ⟨⟨λ (i : fin n.succ), B⟩ , by {}⟩,
  --use ⟨⟨λ i, B⟩, _⟩,
  --refine ⟨⟨λ x, B⟩ ,_⟩ , (univ : set α)⟩,
  --rw hn at Ms,
  rcases max_spec (matroid_union_lb_fn Ms) with ⟨Is, ⟨hIs₁, hIs₂⟩⟩,
  rcases min_spec (matroid_union_ub_fn Ms) with ⟨A, ⟨hA₁, hA₂⟩⟩,

  rw [←hIs₁, ←hA₁],
  sorry,
  --unfold matroid_union_ub_fn matroid_union_lb_fn,

end
-/


import SciLean.Core.IntegralProperties

set_option synthInstance.maxSize 2000

namespace SciLean

--------------------------------------------------------------------------------
-- Divergence
--------------------------------------------------------------------------------

/-- This divergence is an adjoint of `∇ : (X⟿ℝ) → (X⟿X)` -/
noncomputable
def divergence {X ι} [Enumtype ι] [FinVec X ι] (f : X→X) : X→ℝ :=
  λ x => ∑ i, 𝕡 i (∂ f x (𝕖[X] i))  -- ⟪∂ f x (e[X] i), 𝕖'[X] i⟫

/-- This divergence is an adjoint of `∇ : (X⟿ℝ) → (X⟿X)` -/
noncomputable
def Smooth.divergence {X ι} [Enumtype ι] [FinVec X ι] (f : X⟿X) : X⟿ℝ :=
  λ x ⟿ ∑ i, 𝕡 i (∂ f x (𝕖[X] i))  -- ⟪∂ f x (e[X] i), 𝕖'[X] i⟫

instance Smooth.divergence.instDivergenceNotation
  {X ι} [Enumtype ι] [FinVec X ι] (f : X⟿X)
  : Divergence f (Smooth.divergence f) := ⟨⟩

/-- This divergence is an adjoint of `∂ : (X⟿Y) → (X⟿X⊸Y)` -/
noncomputable
def divergenceDual {X Y ι} [Enumtype ι] [FinVec X ι] [Vec Y] (f : X→X→Y) : X→Y :=
  λ x => ∑ i, ∂ f x (𝕖'[X] i) (𝕖'[X] i)

/-- This divergence is an adjoint of `∂ : (X⟿Y) → (X⟿X⊸Y)` -/
noncomputable
def Smooth.divergenceDual {X Y ι} [Enumtype ι] [FinVec X ι] [Vec Y] (f : X⟿X⊸Y) : X⟿Y :=
  λ x ⟿ ∑ i, ∂ f x (𝕖'[X] i) (𝕖'[X] i)

instance Smooth.divergenceDual.instDivergenceNotation
  {X Y ι} [Enumtype ι] [FinVec X ι] [Vec Y] (f : X⟿X⊸Y)
  : Divergence f (Smooth.divergenceDual f) := ⟨⟩

--------------------------------------------------------------------------------
-- Divergence - properties
--------------------------------------------------------------------------------

variable {X Y ι} [Enumtype ι] [FinVec X ι] [Hilbert Y]

-- Divergence

instance Smooth.divergence.arg_f.hasAdjoint
  : HasAdjoint (Smooth.divergence : (X⟿X) → (X⟿ℝ)) := sorry_proof
instance Smooth.divergence.arg_f.isLin
  : IsLin (Smooth.divergence : (X⟿X) → (X⟿ℝ)) := by infer_instance
instance Smooth.divergence.arg_f.isSmooth
  : IsSmooth (Smooth.divergence : (X⟿X) → (X⟿ℝ)) := by infer_instance

@[diff]
theorem Smooth.divergence.arg_f.adj_simp
  : (Smooth.divergence : (X⟿X) → (X⟿ℝ))†
    =
    - Smooth.gradient := sorry_proof

-- Divergence Dual

instance Smooth.divergenceDual.arg_f.hasAdjoint
  : HasAdjoint (Smooth.divergenceDual : (X⟿X⊸Y) → (X⟿Y)) := sorry_proof
instance Smooth.divergenceDual.arg_f.isLin
  : IsLin (Smooth.divergenceDual : (X⟿X⊸Y) → (X⟿Y)) := by infer_instance
instance Smooth.divergenceDual.arg_f.isSmooth
  : IsSmooth (Smooth.divergenceDual : (X⟿X⊸Y) → (X⟿Y)) := by infer_instance

@[diff]
theorem Smooth.divergenceDual.arg_f.adj_simp
  : (Smooth.divergenceDual : (X⟿X⊸Y) → (X⟿Y))†
    =
    - Smooth.differential := sorry_proof

--------------------------------------------------------------------------------
-- Differential - properties
--------------------------------------------------------------------------------

instance Smooth.differential.arg_f.hasAdjoint
  : HasAdjoint (Smooth.differential : (X⟿Y) → X⟿X⊸Y) := by (try infer_instance); sorry_proof
instance Smooth.differential.arg_f.isLin {X Y} [Vec X] [Vec Y]
  : IsLin (Smooth.differential : (X⟿Y) → X⟿X⊸Y) := by (try infer_instance); sorry_proof
instance Smooth.differential.arg_f.isSmooth {X Y} [Vec X] [Vec Y]
  : IsSmooth (Smooth.differential : (X⟿Y) → X⟿X⊸Y) := by infer_instance

theorem Smooth.differential.arg_f.adj_simp {X Y ι} [Enumtype ι] [FinVec X ι] [Hilbert Y]
  : (Smooth.differential : (X⟿Y) → X⟿X⊸Y)†
    =
    - Smooth.divergenceDual
    := sorry_proof

--------------------------------------------------------------------------------
-- Differential Scalar - properties
--------------------------------------------------------------------------------

instance Smooth.differentialScalar.arg_f.hasAdjoint {X} [Hilbert X]
  : HasAdjoint (λ (f : ℝ⟿X) => ⅆ f) := by (try infer_instance); sorry_proof
instance Smooth.differentialScalar.arg_f.isLin {X} [Vec X]
  : IsLin (Smooth.differentialScalar : (ℝ⟿X) → ℝ⟿X) := by (try infer_instance); sorry_proof
instance Smooth.differentialScalar.arg_f.isSmooth {X} [Vec X]
  : IsSmooth (Smooth.differentialScalar : (ℝ⟿X) → ℝ⟿X) := by infer_instance

@[diff]
theorem Smooth.differentialScalar.arg_f.adj_simp {X} [Hilbert X]
  : (Smooth.differentialScalar : (ℝ⟿X) → (ℝ⟿X))†
    =
    - Smooth.differentialScalar
    := sorry_proof

--------------------------------------------------------------------------------
-- Differential Scalar - properties
--------------------------------------------------------------------------------

instance Smooth.gradient.arg_f.hasAdjoint
  : HasAdjoint (Smooth.gradient : (X⟿ℝ) → (X⟿X)) := by (try infer_instance); sorry_proof
instance Smooth.gradient.arg_f.isLin {X} [SemiHilbert X]
  : IsLin (Smooth.gradient : (X⟿ℝ) → (X⟿X)) := by (try infer_instance); sorry_proof
instance Smooth.gradient.arg_f.isSmooth {X} [SemiHilbert X]
  : IsSmooth (Smooth.gradient : (X⟿ℝ) → (X⟿X)) := by infer_instance

@[diff]
theorem Smooth.gradient.arg_f.adj_simp
  : (Smooth.gradient : (X⟿ℝ) → X⟿X)†
    =
    - Smooth.divergence
    := sorry_proof

--------------------------------------------------------------------------------
-- doodle
--------------------------------------------------------------------------------

set_option synthInstance.maxSize 2000 in
example  (f : ℝ⟿ℝ) : (fun (g : ℝ⟿ℝ) => fun x ⟿ ⟪f x, ⅆ g x⟫)†
                       =
                       λ h => - ⅆ (λ x ⟿ h x * f x) := by symdiff; done

set_option synthInstance.maxSize 2000 in
example  (f : ℝ⟿ℝ) : HasAdjointT fun (g : ℝ⟿ℝ) => fun x ⟿ ⟪ⅆ f x, ⅆ g x⟫ := by infer_instance

-- set_option synthInstance.maxSize 2000 in
example  (f : X⟿ℝ) : (fun (g : X⟿ℝ) => fun x ⟿ ⟪∇ f x, ∇ g x⟫)†
                       =
                       λ h : X⟿ℝ => - ∇· (λ x ⟿ (h x * ∇ f x)) := by symdiff; done

@[diff]
theorem hahah {X Y Z} [Vec X] [Vec Y] [Vec Z]
  (f : X → Y → Z) [IsSmoothNT 2 f]
  : ∂ (λ x => λ y ⟿ f x y) = λ x dx => λ y ⟿ (∂ f) x dx y := sorry_proof

@[simp, diff_simp]
theorem differential_zero_dir {X Y} [Vec X] [Vec Y]
  (f : X → Y) [IsSmooth f] (x)
  : ∂ f x 0 = 0 := sorry_proof

#check integral.arg_f.isLin

example : ∂ (fun (g : X⟿ℝ) => ∫ x, ∥∇ g x∥²)
          =
          λ g dg : X⟿ℝ => ∫ x, 2 * ⟪∇ dg x, ∇ g x⟫ :=
by symdiff; done

attribute [default_instance] Smooth.gradient.instNablaNotation

-- set_option trace.Meta.Tactic.simp.discharge true in

example : ∇ (g : X⟿ℝ), ∫ x, (1/2:ℝ) * ∥∇ g x∥²
          =
          λ g : X⟿ℝ => - ∇· (∇ g) :=
by unfold variationalGradient
   symdiff; symdiff; simp only [uncurryN, Prod.Uncurry.uncurry];
   simp only [(sorry_proof : ∀ x y : X, ⟪x,y⟫ = ⟪y,x⟫)];
   symdiff
   done


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/

import data.polynomial.taylor
import ring_theory.ideal.local_ring
import linear_algebra.adic_completion

/-!
# Henselian rings

In this file we set up the basic theory of Henselian (local) rings.
A ring `R` is *Henselian* at an ideal `I` if the following conditions hold:
* `I` is contained in the Jacobson radical of `R`
* for every polynomial `f` over `R`, with a *simple* root `a₀` over the quotient ring `R/I`,
  there exists a lift `a : R` of `a₀` that is a root of `f`.

(Here, saying that a root `b` of a polynomial `g` is *simple* means that `g.derivative.eval b` is a
unit. Warning: if `R/I` is not a field then it is not enough to assume that `g` has a factorization
into monic linear factors in which `X - b` shows up only once; for example `1` is not a simple root
of `X^2-1` over `ℤ/4ℤ`.)

A local ring `R` is *Henselian* if it is Henselian at its maximal ideal.
In this case the first condition is automatic, and in the second condition we may ask for
`f.derivative.eval a ≠ 0`, since the quotient ring `R/I` is a field in this case.

## Main declarations

* `henselian_ring`: a typeclass on commutative rings,
  asserting that the ring is Henselian at the ideal `I`.
* `henselian_local_ring`: a typeclass on commutative rings,
   asserting that the ring is local Henselian.
* `field.henselian`: fields are Henselian local rings
* `henselian.tfae`: equivalent ways of expressing the Henselian property for local rings
* `is_adic_complete.henselian`:
  a ring `R` with ideal `I` that is `I`-adically complete is Henselian at `I`

## References

https://stacks.math.columbia.edu/tag/04GE

## Todo

After a good API for etale ring homomorphisms has been developed,
we can give more equivalent characterization os Henselian rings.

In particular, this can give a proof that factorizations into coprime polynomials can be lifted
from the residue field to the Henselian ring.

The following gist contains some code sketches in that direction.
https://gist.github.com/jcommelin/47d94e4af092641017a97f7f02bf9598

-/

noncomputable theory

universes u v

open_locale big_operators polynomial

open local_ring polynomial function

lemma is_local_ring_hom_of_le_jacobson_bot {R : Type*} [comm_ring R]
  (I : ideal R) (h : I ≤ ideal.jacobson ⊥) :
  is_local_ring_hom (ideal.quotient.mk I) :=
begin
  constructor,
  intros a h,
  have : is_unit (ideal.quotient.mk (ideal.jacobson ⊥) a),
  { rw [is_unit_iff_exists_inv] at *,
    obtain ⟨b, hb⟩ := h,
    obtain ⟨b, rfl⟩ := ideal.quotient.mk_surjective b,
    use ideal.quotient.mk _ b,
    rw [←(ideal.quotient.mk _).map_one, ←(ideal.quotient.mk _).map_mul, ideal.quotient.eq] at ⊢ hb,
    exact h hb },
  obtain ⟨⟨x, y, h1, h2⟩, rfl : x = _⟩ := this,
  obtain ⟨y, rfl⟩ := ideal.quotient.mk_surjective y,
  rw [← (ideal.quotient.mk _).map_mul, ← (ideal.quotient.mk _).map_one, ideal.quotient.eq,
    ideal.mem_jacobson_bot] at h1 h2,
  specialize h1 1,
  simp at h1,
  exact h1.1,
end

/-- A ring `R` is *Henselian* at an ideal `I` if the following condition holds:
for every polynomial `f` over `R`, with a *simple* root `a₀` over the quotient ring `R/I`,
there exists a lift `a : R` of `a₀` that is a root of `f`.

(Here, saying that a root `b` of a polynomial `g` is *simple* means that `g.derivative.eval b` is a
unit. Warning: if `R/I` is not a field then it is not enough to assume that `g` has a factorization
into monic linear factors in which `X - b` shows up only once; for example `1` is not a simple root
of `X^2-1` over `ℤ/4ℤ`.) -/
class henselian_ring (R : Type*) [comm_ring R] (I : ideal R) : Prop :=
(jac : I ≤ ideal.jacobson ⊥)
(is_henselian : ∀ (f : R[X]) (hf : f.monic) (a₀ : R) (h₁ : f.eval a₀ ∈ I)
  (h₂ : is_unit (ideal.quotient.mk I (f.derivative.eval a₀))),
  ∃ a : R, f.is_root a ∧ (a - a₀ ∈ I))

/-- A local ring `R` is *Henselian* if the following condition holds:
for every polynomial `f` over `R`, with a *simple* root `a₀` over the residue field,
there exists a lift `a : R` of `a₀` that is a root of `f`.
(Recall that a root `b` of a polynomial `g` is *simple* if it is not a double root, so if
`g.derivative.eval b ≠ 0`.)

In other words, `R` is local Henselian if it is Henselian at the ideal `I`,
in the sense of `henselian_ring`. -/
class henselian_local_ring (R : Type*) [comm_ring R] extends local_ring R : Prop :=
(is_henselian : ∀ (f : R[X]) (hf : f.monic) (a₀ : R) (h₁ : f.eval a₀ ∈ maximal_ideal R)
  (h₂ : is_unit (f.derivative.eval a₀)),
  ∃ a : R, f.is_root a ∧ (a - a₀ ∈ maximal_ideal R))

@[priority 100] -- see Note [lower instance priority]
instance field.henselian (K : Type*) [field K] : henselian_local_ring K :=
{ is_henselian := λ f hf a₀ h₁ h₂,
  begin
    refine ⟨a₀, _, _⟩;
    rwa [(maximal_ideal K).eq_bot_of_prime, ideal.mem_bot] at *,
    rw sub_self,
  end }

lemma henselian_local_ring.tfae (R : Type u) [comm_ring R] [local_ring R] :
  tfae [
  henselian_local_ring R,
  ∀ (f : R[X]) (hf : f.monic) (a₀ : residue_field R) (h₁ : aeval a₀ f = 0)
    (h₂ : aeval a₀ f.derivative ≠ 0),
    ∃ a : R, f.is_root a ∧ (residue R a = a₀),
  ∀ {K : Type u} [field K], by exactI ∀ (φ : R →+* K) (hφ : surjective φ)
    (f : R[X]) (hf : f.monic) (a₀ : K) (h₁ : f.eval₂ φ a₀ = 0)
    (h₂ : f.derivative.eval₂ φ a₀ ≠ 0),
    ∃ a : R, f.is_root a ∧ (φ a = a₀)] :=
begin
  tfae_have _3_2 : 3 → 2, { intro H, exact H (residue R) ideal.quotient.mk_surjective, },
  tfae_have _2_1 : 2 → 1,
  { intros H, constructor, intros f hf a₀ h₁ h₂,
    specialize H f hf (residue R a₀),
    have aux := flip mem_nonunits_iff.mp h₂,
    simp only [aeval_def, residue_field.algebra_map_eq, eval₂_at_apply,
      ← ideal.quotient.eq_zero_iff_mem, ← local_ring.mem_maximal_ideal] at H h₁ aux,
    obtain ⟨a, ha₁, ha₂⟩ := H h₁ aux,
    refine ⟨a, ha₁, _⟩,
    rw ← ideal.quotient.eq_zero_iff_mem,
    rwa [← sub_eq_zero, ← ring_hom.map_sub] at ha₂, },
  tfae_have _1_3 : 1 → 3,
  { introsI hR K _K φ hφ f hf a₀ h₁ h₂,
    obtain ⟨a₀, rfl⟩ := hφ a₀,
    have H := henselian_local_ring.is_henselian f hf a₀,
    simp only [← ker_eq_maximal_ideal φ hφ, eval₂_at_apply, φ.mem_ker] at H h₁ h₂,
    obtain ⟨a, ha₁, ha₂⟩ := H h₁ _,
    { refine ⟨a, ha₁, _⟩, rwa [φ.map_sub, sub_eq_zero] at ha₂, },
    { contrapose! h₂,
      rwa [← mem_nonunits_iff, ← local_ring.mem_maximal_ideal,
        ← local_ring.ker_eq_maximal_ideal φ hφ, φ.mem_ker] at h₂, } },
  tfae_finish,
end

instance (R : Type*) [comm_ring R] [hR : henselian_local_ring R] :
  henselian_ring R (maximal_ideal R) :=
{ jac := by { rw [ideal.jacobson, le_Inf_iff], rintro I ⟨-, hI⟩, exact (eq_maximal_ideal hI).ge },
  is_henselian :=
  begin
    intros f hf a₀ h₁ h₂,
    refine henselian_local_ring.is_henselian f hf a₀ h₁ _,
    contrapose! h₂,
    rw [← mem_nonunits_iff, ← local_ring.mem_maximal_ideal, ← ideal.quotient.eq_zero_iff_mem] at h₂,
    rw h₂,
    exact not_is_unit_zero
  end }

/-- A ring `R` that is `I`-adically complete is Henselian at `I`. -/
@[priority 100] -- see Note [lower instance priority]
instance is_adic_complete.henselian_ring
  (R : Type*) [comm_ring R] (I : ideal R) [is_adic_complete I R] :
  henselian_ring R I :=
{ jac := is_adic_complete.le_jacobson_bot _,
  is_henselian :=
  begin
    intros f hf a₀ h₁ h₂,
    classical,
    let f' := f.derivative,
    -- we define a sequence `c n` by starting at `a₀` and then continually
    -- applying the function sending `b` to `b - f(b)/f'(b)` (Newton's method).
    -- Note that `f'.eval b` is a unit, because `b` has the same residue as `a₀` modulo `I`.
    let c : ℕ → R := λ n, nat.rec_on n a₀ (λ _ b, b - f.eval b * ring.inverse (f'.eval b)),
    have hc : ∀ n, c (n+1) = c n - f.eval (c n) * ring.inverse (f'.eval (c n)),
    { intro n, dsimp only [c, nat.rec_add_one], refl, },
    -- we now spend some time determining properties of the sequence `c : ℕ → R`
    -- `hc_mod`: for every `n`, we have `c n ≡ a₀ [SMOD I]`
    -- `hf'c`  : for every `n`, `f'.eval (c n)` is a unit
    -- `hfcI`  : for every `n`, `f.eval (c n)` is contained in `I ^ (n+1)`
    have hc_mod : ∀ n, c n ≡ a₀ [SMOD I],
    { intro n, induction n with n ih, { refl },
      rw [nat.succ_eq_add_one, hc, sub_eq_add_neg, ← add_zero a₀],
      refine ih.add _,
      rw [smodeq.zero, ideal.neg_mem_iff],
      refine I.mul_mem_right _ _,
      rw [← smodeq.zero] at h₁ ⊢,
      exact (ih.eval f).trans h₁, },
    have hf'c : ∀ n, is_unit (f'.eval (c n)),
    { intro n,
      haveI := is_local_ring_hom_of_le_jacobson_bot I (is_adic_complete.le_jacobson_bot I),
      apply is_unit_of_map_unit (ideal.quotient.mk I),
      convert h₂ using 1,
      exact smodeq.def.mp ((hc_mod n).eval _), },
    have hfcI : ∀ n, f.eval (c n) ∈ I ^ (n+1),
    { intro n,
      induction n with n ih, { simpa only [pow_one] },
      simp only [nat.succ_eq_add_one],
      rw [← taylor_eval_sub (c n), hc],
      simp only [sub_eq_add_neg, add_neg_cancel_comm],
      rw [eval_eq_sum, sum_over_range' _ _ _ (lt_add_of_pos_right _ zero_lt_two),
        ← finset.sum_range_add_sum_Ico _ (nat.le_add_left _ _)],
      swap, { intro i, rw zero_mul },
      refine ideal.add_mem _ _ _,
      { simp only [finset.sum_range_succ, taylor_coeff_one, mul_one, pow_one, taylor_coeff_zero,
          mul_neg, finset.sum_singleton, finset.range_one, pow_zero],
        rw [mul_left_comm, ring.mul_inverse_cancel _ (hf'c n), mul_one, add_neg_self],
        exact ideal.zero_mem _ },
      { refine submodule.sum_mem _ _, simp only [finset.mem_Ico],
        rintro i ⟨h2i, hi⟩,
        have aux : n + 2 ≤ i * (n + 1), { transitivity 2 * (n + 1); nlinarith only [h2i], },
        refine ideal.mul_mem_left _ _ (ideal.pow_le_pow aux _),
        rw [pow_mul'],
        refine ideal.pow_mem_pow ((ideal.neg_mem_iff _).2 $ ideal.mul_mem_right _ _ ih) _, } },
    -- we are now in the position to show that `c : ℕ → R` is a Cauchy sequence
    have aux : ∀ m n, m ≤ n → c m ≡ c n [SMOD (I ^ m • ⊤ : ideal R)],
    { intros m n hmn,
      rw [← ideal.one_eq_top, ideal.smul_eq_mul, mul_one],
      obtain ⟨k, rfl⟩ := nat.exists_eq_add_of_le hmn, clear hmn,
      induction k with k ih, { rw add_zero, },
      rw [nat.succ_eq_add_one, ← add_assoc, hc, ← add_zero (c m), sub_eq_add_neg],
      refine ih.add _, symmetry,
      rw [smodeq.zero, ideal.neg_mem_iff],
      refine ideal.mul_mem_right _ _ (ideal.pow_le_pow _ (hfcI _)),
      rw [add_assoc], exact le_self_add },
    -- hence the sequence converges to some limit point `a`, which is the `a` we are looking for
    obtain ⟨a, ha⟩ := is_precomplete.prec' c aux,
    refine ⟨a, _, _⟩,
    { show f.is_root a,
      suffices : ∀ n, f.eval a ≡ 0 [SMOD (I ^ n • ⊤ : ideal R)], { from is_Hausdorff.haus' _ this },
      intro n, specialize ha n,
      rw [← ideal.one_eq_top, ideal.smul_eq_mul, mul_one] at ha ⊢,
      refine (ha.symm.eval f).trans _,
      rw [smodeq.zero],
      exact ideal.pow_le_pow le_self_add (hfcI _), },
    { show a - a₀ ∈ I,
      specialize ha 1,
      rw [hc, pow_one, ← ideal.one_eq_top, ideal.smul_eq_mul, mul_one, sub_eq_add_neg] at ha,
      rw [← smodeq.sub_mem, ← add_zero a₀],
      refine ha.symm.trans (smodeq.rfl.add _),
      rw [smodeq.zero, ideal.neg_mem_iff],
      exact ideal.mul_mem_right _ _ h₁, }
  end }


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import linear_algebra.matrix.charpoly.coeff
import linear_algebra.matrix.to_lin

/-!

# Calyley-Hamilton theorem for f.g. modules.

Given a fixed finite spanning set `b : ι → M` of a `R`-module `M`, we say that a matrix `M`
represents an endomorphism `f : M →ₗ[R] M` if the matrix as an endomorphism of `ι → R` commutes
with `f` via the projection `(ι → R) →ₗ[R] M` given by `b`.

We show that every endomorphism has a matrix representation, and if `f.range ≤ I • ⊤` for some
ideal `I`, we may furthermore obtain a matrix representation whose entries fall in `I`.

This is used to conclude the Cayley-Hamilton theorem for f.g. modules over arbitrary rings.
-/

variables {ι : Type*} [fintype ι]
variables {M : Type*} [add_comm_group M] (R : Type*) [comm_ring R] [module R M] (I : ideal R)
variables (b : ι → M) (hb : submodule.span R (set.range b) = ⊤)

open_locale big_operators
open_locale polynomial

/-- The composition of a matrix (as an endomporphism of `ι → R`) with the projection
`(ι → R) →ₗ[R] M`.  -/
def pi_to_module.from_matrix [decidable_eq ι] : matrix ι ι R →ₗ[R] (ι → R) →ₗ[R] M :=
(linear_map.llcomp R _ _ _ (fintype.total R R b)).comp alg_equiv_matrix'.symm.to_linear_map

lemma pi_to_module.from_matrix_apply [decidable_eq ι] (A : matrix ι ι R) (w : ι → R) :
  pi_to_module.from_matrix R b A w = fintype.total R R b (A.mul_vec w) := rfl

lemma pi_to_module.from_matrix_apply_single_one [decidable_eq ι] (A : matrix ι ι R) (j : ι) :
  pi_to_module.from_matrix R b A (pi.single j 1) = ∑ (i : ι), A i j • b i :=
begin
  rw [pi_to_module.from_matrix_apply, fintype.total_apply, matrix.mul_vec_single],
  simp_rw [mul_one]
end

/-- The endomorphisms of `M` acts on `(ι → R) →ₗ[R] M`, and takes the projection
to a `(ι → R) →ₗ[R] M`. -/
def pi_to_module.from_End : (module.End R M) →ₗ[R] (ι → R) →ₗ[R] M :=
linear_map.lcomp _ _ (fintype.total R R b)

lemma pi_to_module.from_End_apply (f : module.End R M) (w : ι → R) :
  pi_to_module.from_End R b f w = f (fintype.total R R b w) := rfl

lemma pi_to_module.from_End_apply_single_one [decidable_eq ι] (f : module.End R M) (i : ι) :
  pi_to_module.from_End R b f (pi.single i 1) = f (b i) :=
begin
  rw pi_to_module.from_End_apply,
  congr,
  convert fintype.total_apply_single R b i 1,
  rw one_smul,
end

lemma pi_to_module.from_End_injective (hb : submodule.span R (set.range b) = ⊤) :
  function.injective (pi_to_module.from_End R b) :=
begin
  intros x y e,
  ext m,
  obtain ⟨m, rfl⟩ : m ∈ (fintype.total R R b).range,
  { rw (fintype.range_total R b).trans hb, trivial },
  exact (linear_map.congr_fun e m : _)
end

section

variables {R} [decidable_eq ι]

/-- We say that a matrix represents an endomorphism of `M` if the matrix acting on `ι → R` is
equal to `f` via the projection `(ι → R) →ₗ[R] M` given by a fixed (spanning) set.  -/
def matrix.represents (A : matrix ι ι R) (f : module.End R M) : Prop :=
pi_to_module.from_matrix R b A = pi_to_module.from_End R b f

variables {b}

lemma matrix.represents.congr_fun {A : matrix ι ι R} {f : module.End R M}
  (h : A.represents b f) (x) :
  fintype.total R R b (A.mul_vec x) = f (fintype.total R R b x) :=
linear_map.congr_fun h x

lemma matrix.represents_iff {A : matrix ι ι R} {f : module.End R M} :
  A.represents b f ↔
    ∀ x, fintype.total R R b (A.mul_vec x) = f (fintype.total R R b x) :=
⟨λ e x, e.congr_fun x, λ H, linear_map.ext $ λ x, H x⟩

lemma matrix.represents_iff' {A : matrix ι ι R} {f : module.End R M} :
  A.represents b f ↔ ∀ j, ∑ (i : ι), A i j • b i = f (b j) :=
begin
  split,
  { intros h i,
    have := linear_map.congr_fun h (pi.single i 1),
    rwa [pi_to_module.from_End_apply_single_one,
      pi_to_module.from_matrix_apply_single_one] at this },
  { intros h,
    ext,
    simp_rw [linear_map.comp_apply, linear_map.coe_single, pi_to_module.from_End_apply_single_one,
      pi_to_module.from_matrix_apply_single_one],
    apply h }
end

lemma matrix.represents.mul {A A' : matrix ι ι R} {f f' : module.End R M}
  (h : A.represents b f) (h' : matrix.represents b A' f') :
  (A * A').represents b (f * f') :=
begin
  delta matrix.represents pi_to_module.from_matrix at ⊢,
  rw [linear_map.comp_apply, alg_equiv.to_linear_map_apply, map_mul],
  ext,
  dsimp [pi_to_module.from_End],
  rw [← h'.congr_fun, ← h.congr_fun],
  refl,
end

lemma matrix.represents.one : (1 : matrix ι ι R).represents b 1 :=
begin
  delta matrix.represents pi_to_module.from_matrix,
  rw [linear_map.comp_apply, alg_equiv.to_linear_map_apply, map_one],
  ext,
  refl
end

lemma matrix.represents.add {A A' : matrix ι ι R} {f f' : module.End R M}
  (h : A.represents b f) (h' : matrix.represents b A' f') :
  (A + A').represents b (f + f') :=
begin
  delta matrix.represents at ⊢ h h', rw [map_add, map_add, h, h'],
end

lemma matrix.represents.zero :
  (0 : matrix ι ι R).represents b 0 :=
begin
  delta matrix.represents, rw [map_zero, map_zero],
end

lemma matrix.represents.smul {A : matrix ι ι R} {f : module.End R M}
  (h : A.represents b f) (r : R) :
  (r • A).represents b (r • f) :=
begin
  delta matrix.represents at ⊢ h, rw [map_smul, map_smul, h],
end

lemma matrix.represents.eq {A : matrix ι ι R} {f f' : module.End R M}
  (h : A.represents b f) (h' : A.represents b f') : f = f' :=
pi_to_module.from_End_injective R b hb (h.symm.trans h')

variables (b R)

/-- The subalgebra of `matrix ι ι R` that consists of matrices that actually represent
endomorphisms on `M`. -/
def matrix.is_representation : subalgebra R (matrix ι ι R) :=
{ carrier := { A | ∃ f : module.End R M, A.represents b f },
  mul_mem' := λ A₁ A₂ ⟨f₁, e₁⟩ ⟨f₂, e₂⟩, ⟨f₁ * f₂, e₁.mul e₂⟩,
  one_mem' := ⟨1, matrix.represents.one⟩,
  add_mem' := λ A₁ A₂ ⟨f₁, e₁⟩ ⟨f₂, e₂⟩, ⟨f₁ + f₂, e₁.add e₂⟩,
  zero_mem' := ⟨0, matrix.represents.zero⟩,
  algebra_map_mem' := λ r, ⟨r • 1, matrix.represents.one.smul r⟩ }

/-- The map sending a matrix to the endomorphism it represents. This is an `R`-algebra morphism. -/
noncomputable
def matrix.is_representation.to_End : matrix.is_representation R b →ₐ[R] module.End R M :=
{ to_fun := λ A, A.2.some,
  map_one' := (1 : matrix.is_representation R b).2.some_spec.eq hb matrix.represents.one,
  map_mul' := λ A₁ A₂, (A₁ * A₂).2.some_spec.eq hb (A₁.2.some_spec.mul A₂.2.some_spec),
  map_zero' := (0 : matrix.is_representation R b).2.some_spec.eq hb matrix.represents.zero,
  map_add' := λ A₁ A₂, (A₁ + A₂).2.some_spec.eq hb (A₁.2.some_spec.add A₂.2.some_spec),
  commutes' := λ r, (r • 1 : matrix.is_representation R b).2.some_spec.eq
    hb (matrix.represents.one.smul r) }

lemma matrix.is_representation.to_End_represents (A : matrix.is_representation R b) :
  (A : matrix ι ι R).represents b (matrix.is_representation.to_End R b hb A) :=
A.2.some_spec

lemma matrix.is_representation.eq_to_End_of_represents (A : matrix.is_representation R b)
  {f : module.End R M} (h : (A : matrix ι ι R).represents b f) :
    matrix.is_representation.to_End R b hb A = f :=
A.2.some_spec.eq hb h

lemma matrix.is_representation.to_End_exists_mem_ideal
  (f : module.End R M) (I : ideal R) (hI : f.range ≤ I • ⊤) :
  ∃ M, matrix.is_representation.to_End R b hb M = f ∧ ∀ i j, M.1 i j ∈ I :=
begin
  have : ∀ x, f x ∈ (ideal.finsupp_total ι M I b).range,
  { rw [ideal.range_finsupp_total, hb], exact λ x, hI (f.mem_range_self x) },
  choose bM' hbM',
  let A : matrix ι ι R := λ i j, bM' (b j) i,
  have : A.represents b f,
  { rw matrix.represents_iff',
    dsimp [A],
    intro j,
    specialize hbM' (b j),
    rwa ideal.finsupp_total_apply_eq_of_fintype at hbM' },
  exact ⟨⟨A, f, this⟩, matrix.is_representation.eq_to_End_of_represents R b hb ⟨A, f, this⟩ this,
    λ i j, (bM' (b j) i).prop⟩,
end

lemma matrix.is_representation.to_End_surjective :
  function.surjective (matrix.is_representation.to_End R b hb) :=
begin
  intro f,
  obtain ⟨M, e, -⟩ := matrix.is_representation.to_End_exists_mem_ideal R b hb f ⊤ _,
  exact ⟨M, e⟩,
  simp,
end

end

/--
The **Cayley-Hamilton Theorem** for f.g. modules over arbitrary rings states that for each
`R`-endomorphism `φ` of an `R`-module `M` such that `φ(M) ≤ I • M` for some ideal `I`, there
exists some `n` and some `aᵢ ∈ Iⁱ` such that `φⁿ + a₁ φⁿ⁻¹ + ⋯ + aₙ = 0`.

This is the version found in Eisenbud 4.3, which is slightly weaker than Matsumura 2.1
(this lacks the constraint on `n`), and is slightly stronger than Atiyah-Macdonald 2.4.
-/
lemma linear_map.exists_monic_and_coeff_mem_pow_and_aeval_eq_zero_of_range_le_smul
  [module.finite R M] (f : module.End R M) (I : ideal R) (hI : f.range ≤ I • ⊤) :
  ∃ p : R[X],
    p.monic ∧ (∀ k, p.coeff k ∈ I ^ (p.nat_degree - k)) ∧ polynomial.aeval f p = 0 :=
begin
  classical,
  casesI subsingleton_or_nontrivial R,
  { exactI ⟨0, polynomial.monic_of_subsingleton _, by simp⟩ },
  obtain ⟨s : finset M, hs : submodule.span R (s : set M) = ⊤⟩ := module.finite.out,
  obtain ⟨A, rfl, h⟩ := matrix.is_representation.to_End_exists_mem_ideal R (coe : s → M)
    (by rw [subtype.range_coe_subtype, finset.set_of_mem, hs]) f I hI,
  refine ⟨A.1.charpoly, A.1.charpoly_monic, _, _⟩,
  { rw A.1.charpoly_nat_degree_eq_dim,
    exact coeff_charpoly_mem_ideal_pow h },
  { rw [polynomial.aeval_alg_hom_apply, ← map_zero (matrix.is_representation.to_End R coe _)],
    congr' 1,
    ext1,
    rw [polynomial.aeval_subalgebra_coe, subtype.val_eq_coe, matrix.aeval_self_charpoly,
      subalgebra.coe_zero] },
  { apply_instance }
end

lemma linear_map.exists_monic_and_aeval_eq_zero [module.finite R M]
  (f : module.End R M) : ∃ p : R[X], p.monic ∧ polynomial.aeval f p = 0 :=
(linear_map.exists_monic_and_coeff_mem_pow_and_aeval_eq_zero_of_range_le_smul R f ⊤ (by simp)).imp
  (λ p h, h.imp_right and.elim_right)


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Johan Commelin, Mario Carneiro

! This file was ported from Lean 3 source module data.mv_polynomial.rename
! leanprover-community/mathlib commit eabc6192c84ccce3936a8577a987b80b95ba75f6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.MvPolynomial.Basic

/-!
# Renaming variables of polynomials

This file establishes the `rename` operation on multivariate polynomials,
which modifies the set of variables.

## Main declarations

* `MvPolynomial.rename`
* `MvPolynomial.renameEquiv`

## Notation

As in other polynomial files, we typically use the notation:

+ `σ τ α : Type*` (indexing the variables)

+ `R S : Type*` `[CommSemiring R]` `[CommSemiring S]` (the coefficients)

+ `s : σ →₀ ℕ`, a function from `σ` to `ℕ` which is zero away from a finite set.
This will give rise to a monomial in `MvPolynomial σ R` which mathematicians might call `X^s`

+ `r : R` elements of the coefficient ring

+ `i : σ`, with corresponding monomial `X i`, often denoted `X_i` by mathematicians

+ `p : MvPolynomial σ α`

-/

noncomputable section

open Classical BigOperators

open Set Function Finsupp AddMonoidAlgebra

open BigOperators

variable {σ τ α R S : Type _} [CommSemiring R] [CommSemiring S]

namespace MvPolynomial

section Rename

/-- Rename all the variables in a multivariable polynomial. -/
def rename (f : σ → τ) : MvPolynomial σ R →ₐ[R] MvPolynomial τ R :=
  aeval (X ∘ f)
#align mv_polynomial.rename MvPolynomial.rename

@[simp]
theorem rename_C (f : σ → τ) (r : R) : rename f (C r) = C r :=
  eval₂_C _ _ _
set_option linter.uppercaseLean3 false in
#align mv_polynomial.rename_C MvPolynomial.rename_C

@[simp]
theorem rename_X (f : σ → τ) (i : σ) : rename f (X i : MvPolynomial σ R) = X (f i) :=
  eval₂_X _ _ _
set_option linter.uppercaseLean3 false in
#align mv_polynomial.rename_X MvPolynomial.rename_X

theorem map_rename (f : R →+* S) (g : σ → τ) (p : MvPolynomial σ R) :
    map f (rename g p) = rename g (map f p) := by
  apply MvPolynomial.induction_on p
    (fun a => by simp only [map_C, rename_C])
    (fun p q hp hq => by simp only [hp, hq, AlgHom.map_add, RingHom.map_add]) fun p n hp => by
    simp only [hp, rename_X, map_X, RingHom.map_mul, AlgHom.map_mul]
#align mv_polynomial.map_rename MvPolynomial.map_rename

@[simp]
theorem rename_rename (f : σ → τ) (g : τ → α) (p : MvPolynomial σ R) :
    rename g (rename f p) = rename (g ∘ f) p :=
  show rename g (eval₂ C (X ∘ f) p) = _
    by
    simp only [rename, aeval_eq_eval₂Hom]
    -- porting note: the Lean 3 proof of this was very fragile and included a nonterminal `simp`.
    -- Hopefully this is less prone to breaking
    rw [eval₂_comp_left (eval₂Hom (algebraMap R (MvPolynomial α R)) (X ∘ g)) C (X ∘ f) p]
    simp only [(· ∘ ·), eval₂Hom_X', coe_eval₂Hom]
    refine' eval₂Hom_congr _ rfl rfl
    ext1; simp only [comp_apply, RingHom.coe_comp, eval₂Hom_C]
#align mv_polynomial.rename_rename MvPolynomial.rename_rename

@[simp]
theorem rename_id (p : MvPolynomial σ R) : rename id p = p :=
  eval₂_eta p
#align mv_polynomial.rename_id MvPolynomial.rename_id

theorem rename_monomial (f : σ → τ) (d : σ →₀ ℕ) (r : R) :
    rename f (monomial d r) = monomial (d.mapDomain f) r := by
  rw [rename, aeval_monomial, monomial_eq (s := Finsupp.mapDomain f d),
    Finsupp.prod_mapDomain_index]
  · rfl
  · exact fun n => pow_zero _
  · exact fun n i₁ i₂ => pow_add _ _ _
#align mv_polynomial.rename_monomial MvPolynomial.rename_monomial

theorem rename_eq (f : σ → τ) (p : MvPolynomial σ R) :
    rename f p = Finsupp.mapDomain (Finsupp.mapDomain f) p := by
  simp only [rename, aeval_def, eval₂, Finsupp.mapDomain, algebraMap_eq, comp_apply,
    X_pow_eq_monomial, ← monomial_finsupp_sum_index]
  rfl
#align mv_polynomial.rename_eq MvPolynomial.rename_eq

theorem rename_injective (f : σ → τ) (hf : Function.Injective f) :
    Function.Injective (rename f : MvPolynomial σ R → MvPolynomial τ R) := by
  have :
    (rename f : MvPolynomial σ R → MvPolynomial τ R) = Finsupp.mapDomain (Finsupp.mapDomain f) :=
    funext (rename_eq f)
  rw [this]
  exact Finsupp.mapDomain_injective (Finsupp.mapDomain_injective hf)
#align mv_polynomial.rename_injective MvPolynomial.rename_injective

section

variable {f : σ → τ} (hf : Function.Injective f)

open Classical

/-- Given a function between sets of variables `f : σ → τ` that is injective with proof `hf`,
  `MvPolynomial.killCompl hf` is the `AlgHom` from `R[τ]` to `R[σ]` that is left inverse to
  `rename f : R[σ] → R[τ]` and sends the variables in the complement of the range of `f` to `0`. -/
def killCompl : MvPolynomial τ R →ₐ[R] MvPolynomial σ R :=
  aeval fun i => if h : i ∈ Set.range f then X <| (Equiv.ofInjective f hf).symm ⟨i, h⟩ else 0
#align mv_polynomial.kill_compl MvPolynomial.killCompl

theorem killCompl_comp_rename : (killCompl hf).comp (rename f) = AlgHom.id R _ :=
  algHom_ext fun i => by
    dsimp
    rw [rename, killCompl, aeval_X, comp_apply, aeval_X, dif_pos, Equiv.ofInjective_symm_apply]
#align mv_polynomial.kill_compl_comp_rename MvPolynomial.killCompl_comp_rename

@[simp]
theorem killCompl_rename_app (p : MvPolynomial σ R) : killCompl hf (rename f p) = p :=
  AlgHom.congr_fun (killCompl_comp_rename hf) p
#align mv_polynomial.kill_compl_rename_app MvPolynomial.killCompl_rename_app

end

section

variable (R)

/-- `MvPolynomial.rename e` is an equivalence when `e` is. -/
@[simps apply]
def renameEquiv (f : σ ≃ τ) : MvPolynomial σ R ≃ₐ[R] MvPolynomial τ R :=
  { rename f with
    toFun := rename f
    invFun := rename f.symm
    left_inv := fun p => by rw [rename_rename, f.symm_comp_self, rename_id]
    right_inv := fun p => by rw [rename_rename, f.self_comp_symm, rename_id] }
#align mv_polynomial.rename_equiv MvPolynomial.renameEquiv

@[simp]
theorem renameEquiv_refl : renameEquiv R (Equiv.refl σ) = AlgEquiv.refl :=
  AlgEquiv.ext rename_id
#align mv_polynomial.rename_equiv_refl MvPolynomial.renameEquiv_refl

@[simp]
theorem renameEquiv_symm (f : σ ≃ τ) : (renameEquiv R f).symm = renameEquiv R f.symm :=
  rfl
#align mv_polynomial.rename_equiv_symm MvPolynomial.renameEquiv_symm

@[simp]
theorem renameEquiv_trans (e : σ ≃ τ) (f : τ ≃ α) :
    (renameEquiv R e).trans (renameEquiv R f) = renameEquiv R (e.trans f) :=
  AlgEquiv.ext (rename_rename e f)
#align mv_polynomial.rename_equiv_trans MvPolynomial.renameEquiv_trans

end

section

variable (f : R →+* S) (k : σ → τ) (g : τ → S) (p : MvPolynomial σ R)

theorem eval₂_rename : (rename k p).eval₂ f g = p.eval₂ f (g ∘ k) := by
  apply MvPolynomial.induction_on p <;>
    · intros
      simp [*]
#align mv_polynomial.eval₂_rename MvPolynomial.eval₂_rename

theorem eval₂Hom_rename : eval₂Hom f g (rename k p) = eval₂Hom f (g ∘ k) p :=
  eval₂_rename _ _ _ _
#align mv_polynomial.eval₂_hom_rename MvPolynomial.eval₂Hom_rename

theorem aeval_rename [Algebra R S] : aeval g (rename k p) = aeval (g ∘ k) p :=
  eval₂Hom_rename _ _ _ _
#align mv_polynomial.aeval_rename MvPolynomial.aeval_rename

theorem rename_eval₂ (g : τ → MvPolynomial σ R) :
    rename k (p.eval₂ C (g ∘ k)) = (rename k p).eval₂ C (rename k ∘ g) := by
  apply MvPolynomial.induction_on p <;>
    · intros
      simp [*]
#align mv_polynomial.rename_eval₂ MvPolynomial.rename_eval₂

theorem rename_prod_mk_eval₂ (j : τ) (g : σ → MvPolynomial σ R) :
    rename (Prod.mk j) (p.eval₂ C g) = p.eval₂ C fun x => rename (Prod.mk j) (g x) := by
  apply MvPolynomial.induction_on p <;>
    · intros
      simp [*]
#align mv_polynomial.rename_prodmk_eval₂ MvPolynomial.rename_prod_mk_eval₂

theorem eval₂_rename_prod_mk (g : σ × τ → S) (i : σ) (p : MvPolynomial τ R) :
    (rename (Prod.mk i) p).eval₂ f g = eval₂ f (fun j => g (i, j)) p := by
  apply MvPolynomial.induction_on p <;>
    · intros
      simp [*]
#align mv_polynomial.eval₂_rename_prodmk MvPolynomial.eval₂_rename_prod_mk

theorem eval_rename_prod_mk (g : σ × τ → R) (i : σ) (p : MvPolynomial τ R) :
    eval g (rename (Prod.mk i) p) = eval (fun j => g (i, j)) p :=
  eval₂_rename_prod_mk (RingHom.id _) _ _ _
#align mv_polynomial.eval_rename_prodmk MvPolynomial.eval_rename_prod_mk

end

/-- Every polynomial is a polynomial in finitely many variables. -/
theorem exists_finset_rename (p : MvPolynomial σ R) :
    ∃ (s : Finset σ)(q : MvPolynomial { x // x ∈ s } R), p = rename (↑) q := by
  apply induction_on p
  · intro r
    exact ⟨∅, C r, by rw [rename_C]⟩
  · rintro p q ⟨s, p, rfl⟩ ⟨t, q, rfl⟩
    refine' ⟨s ∪ t, ⟨_, _⟩⟩
    ·
      refine' rename (Subtype.map id _) p + rename (Subtype.map id _) q <;>
        simp (config := { contextual := true }) only [id.def, true_or_iff, or_true_iff,
          Finset.mem_union, forall_true_iff]
    · simp only [rename_rename, AlgHom.map_add]
      rfl
  · rintro p n ⟨s, p, rfl⟩
    refine' ⟨insert n s, ⟨_, _⟩⟩
    · refine' rename (Subtype.map id _) p * X ⟨n, s.mem_insert_self n⟩
      simp (config := { contextual := true }) only [id.def, or_true_iff, Finset.mem_insert,
        forall_true_iff]
    · simp only [rename_rename, rename_X, Subtype.coe_mk, AlgHom.map_mul]
      rfl
#align mv_polynomial.exists_finset_rename MvPolynomial.exists_finset_rename

/-- `exists_finset_rename` for two polyonomials at once: for any two polynomials `p₁`, `p₂` in a
  polynomial semiring `R[σ]` of possibly infinitely many variables, `exists_finset_rename₂` yields
  a finite subset `s` of `σ` such that both `p₁` and `p₂` are contained in the polynomial semiring
  `R[s]` of finitely many variables. -/
theorem exists_finset_rename₂ (p₁ p₂ : MvPolynomial σ R) :
    ∃ (s : Finset σ)(q₁ q₂ : MvPolynomial s R), p₁ = rename (↑) q₁ ∧ p₂ = rename (↑) q₂ := by
  obtain ⟨s₁, q₁, rfl⟩ := exists_finset_rename p₁
  obtain ⟨s₂, q₂, rfl⟩ := exists_finset_rename p₂
  classical
    use s₁ ∪ s₂
    use rename (Set.inclusion <| s₁.subset_union_left s₂) q₁
    use rename (Set.inclusion <| s₁.subset_union_right s₂) q₂
    constructor -- porting note: was `<;> simp <;> rfl` but Lean couldn't infer the arguments
    · rw [rename_rename (Set.inclusion <| s₁.subset_union_left s₂)]
      rfl
    · rw [rename_rename (Set.inclusion <| s₁.subset_union_right s₂)]
      rfl
#align mv_polynomial.exists_finset_rename₂ MvPolynomial.exists_finset_rename₂

/-- Every polynomial is a polynomial in finitely many variables. -/
theorem exists_fin_rename (p : MvPolynomial σ R) :
    ∃ (n : ℕ)(f : Fin n → σ) (_hf : Injective f)(q : MvPolynomial (Fin n) R), p = rename f q := by
  obtain ⟨s, q, rfl⟩ := exists_finset_rename p
  let n := Fintype.card { x // x ∈ s }
  let e := Fintype.equivFin { x // x ∈ s }
  refine' ⟨n, (↑) ∘ e.symm, Subtype.val_injective.comp e.symm.injective, rename e q, _⟩
  rw [← rename_rename, rename_rename e]
  simp only [Function.comp, Equiv.symm_apply_apply, rename_rename]
#align mv_polynomial.exists_fin_rename MvPolynomial.exists_fin_rename

end Rename

theorem eval₂_cast_comp (f : σ → τ) (c : ℤ →+* R) (g : τ → R) (p : MvPolynomial σ ℤ) :
    eval₂ c (g ∘ f) p = eval₂ c g (rename f p) := by
  apply MvPolynomial.induction_on p (fun n => by simp only [eval₂_C, rename_C])
    (fun p q hp hq => by simp only [hp, hq, rename, eval₂_add, AlgHom.map_add])
    fun p n hp => by simp only [eval₂_mul, hp, eval₂_X, comp_apply, map_mul, rename_X, eval₂_mul]
#align mv_polynomial.eval₂_cast_comp MvPolynomial.eval₂_cast_comp

section Coeff

@[simp]

theorem coeff_rename_eq_zero (f : σ → τ) (φ : MvPolynomial σ R) (d : τ →₀ ℕ)
    (h : ∀ u : σ →₀ ℕ, u.mapDomain f = d → φ.coeff u = 0) : (rename f φ).coeff d = 0 := by
  rw [rename_eq, ← not_mem_support_iff]
  intro H
  replace H := mapDomain_support H
  rw [Finset.mem_image] at H
  obtain ⟨u, hu, rfl⟩ := H
  specialize h u rfl
  simp at h hu
  contradiction
#align mv_polynomial.coeff_rename_eq_zero MvPolynomial.coeff_rename_eq_zero

theorem coeff_rename_ne_zero (f : σ → τ) (φ : MvPolynomial σ R) (d : τ →₀ ℕ)
    (h : (rename f φ).coeff d ≠ 0) : ∃ u : σ →₀ ℕ, u.mapDomain f = d ∧ φ.coeff u ≠ 0 := by
  contrapose! h
  apply coeff_rename_eq_zero _ _ _ h
#align mv_polynomial.coeff_rename_ne_zero MvPolynomial.coeff_rename_ne_zero

@[simp]
theorem constantCoeff_rename {τ : Type _} (f : σ → τ) (φ : MvPolynomial σ R) :
    constantCoeff (rename f φ) = constantCoeff φ := by
  apply φ.induction_on
  · intro a
    simp only [constantCoeff_C, rename_C]
  · intro p q hp hq
    simp only [hp, hq, RingHom.map_add, AlgHom.map_add]
  · intro p n hp
    simp only [hp, rename_X, constantCoeff_X, RingHom.map_mul, AlgHom.map_mul]
#align mv_polynomial.constant_coeff_rename MvPolynomial.constantCoeff_rename

end Coeff

section Support

theorem support_rename_of_injective {p : MvPolynomial σ R} {f : σ → τ} (h : Function.Injective f) :
    (rename f p).support = Finset.image (Finsupp.mapDomain f) p.support := by
  rw [rename_eq]
  exact Finsupp.mapDomain_support_of_injective (mapDomain_injective h) _
#align mv_polynomial.support_rename_of_injective MvPolynomial.support_rename_of_injective

end Support

end MvPolynomial