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

! This file was ported from Lean 3 source module deprecated.subring
! leanprover-community/mathlib commit 2738d2ca56cbc63be80c3bd48e9ed90ad94e947d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Deprecated.Subgroup
import Mathlib.Deprecated.Group
import Mathlib.RingTheory.Subring.Basic

/-!
# Unbundled subrings (deprecated)

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines predicates for unbundled subrings. Instead of using this file, please use
`Subring`, defined in `RingTheory.Subring.Basic`, for subrings of rings.

## Main definitions

`IsSubring (S : Set R) : Prop` : the predicate that `S` is the underlying set of a subring
of the ring `R`. The bundled variant `Subring R` should be used in preference to this.

## Tags

IsSubring
-/

universe u v

open Group

variable {R : Type u} [Ring R]

/-- `S` is a subring: a set containing 1 and closed under multiplication, addition and additive
inverse. -/
structure IsSubring (S : Set R) extends IsAddSubgroup S, IsSubmonoid S : Prop
#align is_subring IsSubring

/-- Construct a `Subring` from a set satisfying `IsSubring`. -/
def IsSubring.subring {S : Set R} (hs : IsSubring S) : Subring R where
  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
#align is_subring.subring IsSubring.subring

namespace RingHom

theorem isSubring_preimage {R : Type u} {S : Type v} [Ring R] [Ring S] (f : R →+* S) {s : Set S}
    (hs : IsSubring s) : IsSubring (f ⁻¹' s) :=
  { IsAddGroupHom.preimage f.to_isAddGroupHom hs.toIsAddSubgroup,
    IsSubmonoid.preimage f.to_isMonoidHom hs.toIsSubmonoid with }
#align ring_hom.is_subring_preimage RingHom.isSubring_preimage

theorem isSubring_image {R : Type u} {S : Type v} [Ring R] [Ring S] (f : R →+* S) {s : Set R}
    (hs : IsSubring s) : IsSubring (f '' s) :=
  { IsAddGroupHom.image_addSubgroup f.to_isAddGroupHom hs.toIsAddSubgroup,
    IsSubmonoid.image f.to_isMonoidHom hs.toIsSubmonoid with }
#align ring_hom.is_subring_image RingHom.isSubring_image

theorem isSubring_set_range {R : Type u} {S : Type v} [Ring R] [Ring S] (f : R →+* S) :
    IsSubring (Set.range f) :=
  { IsAddGroupHom.range_addSubgroup f.to_isAddGroupHom, Range.isSubmonoid f.to_isMonoidHom with }
#align ring_hom.is_subring_set_range RingHom.isSubring_set_range

end RingHom

variable {cR : Type u} [CommRing cR]

theorem IsSubring.inter {S₁ S₂ : Set R} (hS₁ : IsSubring S₁) (hS₂ : IsSubring S₂) :
    IsSubring (S₁ ∩ S₂) :=
  { IsAddSubgroup.inter hS₁.toIsAddSubgroup hS₂.toIsAddSubgroup,
    IsSubmonoid.inter hS₁.toIsSubmonoid hS₂.toIsSubmonoid with }
#align is_subring.inter IsSubring.inter

theorem IsSubring.interᵢ {ι : Sort _} {S : ι → Set R} (h : ∀ y : ι, IsSubring (S y)) :
    IsSubring (Set.interᵢ S) :=
  { IsAddSubgroup.interᵢ fun i ↦ (h i).toIsAddSubgroup,
    IsSubmonoid.interᵢ fun i ↦ (h i).toIsSubmonoid with }
#align is_subring.Inter IsSubring.interᵢ

theorem isSubring_unionᵢ_of_directed {ι : Type _} [Nonempty ι] {s : ι → Set R}
    (h : ∀ i, IsSubring (s i)) (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
    IsSubring (⋃ i, s i) :=
  { toIsAddSubgroup := isAddSubgroup_unionᵢ_of_directed (fun i ↦ (h i).toIsAddSubgroup) directed
    toIsSubmonoid := isSubmonoid_unionᵢ_of_directed (fun i ↦ (h i).toIsSubmonoid) directed }
#align is_subring_Union_of_directed isSubring_unionᵢ_of_directed

namespace Ring

/-- The smallest subring containing a given subset of a ring, considered as a set. This function
is deprecated; use `Subring.closure`. -/
def closure (s : Set R) :=
  AddGroup.closure (Monoid.Closure s)
#align ring.closure Ring.closure

variable {s : Set R}

-- attribute [local reducible] closure -- Porting note: not available in Lean4

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 :=
  AddGroup.InClosure.recOn h
    fun {x} hx ↦ match x, Monoid.exists_list_of_mem_closure hx with
    | _, ⟨L, h1, rfl⟩ => ⟨[L], List.forall_mem_singleton.2 fun r hr ↦ Or.inl (h1 r hr), zero_add _⟩
    ⟨[], List.forall_mem_nil _, rfl⟩
    fun {b} _ ih ↦ match b, ih with
    | _, ⟨L1, h1, rfl⟩ =>
      ⟨L1.map (List.cons (-1)),
        fun L2 h2 ↦ match L2, List.mem_map.1 h2 with
        | _, ⟨L3, h3, rfl⟩ => List.forall_mem_cons.2 ⟨Or.inr rfl, h1 L3 h3⟩, by
        simp only [List.map_map, (· ∘ ·), List.prod_cons, neg_one_mul]
        refine' List.recOn L1 neg_zero.symm fun hd tl ih ↦ _
        rw [List.map_cons, List.sum_cons, ih, List.map_cons, List.sum_cons, neg_add]⟩
    fun {r1 r2} _ _ 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]⟩
#align ring.exists_list_of_mem_closure Ring.exists_list_of_mem_closure

@[elab_as_elim]
protected theorem InClosure.recOn {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 := by
  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) by
    rw [List.map_cons, List.sum_cons]
    exact ha this (ih HL.2)
  replace HL := HL.1
  clear ih tl
  -- Porting note: Expanded `rsuffices`
  suffices ∃ L, (∀ x ∈ L, x ∈ s) ∧ (List.prod hd = List.prod L ∨ List.prod hd = -List.prod L) by
    rcases this with ⟨L, HL', HP | HP⟩ <;> rw [HP] <;> clear HP HL
    · 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)
    · 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]⟩
