import combinatorics.simple_graph.metric
import combinatorics.simple_graph.coloring
import data.nat.parity

/-
Main theorem: `parity_adj_imp_odd_cycle`
If a connected graph G has an edge xy joining vertices that are both an even (or both odd) distance
from a vertex z then G contains an odd cycle.

Corollary :
If G is connected and does not contain an odd cycle then G is two-colourable (by parity from an arbitary vertex)

-/
namespace simple_graph
variables {V : Type*} {G : simple_graph V}
variables {x y z  u v w: V}
variable [decidable_eq V]

open list walk nat

/-- Disjoint paths can be appended to give a new path -/
lemma append_disj_paths  {p : G.walk u v} {q : G.walk v w} (hp :p.is_path) (hq: q.is_path) (hnd: p.support.disjoint q.support.tail)
: (p.append q).is_path:=
begin
  rw is_path_def, rw support_append, have :=((support_eq_cons q)),
  apply nodup_append.2 ,  refine ⟨hp.2,_,hnd⟩,
  refine  (nodup_cons.1 _).2, exact v,exact (this ▸ hq.2),
end

/-- if z is in p then it is cons h p -/
lemma mem_cons_of_mem (h: G.adj v x) (p : G.walk x y) : z ∈ p.support → z ∈ (cons h p).support:=
begin
  intro h, rw [support_cons, mem_cons_iff], exact or.inr h,
end

/-- z ∈ (cons h p).support iff z is the newly adjoined vertex or z ∈ p.support -/
lemma mem_support_cons  (h : G.adj u x)  (p: G.walk x y): z ∈ (cons h p).support ↔   z = u ∨ z ∈ p.support:=
begin
  simp only [support_cons, mem_cons_iff],
end

/-- nil.take_until is nil -/
@[simp]
lemma take_until_nil : (nil : G.walk x x).take_until x (start_mem_support _)= nil' x:=rfl

/-- (cons h p).take_until u = nil' u if u is the new vertex-/
@[simp]
lemma take_until_cons_self   (h : G.adj u x) (p: G.walk x y) : (cons h p).take_until u (start_mem_support _) = nil' u:=
begin
  rw [take_until,dif_pos],refl,
end

/-- (cons h p).take_until z = (cons h (p.take_until z)) if z is not the new vertex the new vertex-/
@[simp]
lemma take_until_cons_ne_self (h : G.adj u x) (p: G.walk x y)  (hz : z ∈ p.support) (hz2: z ≠ u):
(cons h p: G.walk u y).take_until z ((mem_support_cons  h p).2 (or.inr hz) ) = (cons h (p.take_until z hz)):=
begin
  rw [take_until],
  split_ifs, exfalso, exact hz2 h_1.symm,
  exact ⟨rfl,by refl⟩,
end

/-- If p is a u v walk then  p.support = p.reverse.support.tail.reverse ++ [v] -/
lemma support_eq_concat {u v : V} (p : G.walk u v) : p.support = (p.reverse.support.tail).reverse ++ [v] :=
begin
  have :=support_eq_cons p.reverse,
  rw support_reverse at *,
  apply_fun list.reverse at this,
  rw reverse_cons' at this,
  rw concat_eq_append at this,
  convert this,rw list.reverse_reverse,
end

/-- p.take_until z only contains z at the end -/
lemma take_until_rev_tail {u v z : V} (p : G.walk u v) (hz : z ∈ p.support ):  z ∉ (p.take_until z hz).reverse.support.tail:=
begin
  intro h,
  have :=support_eq_concat (p.take_until z hz) ,
  apply_fun count z at this,
  rw count_append at this,
  simp only [count_support_take_until_eq_one, support_reverse, count_eq_one_of_mem, nodup_cons, not_mem_nil, not_false_iff,
  nodup_nil, and_self, mem_singleton, self_eq_add_left, count_eq_zero, mem_reverse] at this,
  rw support_reverse at h, contradiction,
end

/-- Two walks to the same vertex z meet at `meet p q` -/
def meet : ∀ {x y z : V} (p : G.walk x z) (q: G.walk y z) , V
| x y z nil q := x
| x y z (cons r p) q  :=
    if hx : x ∈ q.support then x
    else meet p q

/-- If we add a new vertex u to p that is in q then `meet (cons h p) q = u` -/
@[simp]
lemma meet_cons_mem (p : G.walk x z) (q: G.walk y z) (h: G.adj u x) (hu :u ∈ q.support) : meet (cons h p) q = u:=
begin
  unfold meet,split_ifs,refl,
end

/-- If we add a new vertex u to p that is not in q then `meet (cons h p) q = meet p q` -/
@[simp]
lemma meet_cons_not_mem (p : G.walk x z) (q: G.walk y z) (h: G.adj u x) (hu :u ∉ q.support) : meet (cons h p) q = meet p q:=
begin
  unfold meet, split_ifs,refl,
end

/-- ite for meet (cons h p) q -/
lemma meet_cons_eq (p : G.walk x z) (q: G.walk y z) (h: G.adj u x) : meet (cons h p) q = ite (u ∈ q.support) u (meet p q):=
begin
  split_ifs, exact meet_cons_mem p q h h_1,exact meet_cons_not_mem p q h h_1,
end

/-- nil z and q meet at z -/
@[simp]
lemma meet_nil (q: G.walk y z) : meet (nil: G.walk z z) q = z:=rfl

/-- p and nil z meet at z -/
@[simp]
lemma meet_nil' (p: G.walk x z) : meet p (nil: G.walk z z) = z:=
begin
  induction p, refl, rw meet_cons_eq, split_ifs, rwa mem_support_nil_iff at h,
  exact p_ih,
end

/-- meet p q belongs to p -/
lemma meet_mem (p : G.walk x z) (q : G.walk y z) : meet p q ∈  p.support:=
begin
  induction p, unfold meet, rw support_nil, exact mem_singleton_self _,
  unfold meet,split_ifs,rw support_cons,  exact mem_cons_self _ _,
  apply mem_cons_of_mem, apply p_ih,
end

/-- meet p q belongs to q -/
lemma meet_mem' (p : G.walk x z) (q : G.walk y z) : meet p q ∈  q.support:=
begin
  induction p, unfold meet, exact end_mem_support q,
  unfold meet,
  split_ifs, exact h,
  apply p_ih,
end