#align ring.in_closure.rec_on Ring.InClosure.recOn

theorem closure.isSubring : IsSubring (closure s) :=
  { AddGroup.closure.isAddSubgroup _ with
    one_mem := AddGroup.mem_closure <| IsSubmonoid.one_mem <| Monoid.closure.isSubmonoid _
    mul_mem := fun {a _} ha hb ↦ AddGroup.InClosure.recOn hb
      (fun {c} hc ↦ AddGroup.InClosure.recOn ha
        (fun hd ↦ AddGroup.subset_closure ((Monoid.closure.isSubmonoid _).mul_mem hd hc))
        ((zero_mul c).symm ▸ (AddGroup.closure.isAddSubgroup _).zero_mem)
        (fun {d} _ hdc ↦ neg_mul_eq_neg_mul d c ▸ (AddGroup.closure.isAddSubgroup _).neg_mem hdc)
        fun {d e} _ _ hdc hec ↦
          (add_mul d e c).symm ▸ (AddGroup.closure.isAddSubgroup _).add_mem hdc hec)
      ((mul_zero a).symm ▸ (AddGroup.closure.isAddSubgroup _).zero_mem)
      (fun {c} _ hac ↦ neg_mul_eq_mul_neg a c ▸ (AddGroup.closure.isAddSubgroup _).neg_mem hac)
      fun {c d} _ _ hac had ↦
        (mul_add a c d).symm ▸ (AddGroup.closure.isAddSubgroup _).add_mem hac had }
#align ring.closure.is_subring Ring.closure.isSubring

theorem mem_closure {a : R} : a ∈ s → a ∈ closure s :=
  AddGroup.mem_closure ∘ @Monoid.subset_closure _ _ _ _
#align ring.mem_closure Ring.mem_closure

theorem subset_closure : s ⊆ closure s :=
  fun _ ↦ mem_closure
#align ring.subset_closure Ring.subset_closure

theorem closure_subset {t : Set R} (ht : IsSubring t) : s ⊆ t → closure s ⊆ t :=
  AddGroup.closure_subset ht.toIsAddSubgroup ∘ Monoid.closure_subset ht.toIsSubmonoid
#align ring.closure_subset Ring.closure_subset

theorem closure_subset_iff {s t : Set R} (ht : IsSubring t) : closure s ⊆ t ↔ s ⊆ t :=
  (AddGroup.closure_subset_iff ht.toIsAddSubgroup).trans
    ⟨Set.Subset.trans Monoid.subset_closure, Monoid.closure_subset ht.toIsSubmonoid⟩
#align ring.closure_subset_iff Ring.closure_subset_iff

theorem closure_mono {s t : Set R} (H : s ⊆ t) : closure s ⊆ closure t :=
  closure_subset closure.isSubring <| Set.Subset.trans H subset_closure
#align ring.closure_mono Ring.closure_mono

theorem image_closure {S : Type _} [Ring S] (f : R →+* S) (s : Set R) :
    f '' closure s = closure (f '' s) := by
  refine' le_antisymm _ (closure_subset (RingHom.isSubring_image _ closure.isSubring) <|
    Set.image_subset _ subset_closure)
  rintro _ ⟨x, hx, rfl⟩
  apply AddGroup.InClosure.recOn (motive := fun {x} _ ↦ f x ∈ closure (f '' s)) hx _ <;> intros
  · rw [f.map_zero]
    apply closure.isSubring.zero_mem
  · rw [f.map_neg]
    apply closure.isSubring.neg_mem
    assumption
  · rw [f.map_add]
    apply closure.isSubring.add_mem
    assumption'
  · apply AddGroup.mem_closure
    rw [← Monoid.image_closure f.to_isMonoidHom]
    apply Set.mem_image_of_mem
    assumption
#align ring.image_closure Ring.image_closure

end Ring


/-
Here is an example where typeclass resolution triggers nested typeclass resolution.
-/

class Ring   (α : Type) : Type := (x : Unit)
class Double (α : Type) : Type := (x : Unit)
class Foo    (α : Type) [Double α] : Type := (x : Unit)

instance RingToDouble (α : Type) [Ring α] : Double α := Double.mk α ()

-- Note: The return type is really `@Foo α (@RingToDouble α s)`.
instance RingFoo (α : Type) [s : Ring α] : Foo α := Foo.mk α ()

instance RingInt : Ring Int := Ring.mk Int ()
instance DoubleInt : Double Int := Double.mk Int ()

def foo [@Foo Int DoubleInt] : Unit := ()

set_option pp.all true
set_option trace.class_instances true
set_option trace.type_context.complete_instance true

#check @foo _

/-
[class_instances]  class-instance resolution trace
[class_instances] (0) ?x_0 : @Foo Int DoubleInt := @RingFoo ?x_1 ?x_2
[type_context.complete_instance] about to synth: Ring Int
[class_instances]  class-instance resolution trace
[class_instances] (0) ?x_3 : Ring Int := RingInt
[class_instances] (1) ?x_2 : Ring Int := RingInt
@foo (@RingFoo Int RingInt) : Unit
-/


import tactic combinatorics.simple_graph.connectivity
import graph_theory.path graph_theory.pushforward graph_theory.contraction
open classical function

namespace simple_graph