/-- The shortcut from Pxz and Qyz to Wxy : follow P from x to meet p q and then from there to the start of Q in reverse. -/
def shortcut  {x y z : V} (p : G.walk x z) (q: G.walk y z) : G.walk x y
:=(p.take_until (meet p q) (meet_mem p q)).append (q.take_until (meet p q) (meet_mem' p q)).reverse

/-- edges of shortcut p q are edges of p or q -/
lemma shortcut_edges_subset  {x y z : V} (p : G.walk x z) (q: G.walk y z) {e : sym2 V}
  (he : e ∈ (shortcut p q).edges): e ∈ p.edges ∨ e ∈ q.edges:=
begin
  unfold shortcut at he, rw edges_append at he,
  cases mem_append.1 he,
  left, exact edges_take_until_subset p _ h,
  right, rw edges_reverse at h, rw mem_reverse at h,
  exact edges_take_until_subset q _ h,
end

/-- Useful for some rewriting when the name of the vertex we are walking to changes from u to v
p.take_until v is the same as p.take_until u if u = v -/
lemma take_until_eq_eq (p : G.walk x y) (hu : u ∈ p.support) (hv : u = v) :
p.take_until v (hv ▸ hu) = (p.take_until u hu).copy rfl hv :=
begin
  subst v, refl,
end

/-- If you add a vertex u ∈ q  to p then `meet (cons h p) q = u`
so the path along this until we meet q is just the vertex u -/
lemma cons_take_meet_of_mem (p : G.walk x z) (q : G.walk y z) (hadj : G.adj u x) (hu : u ∈ q.support)
: ((cons hadj p).take_until (meet (cons hadj p ) q) (meet_mem _ q)).support = [u] :=
begin
  have h1:= meet_cons_mem p q hadj hu,
  have h2:= take_until_cons_self hadj p,
  rw  take_until_eq_eq (cons hadj p) (meet_mem (cons hadj p) q) h1 at h2,
  apply_fun walk.support at h2,
  rwa [support_copy, support_nil] at h2,
end

/-- If you add a vertex u ∉ q to p the (cons h p).take_until meet.. is just u :: (p.take_until...)-/
lemma cons_take_meet_of_not_mem (p : G.walk x z) (q : G.walk y z) (hadj : G.adj u x) (hu : u ∉ q.support)
: ((cons hadj p).take_until (meet (cons hadj p ) q) (meet_mem _ q)).support = u::(p.take_until (meet p q)(meet_mem p q)).support :=
begin
  have h1:= meet_cons_not_mem p q hadj hu,
  have h3: meet p q ≠ u,{
    intro hf, apply hu (hf ▸ meet_mem' p q),},
  have h2:= take_until_cons_ne_self hadj p (meet_mem p q) h3,
  rw  take_until_eq_eq (cons hadj p) (meet_mem (cons hadj p) q) h1 at h2,
  apply_fun walk.support at h2,rwa [support_copy,support_cons] at h2,
end

/-- If v belongs to p.take_until meet p q and also belongs to q then v = meet p q -/
lemma meet_take_mem_imp (p : G.walk x z) (q : G.walk y z) :
v ∈ (p.take_until (meet p q) (meet_mem p q)).support → v ∈ q.support → v = meet p q :=
begin
  intros hp hq,
  induction p,
  have : v ∈(nil' p).support:=support_take_until_subset (nil' p) _ hp,
  rw support_nil at this,
  rw meet_nil, exact mem_singleton.1 this,
  by_cases h1: p_u ∈ q.support,
  rw meet_cons_mem p_p q p_h h1 at *,
  rw cons_take_meet_of_mem p_p q p_h h1 at hp, exact mem_singleton.1 hp,
  by_cases v = p_u, subst v,
  exact (meet_cons_mem p_p q p_h hq).symm,
  rw cons_take_meet_of_not_mem p_p q p_h h1 at hp,
  cases hp, contradiction,
  rw meet_cons_not_mem p_p q p_h h1,
  exact p_ih q hp hq,
end

/-- `shortcut p q` is a path if p and q are paths -/
lemma shortcut_is_path {x y z : V} {p : G.walk x z} {q: G.walk y z} (hp : p.is_path) (hq : q.is_path):
(shortcut p q).is_path:=
begin
  apply append_disj_paths (hp.take_until (meet_mem p q))  (hq.take_until (meet_mem' p q)).reverse,
  intros v hvp hvq,
  apply take_until_rev_tail q (meet_mem' p q),
  rwa meet_take_mem_imp p q hvp _ at hvq,
  rw support_reverse at hvq,
  apply support_take_until_subset q _ (mem_reverse.1 (tail_subset _ hvq)),
end

/-- If p.bypass = p then p is a path -/
lemma bypass_eq_self_imp_path {p: G.walk x y } (h: p.bypass = p ) : p.is_path:= (h ▸ bypass_is_path p)

/-- If p is a walk and p.bypass ≠ p then p.bypass is strictly shorter than p -/
lemma bypass_ne_self_imp_lt {p: G.walk x y} (h: p.bypass ≠ p) : p.bypass.length < p.length:=
begin
  induction p with _ u v z hadj hw ih, contradiction,
  simp only [bypass, walk.length_cons],
  split_ifs with h1,
  apply lt_succ_of_le ((length_drop_until_le _ h1).trans (length_bypass_le hw)),
  simp only [walk.length_cons, add_lt_add_iff_right],
  apply ih,
  intro hf,
  simp only [*, bypass, not_false_iff, dif_neg, ne.def, eq_self_iff_true, heq_iff_eq, and_self, not_true] at h,
  exact h,
end

/-- any shortest walk is a path-/
lemma shortest_is_path {p : G.walk x y} (hp : p.length = G.dist x y) : p.is_path:=
begin
  apply bypass_eq_self_imp_path , by_contra,
  apply not_lt_of_ge (dist_le p.bypass),
  apply lt_of_lt_of_le ((bypass_ne_self_imp_lt h)) hp.le,
end

/-- length of a path is length upto z + length from z -/
lemma take_until_drop_length (p : G.walk x y) (hz : z ∈ p.support) :
p.length = (p.take_until z hz).length + (p.drop_until z hz).length   :=
begin
  rw ← walk.length_append, congr, rwa take_spec p hz,
end

/-- If p is a shortest x y walk and z ∈ p then p.take_until z is a shortest x z walk  -/
lemma shortest_to (hconn : G.connected) (p: G.walk x y) (hp: p.length = G.dist x y) (hz : z ∈ p.support) :
G.dist x z = (p.take_until z hz).length:=
begin
  apply le_antisymm ,
  apply dist_le,
  by_contra,
  apply lt_irrefl (G.dist x y),
  calc
    G.dist x y ≤ G.dist x z + G.dist z y : hconn.dist_triangle
    ...        < (p.take_until z hz).length + G.dist z y : add_lt_add_right (lt_of_not_ge h) _
    ...        ≤ (p.take_until z hz).length + (p.drop_until z hz).length :  add_le_add_left (dist_le (p.drop_until z hz)) _
    ...        = G.dist x y : (take_until_drop_length p hz) ▸ hp,
end

/-- If p is a shortest x y walk and z ∈ p then p.drop_until z is a shortest z y walk  -/
lemma shortest_from (hconn : G.connected) (p: G.walk x y) (hp: p.length = G.dist x y) (hz : z ∈ p.support) :
G.dist z y = (p.drop_until z hz).length :=
begin
  apply  le_antisymm ,
  apply dist_le,
  by_contra,
  apply lt_irrefl (G.dist x y),
  calc G.dist x y ≤ G.dist x z + G.dist z y : hconn.dist_triangle
        ...       < G.dist x z + (p.drop_until z hz).length : add_lt_add_left (lt_of_not_ge h) _
        ...       ≤ (p.take_until z hz).length + (p.drop_until z hz).length : add_le_add_right (dist_le _ ) _
        ...       = G.dist x y : (take_until_drop_length p hz) ▸ hp,
end

/-- Given any shortest x y walk p and a vertex lying z ∈ p, the distance triangle inequality is equality for x z y.-/
lemma triangle_eq (hconn : G.connected) (p: G.walk x y) (hp: p.length = G.dist x y) (hz : z ∈ p.support) :
 G.dist x y = G.dist x z + G.dist z y :=
begin
  rw [shortest_to hconn p hp hz, shortest_from hconn p hp hz,← hp],
  exact take_until_drop_length p hz,
end

/-- If xy is an edge in a shortest x-z walk then distance from x to z is distance from y to z + 1 -/
lemma shortest_path_edge_odd {p : G.walk x z} (hconn : G.connected) (hp : p.length = G.dist x z) (he : ⟦(x,y)⟧∈ p.edges):
G.dist x z = G.dist y z + 1:=
begin
  rw [triangle_eq hconn p hp (snd_mem_support_of_mem_edges  p he),add_comm, add_right_inj],
  apply le_antisymm,
  exact dist_le (walk.cons (edges_subset_edge_set p he) walk.nil),
  apply connected.pos_dist_of_ne hconn (edges_subset_edge_set p he).ne,
end

/-- If the shortcut from Pyx and Qzx from y to z contains the edge zy then the distances x-z and y-z have different parities -/
lemma shortcut_edge_imp  {p1: G.walk x z} {p2: G.walk y z} (hconn : G.connected)(hp1: p1.length= G.dist x z) (hp2: p2.length= G.dist y z)
 (he: ⟦(y,x)⟧ ∈ (shortcut p1 p2).edges) : ¬2 ∣ G.dist x z+ G.dist y z :=
begin
  cases shortcut_edges_subset p1 p2 he,
  rw sym2.eq_swap at h, rw add_comm,
  have:= shortest_path_edge_odd hconn hp1  h, rw [this,← add_assoc,← two_mul],
  exact two_not_dvd_two_mul_add_one _,
  have:= shortest_path_edge_odd hconn hp2  h, rw [this,← add_assoc,← two_mul],
  exact two_not_dvd_two_mul_add_one _,
end

/-- If y is on a shortest x-z walk then y is no further from z than x -/
lemma mem_shortest_path_closer {p: G.walk x z} (hconn: G.connected) (hp: p.length = G.dist x z) (hy : y ∈ p.support ):
G.dist y z ≤ G.dist x z:=
begin
  rw shortest_from hconn p hp hy, rw ← hp,
  exact walk.length_drop_until_le _ _,
end

/-- If y is on a shortest x-z walk then x is no further from y than z -/
lemma mem_shortest_path_closer' {p: G.walk x z} (hconn: G.connected) (hp: p.length = G.dist x z) (hy : y ∈ p.support ):
G.dist x y ≤ G.dist x z:=
begin
  rw shortest_to hconn p hp hy, rw ← hp,
  exact walk.length_take_until_le _ _,
end

/-- If dist x z ≤ dist y z and x ≠ y then y cannot lie on any shortest x z walk -/
lemma not_mem_shortest_of_le {p: G.walk x z} (hconn: G.connected) (hxz: G.dist x z ≤ G.dist y z)
(hp: p.length = G.dist x z) (hne: x ≠ y): y ∉ p.support:=
begin
  by_contra,
  have :=le_antisymm hxz (mem_shortest_path_closer hconn hp h),
  apply hne, apply hconn.dist_eq_zero_iff.1,
  rw triangle_eq hconn p hp h at this,
  exact add_left_eq_self.1 this,
end

/-- If G is connected and there is an edge joining two vertices x and y whose distances
from a vertex z have the same parity then G contains an odd-length cycle -/
lemma parity_adj_imp_odd_cycle (hconn: G.connected)(hadj: G.adj y x) (he: 2 ∣ G.dist x z + G.dist y z) :
∃ c : G.walk y y, c.is_cycle ∧ odd c.length :=
begin
-- get a shortest walk from x to z
  obtain ⟨p1,hp1⟩:=hconn.exists_walk_of_dist x z,
-- get a shortest walk from y to z
  obtain ⟨p2,hp2⟩:=hconn.exists_walk_of_dist y z,
-- these walks are both paths (because they are shortest walks)
-- these paths meet  at some vertex v (since they both end at z) so we can append them by
-- following p1 from x to v and then follow p2 in reverse from v to y.
-- this "shortcut" is still a path, but now from x to y
  have sp:=shortcut_is_path (shortest_is_path hp1) (shortest_is_path hp2),
-- we can now close this path into a cycle using the fact that xy is an edge
  refine ⟨walk.cons hadj (shortcut p1 p2),_,_⟩,
-- to prove this is in fact a cycle we need to check that the edge xy was not already used in the path
  apply path.cons_is_cycle ⟨shortcut p1 p2,sp⟩,
-- but if it were then the shortest paths from x to z and y to z would differ in length by exactly 1 and hence
-- 2 could not divide the sum of their lengths
  intro hf, apply shortcut_edge_imp hconn hp1 hp2 hf he,
-- now just need to check that the length of the cycle is in fact odd
  rw [shortcut,walk.length_cons, walk.length_append],
  rw [triangle_eq hconn p1 hp1 (meet_mem p1 p2),triangle_eq hconn p2 hp2 ((meet_mem' p1 p2))] at he,
  rw [add_comm (G.dist y (meet p1 p2)),←add_assoc,add_comm _ (G.dist (meet p1 p2) z),add_comm (G.dist x (meet p1 p2)),←add_assoc,←two_mul] at he,
  rw [← shortest_to hconn p1 hp1 _, walk.length_reverse, ← shortest_to hconn p2 hp2],
  rw [add_assoc,add_comm, @dist_comm _ _ y _, nat.dvd_add_left (dvd_mul_right 2 _)] at he,
  obtain ⟨k,hk⟩:=he,
  use k, nth_rewrite 1 dist_comm, rw hk,
end

/-- If G is connected and z ∈ V then we can try to define a 2-colouring by distance from z using "bool = {tt, ff}"-/
noncomputable
def colour_bool (hconn : G.connected) (z : V): V → bool := λ x, ite (even (G.dist x z)) tt ff

/-- G has no_odd_cycle iff -/
def no_odd_cycle (G: simple_graph V): Prop := ¬ ∃ (v:V), ∃ (c: G.walk v v), c.is_cycle ∧ odd c.length

/-- If G is connected and has no odd cycle then the colouring by distance from an arbitrary z ∈ V is valid-/
theorem no_odd_cycle_imp_two_col (hconn : G.connected) (z : V) (nodd: G.no_odd_cycle):
 ∀ (x y :V), G.adj x y → colour_bool hconn z x ≠ colour_bool hconn z y:=
begin
  intros x y hadj hf,
  unfold colour_bool at hf, split_ifs at hf,
  apply nodd, use x, apply parity_adj_imp_odd_cycle hconn hadj _,
  exact z,
  obtain ⟨a,ha⟩:=h,obtain ⟨b,hb⟩:=h_1, use (b+a),
  rwa [ha, hb,two_mul, ← add_assoc , ← add_assoc , add_comm (b+a), ← add_assoc],
  exact hf,
  rw ← odd_iff_not_even at *,
  apply nodd, use x, apply parity_adj_imp_odd_cycle hconn hadj _,
  exact z,
  obtain ⟨a,ha⟩:=h,obtain ⟨b,hb⟩:=h_1,  use (a+b+1),
  rw [hb,ha, add_comm (2*b +1), add_assoc, add_comm 1, add_assoc, ← two_mul 1, ← add_assoc, ← mul_add, ← mul_add],
end

/-- If G has no odd cycle then it can be two-coloured (by bool tt/ff)-/
noncomputable
def two_colouring (hconn : G.connected) (z : V) (nodd: G.no_odd_cycle) :
 G.coloring bool:=⟨colour_bool hconn z, λ a b h, no_odd_cycle_imp_two_col hconn z nodd a b h⟩

/-- Any connected nonempty graph with no odd cycle has χ(G) ≤ 2 -/
lemma chromatic_number_le_two_of_no_odd_cycle (hconn : G.connected) (z : V) (nodd: G.no_odd_cycle) :
G.chromatic_number ≤ 2:=
begin
  exact chromatic_number_le_of_colorable (coloring.to_colorable (two_colouring hconn z nodd)),
end

end simple_graph


import prelim.collections prelim.embed prelim.size prelim.induction prelim.minmax
import .parallel matroid.submatroid.projection

noncomputable theory
open_locale classical

open set
namespace matroid

variables {α β : Type*} [fintype α] [fintype β] {N M : matroid α} {e f : α} {S X : set α}

section simple

/-- the property of a set not containing any loops -/
def is_loopless_set (M : matroid α) (S : set α) :=
  ∀ X ⊆ S, size X ≤ 1 → M.is_indep X

/-- the property of a matroid having no loops -/
def is_loopless (M : matroid α) :=
  is_loopless_set M univ

lemma loopless_iff_univ_loopless {M : matroid α} :
  is_loopless M ↔ is_loopless_set M univ :=
iff.rfl

/-- the property of a set containing no loops or parallel pairs -/
def is_simple_set (M : matroid α) (S : set α) :=
  ∀ X ⊆ S, size X ≤ 2 → M.is_indep X

lemma simple_of_subset_simple {M : matroid α} {S T : set α} (hT : M.is_simple_set T) (hST : S ⊆ T) :
  M.is_simple_set S :=
λ X hX, hT X (subset.trans hX hST)

/-- the property of a matroid containing no loops or parallel pairs -/
def is_simple (M : matroid α) :=
  is_simple_set M univ

lemma simple_set_iff_r :
  M.is_simple_set S ↔ ∀ X ⊆ S, size X ≤ 2 → size X ≤ M.r X :=
by simp_rw [is_simple_set, indep_iff_size_le_r]

lemma rank_subset_simple (h : M.is_simple) (hX : size X ≤ 2) :
  M.r X = size X :=
h X (subset_univ _) hX

lemma rank_singleton_of_simple (h : M.is_simple) (e : α) :
  M.r {e} = 1 :=
by {rw [←size_singleton e, ← indep_iff_r], apply h _ (subset_univ _), rw size_singleton, norm_num }

lemma rank_pair_of_simple (h : M.is_simple) (hef : e ≠ f) :
  M.r {e,f} = 2 :=
by rw [indep_iff_r.mp (h {e,f} (subset_univ _) (by rw size_pair hef)), size_pair hef]

lemma rank_mem_simple_set (h : M.is_simple_set S) (he : e ∈ S) :
  M.r {e} = 1 :=
begin
  rw [←size_singleton e, ← indep_iff_r],
  apply h _ (singleton_subset_iff.mpr he),
  rw size_singleton,
  norm_num,
end

lemma rank_pair_of_simple_set (h : M.is_simple_set S) (hef : e ≠ f) (he : e ∈ S) (hf : f ∈ S):
  M.r {e,f} = 2 :=
begin
  rw [indep_iff_r.mp (h {e,f} _ (by rw size_pair hef)), size_pair hef],
  rw ← singleton_subset_iff at he hf,
  convert union_subset he hf,
end

lemma rank_subset_simple_set (h : M.is_simple_set S) (hX : X ⊆ S) (hX' : size X ≤ 2):
  M.r X = size X :=
by convert h X hX hX'

lemma rank_subset_simple_set_lb (h : M.is_simple_set S) (hX : X ⊆ S):
  min 2 (size X) ≤ M.r X :=
begin
  cases le_or_lt (size X) 2 with h1 h2,
  { rwa [min_eq_right h1, rank_subset_simple_set h hX]},
  rw min_eq_left (le_of_lt h2),
  obtain ⟨X₀, hX₀, hX₀'⟩ := has_subset_of_size (by norm_num : (0 : ℤ) ≤ 2) (le_of_lt h2),
  rw [← hX₀', ← (rank_subset_simple_set h (subset.trans hX₀ hX) (le_of_eq hX₀'))],
  exact rank_mono _ hX₀,
end

lemma rank_subset_simple_lb (h : M.is_simple) (X : set α):
  min 2 (size X) ≤ M.r X :=
rank_subset_simple_set_lb h (subset_univ _)

lemma eq_of_rank_one_simple (h : M.is_simple) (hef : M.r {e,f} = 1) :
  e = f :=
by_contra (λ hn, by {rw rank_pair_of_simple h hn at hef, norm_num at hef })

lemma eq_of_rank_le_one_simple (h : M.is_simple) (hef : M.r {e,f} ≤ 1) :
  e = f :=
begin
  refine eq_of_rank_one_simple h (le_antisymm hef _),
  rw ← rank_singleton_of_simple h e,
  apply rank_mono,
  simp,
end

lemma loopless_of_simple (hM : M.is_simple) :
  M.is_loopless :=
λ X hX hs, hM X hX (by linarith)

lemma simple_iff_univ_simple {M : matroid α} :
  is_simple M ↔ is_simple_set M univ :=
iff.rfl

def simple_set (M : matroid α) := {X : set α // M.is_simple_set X}

instance simple_set_nonempty {M : matroid α} : nonempty M.simple_set :=
  ⟨⟨∅, λ X hX _, by {rw eq_empty_of_subset_empty hX, apply empty_indep, }⟩⟩

instance simple_set_fintype {M : matroid α} : fintype M.simple_set :=
  by {unfold simple_set, apply_instance,}

instance {M : matroid α} : has_coe M.simple_set (set α) := ⟨subtype.val⟩

def simple_subset_of (M : matroid α) (S : set α) := {X : set α // M.is_simple_set X ∧ X ⊆ S}

instance simple_subset.ne {M : matroid α} {S : set α} : nonempty (M.simple_subset_of S) :=
  ⟨⟨∅, ⟨λ X hX _, by {rw eq_empty_of_subset_empty hX, apply empty_indep, }, empty_subset _⟩ ⟩⟩

instance simple_subset.fin {M : matroid α} {S : set α} : fintype (M.simple_subset_of S) :=
by {unfold simple_subset_of, apply_instance,}

instance simple_subset.coe {M : matroid α} {S : set α} :
  has_coe (M.simple_subset_of S) (set α) := ⟨subtype.val⟩

lemma simple_of_indep {M : matroid α} {I : set α} (hI : M.is_indep I):
  M.is_simple_set I :=
λ _ hX _, indep_of_subset_indep hX hI

lemma loopless_set_iff_all_nonloops {M : matroid α} {S : set α} :
  M.is_loopless_set S ↔ ∀ e ∈ S, M.is_nonloop e :=
begin
  simp_rw [nonloop_iff_r, is_loopless_set, size_le_one_iff_empty_or_singleton, indep_iff_r],
  refine ⟨λ h, λ e he ,_  , λ h, λ X hX h', _⟩,
  {rw ← size_singleton e, exact h _ (singleton_subset_iff.mpr he) (or.inr ⟨e, rfl⟩)},
  rcases h' with (rfl | ⟨e,rfl⟩), simp,
  rw [size_singleton, h e (singleton_subset_iff.mp hX)],
end

lemma loopless_set_iff_subset_nonloops {M : matroid α} {S : set α} :
  M.is_loopless_set S ↔ S ⊆ M.nonloops :=
by {rw [loopless_set_iff_all_nonloops, nonloops], tauto}

lemma loopless_iff_all_nonloops {M : matroid α} :
  M.is_loopless ↔ ∀ e, M.is_nonloop e :=
by {rw [loopless_iff_univ_loopless, loopless_set_iff_all_nonloops], tauto}

lemma nonloop_of_mem_loopless_set {M : matroid α} {S : set α} {e : α}
(h : M.is_loopless_set S) (he : e ∈ S) :
  M.is_nonloop e :=
by {rw loopless_set_iff_all_nonloops at h, tauto, }

lemma nonloop_of_simple {M : matroid α} (hM : M.is_simple) (e : α) :
  M.is_nonloop e :=
nonloop_of_mem_loopless_set (loopless_of_simple hM) (mem_univ e)

lemma exists_loop_of_not_loopless_set {M : matroid α} {S : set α} (hS : ¬M.is_loopless_set S) :
  ∃ e ∈ S, M.is_loop e :=
begin
  by_contra hn,
  simp_rw [loopless_set_iff_all_nonloops, nonloop_iff_not_loop] at hS,
  push_neg at hS hn,
  obtain ⟨e,⟨he,he'⟩⟩ := hS,
  exact hn e he he',
end

lemma exists_loop_of_not_loopless {M : matroid α} (h : ¬M.is_loopless) :
  ∃ e, M.is_loop e :=
let ⟨e,_,h'⟩ := exists_loop_of_not_loopless_set h in ⟨e,h'⟩

lemma nonloop_of_loopless {M : matroid α} (e : α) (h : M.is_loopless) :
  M.is_nonloop e :=
by {rw loopless_iff_all_nonloops at h, tauto, }

lemma rank_single_of_loopless {M : matroid α} (h : M.is_loopless) (e : α) :
  M.r {e} = 1 :=
by {rw [←nonloop_iff_r], apply nonloop_of_loopless e h,  }

lemma simple_set_iff_no_loops_or_parallel_pairs {M : matroid α} {S : set α} :
  M.is_simple_set S ↔ M.is_loopless_set S ∧ ∀ (e f ∈ S), M.parallel e f → e = f :=
begin
  refine ⟨λ h, ⟨λ X hXS hX, h X hXS (by linarith [hX]),λ e f he hf hef, by_contra (λ hn, _)⟩,
  λ h, λ X hXS hX, _⟩,
  { rcases hef with ⟨he,hf,hef⟩,
    have hef' := size_pair hn,
    linarith [r_indep (h {e,f} (λ x, by {simp, rintros (rfl | rfl); assumption, }) (by linarith))]},
  rcases int.nonneg_le_two_iff (size_nonneg X) hX with (h0 | h1 | h2),
  { rw size_zero_iff_empty at h0, rw h0, apply M.empty_indep, },
  { obtain ⟨e,rfl⟩ := size_one_iff_eq_singleton.mp h1,
    rw singleton_subset_iff at hXS,
    exact nonloop_iff_indep.mp (nonloop_of_mem_loopless_set h.1 hXS), },
  rcases size_eq_two_iff_pair.mp h2 with ⟨e,f,hef,rfl⟩,
  by_contra hn,
  cases pair_subset_iff.mp hXS with he hf,

  suffices heq : e = f, rw [heq, pair_eq_singleton, size_singleton] at h2, norm_num at h2,
  apply h.2 e f he hf, rw parallel_iff_dep _ _, right,
    rwa [←dep_iff_not_indep] at hn,
  all_goals {apply nonloop_of_mem_loopless_set h.1, assumption,  },
end

lemma simple_iff_no_loops_or_parallel_pairs {M : matroid α} :
  M.is_simple ↔ M.is_loopless ∧ ∀ (e f : α), M.parallel e f → e = f :=
by {rw [simple_iff_univ_simple, simple_set_iff_no_loops_or_parallel_pairs], tidy, }

lemma simple_set_exchange (hS : M.is_simple_set S) (he : e ∈ S) (hp : M.parallel e f) :
  M.is_simple_set (S \ {e} ∪ {f}) :=
begin
  rw [simple_set_iff_no_loops_or_parallel_pairs, loopless_set_iff_all_nonloops] at ⊢ hS,
  simp only [mem_union_iff, mem_diff, mem_singleton_iff, mem_singleton_iff],
  refine ⟨λ x hxS, _, λ x y hxS hyS hxy, _⟩,
  { obtain (⟨hxS, -⟩ | rfl) := hxS, exact hS.1 x hxS, exact hp.nonloop_right},
  obtain (⟨hxS, hxe⟩ | rfl) := hxS; obtain (⟨hyS, hye⟩ | rfl) := hyS,
  { exact hS.2 _ _ hxS hyS hxy},
  { exact false.elim ((ne.symm hxe) (hS.2 e x he hxS (hp.trans hxy.symm)))},
  { exact false.elim ((ne.symm hye) (hS.2 e y he hyS (hp.trans hxy)))},
  refl,
end

lemma simple_set_exchange' (hS : M.is_simple_set S) (hf : f ∈ S) (hp : M.parallel e f) :
  M.is_simple_set ((S ∪ {e}) \ {f}) :=
begin
  rcases em (e = f) with (rfl | hef),
  rw [union_mem_singleton hf],
  exact simple_of_subset_simple hS (diff_subset _ _),
  rw ← exchange_comm (ne.symm hef),
  exact simple_set_exchange hS hf hp.symm,
end

lemma loopify_simple_set_of_simple_set (hS : M.is_simple_set S) (hX : disjoint S X):
  (M ⟍ X).is_simple_set S :=
begin
  intros Y hY hsize,
  rw indep_loopify_iff,
  refine ⟨hS Y hY hsize, _⟩,
  rw [← disjoint_iff_inter_eq_empty],
  exact disjoint_of_subset_left hY hX,
end

lemma loopify_simple_iff_simple_disjoint :
  (M ⟍ X).is_simple_set S ↔ M.is_simple_set S ∧ disjoint S X :=
begin
  refine ⟨λ h, ⟨ λ X hX hsize, _ ,_⟩, λ h, loopify_simple_set_of_simple_set h.1 h.2⟩,
  { exact indep_of_loopify_indep (h X hX hsize)},
  by_contra hn,
  obtain ⟨e, hx, hx'⟩ :=  not_disjoint_iff.mp hn,
  simp_rw [simple_set_iff_no_loops_or_parallel_pairs, loopless_set_iff_all_nonloops,
    nonloop_iff_not_loop] at h,
  exact h.1 e hx (loop_of_loopify _ hx'),
end

/- The simple matroid associated with M (simplification of M). Its elements are the parallel classes
 of M, and the rank of a set of parallel classes is the rank in M of their union. -/
def si (M : matroid α) : matroid (M.parallel_class) :=
{ r := λ X, M.r (union_parallel_classes X),
  R0 := λ X, by {apply M.R0 },
  R1 := λ X, begin
    let f := choose_transversal M,
    simp only [rank_img_transversal f, ←size_image_transversal f],
    apply M.R1,
  end,
  R2 := λ X Y hXY, begin
    dsimp only,
    convert M.rank_mono (inter_subset_right _ _),
    rw [←(subset_iff_inter_eq_left.mp hXY), inter_union_parallel_classes],
  end,
  R3 := λ X Y, begin
    dsimp only,
    convert M.rank_submod _ _, apply union_union_parallel_classes,
    apply inter_union_parallel_classes,
  end }

lemma si_r (M : matroid α) (S : set M.parallel_class) :
  M.si.r S = M.r (union_parallel_classes S) :=
rfl

/- it is more convenient to think of the simplification rank in terms of a fixed transversal of the parallel classes-/
lemma si_r_transversal {M : matroid α} (f : M.transversal) (S : set M.parallel_class) :
  (si M).r S = M.r (f '' S) :=
by rw [←rank_img_transversal, si_r]

lemma si_is_loopless (M : matroid α) :
  (si M).is_loopless :=
let f := M.choose_transversal in
  loopless_iff_all_nonloops.mpr (λ S, by
  { rw [nonloop_iff_r, si_r_transversal f, image_singleton, ←nonloop_iff_r], apply nonloop_of_range_transversal,  })

lemma si_is_simple (M : matroid α) :
  (si M).is_simple :=
begin
  let f := M.choose_transversal,
  refine simple_iff_no_loops_or_parallel_pairs.mpr ⟨(M.si_is_loopless), λ P Q hPQ, _⟩,
  apply eq_of_parallel_range_transversal f,
  obtain ⟨-,-,hr⟩ := hPQ,
  refine ⟨_,_,_⟩, all_goals {try {apply nonloop_of_range_transversal}},
  rwa [si_r_transversal f, image_pair] at hr,
end

lemma si_is_irestr (M : matroid α) :
  (si M).is_irestr_of M :=
begin
  rw irestr_of_iff_exists_map,
  let f := choose_transversal M,
  exact ⟨⟨f, transversal_inj f⟩, λ S, by {rw [si_r_transversal f], refl}⟩,
end

lemma si_is_iminor (M : matroid α) :
  (si M).is_iminor_of M :=
iminor_of_irestr M.si_is_irestr

lemma si_r_eq_r_parallel_cl_image (M : matroid α) (X : set α) :
  (si M).r (M.parallel_cl_image_of X) = M.r X :=
by {rw [si_r, ← rank_eq_rank_parallel_cl_image_of]}

lemma simple_set_of_weak_le {N M : matroid α}{X : set α}(hNM : N ≤ M)(hX : N.is_simple_set X):
  M.is_simple_set X :=
by {rw simple_set_iff_r at hX ⊢, exact λ Y hY hsize, le_trans (hX Y hY hsize) (hNM Y)}

lemma simple_loopify_iff {D : set α} :
  (N ⟍ D).is_simple_set S ↔ N.is_simple_set S ∧ S ∩ D = ∅ :=
begin
  refine ⟨λ h, ⟨ simple_set_of_weak_le (loopify_is_weak_image _ _) h ,_⟩, λ h, _⟩,
  { by_contra hn,
    obtain ⟨e,⟨heS,heD⟩⟩ := ne_empty_iff_has_mem.mp hn,
    rw [simple_set_iff_no_loops_or_parallel_pairs, loopless_set_iff_all_nonloops] at h,
    exact loop_iff_not_nonloop.mp (loop_of_loopify N heD) (h.1 e heS)},
  simp_rw [is_simple_set, indep_loopify_iff],
  exact λ X hX hsize, ⟨h.1 X hX hsize, disjoint_of_subset_left' hX h.2⟩,
end

lemma simple_loopify_to_iff {R : set α}:
  (N ‖ R).is_simple_set S ↔ N.is_simple_set S ∧ S ⊆ R :=
by rw [loopify_to, simple_loopify_iff, subset_iff_disjoint_compl]

end simple

section simple_minor

/-- If N is loopless and is isomorphic to a minor of a pminor of M, then N is isomorphic
to a minor of M.  -/
lemma iminor_of_iminor_of_pminor {N : matroid β} {M' M: matroid α} (hN : N.is_loopless)
(hNM' : N.is_iminor_of M') (hM'M : M'.is_pminor_of M) :
N.is_iminor_of M :=
begin
  obtain ⟨φ,C, hrange, hr, hCi, hCr⟩ := iminor_of_iff_exists_good_C.mp hNM',
  obtain ⟨C',D',hC'D', h⟩ := pminor_iff_exists_pr_lp_disjoint.mp hM'M, substI h,
  clear hM'M hNM',

  have hrange' : range φ ∩ (C' ∪ D') = ∅,
  { by_contra hn,
    obtain ⟨e,he⟩ := ne_empty_iff_has_mem.mp hn, clear hn,
    obtain ⟨heφ, heC⟩ := ((mem_inter_iff _ _ _).mp he), clear he,
    obtain ⟨f,rfl⟩ := mem_range.mp heφ, clear heφ,
    specialize hr {f},
    --have := @rank_single_of_loopless β _inst_2 N hN f,

    rw [rank_single_of_loopless hN, image_singleton] at hr,
    rw [union_comm, rank_eq_rank_union_rank_zero C _, sub_self] at hr,
    exact one_ne_zero hr,
    apply rank_zero_of_subset_rank_zero (singleton_subset_iff.mpr heC),
    apply rank_zero_of_pr_lp, },
  have hCC'D' : C ∩ (C' ∪ D') = ∅,

  rw [←size_zero_iff_empty,
        ←rank_zero_of_inter_rank_zero C (rank_zero_of_pr_lp M C' D'),
        ←r_indep (inter_indep_of_indep_left _ (C' ∪ D') hCi)],

  refine iminor_of_iff_exists_embedding.mpr ⟨φ, C ∪ C', _, λ X, _⟩,
  { rw [disjoint_iff_inter_eq_empty] at *,
    rw disjoint_iff_subset_compl at *,
    refine subset.trans (subset_inter hrange hrange') _,
    intros x,
    simp only [and_imp, compl_union, mem_inter_eq, mem_compl_eq],
    tauto},

  have h' : ∀ Z: set α, Z ∩ (C' ∪ D') = ∅ → D' ∩ Z = ∅,
  { intros Z hZ, rw inter_comm, apply disjoint_of_subset_right' (subset_union_right C' D') hZ, },

  rw [hr X, loopify_rank_of_disjoint (M ⟋ C') (h' _ hCC'D'), ←union_assoc,
      loopify_rank_of_disjoint (M ⟋ C'), project_r, project_r], ring,

  rw [inter_distrib_left, h' _ hCC'D', disjoint_of_subset_right' _ (h' _ hrange'), union_self],
  apply image_subset_range,
end

/-- a simple matroid is a minor of M iff if it is a minor of si M . -/

lemma iminor_iff_iminor_si {N : matroid β} {M : matroid α} (hN : N.is_simple) :
  N.is_iminor_of (si M) ↔ N.is_iminor_of M :=
begin
  refine ⟨λ h, iminor_trans h M.si_is_iminor, λ h, iminor_of_iff_exists_embedding.mpr _⟩,

  obtain ⟨ce⟩ := iminor_of_iff_exists_con_emb.mp h,
  -- all elements of N map to nonloops of M...
  have hnl : ∀ x, M.is_nonloop (ce.e x), from
    λ x, ce.nonloop_of_nonloop (nonloop_of_simple hN x),

  -- so we can define a map φ' taking β to nonloops of M
  set φ' : β → M.nonloop := λ x, ⟨ce.e x, hnl x⟩ with hφ',

  -- the contract_set is the parallel_cl image of C
  set C' := M.parallel_cl_image_of ce.C with hC',

  -- the contract map is basically (parallel_class_of) ∘ φ, modulo punctuation
  refine ⟨⟨λ b, parallel_class_of' (φ' b), λ x y hxy, _⟩, C', _, λ X, _⟩,

  -- the contract map is injective
  { dsimp only at hxy,
    simp only [hφ', parallel_class_of'_eq, hφ', subtype.mk_eq_mk, subtype.coe_mk] at hxy,
    have hr := ce.rank_le_rank_image {x,y},
    rw [image_pair, (parallel_of_parallel_cl_eq_left (hnl x) hxy).2.2]  at hr,
    exact eq_of_rank_le_one_simple hN hr},

  -- the contract set is disjoint from the contract map's range
  { simp only [parallel_class_of'_eq, function.embedding.coe_fn_mk, subtype.coe_mk,
      ←disjoint_iff_inter_eq_empty, disjoint_left,  forall_apply_eq_imp_iff', mem_range,
      exists_imp_distrib, hC', mem_parallel_cl_image_of_iff],
    rintros b ⟨a, ha⟩,
    rw [mem_inter_iff, mem_parallel_cl] at ha,
    have hr := ha.2.2.2,
    have hr' := ce.on_rank {b},
    rw [rank_nonloop (nonloop_of_simple hN b), union_comm, image_singleton, union_singleton,
    rank_eq_rank_parallel_ext ha.1 ha.2] at hr', linarith,},

  -- the rank functions agree. A bit nasty
  convert ce.on_rank X using 2, swap,
  { rw hC', exact M.si_r_eq_r_parallel_cl_image _, },
  rw [hC', ← M.si_r_eq_r_parallel_cl_image],
  convert rfl,
  ext P, rcases P with ⟨P, hP⟩,
  simp only [mem_parallel_cl_image_of_iff, mem_image, parallel_class_of'_eq,
  mem_union_eq, subtype.mk_eq_mk, function.embedding.coe_fn_mk, subtype.coe_mk,
  nonempty_inter_iff_exists_right],
  split,
  { rintro ⟨⟨x,hx⟩, (⟨b, hbX, hbx⟩  | hxc )⟩,
    { refine or.inl ⟨b, hbX, _⟩,
      rw [hbx, subtype.coe_mk, parallel_class_eq_cl_mem hP hx]},
    exact or.inr ⟨_, hxc⟩,},
  rintro (⟨b, ⟨hb, rfl⟩⟩ | ⟨x, hx⟩),
  { refine ⟨⟨ce.e b,_⟩, or.inl ⟨b,hb,rfl⟩⟩,
    rw [mem_parallel_cl, parallel_refl_iff_nonloop],
    apply ce.nonloop_of_nonloop (nonloop_of_simple hN _) },
  exact ⟨x, or.inr hx⟩,
end

end simple_minor
end matroid


/-
Copyright (c) 2018 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import deprecated.subgroup
import deprecated.group
import ring_theory.subring.basic

universes u v

open group

variables {R : Type u} [ring R]

/-- `S` is a subring: a set containing 1 and closed under multiplication, addition and additive
inverse. -/
structure is_subring (S : set R) extends is_add_subgroup S, is_submonoid S : Prop.

/-- Construct a `subring` from a set satisfying `is_subring`. -/
def is_subring.subring {S : set R} (hs : is_subring S) : subring R :=
{ carrier := S,
  one_mem' := hs.one_mem,
  mul_mem' := hs.mul_mem,
  zero_mem' := hs.zero_mem,
  add_mem' := hs.add_mem,
  neg_mem' := hs.neg_mem }

namespace ring_hom

lemma is_subring_preimage {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) {s : set S} (hs : is_subring s) : is_subring (f ⁻¹' s) :=
{ ..is_add_group_hom.preimage f.to_is_add_group_hom hs.to_is_add_subgroup,
  ..is_submonoid.preimage f.to_is_monoid_hom hs.to_is_submonoid, }

lemma is_subring_image {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) {s : set R} (hs : is_subring s) : is_subring (f '' s) :=
{ ..is_add_group_hom.image_add_subgroup f.to_is_add_group_hom hs.to_is_add_subgroup,
  ..is_submonoid.image f.to_is_monoid_hom hs.to_is_submonoid, }

lemma is_subring_set_range {R : Type u} {S : Type v} [ring R] [ring S]
  (f : R →+* S) : is_subring (set.range f) :=
{ ..is_add_group_hom.range_add_subgroup f.to_is_add_group_hom,
  ..range.is_submonoid f.to_is_monoid_hom, }

end ring_hom

variables {cR : Type u} [comm_ring cR]

lemma is_subring.inter {S₁ S₂ : set R} (hS₁ : is_subring S₁) (hS₂ : is_subring S₂) :
  is_subring (S₁ ∩ S₂) :=
{ ..is_add_subgroup.inter hS₁.to_is_add_subgroup hS₂.to_is_add_subgroup,
  ..is_submonoid.inter hS₁.to_is_submonoid hS₂.to_is_submonoid }

lemma is_subring.Inter {ι : Sort*} {S : ι → set R} (h : ∀ y : ι, is_subring (S y)) :
  is_subring (set.Inter S) :=
{ ..is_add_subgroup.Inter (λ i, (h i).to_is_add_subgroup),
  ..is_submonoid.Inter (λ i, (h i).to_is_submonoid) }

lemma is_subring_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set R} (h : ∀ i, is_subring (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subring (⋃i, s i) :=
{ to_is_add_subgroup := is_add_subgroup_Union_of_directed
    (λ i, (h i).to_is_add_subgroup) directed,
  to_is_submonoid := is_submonoid_Union_of_directed (λ i, (h i).to_is_submonoid) directed }

namespace ring

def closure (s : set R) := add_group.closure (monoid.closure s)

variable {s : set R}

local attribute [reducible] closure

theorem exists_list_of_mem_closure {a : R} (h : a ∈ closure s) :
  (∃ L : list (list R), (∀ l ∈ L, ∀ x ∈ l, x ∈ s ∨ x = (-1:R)) ∧ (L.map list.prod).sum = a) :=
add_group.in_closure.rec_on h
  (λ x hx, match x, monoid.exists_list_of_mem_closure hx with
    | _, ⟨L, h1, rfl⟩ := ⟨[L], list.forall_mem_singleton.2 (λ r hr, or.inl (h1 r hr)), zero_add _⟩
    end)
  ⟨[], list.forall_mem_nil _, rfl⟩
  (λ b _ ih, match b, ih with
    | _, ⟨L1, h1, rfl⟩ := ⟨L1.map (list.cons (-1)),
      λ L2 h2, match L2, list.mem_map.1 h2 with
        | _, ⟨L3, h3, rfl⟩ := list.forall_mem_cons.2 ⟨or.inr rfl, h1 L3 h3⟩
        end,
      by simp only [list.map_map, (∘), list.prod_cons, neg_one_mul];
      exact list.rec_on L1 neg_zero.symm (λ hd tl ih,
        by rw [list.map_cons, list.sum_cons, ih, list.map_cons, list.sum_cons, neg_add])⟩
    end)
  (λ r1 r2 hr1 hr2 ih1 ih2, match r1, r2, ih1, ih2 with
    | _, _, ⟨L1, h1, rfl⟩, ⟨L2, h2, rfl⟩ := ⟨L1 ++ L2, list.forall_mem_append.2 ⟨h1, h2⟩,
      by rw [list.map_append, list.sum_append]⟩
    end)

@[elab_as_eliminator]
protected theorem in_closure.rec_on {C : R → Prop} {x : R} (hx : x ∈ closure s)
  (h1 : C 1) (hneg1 : C (-1)) (hs : ∀ z ∈ s, ∀ n, C n → C (z * n))
  (ha : ∀ {x y}, C x → C y → C (x + y)) : C x :=
begin
  have h0 : C 0 := add_neg_self (1:R) ▸ ha h1 hneg1,
  rcases exists_list_of_mem_closure hx with ⟨L, HL, rfl⟩, clear hx,
  induction L with hd tl ih, { exact h0 },
  rw list.forall_mem_cons at HL,
  suffices : C (list.prod hd),
  { rw [list.map_cons, list.sum_cons],
    exact ha this (ih HL.2) },
  replace HL := HL.1, clear ih tl,
  suffices : ∃ L : list R,
    (∀ x ∈ L, x ∈ s) ∧ (list.prod hd = list.prod L ∨ list.prod hd = -list.prod L),
  { rcases this with ⟨L, HL', HP | HP⟩,
    { rw HP, clear HP HL hd, induction L with hd tl ih, { exact h1 },
      rw list.forall_mem_cons at HL',
      rw list.prod_cons,
      exact hs _ HL'.1 _ (ih HL'.2) },
    rw HP, clear HP HL hd, induction L with hd tl ih, { exact hneg1 },
    rw [list.prod_cons, neg_mul_eq_mul_neg],
    rw list.forall_mem_cons at HL',
    exact hs _ HL'.1 _ (ih HL'.2) },
  induction hd with hd tl ih,
  { exact ⟨[], list.forall_mem_nil _, or.inl rfl⟩ },
  rw list.forall_mem_cons at HL,
  rcases ih HL.2 with ⟨L, HL', HP | HP⟩; cases HL.1 with hhd hhd,
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inl $
      by rw [list.prod_cons, list.prod_cons, HP]⟩ },
  { exact ⟨L, HL', or.inr $ by rw [list.prod_cons, hhd, neg_one_mul, HP]⟩ },
  { exact ⟨hd :: L, list.forall_mem_cons.2 ⟨hhd, HL'⟩, or.inr $
      by rw [list.prod_cons, list.prod_cons, HP, neg_mul_eq_mul_neg]⟩ },
  { exact ⟨L, HL', or.inl $ by rw [list.prod_cons, hhd, HP, neg_one_mul, neg_neg]⟩ }
end

lemma closure.is_subring : is_subring (closure s) :=
{ one_mem := add_group.mem_closure $ is_submonoid.one_mem $ monoid.closure.is_submonoid _,
  mul_mem := λ a b ha hb, add_group.in_closure.rec_on hb
    ( λ c hc, add_group.in_closure.rec_on ha
      ( λ d hd, add_group.subset_closure ((monoid.closure.is_submonoid _).mul_mem hd hc))
      ( (zero_mul c).symm ▸ (add_group.closure.is_add_subgroup _).zero_mem)
      ( λ d hd hdc, neg_mul_eq_neg_mul d c ▸ (add_group.closure.is_add_subgroup _).neg_mem hdc)
      ( λ d e hd he hdc hec, (add_mul d e c).symm ▸
        ((add_group.closure.is_add_subgroup _).add_mem hdc hec)))
    ( (mul_zero a).symm ▸ (add_group.closure.is_add_subgroup _).zero_mem)
    ( λ c hc hac, neg_mul_eq_mul_neg a c ▸ (add_group.closure.is_add_subgroup _).neg_mem hac)
    ( λ c d hc hd hac had, (mul_add a c d).symm ▸
      (add_group.closure.is_add_subgroup _).add_mem hac had),
  ..add_group.closure.is_add_subgroup _}

theorem mem_closure {a : R} : a ∈ s → a ∈ closure s :=
add_group.mem_closure ∘ @monoid.subset_closure _ _ _ _

theorem subset_closure : s ⊆ closure s :=
λ _, mem_closure

theorem closure_subset {t : set R} (ht : is_subring t) : s ⊆ t → closure s ⊆ t :=
(add_group.closure_subset ht.to_is_add_subgroup) ∘ (monoid.closure_subset ht.to_is_submonoid)

theorem closure_subset_iff {s t : set R} (ht : is_subring t) : closure s ⊆ t ↔ s ⊆ t :=
(add_group.closure_subset_iff ht.to_is_add_subgroup).trans
  ⟨set.subset.trans monoid.subset_closure, monoid.closure_subset ht.to_is_submonoid⟩

theorem closure_mono {s t : set R} (H : s ⊆ t) : closure s ⊆ closure t :=
closure_subset closure.is_subring $ set.subset.trans H subset_closure

lemma image_closure {S : Type*} [ring S] (f : R →+* S) (s : set R) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { rw [f.map_one], apply closure.is_subring.to_is_submonoid.one_mem },
    { rw [f.map_neg, f.map_one],
      apply closure.is_subring.to_is_add_subgroup.neg_mem,
      apply closure.is_subring.to_is_submonoid.one_mem },
    { rw [f.map_mul],
      apply closure.is_subring.to_is_submonoid.mul_mem;
      solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [f.map_add], apply closure.is_subring.to_is_add_submonoid.add_mem, assumption' },
  end
  (closure_subset (ring_hom.is_subring_image _ closure.is_subring) $
    set.image_subset _ subset_closure)

end ring


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

! This file was ported from Lean 3 source module set_theory.cardinal.finite
! leanprover-community/mathlib commit 34ee86e6a59d911a8e4f89b68793ee7577ae79c7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Zmod.Defs
import Mathbin.SetTheory.Cardinal.Basic

/-!
# Finite Cardinality Functions

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

## Main Definitions

* `nat.card α` is the cardinality of `α` as a natural number.
  If `α` is infinite, `nat.card α = 0`.
* `part_enat.card α` is the cardinality of `α` as an extended natural number
  (`part ℕ` implementation). If `α` is infinite, `part_enat.card α = ⊤`.
-/

open Cardinal

noncomputable section

open BigOperators

variable {α β : Type _}

namespace Nat

#print Nat.card /-
/-- `nat.card α` is the cardinality of `α` as a natural number.
  If `α` is infinite, `nat.card α = 0`. -/
protected def card (α : Type _) : ℕ :=
  (mk α).toNat
#align nat.card Nat.card
-/

#print Nat.card_eq_fintype_card /-
@[simp]
theorem card_eq_fintype_card [Fintype α] : Nat.card α = Fintype.card α :=
  mk_toNat_eq_card
#align nat.card_eq_fintype_card Nat.card_eq_fintype_card
-/

#print Nat.card_eq_zero_of_infinite /-
@[simp]
theorem card_eq_zero_of_infinite [Infinite α] : Nat.card α = 0 :=
  mk_toNat_of_infinite
#align nat.card_eq_zero_of_infinite Nat.card_eq_zero_of_infinite
-/

#print Nat.finite_of_card_ne_zero /-
theorem finite_of_card_ne_zero (h : Nat.card α ≠ 0) : Finite α :=
  not_infinite_iff_finite.mp <| h ∘ @Nat.card_eq_zero_of_infinite α
#align nat.finite_of_card_ne_zero Nat.finite_of_card_ne_zero
-/

/- warning: nat.card_congr -> Nat.card_congr is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}}, (Equiv.{succ u1, succ u2} α β) -> (Eq.{1} Nat (Nat.card.{u1} α) (Nat.card.{u2} β))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}}, (Equiv.{succ u2, succ u1} α β) -> (Eq.{1} Nat (Nat.card.{u2} α) (Nat.card.{u1} β))
Case conversion may be inaccurate. Consider using '#align nat.card_congr Nat.card_congrₓ'. -/
theorem card_congr (f : α ≃ β) : Nat.card α = Nat.card β :=
  Cardinal.toNat_congr f
#align nat.card_congr Nat.card_congr

/- warning: nat.card_eq_of_bijective -> Nat.card_eq_of_bijective is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (f : α -> β), (Function.Bijective.{succ u1, succ u2} α β f) -> (Eq.{1} Nat (Nat.card.{u1} α) (Nat.card.{u2} β))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (f : α -> β), (Function.Bijective.{succ u2, succ u1} α β f) -> (Eq.{1} Nat (Nat.card.{u2} α) (Nat.card.{u1} β))
Case conversion may be inaccurate. Consider using '#align nat.card_eq_of_bijective Nat.card_eq_of_bijectiveₓ'. -/
theorem card_eq_of_bijective (f : α → β) (hf : Function.Bijective f) : Nat.card α = Nat.card β :=
  card_congr (Equiv.ofBijective f hf)
#align nat.card_eq_of_bijective Nat.card_eq_of_bijective

#print Nat.card_eq_of_equiv_fin /-
theorem card_eq_of_equiv_fin {α : Type _} {n : ℕ} (f : α ≃ Fin n) : Nat.card α = n := by
  simpa using card_congr f
#align nat.card_eq_of_equiv_fin Nat.card_eq_of_equiv_fin
-/

#print Nat.equivFinOfCardPos /-
/-- If the cardinality is positive, that means it is a finite type, so there is
an equivalence between `α` and `fin (nat.card α)`. See also `finite.equiv_fin`. -/
def equivFinOfCardPos {α : Type _} (h : Nat.card α ≠ 0) : α ≃ Fin (Nat.card α) :=
  by
  cases fintypeOrInfinite α
  · simpa using Fintype.equivFin α
  · simpa using h
#align nat.equiv_fin_of_card_pos Nat.equivFinOfCardPos
-/

#print Nat.card_of_subsingleton /-
theorem card_of_subsingleton (a : α) [Subsingleton α] : Nat.card α = 1 :=
  by
  letI := Fintype.ofSubsingleton a
  rw [card_eq_fintype_card, Fintype.card_ofSubsingleton a]
#align nat.card_of_subsingleton Nat.card_of_subsingleton
-/

#print Nat.card_unique /-
@[simp]
theorem card_unique [Unique α] : Nat.card α = 1 :=
  card_of_subsingleton default
#align nat.card_unique Nat.card_unique
-/

#print Nat.card_eq_one_iff_unique /-
theorem card_eq_one_iff_unique : Nat.card α = 1 ↔ Subsingleton α ∧ Nonempty α :=
  Cardinal.toNat_eq_one_iff_unique
#align nat.card_eq_one_iff_unique Nat.card_eq_one_iff_unique
-/

#print Nat.card_eq_two_iff /-
theorem card_eq_two_iff : Nat.card α = 2 ↔ ∃ x y : α, x ≠ y ∧ {x, y} = @Set.univ α :=
  (toNat_eq_iff two_ne_zero).trans <| Iff.trans (by rw [Nat.cast_two]) mk_eq_two_iff
#align nat.card_eq_two_iff Nat.card_eq_two_iff
-/

#print Nat.card_eq_two_iff' /-
theorem card_eq_two_iff' (x : α) : Nat.card α = 2 ↔ ∃! y, y ≠ x :=
  (toNat_eq_iff two_ne_zero).trans <| Iff.trans (by rw [Nat.cast_two]) (mk_eq_two_iff' x)
#align nat.card_eq_two_iff' Nat.card_eq_two_iff'
-/

#print Nat.card_of_isEmpty /-
theorem card_of_isEmpty [IsEmpty α] : Nat.card α = 0 := by simp
#align nat.card_of_is_empty Nat.card_of_isEmpty
-/

/- warning: nat.card_prod -> Nat.card_prod is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) (β : Type.{u2}), Eq.{1} Nat (Nat.card.{max u1 u2} (Prod.{u1, u2} α β)) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (Nat.card.{u1} α) (Nat.card.{u2} β))
but is expected to have type
  forall (α : Type.{u2}) (β : Type.{u1}), Eq.{1} Nat (Nat.card.{max u1 u2} (Prod.{u2, u1} α β)) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (Nat.card.{u2} α) (Nat.card.{u1} β))
Case conversion may be inaccurate. Consider using '#align nat.card_prod Nat.card_prodₓ'. -/
@[simp]
theorem card_prod (α β : Type _) : Nat.card (α × β) = Nat.card α * Nat.card β := by
  simp only [Nat.card, mk_prod, to_nat_mul, to_nat_lift]
#align nat.card_prod Nat.card_prod

/- warning: nat.card_ulift -> Nat.card_uLift is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}), Eq.{1} Nat (Nat.card.{max u1 u2} (ULift.{u2, u1} α)) (Nat.card.{u1} α)
but is expected to have type
  forall (α : Type.{u2}), Eq.{1} Nat (Nat.card.{max u2 u1} (ULift.{u1, u2} α)) (Nat.card.{u2} α)
Case conversion may be inaccurate. Consider using '#align nat.card_ulift Nat.card_uLiftₓ'. -/
@[simp]
theorem card_uLift (α : Type _) : Nat.card (ULift α) = Nat.card α :=
  card_congr Equiv.ulift
#align nat.card_ulift Nat.card_uLift

#print Nat.card_pLift /-
@[simp]
theorem card_pLift (α : Type _) : Nat.card (PLift α) = Nat.card α :=
  card_congr Equiv.plift
#align nat.card_plift Nat.card_pLift
-/

#print Nat.card_pi /-
theorem card_pi {β : α → Type _} [Fintype α] : Nat.card (∀ a, β a) = ∏ a, Nat.card (β a) := by
  simp_rw [Nat.card, mk_pi, prod_eq_of_fintype, to_nat_lift, to_nat_finset_prod]
#align nat.card_pi Nat.card_pi
-/

/- warning: nat.card_fun -> Nat.card_fun is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Finite.{succ u1} α], Eq.{1} Nat (Nat.card.{max u1 u2} (α -> β)) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat (Monoid.Pow.{0} Nat Nat.monoid)) (Nat.card.{u2} β) (Nat.card.{u1} α))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Finite.{succ u2} α], Eq.{1} Nat (Nat.card.{max u2 u1} (α -> β)) (HPow.hPow.{0, 0, 0} Nat Nat Nat (instHPow.{0, 0} Nat Nat instPowNat) (Nat.card.{u1} β) (Nat.card.{u2} α))
Case conversion may be inaccurate. Consider using '#align nat.card_fun Nat.card_funₓ'. -/
theorem card_fun [Finite α] : Nat.card (α → β) = Nat.card β ^ Nat.card α :=
  by
  haveI := Fintype.ofFinite α
  rw [Nat.card_pi, Finset.prod_const, Finset.card_univ, ← Nat.card_eq_fintype_card]
#align nat.card_fun Nat.card_fun

#print Nat.card_zMod /-
@[simp]
theorem card_zMod (n : ℕ) : Nat.card (ZMod n) = n :=
  by
  cases n
  · exact Nat.card_eq_zero_of_infinite
  · rw [Nat.card_eq_fintype_card, ZMod.card]
#align nat.card_zmod Nat.card_zMod
-/

end Nat

namespace PartENat

#print PartENat.card /-
/-- `part_enat.card α` is the cardinality of `α` as an extended natural number.
  If `α` is infinite, `part_enat.card α = ⊤`. -/
def card (α : Type _) : PartENat :=
  (mk α).toPartENat
#align part_enat.card PartENat.card
-/

/- warning: part_enat.card_eq_coe_fintype_card -> PartENat.card_eq_coe_fintype_card is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : Fintype.{u1} α], Eq.{1} PartENat (PartENat.card.{u1} α) ((fun (a : Type) (b : Type) [self : HasLiftT.{1, 1} a b] => self.0) Nat PartENat (HasLiftT.mk.{1, 1} Nat PartENat (CoeTCₓ.coe.{1, 1} Nat PartENat (Nat.castCoe.{0} PartENat (AddMonoidWithOne.toNatCast.{0} PartENat (AddCommMonoidWithOne.toAddMonoidWithOne.{0} PartENat PartENat.addCommMonoidWithOne))))) (Fintype.card.{u1} α _inst_1))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : Fintype.{u1} α], Eq.{1} PartENat (PartENat.card.{u1} α) (Nat.cast.{0} PartENat (AddMonoidWithOne.toNatCast.{0} PartENat (AddCommMonoidWithOne.toAddMonoidWithOne.{0} PartENat PartENat.instAddCommMonoidWithOnePartENat)) (Fintype.card.{u1} α _inst_1))
Case conversion may be inaccurate. Consider using '#align part_enat.card_eq_coe_fintype_card PartENat.card_eq_coe_fintype_cardₓ'. -/
@[simp]
theorem card_eq_coe_fintype_card [Fintype α] : card α = Fintype.card α :=
  mk_toPartENat_eq_coe_card
#align part_enat.card_eq_coe_fintype_card PartENat.card_eq_coe_fintype_card

#print PartENat.card_eq_top_of_infinite /-
@[simp]
theorem card_eq_top_of_infinite [Infinite α] : card α = ⊤ :=
  mk_toPartENat_of_infinite
#align part_enat.card_eq_top_of_infinite PartENat.card_eq_top_of_infinite
-/

end PartENat


import basic_definitions.group_representation
import basic_definitions.morphism
import tactic.apply_fun
import basic_definitions.sub_module
import Tools.tools
set_option pp.generalized_field_notation false
open_locale big_operators    ----  his there a standart notation ?
/-!
*    Let `ρ and π` two representations on `M` and `M'`. Let `f : M →ₗ[R] M'` a `linear_map`.
*    Let  `ℒ f := Σ_{g ∈ G} π g⁻¹ ∘ f ∘ ρ  g`,   then  `ℒ f` is a morphism `ρ ⟶ᵣ π`.
*    Proof :  `∀ t ∈ G,  ρ t ∘ ℒ f ∘ π t⁻¹  := ∑ ρ t g⁻¹  ∘ f ∘ π g t  = ∑  t'⁻¹  ∘  f ∘ π t'`

#    We start to define sum operator on `M →ₗ[R] M'`
*     Let `(X : Type u)[fintype X]` and ` φ : X → M→ₗ[R]M'`. We fix a notation for
*    `finset.sum finset.univ φ := Σ φ`.  The notation change in mathlib taht cool
-/
universes  u v w w' w''
open linear_map
/-!
*   We illustrate in a first time the name of the function.
-/
namespace Illustration
variables {G : Type u } [group G][fintype G]
          {R : Type v}[comm_ring R]
          {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          (ρ : G → M →ₗ[R]M')
          (f : M' →ₗ[R]M')
          (g : M →ₗ[R]M)
          (x : M)
/-!
    Here ` * ` denote the composition of linear application. We have a structure of `add_comm_monoid`
    on ` M→ₗ[R]M' ` That ensure `Σ` is well define.
    I don't know if this lemma is on mathlib so i rename it in a file tools.
-/
example :  f ⊚  (∑ g, ρ g) = ∑ g, f ⊚  (ρ g)  :=
begin
    erw sum_left_comp,
end

example : (∑ t,  ρ t) ⊚  g = ∑  s, (ρ s) ⊚  g   :=
begin
    erw sum_right_comp,
end
example :  (∑ g, ρ g ) x = ∑ g , (ρ g) x        :=
begin
    rw sum_apply,
end

end Illustration

variables {G : Type u} [group G][fintype G]
          {R : Type v}[comm_ring R]   --- Commutative ring

namespace Reynold
open Illustration
variables {M : Type w}  [add_comm_group M] [module R M]
          {M' : Type w'} [add_comm_group M'] [module R M']
          (ρ : group_representation G R M)
          (π : group_representation G R M')

/--
    `mixte_conj π ρ f s  : M→ₗ[R] M' := π s⁻¹ * f * ρ s`
-/
def mixte_conj (f : M→ₗ[R]M') : G →   M→ₗ[R] M' := λ s, π s⁻¹  ⊚  f ⊚  ρ s

lemma mixte_conj_ext (f : M→ₗ[R]M')(s : G) : mixte_conj ρ π f s = (π s⁻¹)  ⊚   f ⊚  (ρ s) := rfl
/--
        we have `∀ g : G, (π g) (π s⁻¹) * f * ρ s = π (s g⁻¹)⁻¹  * f * ρ (s g⁻¹) * ρ g`
        so `π  g * mixte_conj s = mixte_conj (s g⁻¹) ρ g`
-/
theorem mixte_conj_mul_left (f : M→ₗ[R]M') (g : G)(s : G):
 (π g) ⊚  (mixte_conj ρ π f s) = (mixte_conj ρ π f (s * g⁻¹)) ⊚  (ρ g ) :=
 begin
    rw mixte_conj_ext, rw mixte_conj_ext,
    erw mul_inv_rev, rw inv_inv, rw map_comp,
    conv_rhs {
        rw  comp_assoc (ρ g),
        rw ← map_comp ρ , rw mul_assoc, rw inv_mul_self, rw mul_one,
    },
    ext, exact rfl,
end

/--
    The operator `ℒ`
-/
def ℒ (f : M→ₗ[R]M') : M→ₗ[R] M' := ∑ s, mixte_conj ρ π f s

/--
    Ici j'ai détaillé la preuve
-/
theorem Per (f : M→ₗ[R]M') (g : G) : ∑ s, mixte_conj ρ π f s   = ∑  s, mixte_conj ρ π f (s * g⁻¹) :=
sum_univ_perm (mixte_conj ρ π f) (to_equiv g)

open morphism

theorem L_is_morphism (f : M→ₗ[R]M')  :  is_invariant ρ π (ℒ ρ π f)    :=
begin
    unfold ℒ,  intros g,
    erw sum_left_comp,
    rw Per ρ π  f g,
    erw  sum_right_comp,
    congr,funext s,
    rw mixte_conj_mul_left,
end
/--
    The Reynold opérator.
-/

def ℛ : (M→ₗ[R]M') → (ρ ⟶ᵣ  π) := λ f, to_morphism (ℒ ρ π f) (L_is_morphism ρ π f )

lemma reynold_ext(f : M →ₗ[R]M' ) : (ℛ ρ π f).ℓ = ∑ s, mixte_conj ρ π f s := rfl
#check ℛ ρ ρ
/-!
    THE Reynold opérator is linear !
        note the structure of module of ρ ⟶ᵣ ρ' is define in the file
        `basic_definition.morphism_module`

    Remarque je n'ai toujours pas inversé le cardinal de G pour des raisons de confort !
-/
variables {M'' : Type w''} [add_comm_group M''] [module R M'']
lemma comp_left_distrib (a : M' →ₗ[R]M'')(b c : M →ₗ[R]M') : a ⊚ (b + c) = a ⊚ b + a ⊚ c :=
begin
    intros, ext x, erw map_add, exact rfl,
end
lemma comp_smul (r : R) (a : M' →ₗ[R]M'')(b  : M →ₗ[R]M') : a ⊚  (r • b) = r • (a ⊚ b) :=
begin
    intros,ext,erw map_smul, exact rfl,
end
def Re : (M→ₗ[R]M') →ₗ[R] (ρ ⟶ᵣ  π) := {
    to_fun := ℛ ρ π ,
    add :=
    begin
        intros f1 f2, apply morphism.ext,
        rw morphism_module.add_coe,
        erw ← multiset.sum_map_add,rw reynold_ext, congr, funext,
        rw mixte_conj_ext, erw comp_left_distrib, exact rfl,
  end,
  smul := begin  -- mieux avec morphism.ext
    intros r f,apply morphism.ext, rw morphism_module.coe_smul,
    rw reynold_ext, rw reynold_ext,rw finset.smul_sum, congr,
    funext,
    rw mixte_conj_ext,
    rw comp_smul,
    exact rfl,
  end }
lemma reynold_ext'(f : M →ₗ[R]M' ) : (Re ρ π f).ℓ  = ∑ s, mixte_conj ρ π f s  := rfl
end Reynold
open Reynold
variables {M : Type w}  [add_comm_group M] [module R M] (ρ : group_representation G R M)

lemma comp_conjugate (p1 p2  : M→ₗ[R]M ) (g : G) :  (mixte_conj ρ ρ (p1 ) g)  * mixte_conj ρ ρ p2 g =  mixte_conj ρ ρ (p1 * p2) g :=
begin
    rw mixte_conj_ext,
    change _ ⊚ ( p1 ⊚ (ρ g ⊚  ρ  g ⁻¹) ⊚  p2 ) ⊚  _ = _,
    rw ← map_comp, rw mul_inv_self, rw ρ.map_one, erw comp_id, exact rfl,
end
/--
    `is_projector p ` →  `is_projector (mixte_conj ρ ρ p g)`
-/
lemma conjugate_projector (p : M→ₗ[R]M )(hyp : is_projector p) (g : G) : is_projector (mixte_conj ρ ρ p g) :=
begin
    unfold is_projector at *,
    rw comp_conjugate, rw hyp,
end
/--
    `range (p * ρ g) =   (range p )`
-/
lemma pre_compose_range (p : M→ₗ[R]M ) (g : G) : range (p * ρ g) =   (range p ) :=
begin
        apply le_antisymm,
        {unfold range, erw  submodule.map_comp, apply submodule.map_mono, exact le_top},
        rw submodule.le_def', intros x,  intros hyp, rcases hyp with ⟨z,hyp_z ⟩,  use (ρ g⁻¹ ) z, split,
        change (ρ g⁻¹ ) z ∈ ⊤ ,
        trivial, rw ←  hyp_z.2,
        change  p  (( ρ g ⊚ ρ g⁻¹ ) z ) = p z,
        rw ← map_comp, rw mul_inv_self, rw ρ.map_one, exact rfl,
end
lemma conjugate_range (p : M→ₗ[R]M ) (g : G) : range (mixte_conj ρ ρ p g) = submodule.map (ρ g⁻¹ )  (range p ) :=
begin
    unfold mixte_conj,
    erw ← submodule.map_comp, erw pre_compose_range,
    exact rfl,
end
open stability
lemma conj_mixte_range (p : M→ₗ[R]M )[stable_submodule ρ (range p)] (g : G)  : range (mixte_conj ρ ρ p g) = range p :=
begin
    rw conjugate_range,
    rw stability.map,
end


import Duper.TPTP
import Duper.Tactic

-- inhabitants
axiom Inhab : Type

axiom Fether   : Inhab
axiom Tarr     : Inhab
axiom Jones    : Inhab
axiom Smith    : Inhab
axiom A        : Inhab
axiom B        : Inhab
axiom C        : Inhab
axiom D        : Inhab
axiom Sane     : Inhab → Prop
axiom Doctor   : Inhab → Prop
axiom Peculiar : Inhab → Prop
axiom Special  : Inhab → Prop
axiom bf       : Inhab → Inhab

axiom ax1 : ∀ x, Peculiar x ↔ (Sane x ↔ ¬ Doctor x)
axiom ax2 : ∀ x, Special x ↔ ∀ y, (¬ Doctor y ↔ (Sane y ↔ Peculiar x))
axiom ax3 : ∀ x y, (Sane x ↔ Special y) → (Sane (bf x) ↔ ¬ Doctor y)
axiom ax4 : Sane Tarr ↔ ∀ x, Doctor x → Sane x
axiom ax5 : Sane Fether ↔ ∀ x, ¬ Doctor x → ¬ (Sane x)
axiom ax6 : Sane Fether ↔ Sane Tarr

example
  (ax1 : ∀ x, Peculiar x ↔ (Sane x ↔ ¬ Doctor x))
  (ax2 : ∀ x, Special x ↔ ∀ y, (¬ Doctor y ↔ (Sane y ↔ Peculiar x)))
  (ax3 : ∀ x y, (Sane x ↔ Special y) → (Sane (bf x) ↔ ¬ Doctor y))
  (ax4 : Sane Tarr ↔ ∀ x, Doctor x → Sane x)
  (ax5 : Sane Fether ↔ ∀ x, ¬ Doctor x → ¬ (Sane x))
  (ax6 : Sane Fether ↔ Sane Tarr)
  : False := sorry --by duper -- timeout

theorem asylum_one
  (h1 : Sane Jones ↔ Doctor Smith)
  (h2 : Sane Smith ↔ ¬ Doctor Jones)
  : ∃ x : Inhab, (¬ Sane (x) ∧ Doctor (x)) ∨ (Sane (x) ∧ ¬ Doctor (x)) := by duper

#print axioms asylum_one

theorem asylum_seven
  (h1 : Sane A ↔ ¬ Sane B)
  (h2 : Sane B ↔ Doctor A)
  : (¬ Sane A ∧ Doctor A) ∨ (Sane A ∧ ¬ Doctor A) := by duper

#print axioms asylum_seven

set_option trace.Timeout.debug true

theorem asylum_nine
  (h1 : Sane A ↔ (Sane B ↔ Sane C))
  (h2 : Sane B ↔ (Sane A ↔ Sane D))
  (h3 : Sane C ↔ ¬ (Doctor C ∧ Doctor D))
  (h4 : A ≠ B ∧ A ≠ C ∧ A ≠ D ∧ B ≠ C ∧ B ≠ D ∧ C ≠ D) :
  (∃ x : Inhab, Sane x ∧ ¬ Doctor x) ∨
  (∃ x : Inhab, ∃ y : Inhab, x ≠ y ∧ (¬ Sane x) ∧ Doctor x ∧ (¬ Sane y) ∧ Doctor y) :=
  by duper

#print axioms asylum_nine
#print asylum_nine


import algebra.comm_rings.basic
import algebra.comm_rings.ideals.basic
import algebra.comm_rings.ideals.instances
import misc.zorns_lemma
import misc.prop

namespace comm_ring

open set
open classical

universe u

def le_proper_ideal {R : Type u} [comm_ring R] : proper_ideal R → proper_ideal R → Prop :=
  λ I₁ I₂ : proper_ideal R, I₁.body ⊆ I₂.body

instance le_for_proper_ideals {R : Type u} [comm_ring R] : has_le (proper_ideal R) := ⟨le_proper_ideal⟩

theorem le_proper_ideal_refl {R : Type u} [comm_ring R] : ∀ I : proper_ideal R, I ≤ I :=
begin
  intro I,
  apply subset_reflexive,
end

theorem le_proper_ideal_trans {R : Type u} [comm_ring R] : ∀ I₁ I₂ I₃ : proper_ideal R,  I₁ ≤ I₂ →  I₂ ≤ I₃ →  I₁ ≤ I₃ :=
begin
  intros I₁ I₂ I₃ h₁ h₂,
  apply subset_transitive,
  exact h₁,
  exact h₂,
end

theorem le_proper_ideal_anti_symm {R : Type u} [comm_ring R] : ∀ I₁ I₂ : proper_ideal R,  I₁ ≤ I₂ →  I₂ ≤ I₁ → I₁ = I₂ :=
begin
  intros I₁ I₂ h₁ h₂,
  apply proper_ideal_equality,
  apply subset_antisymmetric,
  split,
  exact h₁,
  exact h₂,
end

instance proper_ideals_poset {R : Type u} [l:comm_ring R] : partial_order (proper_ideal R) :=
 begin
   split,
   apply le_proper_ideal_anti_symm,
   apply le_proper_ideal_refl,
   apply le_proper_ideal_trans,
 end

 theorem maximal_element_is_maximal_ideal {R : Type u} [comm_ring R] : ∀ {I : proper_ideal R}, maximal_element I ↔ is_maximal I :=
 begin

   intro I,
   split,
   intros hI J hJ,
   by_cases ↑J = univ,
   right,
   have trv : ↑J = J.body := rfl,
   rw ← trv,
   exact h,
   left,
   let K := ideal_to_proper h,
   have trv : ↑J = K.body := rfl,
   rw ← hI K hJ,
   rw trv,
   intros hI J hJ,
   apply proper_ideal_equality,
   cases hI (proper_ideals_are_ideals J) hJ,
   exact h,
   apply false.elim,
   apply J.proper,
   exact h,
 end

def union_of_chain_of_ideals_set {R : Type u} [comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅) : set R
  := ⋃₀ (image (λ I : proper_ideal R, I.body) s)

lemma union_of_chain_of_ideals_contains_zero {R : Type u} [l:comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅)
  : l.zero ∈ union_of_chain_of_ideals_set hs ns :=
begin
  let I := some (not_empty_set_has_element ns),
  have hI : I ∈ s := some_spec (not_empty_set_has_element ns),
  apply union_upper_bound,
  have hIbody : I.body ∈ image (λ I :proper_ideal R, I.body) s,
    apply image_membership,
    exact hI,
  exact hIbody,
  apply I.contains_zero,
end

lemma union_of_chain_of_ideals_add_closure {R : Type u} [comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅)
  : ∀ a b, a ∈ union_of_chain_of_ideals_set hs ns → b ∈ union_of_chain_of_ideals_set hs ns → a + b ∈ union_of_chain_of_ideals_set hs ns :=
begin
  intros a b ha hb,
  cases ha with A₁ hA₁,
  cases hb with A₂ hA₂,
  cases hA₁ with hA₁inim hainA₁,
  cases hA₂ with hA₂inim hbinA₂,
  cases hA₁inim with I₁ hI₁,
  cases hA₂inim with I₂ hI₂,
  let I := some (every_pair_is_bounded_in_chain hs ⟨and.left hI₁,and.left hI₂⟩),
  have hI : I ∈ s ∧ I₁ ≤ I ∧ I₂ ≤ I := some_spec (every_pair_is_bounded_in_chain hs ⟨and.left hI₁,and.left hI₂⟩),
  existsi I.body,
  have trv : I.body ∈ image (λ I : proper_ideal R, I.body) s,
    apply image_membership,
    exact and.left hI,
  existsi trv,
  apply I.add_closure,
  apply and.left (and.right hI),
  rw ← and.right hI₁ at hainA₁,
  exact hainA₁,
  apply and.right (and.right hI),
  rw ← and.right hI₂ at hbinA₂,
  exact hbinA₂,
end

lemma union_of_chain_of_ideals_mul_absorb {R : Type u} [comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅)
  : ∀ r {i}, i ∈ union_of_chain_of_ideals_set hs ns → r * i ∈ union_of_chain_of_ideals_set hs ns :=
begin
  intros r i hi,
  cases hi with A hA,
  cases hA with hAinim hiinA,
  cases hAinim with I hI,
  existsi I.body,
  have trv : I.body ∈ image (λ I : proper_ideal R, I.body) s,
    apply image_membership,
    exact and.left hI,
  existsi trv,
  apply I.mul_absorb,
  rw ← and.right hI at hiinA,
  exact hiinA,
end

lemma union_of_chain_of_ideals_proper {R : Type u} [l:comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅)
  : union_of_chain_of_ideals_set hs ns ≠ univ :=
begin
  have h : l.one ∉ union_of_chain_of_ideals_set hs ns,
    intro ab,
    cases ab with A hA,
    cases hA with hAinIm hainA,
    cases hAinIm with I hI,
    rw ← (and.right hI) at hainA,
    have h₁ : l.one ∉ I.body := unit_not_in_proper_ideal one_is_unit,
    apply h₁,
    exact hainA,
  intro ab,
  apply h,
  rw ab,
  trivial,
end

lemma union_of_chain_of_ideals_minus_closure {R : Type u} [comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅)
  : ∀ r : R, r ∈ union_of_chain_of_ideals_set hs ns → -r ∈ union_of_chain_of_ideals_set hs ns :=
begin
  intros i hi,
  cases hi with A hA,
  cases hA with hAinim hiinA,
  cases hAinim with I hI,
  existsi I.body,
  have trv : I.body ∈ image (λ I : proper_ideal R, I.body) s,
    apply image_membership,
    exact and.left hI,
  existsi trv,
  apply I.minus_closure,
  rw ← and.right hI at hiinA,
  exact hiinA,
end

def union_of_chain_of_ideals {R : Type u} [comm_ring R] {s : set (proper_ideal R)} (hs : is_chain s) (ns : s ≠ ∅) : proper_ideal R :=
  {
    body := union_of_chain_of_ideals_set hs ns,
    contains_zero := union_of_chain_of_ideals_contains_zero hs ns,
    minus_closure := union_of_chain_of_ideals_minus_closure hs ns,
    add_closure := union_of_chain_of_ideals_add_closure hs ns,
    mul_absorb := union_of_chain_of_ideals_mul_absorb hs ns,
    proper := union_of_chain_of_ideals_proper hs ns,
  }

theorem union_of_chain_of_ideals_is_upper_bound {R : Type u} [comm_ring R] (s : set (proper_ideal R)) (hs : is_chain s) (ns : s ≠ ∅)
  : ∀ t : proper_ideal R, t ∈ s → t ≤ (union_of_chain_of_ideals hs ns) :=
begin
  intros t htins,
  apply union_upper_bound,
  split,
  split,
  exact htins,
  refl,
end

theorem non_zero_ring_has_maximal_ideal {R: Type u} [comm_ring R] (not_zero: ∃ x : R, x ≠ 0) : ∃ I : proper_ideal R, is_maximal I :=
begin
  have h : ∃ I : proper_ideal R, maximal_element I,
    apply zorns_lemma,
    intros C hC,
    by_cases C ≠ ∅,
    existsi union_of_chain_of_ideals hC h,
    apply union_of_chain_of_ideals_is_upper_bound,
    have h₁ := not_not h,
    have zero_ideal_p : proper_ideal R,
      apply ideal_to_proper,
      exact zero_ideal_proper not_zero,
    existsi zero_ideal_p,
    rw h₁,
    intros a ha b hb,
    apply false.elim,
    exact ha,
  let I := some h,
  have hI : maximal_element I := some_spec h,
  existsi I,
  rw ← maximal_element_is_maximal_ideal,
  exact hI,
end

end comm_ring