variables {V V' : Type*} [decidable_eq V] [decidable_eq V'] {f : V → V'}
variables {G G' : simple_graph V} {x y z u v w a b c : V}

structure Walk (G : simple_graph V) := {a b : V} (p : G.walk a b)

namespace Walk

variables {e : G.dart} {p q : G.Walk} {hep : e.snd = p.a} {hpq : p.b = q.a}

def nil (a : V) : G.Walk := ⟨(walk.nil : G.walk a a)⟩

@[simp] lemma nil_a : (nil a : G.Walk).a = a := rfl
@[simp] lemma nil_b : (nil b : G.Walk).b = b := rfl

def cons (e : G.dart) (p : G.Walk) (h : e.snd = p.a) : G.Walk :=
by { let h' := e.is_adj, rw h at h', exact ⟨p.p.cons h'⟩ }

def step (e : G.dart) : G.Walk := cons e (nil e.snd) rfl

def rec₀ {motive : G.Walk → Sort*} :
  (Π u, motive (Walk.nil u)) →
  (Π e p h, motive p → motive (cons e p h)) →
  Π p, motive p :=
λ h_nil h_cons ⟨p⟩, walk.rec_on p h_nil $ λ u v w h p, h_cons ⟨⟨_,_⟩,h⟩ ⟨p⟩ rfl

@[simp] lemma rec_nil {motive h_nil h_cons} :
  @rec₀ V _ G motive h_nil h_cons (nil a) = h_nil a := rfl

@[simp] lemma rec_cons {motive h_nil h_cons h} :
  @rec₀ V _ G motive h_nil h_cons (cons e p h) =
  h_cons e p h (rec₀ h_nil h_cons p) :=
begin
  rcases e with ⟨⟨u,v⟩,e⟩, rcases p with ⟨a,b,p⟩, dsimp only at h, subst v, refl
end

@[simp] lemma cons_a : (cons e p hep).a = e.fst := rfl
@[simp] lemma cons_b : (cons e p hep).b = p.b := rfl

def range (p : G.Walk) : finset V :=
p.p.support.to_finset

@[simp] lemma range_cons : (cons e p hep).range = {e.fst} ∪ p.range :=
by simpa only [range, cons, walk.support_cons, list.to_finset_cons]

@[simp] lemma range_step : (step e).range = {e.fst, e.snd} :=
by simpa only [range, step, cons, walk.support_cons, list.to_finset_cons]

@[simp] lemma range_nonempty : p.range.nonempty :=
begin
  refine rec₀ _ _ p,
  { intro u, use u, simp [range] },
  { intros e p h q, use e.fst, simp }
end

def init : G.Walk → finset V :=
rec₀ (λ v, ∅) (λ e p h q, {e.fst} ∪ q)

@[simp] lemma init_cons : (cons e p hep).init = {e.fst} ∪ p.init := rec_cons

lemma range_eq_init_union_last : p.range = p.init ∪ {p.b} :=
by { refine rec₀ _ _ p, { intro u, refl }, { rintro e p h q, simp [q] } }

def tail : G.Walk → finset V :=
rec₀ (λ v, ∅) (λ e p h q, p.range)

@[simp] lemma tail_cons : (cons e p hep).tail = p.range := rec_cons

lemma range_eq_start_union_tail : p.range = {p.a} ∪ p.tail :=
by { refine rec₀ _ _ p, { intro, refl }, { intros, simp [*] } }

def edges : G.Walk → finset G.dart :=
rec₀ (λ v, ∅) (λ e p h q, {e} ∪ q)

@[simp] lemma edges_cons : (cons e p hep).edges = {e} ∪ p.edges := rec_cons

lemma first_edge : e ∈ (cons e p hep).edges := by simp

@[simp] lemma range_a : (nil a : G.Walk).range = {a} := rfl

@[simp] lemma start_mem_range : p.a ∈ p.range :=
by { refine rec₀ _ _ p; simp }

@[simp] lemma end_mem_range : p.b ∈ p.range :=
by { refine rec₀ _ _ p, simp, rintro e p h q, simp, right, exact q }

lemma range_eq_support : p.range = p.p.support.to_finset :=
begin
  refine rec₀ _ _ p,
  { intro u, refl },
  { intros e p h q, rw [range_cons,q], ext, simpa }
end

def append_aux (p q : G.Walk) (hpq : p.b = q.a) : {w : G.Walk // w.a = p.a ∧ w.b = q.b} :=
begin
  rcases p with ⟨a,b,p⟩, rcases q with ⟨c,d,q⟩, simp only at hpq, subst c,
  refine ⟨⟨p ++ q⟩, rfl, rfl⟩,
end

def append_aux' (p q : G.Walk) (hpq : p.b = q.a) : {w : G.Walk // w.a = p.a ∧ w.b = q.b} :=
begin
  rcases p with ⟨a,b,p⟩, rcases q with ⟨c,d,q⟩, simp only at hpq, subst c,
  refine ⟨⟨p ++ q⟩, rfl, rfl⟩,
end

def append (p q : G.Walk) (hpq : p.b = q.a) : G.Walk :=
(append_aux p q hpq).val

@[simp] lemma append_a : (append p q hpq).a = p.a :=
(append_aux p q hpq).prop.1

@[simp] lemma append_b : (append p q hpq).b = q.b :=
(append_aux p q hpq).prop.2

@[simp] lemma append_nil_left {haq : a = q.a} : append (nil a) q haq = q :=
by { subst haq, rcases q with ⟨a,b,q⟩, refl }

@[simp] lemma append_cons :
  append (cons e p hep) q hpq = cons e (append p q hpq) (by simp [hep]) :=
begin
  rcases e with ⟨⟨u,v⟩,e⟩, rcases p with ⟨a,b,p⟩, rcases q with ⟨c,d,q⟩,
  simp at hep hpq, substs a b, refl
end

@[simp] lemma range_append : (append p q hpq).range = p.range ∪ q.range :=
begin
  revert p, refine rec₀ _ _, simp,
  intros e p h q hpq, simp at hpq, specialize @q hpq, simp, rw ←q, refl
end

lemma mem_append : z ∈ (append p q hpq).p.support ↔ z ∈ p.p.support ∨ z ∈ q.p.support :=
begin
  rcases p with ⟨a,b,p⟩, rcases q with ⟨d,c,q⟩, simp at hpq, subst d,
  rw [append, append_aux], simp only [walk.mem_support_append_iff]
end

def push_step_aux (f : V → V') (e : G.dart) :
  {w : (map f G).Walk // w.a = f e.fst ∧ w.b = f e.snd} :=
begin
  by_cases f e.fst = f e.snd,
  exact ⟨Walk.nil (f e.fst), rfl, h⟩,
  exact ⟨Walk.step ⟨⟨_,_⟩,⟨h,e.fst,e.snd,e.is_adj,rfl,rfl⟩⟩, rfl, rfl⟩
end

def push_step (f : V → V') (e : G.dart) : (map f G).Walk :=
(push_step_aux f e).val

@[simp] lemma push_step_a : (push_step f e).a = f e.fst :=
(push_step_aux f e).prop.1

@[simp] lemma push_step_b : (push_step f e).b = f e.snd :=
(push_step_aux f e).prop.2

def push_Walk_aux (f : V → V') (p : G.Walk) :
  {w : (map f G).Walk // w.a = f p.a ∧ w.b = f p.b} :=
begin
  refine rec₀ _ _ p,
  { intro u, exact ⟨Walk.nil (f u), rfl, rfl⟩ },
  { intros e p h q, simp only [cons_a, cons_b],
    let ee := push_step f e,
    let ww := ee.append q.1 (by { rw [q.2.1,←h], exact push_step_b }),
    refine ⟨ww, _, _⟩, simp,
    rw [←q.2.2], exact (ee.append_aux q.1 (by { rw [q.2.1,←h], exact push_step_b })).2.2 }
end

def push_Walk (f : V → V') (p : G.Walk) : (map f G).Walk :=
(push_Walk_aux f p).val

@[simp] lemma push_Walk_a : (push_Walk f p).a = f p.a :=
 (push_Walk_aux f p).prop.1

@[simp] lemma push_Walk_b : (push_Walk f p).b = f p.b :=
 (push_Walk_aux f p).prop.2

@[simp] lemma push_nil : push_Walk f (@Walk.nil _ _ G a) = Walk.nil (f a) := rfl

lemma push_cons (f : V → V') (e : G.dart) (p : G.Walk) (h : e.snd = p.a) :
  push_Walk f (p.cons e h) = Walk.append (push_step f e) (push_Walk f p) (by simp [h]) :=
by { rcases p with ⟨a,b,p⟩, rcases e with ⟨⟨u,v⟩,e⟩, simp at h, subst a, refl }

lemma push_cons_eq (f : V → V') (e : G.dart) (p : G.Walk) (h : e.snd = p.a) (h' : f e.fst = f e.snd) :
  push_Walk f (p.cons e h) = push_Walk f p :=
begin
  have : push_step f e = Walk.nil (f e.fst) := by simp [push_step,push_step_aux,h'],
  rw [push_cons], simp only [this], exact append_nil_left
end

lemma push_cons_ne (f : V → V') (e : G.dart) (p : G.Walk) (h : e.snd = p.a) (h' : f e.fst ≠ f e.snd) :
  push_Walk f (p.cons e h) = Walk.cons ⟨⟨_,_⟩,⟨h',e.fst,e.snd,e.is_adj,rfl,rfl⟩⟩ (push_Walk f p) (by simp [h]) :=
begin
  have : push_step f e = Walk.step ⟨⟨_,_⟩,⟨h',e.fst,e.snd,e.is_adj,rfl,rfl⟩⟩ :=
    by simp [push_step,push_step_aux,h'],
  rw [push_cons], simp [this,step]
end

lemma push_append (f : V → V') (p q : G.Walk) (hpq : p.b = q.a) :
  push_Walk f (Walk.append p q hpq) =
  Walk.append (push_Walk f p) (push_Walk f q) (by simp [hpq]) :=
begin
  revert p, refine rec₀ (by simp) _,
  intros e p h ih hpq, by_cases h' : f e.fst = f e.snd,
  { have h₁ := push_cons_eq f e p h h',
    have h₂ := push_cons_eq f e (Walk.append p q hpq) (h.trans append_a.symm) h',
      simp only [h₁, h₂, ih, append_cons] },
  { have h₁ := push_cons_ne f e p h h',
    have h₂ := push_cons_ne f e (Walk.append p q hpq) (h.trans append_a.symm) h',
      simpa only [h₁, h₂, ih, append_cons] }
end

lemma push_eq_nil (f : V → V') (w : V') (p : G.Walk) (hp : ∀ z : V, z ∈ p.p.support → f z = w) :
  push_Walk f p = Walk.nil w :=
begin
  revert p, refine rec₀ _ _,
  { intros, specialize hp u (by simp [Walk.nil]), simp [hp] },
  { intros e p h ih hp,
    have h₁ : f e.fst = w := by { apply hp, left, refl },
    have h₂ : f e.snd = w := by { apply hp, right, rw h, exact p.p.start_mem_support },
    rw push_cons_eq f e p h (h₁.trans h₂.symm),
    apply ih, intros z hz, apply hp, right, exact hz }
end

@[simp] lemma push_step_range : (push_step f e).range = {f e.fst, f e.snd} :=
by { by_cases f e.fst = f e.snd; simp [push_step, push_step_aux, h] }

lemma push_range : (push_Walk f p).range = finset.image f p.range :=
begin
  refine rec₀ _ _ p, simp, rintro e p h q,
  rw [push_cons,range_cons,range_append,q,finset.image_union,push_step_range],
  ext, split; intro h',
  { rw finset.mem_union at h' ⊢, cases h', simp at h', cases h', left, subst a, simp,
    right, subst a, rw h, apply finset.mem_image_of_mem, exact start_mem_range,
    right, exact h' },
  { rw finset.mem_union at h' ⊢, cases h', simp at h', subst a, left, simp, right,
    exact h' }
end

variables {hf : adapted f G} {p' : (map f G).Walk} {hx : f x = p'.a} {hy : f y = p'.b}

noncomputable def pull_Walk_aux (f : V → V') (hf : adapted f G) (p' : (map f G).Walk) (x y : V)
  (hx : f x = p'.a) (hy : f y = p'.b) :
  {w : G.Walk // w.a = x ∧ w.b = y ∧ push_Walk f w = p'} :=
begin
  revert p' x y, refine rec₀ _ _,
  { rintros u x y hx hy, simp at hx hy, subst hy, choose p h₃ using hf hx,
    refine ⟨⟨p⟩,rfl,rfl,_⟩, apply push_eq_nil, exact h₃ },
  { rintros ⟨⟨u,v⟩,⟨huv,ee⟩⟩ p h ih x y hx hy,
    choose xx yy h₂ h₃ h₄ using ee, substs h₃ h₄, choose p₁ h₆ using hf hx,
    obtain p₂ := ih yy y (h) hy,
    let pp := Walk.append ⟨p₁⟩ (p₂.val.cons ⟨⟨_,_⟩,h₂⟩ p₂.2.1.symm) rfl,
    refine ⟨pp, rfl, p₂.2.2.1, _⟩,
    have h₇ := push_eq_nil f (f xx) ⟨p₁⟩ h₆,
    simp [pp,push_append,h₇],
    have h₈ := push_cons_ne f ⟨⟨_,_⟩,h₂⟩ p₂.val p₂.2.1.symm huv, refine h₈.trans _,
    congr, exact p₂.2.2.2 }
end

noncomputable def pull_Walk (f : V → V') (hf : adapted f G) (p' : (map f G).Walk) (x y : V)
  (hx : f x = p'.a) (hy : f y = p'.b) : G.Walk :=
(pull_Walk_aux f hf p' x y hx hy).val

lemma pull_Walk_a : (pull_Walk f hf p' x y hx hy).a = x :=
(pull_Walk_aux f hf p' x y hx hy).prop.1

lemma pull_Walk_b : (pull_Walk f hf p' x y hx hy).b = y :=
(pull_Walk_aux f hf p' x y hx hy).prop.2.1

lemma pull_Walk_push : push_Walk f (pull_Walk f hf p' x y hx hy) = p' :=
(pull_Walk_aux f hf p' x y hx hy).prop.2.2

def transportable_to (G' : simple_graph V) (p : G.Walk) : Prop :=
  ∀ e : G.dart, e ∈ p.edges → G'.adj e.fst e.snd

lemma transportable_to_of_le (G_le : G ≤ G') : p.transportable_to G' :=
begin
  refine rec₀ _ _ p,
  { rintro u e h, simp [edges] at h, contradiction },
  { rintro e p h q e' h', simp at h', cases h', rw h', exact G_le e.is_adj, exact q e' h' }
end

def transport (p : G.Walk) (hp : transportable_to G' p) :
  {q : G'.Walk // q.a = p.a ∧ q.b = p.b ∧ q.range = p.range ∧ q.init = p.init ∧ q.tail = p.tail} :=
begin
  revert p, refine rec₀ _ _,
  { rintro a hp, exact ⟨nil a, rfl, rfl, rfl, rfl, rfl⟩ },
  { rintro e p h ih hp,
    have : transportable_to G' p :=
      by { rintro e he, apply hp, rw [edges_cons,finset.mem_union], right, exact he },
    specialize ih this, rcases ih with ⟨q,hq⟩, rw ←hq.1 at h,
    exact ⟨cons ⟨⟨_,_⟩,hp e first_edge⟩ q h, by simp [hq]⟩ }
end

noncomputable def until (p : G.Walk) (X : finset V) (hX : (p.range ∩ X).nonempty) :
  {q : G.Walk // q.a = p.a ∧ q.b ∈ X ∧
    q.range ⊆ p.range ∧ q.init ∩ X = ∅ ∧ q.init ⊆ p.init ∧ q.tail ⊆ p.tail} :=
begin
  revert p, refine rec₀ _ _,
  { rintro u hu, choose z hz using hu, simp at hz, cases hz with hz₁ hz₂, subst z,
    exact ⟨nil u, rfl, hz₂, by refl, rfl, by refl, by refl⟩ },
  { rintro e p h₁ ih h₂, by_cases e.fst ∈ X,
    { exact ⟨nil e.fst, rfl, h, by simp, rfl, by simp [init], by simp [tail]⟩ },
    { simp at h₂, choose z hz using h₂, simp at hz, cases hz with hz₁ hz₂,
      have : z ≠ e.fst := by { intro h, rw h at hz₂, contradiction },
      simp [this] at hz₁,
      have : z ∈ p.range ∩ X := finset.mem_inter.mpr ⟨hz₁,hz₂⟩,
      specialize ih ⟨z,this⟩, rcases ih with ⟨q,hq₁,hq₂,hq₃,hq₄,hq₅,hq₆⟩,
      rw ←hq₁ at h₁,
      refine ⟨cons e q h₁, rfl, hq₂, _, _, _, by simp [hq₃]⟩,
      { simp, apply finset.union_subset_union, refl, exact hq₃ },
      { simp [finset.inter_distrib_right,hq₄,h] },
      { simp, apply finset.union_subset_union, refl, exact hq₅ }
    }
  }
end

noncomputable def after (p : G.Walk) (X : finset V) (hX : (p.range ∩ X).nonempty) :
  {q : G.Walk // q.a ∈ X ∧ q.b = p.b ∧
    q.range ⊆ p.range ∧ q.init ⊆ p.init ∧ q.tail ⊆ p.tail ∧ q.tail ∩ X = ∅} :=
begin
  revert p, refine rec₀ _ _,
  { rintro u hu,
    exact ⟨nil u, finset.singleton_inter_nonempty.mp hu, rfl, by refl, by refl, by refl, rfl⟩ },
  { rintro e p h₁ ih h₂, by_cases (p.range ∩ X).nonempty,
    { rcases ih h with ⟨q, hq₁, hq₂, hq₃, hq₄, hq₅, hq₆⟩,
      refine ⟨q, hq₁, hq₂, _, _, _, hq₆⟩,
      { simp, apply hq₃.trans, apply finset.subset_union_right },
      { simp, apply hq₄.trans, apply finset.subset_union_right },
      { simp, apply hq₅.trans, rw range_eq_start_union_tail, apply finset.subset_union_right }
    },
    { refine ⟨cons e p h₁, _, rfl, by refl, _⟩,
      { simp at h₂ ⊢, rcases h₂ with ⟨z,hz⟩, simp at hz, cases hz with hz₁ hz₂,
        cases hz₁, subst z, exact hz₂, exfalso, apply h, use z, simp, exact ⟨hz₁,hz₂⟩ },
      { simp at h ⊢, exact h } } }
end

def reverse (p : G.Walk) : G.Walk := ⟨p.p.reverse⟩

@[simp] lemma reverse_a : (reverse p).a = p.b := by simp only [reverse]
@[simp] lemma reverse_b : (reverse p).b = p.a := by simp only [reverse]

@[simp] lemma reverse_range : (reverse p).range = p.range :=
by simp only [reverse, range, walk.support_reverse, list.to_finset_reverse]

end Walk

end simple_graph


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.adjunction.default
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.kernel_pair
import Mathlib.PostPort

universes v u l v₂ u₂

namespace Mathlib

/-!
# Reflexive coequalizers

We define reflexive pairs as a pair of morphisms which have a common section. We say a category has
reflexive coequalizers if it has coequalizers of all reflexive pairs.
Reflexive coequalizers often enjoy nicer properties than general coequalizers, and feature heavily
in some versions of the monadicity theorem.

We also give some examples of reflexive pairs: for an adjunction `F ⊣ G` with counit `ε`, the pair
`(FGε_B, ε_FGB)` is reflexive. If a pair `f,g` is a kernel pair for some morphism, then it is
reflexive.

# TODO
* If `C` has binary coproducts and reflexive coequalizers, then it has all coequalizers.
* If `T` is a monad on cocomplete category `C`, then `algebra T` is cocomplete iff it has reflexive
  coequalizers.
* If `C` is locally cartesian closed and has reflexive coequalizers, then it has images: in fact
  regular epi (and hence strong epi) images.
-/

namespace category_theory

/--
The pair `f g : A ⟶ B` is reflexive if there is a morphism `B ⟶ A` which is a section for both.
-/
class is_reflexive_pair {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B) (g : A ⟶ B) where
  common_section : ∃ (s : B ⟶ A), s ≫ f = 𝟙 ∧ s ≫ g = 𝟙

/--
The pair `f g : A ⟶ B` is coreflexive if there is a morphism `B ⟶ A` which is a retraction for both.
-/
class is_coreflexive_pair {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B) (g : A ⟶ B) where
  common_retraction : ∃ (s : B ⟶ A), f ≫ s = 𝟙 ∧ g ≫ s = 𝟙

theorem is_reflexive_pair.mk' {C : Type u} [category C] {A : C} {B : C} {f : A ⟶ B} {g : A ⟶ B}
    (s : B ⟶ A) (sf : s ≫ f = 𝟙) (sg : s ≫ g = 𝟙) : is_reflexive_pair f g :=
  is_reflexive_pair.mk (Exists.intro s { left := sf, right := sg })

theorem is_coreflexive_pair.mk' {C : Type u} [category C] {A : C} {B : C} {f : A ⟶ B} {g : A ⟶ B}
    (s : B ⟶ A) (fs : f ≫ s = 𝟙) (gs : g ≫ s = 𝟙) : is_coreflexive_pair f g :=
  is_coreflexive_pair.mk (Exists.intro s { left := fs, right := gs })

/-- Get the common section for a reflexive pair. -/
def common_section {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B) (g : A ⟶ B)
    [is_reflexive_pair f g] : B ⟶ A :=
  Exists.some (is_reflexive_pair.common_section f g)

@[simp] theorem section_comp_left_assoc {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B)
    (g : A ⟶ B) [is_reflexive_pair f g] {X' : C} (f' : B ⟶ X') : common_section f g ≫ f ≫ f' = f' :=
  sorry

@[simp] theorem section_comp_right {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B) (g : A ⟶ B)
    [is_reflexive_pair f g] : common_section f g ≫ g = 𝟙 :=
  and.right (Exists.some_spec (is_reflexive_pair.common_section f g))

/-- Get the common retraction for a coreflexive pair. -/
def common_retraction {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B) (g : A ⟶ B)
    [is_coreflexive_pair f g] : B ⟶ A :=
  Exists.some (is_coreflexive_pair.common_retraction f g)

@[simp] theorem left_comp_retraction_assoc {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B)
    (g : A ⟶ B) [is_coreflexive_pair f g] {X' : C} (f' : A ⟶ X') :
    f ≫ common_retraction f g ≫ f' = f' :=
  sorry

@[simp] theorem right_comp_retraction_assoc {C : Type u} [category C] {A : C} {B : C} (f : A ⟶ B)
    (g : A ⟶ B) [is_coreflexive_pair f g] {X' : C} (f' : A ⟶ X') :
    g ≫ common_retraction f g ≫ f' = f' :=
  sorry

/-- If `f,g` is a kernel pair for some morphism `q`, then it is reflexive. -/
theorem is_kernel_pair.is_reflexive_pair {C : Type u} [category C] {A : C} {B : C} {R : C}
    {f : R ⟶ A} {g : R ⟶ A} {q : A ⟶ B} (h : is_kernel_pair q f g) : is_reflexive_pair f g :=
  is_reflexive_pair.mk' (subtype.val (is_kernel_pair.lift' h 𝟙 𝟙 rfl))
    (and.left (subtype.property (is_kernel_pair.lift' h 𝟙 𝟙 rfl)))
    (and.right (subtype.property (is_kernel_pair.lift' h 𝟙 𝟙 rfl)))

/-- If `f,g` is reflexive, then `g,f` is reflexive. -/
-- This shouldn't be an instance as it would instantly loop.

theorem is_reflexive_pair.swap {C : Type u} [category C] {A : C} {B : C} {f : A ⟶ B} {g : A ⟶ B}
    [is_reflexive_pair f g] : is_reflexive_pair g f :=
  is_reflexive_pair.mk' (common_section f g) (section_comp_right f g) (section_comp_left f g)

/-- If `f,g` is coreflexive, then `g,f` is coreflexive. -/
-- This shouldn't be an instance as it would instantly loop.

theorem is_coreflexive_pair.swap {C : Type u} [category C] {A : C} {B : C} {f : A ⟶ B} {g : A ⟶ B}
    [is_coreflexive_pair f g] : is_coreflexive_pair g f :=
  is_coreflexive_pair.mk' (common_retraction f g) (right_comp_retraction f g)
    (left_comp_retraction f g)

/-- For an adjunction `F ⊣ G` with counit `ε`, the pair `(FGε_B, ε_FGB)` is reflexive. -/
protected instance app.is_reflexive_pair {C : Type u} [category C] {D : Type u₂} [category D]
    {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G) (B : D) :
    is_reflexive_pair (functor.map F (functor.map G (nat_trans.app (adjunction.counit adj) B)))
        (nat_trans.app (adjunction.counit adj) (functor.obj F (functor.obj G B))) :=
  is_reflexive_pair.mk' (functor.map F (nat_trans.app (adjunction.unit adj) (functor.obj G B)))
    (eq.mpr
      (id
        (Eq._oldrec
          (Eq.refl
            (functor.map F (nat_trans.app (adjunction.unit adj) (functor.obj G B)) ≫
                functor.map F (functor.map G (nat_trans.app (adjunction.counit adj) B)) =
              𝟙))
          (Eq.symm
            (functor.map_comp F (nat_trans.app (adjunction.unit adj) (functor.obj G B))
              (functor.map G (nat_trans.app (adjunction.counit adj) B))))))
      (eq.mpr
        (id
          (Eq._oldrec
            (Eq.refl
              (functor.map F
                  (nat_trans.app (adjunction.unit adj) (functor.obj G B) ≫
                    functor.map G (nat_trans.app (adjunction.counit adj) B)) =
                𝟙))
            (adjunction.right_triangle_components adj)))
        (functor.map_id F (functor.obj G (functor.obj 𝟭 B)))))
    (adjunction.left_triangle_components adj)

namespace limits

/-- `C` has reflexive coequalizers if it has coequalizers for every reflexive pair. -/
class has_reflexive_coequalizers (C : Type u) [category C] where
  has_coeq : ∀ {A B : C} (f g : A ⟶ B) [_inst_3 : is_reflexive_pair f g], has_coequalizer f g

/-- `C` has coreflexive equalizers if it has equalizers for every coreflexive pair. -/
class has_coreflexive_equalizers (C : Type u) [category C] where
  has_eq : ∀ {A B : C} (f g : A ⟶ B) [_inst_3 : is_coreflexive_pair f g], has_equalizer f g

theorem has_coequalizer_of_common_section (C : Type u) [category C] [has_reflexive_coequalizers C]
    {A : C} {B : C} {f : A ⟶ B} {g : A ⟶ B} (r : B ⟶ A) (rf : r ≫ f = 𝟙) (rg : r ≫ g = 𝟙) :
    has_coequalizer f g :=
  let _inst : is_reflexive_pair f g := is_reflexive_pair.mk' r rf rg;
  has_reflexive_coequalizers.has_coeq f g

theorem has_equalizer_of_common_retraction (C : Type u) [category C] [has_coreflexive_equalizers C]
    {A : C} {B : C} {f : A ⟶ B} {g : A ⟶ B} (r : B ⟶ A) (fr : f ≫ r = 𝟙) (gr : g ≫ r = 𝟙) :
    has_equalizer f g :=
  let _inst : is_coreflexive_pair f g := is_coreflexive_pair.mk' r fr gr;
  has_coreflexive_equalizers.has_eq f g

/-- If `C` has coequalizers, then it has reflexive coequalizers. -/
protected instance has_reflexive_coequalizers_of_has_coequalizers (C : Type u) [category C]
    [has_coequalizers C] : has_reflexive_coequalizers C :=
  has_reflexive_coequalizers.mk
    fun (A B : C) (f g : A ⟶ B) (i : is_reflexive_pair f g) =>
      limits.has_colimit_of_has_colimits_of_shape (parallel_pair f g)

/-- If `C` has equalizers, then it has coreflexive equalizers. -/
protected instance has_coreflexive_equalizers_of_has_equalizers (C : Type u) [category C]
    [has_equalizers C] : has_coreflexive_equalizers C :=
  has_coreflexive_equalizers.mk
    fun (A B : C) (f g : A ⟶ B) (i : is_coreflexive_pair f g) =>
      limits.has_limit_of_has_limits_of_shape (parallel_pair f g)

end Mathlib