import algebra.homology.short_complex.Module
import for_mathlib.category_theory.abelian.extensions_derived_category
import ring_theory.non_zero_divisors

noncomputable theory

open category_theory category_theory.abelian category_theory.limits

variables {R : Type*} [comm_ring R] (x : R)

namespace Module

@[simps]
def short_complex_ring_mod_ideal_span_singleton : short_complex (Module R) :=
{ X₁ := Module.of R R,
  X₂ := Module.of R R,
  X₃ := Module.of R (R ⧸(ideal.span {x} : ideal R)),
  f := x • 𝟙 _,
  g := Module.of_hom (submodule.mkq _),
  zero := begin
    ext1,
    erw ideal.quotient.eq_zero_iff_mem,
    rw ideal.mem_span_singleton',
    exact ⟨1, by simp⟩,
  end, }

namespace short_complex_ring_mod_ideal_span_singleton

instance : epi (short_complex_ring_mod_ideal_span_singleton x).g :=
begin
  rw Module.epi_iff_surjective,
  rintro ⟨a⟩,
  exact ⟨a, rfl⟩,
end

lemma exact : (short_complex_ring_mod_ideal_span_singleton x).exact :=
begin
  rw short_complex.Module_exact_iff,
  intros a ha,
  dsimp at a ha,
  rw [ideal.quotient.eq_zero_iff_mem, ideal.mem_span_singleton'] at ha,
  obtain ⟨b, hb⟩ := ha,
  exact ⟨b, by { dsimp, rw [← hb, mul_comm], }⟩,
end

lemma mono_f (hx : x ∈ non_zero_divisors R) :
  mono (short_complex_ring_mod_ideal_span_singleton x).f :=
begin
  simp only [Module.mono_iff_ker_eq_bot, short_complex_ring_mod_ideal_span_singleton_f],
  ext a,
  split,
  { intro ha,
    simp only [linear_map.mem_ker, linear_map.smul_apply, Module.id_apply,
      algebra.id.smul_eq_mul] at ha,
    rw mem_non_zero_divisors_iff at hx,
    simpa only [ideal.mem_bot] using hx a (by rw [mul_comm, ha]), },
  { intro ha,
    simp only [ideal.mem_bot] at ha,
    simp only [ha, linear_map.mem_ker, linear_map.smul_apply, Module.id_apply,
      algebra.id.smul_eq_mul, mul_zero], },
end

lemma short_exact (hx : x ∈ non_zero_divisors R) :
  (short_complex_ring_mod_ideal_span_singleton x).short_exact :=
begin
  haveI := mono_f x hx,
  exact short_complex.short_exact.mk (short_complex_ring_mod_ideal_span_singleton.exact x),
end

end short_complex_ring_mod_ideal_span_singleton

variable (hx : x ∈ non_zero_divisors R)

def extension_of_non_zero_divisor (hx : x ∈ non_zero_divisors R) :
  extension (Module.of R (R ⧸(ideal.span {x} : ideal R))) (Module.of R R) :=
(short_complex_ring_mod_ideal_span_singleton.short_exact x hx).extension

namespace extension_of_non_zero_divisor

lemma nonempty_iso_trivial_iff :
  nonempty (extension_of_non_zero_divisor x hx ≅ extension.trivial _ _) ↔
    is_unit x :=
begin
  split,
  { rintro ⟨e⟩,
    rw is_unit_iff_exists_inv,
    obtain ⟨s, hs⟩ := (extension.iso_trivial_equiv _).symm.surjective e,
    refine ⟨s.r (1 : R),_⟩,
    let φ : ((of R R) ⟶ (of R R)) → R := λ φ, φ (1 : R),
    have eq := congr_arg φ s.f_r,
    dsimp only [extension_of_non_zero_divisor] at eq,
    simpa only [short_complex.short_exact.extension_i,
      short_complex_ring_mod_ideal_span_singleton_f, linear.smul_comp] using eq, },
  { intro hx',
    haveI := is_unit.invertible hx',
    refine nonempty.intro _,
    equiv_rw extension.iso_trivial_equiv _,
    have h : is_zero (short_complex_ring_mod_ideal_span_singleton x).X₃,
    { rw is_zero.iff_id_eq_zero,
      ext,
      simp only [linear_map.coe_comp, function.comp_app, submodule.mkq_apply,
        ideal.quotient.mk_eq_mk, map_one, id_apply, linear_map.zero_apply],
      erw [ideal.quotient.eq_zero_iff_mem, ideal.mem_span_singleton'],
      exact ⟨⅟x, by simp only [inv_of_mul_self]⟩, },
    exact
    { r := ⅟x • 𝟙 _,
      f_r := begin
        dsimp [extension_of_non_zero_divisor],
        simp only [smul_smul, linear.comp_smul, category.comp_id, inv_of_mul_self, one_smul],
      end,
      s := 0,
      s_g := h.eq_of_src _ _,
      id := begin
        dsimp [extension_of_non_zero_divisor],
        simp only [comp_zero, add_zero, linear.smul_comp, category.id_comp,
          smul_smul, inv_of_mul_self, one_smul],
      end, }, },
end

lemma δ_neq_zero  : (extension_of_non_zero_divisor x hx).δ ≠ 0 ↔ ¬is_unit x :=
by simp only [extension.δ_neq_zero_iff, ← nonempty_iso_trivial_iff x hx, not_nonempty_iff]

end extension_of_non_zero_divisor

end Module

lemma int.non_zero_divisor_of_two_le (n : ℤ) (hn : 2 ≤ n) :
  n ∈ non_zero_divisors ℤ :=
begin
  intros a ha,
  rw mul_eq_zero at ha,
  cases ha,
  { exact ha, },
  { linarith, },
end


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.category.Mon.limits
import algebra.category.Group.preadditive
import category_theory.over
import group_theory.subgroup.basic
import category_theory.concrete_category.elementwise

/-!
# The category of (commutative) (additive) groups has all limits

Further, these limits are preserved by the forgetful functor --- that is,
the underlying types are just the limits in the category of types.

-/

open category_theory
open category_theory.limits

universes v u

noncomputable theory

variables {J : Type v} [small_category J]

namespace Group

@[to_additive]
instance group_obj (F : J ⥤ Group.{max v u}) (j) :
  group ((F ⋙ forget Group).obj j) :=
by { change group (F.obj j), apply_instance }

/--
The flat sections of a functor into `Group` form a subgroup of all sections.
-/
@[to_additive
  "The flat sections of a functor into `AddGroup` form an additive subgroup of all sections."]
def sections_subgroup (F : J ⥤ Group) :
  subgroup (Π j, F.obj j) :=
{ carrier := (F ⋙ forget Group).sections,
  inv_mem' := λ a ah j j' f,
  begin
    simp only [forget_map_eq_coe, functor.comp_map, pi.inv_apply, monoid_hom.map_inv, inv_inj],
    dsimp [functor.sections] at ah,
    rw ah f,
  end,
  ..(Mon.sections_submonoid (F ⋙ forget₂ Group Mon)) }

@[to_additive]
instance limit_group (F : J ⥤ Group.{max v u}) :
  group (types.limit_cone (F ⋙ forget Group)).X :=
begin
  change group (sections_subgroup F),
  apply_instance,
end

/-- We show that the forgetful functor `Group ⥤ Mon` creates limits.

All we need to do is notice that the limit point has a `group` instance available, and then reuse
the existing limit. -/
@[to_additive "We show that the forgetful functor `AddGroup ⥤ AddMon` creates limits.

All we need to do is notice that the limit point has an `add_group` instance available, and then
reuse the existing limit."]
instance forget₂.creates_limit (F : J ⥤ Group.{max v u}) :
  creates_limit F (forget₂ Group.{max v u} Mon.{max v u}) :=
creates_limit_of_reflects_iso (λ c' t,
{ lifted_cone :=
  { X := Group.of (types.limit_cone (F ⋙ forget Group)).X,
    π :=
    { app := Mon.limit_π_monoid_hom (F ⋙ forget₂ Group Mon.{max v u}),
      naturality' :=
        (Mon.has_limits.limit_cone (F ⋙ forget₂ Group Mon.{max v u})).π.naturality, } },
  valid_lift := by apply is_limit.unique_up_to_iso (Mon.has_limits.limit_cone_is_limit _) t,
  makes_limit := is_limit.of_faithful (forget₂ Group Mon.{max v u})
    (Mon.has_limits.limit_cone_is_limit _) (λ s, _) (λ s, rfl) })

/--
A choice of limit cone for a functor into `Group`.
(Generally, you'll just want to use `limit F`.)
-/
@[to_additive "A choice of limit cone for a functor into `Group`.
(Generally, you'll just want to use `limit F`.)"]
def limit_cone (F : J ⥤ Group.{max v u}) : cone F :=
lift_limit (limit.is_limit (F ⋙ (forget₂ Group Mon.{max v u})))

/--
The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
@[to_additive "The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)"]
def limit_cone_is_limit (F : J ⥤ Group.{max v u}) : is_limit (limit_cone F) :=
lifted_limit_is_limit _

/-- The category of groups has all limits. -/
@[to_additive "The category of additive groups has all limits."]
instance has_limits_of_size : has_limits_of_size.{v v} Group.{max v u} :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit_of_created F (forget₂ Group Mon.{max v u}) } }

@[to_additive]
instance has_limits : has_limits Group.{u} := Group.has_limits_of_size.{u u}

/-- The forgetful functor from groups to monoids preserves all limits.

This means the underlying monoid of a limit can be computed as a limit in the category of monoids.
-/
@[to_additive AddGroup.forget₂_AddMon_preserves_limits "The forgetful functor from additive groups
to additive monoids preserves all limits.

This means the underlying additive monoid of a limit can be computed as a limit in the category of
additive monoids."]
instance forget₂_Mon_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget₂ Group Mon.{max v u}) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F, by apply_instance } }

@[to_additive]
instance forget₂_Mon_preserves_limits : preserves_limits (forget₂ Group Mon.{u}) :=
Group.forget₂_Mon_preserves_limits_of_size.{u u}

/-- The forgetful functor from groups to types preserves all limits.

This means the underlying type of a limit can be computed as a limit in the category of types. -/
@[to_additive "The forgetful functor from additive groups to types preserves all limits.

This means the underlying type of a limit can be computed as a limit in the category of types."]
instance forget_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget Group.{max v u}) :=
{ preserves_limits_of_shape := λ J 𝒥, by exactI
  { preserves_limit := λ F, limits.comp_preserves_limit (forget₂ Group Mon) (forget Mon) } }

@[to_additive]
instance forget_preserves_limits : preserves_limits (forget Group.{u}) :=
Group.forget_preserves_limits_of_size.{u u}

end Group

namespace CommGroup

@[to_additive]
instance comm_group_obj (F : J ⥤ CommGroup.{max v u}) (j) :
  comm_group ((F ⋙ forget CommGroup).obj j) :=
by { change comm_group (F.obj j), apply_instance }

@[to_additive]
instance limit_comm_group (F : J ⥤ CommGroup.{max v u}) :
  comm_group (types.limit_cone (F ⋙ forget CommGroup.{max v u})).X :=
@subgroup.to_comm_group (Π j, F.obj j) _
  (Group.sections_subgroup (F ⋙ forget₂ CommGroup Group.{max v u}))

/--
We show that the forgetful functor `CommGroup ⥤ Group` creates limits.

All we need to do is notice that the limit point has a `comm_group` instance available,
and then reuse the existing limit.
-/
@[to_additive "We show that the forgetful functor `AddCommGroup ⥤ AddGroup` creates limits.

All we need to do is notice that the limit point has an `add_comm_group` instance available, and
then reuse the existing limit."]
instance forget₂.creates_limit (F : J ⥤ CommGroup.{max v u}) :
  creates_limit F (forget₂ CommGroup Group.{max v u}) :=
creates_limit_of_reflects_iso (λ c' t,
{ lifted_cone :=
  { X := CommGroup.of (types.limit_cone (F ⋙ forget CommGroup)).X,
    π :=
    { app := Mon.limit_π_monoid_hom
        (F ⋙ forget₂ CommGroup Group.{max v u} ⋙ forget₂ Group Mon.{max v u}),
      naturality' := (Mon.has_limits.limit_cone _).π.naturality, } },
  valid_lift := by apply is_limit.unique_up_to_iso (Group.limit_cone_is_limit _) t,
  makes_limit := is_limit.of_faithful (forget₂ _ Group.{max v u} ⋙ forget₂ _ Mon.{max v u})
    (by apply Mon.has_limits.limit_cone_is_limit _) (λ s, _) (λ s, rfl) })

/--
A choice of limit cone for a functor into `CommGroup`.
(Generally, you'll just want to use `limit F`.)
-/
@[to_additive "A choice of limit cone for a functor into `CommGroup`.
(Generally, you'll just want to use `limit F`.)"]
def limit_cone (F : J ⥤ CommGroup.{max v u}) : cone F :=
lift_limit (limit.is_limit (F ⋙ (forget₂ CommGroup Group.{max v u})))

/--
The chosen cone is a limit cone.
(Generally, you'll just want to use `limit.cone F`.)
-/
@[to_additive "The chosen cone is a limit cone.
(Generally, you'll just wantto use `limit.cone F`.)"]
def limit_cone_is_limit (F : J ⥤ CommGroup.{max v u}) : is_limit (limit_cone F) :=
lifted_limit_is_limit _

/-- The category of commutative groups has all limits. -/
@[to_additive "The category of additive commutative groups has all limits."]
instance has_limits_of_size : has_limits_of_size.{v v} CommGroup.{max v u} :=
{ has_limits_of_shape := λ J 𝒥, by exactI
  { has_limit := λ F, has_limit_of_created F (forget₂ CommGroup Group.{max v u}) } }

@[to_additive]
instance has_limits : has_limits CommGroup.{u} := CommGroup.has_limits_of_size.{u u}

/--
The forgetful functor from commutative groups to groups preserves all limits.
(That is, the underlying group could have been computed instead as limits in the category
of groups.)
-/
@[to_additive AddCommGroup.forget₂_AddGroup_preserves_limits
"The forgetful functor from additive commutative groups to groups preserves all limits.
(That is, the underlying group could have been computed instead as limits in the category
of additive groups.)"]
instance forget₂_Group_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget₂ CommGroup Group.{max v u}) :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ F, by apply_instance } }

@[to_additive]
instance forget₂_Group_preserves_limits : preserves_limits (forget₂ CommGroup Group.{u}) :=
CommGroup.forget₂_Group_preserves_limits_of_size.{u u}

/--
An auxiliary declaration to speed up typechecking.
-/
@[to_additive AddCommGroup.forget₂_AddCommMon_preserves_limits_aux
  "An auxiliary declaration to speed up typechecking."]
def forget₂_CommMon_preserves_limits_aux (F : J ⥤ CommGroup.{max v u}) :
  is_limit ((forget₂ CommGroup CommMon).map_cone (limit_cone F)) :=
CommMon.limit_cone_is_limit (F ⋙ forget₂ CommGroup CommMon)

/--
The forgetful functor from commutative groups to commutative monoids preserves all limits.
(That is, the underlying commutative monoids could have been computed instead as limits
in the category of commutative monoids.)
-/
@[to_additive AddCommGroup.forget₂_AddCommMon_preserves_limits
"The forgetful functor from additive commutative groups to additive commutative monoids preserves
all limits. (That is, the underlying additive commutative monoids could have been computed instead
as limits in the category of additive commutative monoids.)"]
instance forget₂_CommMon_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget₂ CommGroup CommMon.{max v u}) :=
{ preserves_limits_of_shape := λ J 𝒥, by exactI
  { preserves_limit := λ F, preserves_limit_of_preserves_limit_cone
    (limit_cone_is_limit F) (forget₂_CommMon_preserves_limits_aux F) } }

/--
The forgetful functor from commutative groups to types preserves all limits. (That is, the
underlying types could have been computed instead as limits in the category of types.)
-/
@[to_additive AddCommGroup.forget_preserves_limits
"The forgetful functor from additive commutative groups to types preserves all limits. (That is,
the underlying types could have been computed instead as limits in the category of types.)"]
instance forget_preserves_limits_of_size :
  preserves_limits_of_size.{v v} (forget CommGroup.{max v u}) :=
{ preserves_limits_of_shape := λ J 𝒥, by exactI
  { preserves_limit := λ F, limits.comp_preserves_limit (forget₂ CommGroup Group) (forget Group) } }

-- Verify we can form limits indexed over smaller categories.
example (f : ℕ → AddCommGroup) : has_product f := by apply_instance

end CommGroup

namespace AddCommGroup

/--
The categorical kernel of a morphism in `AddCommGroup`
agrees with the usual group-theoretical kernel.
-/
def kernel_iso_ker {G H : AddCommGroup.{u}} (f : G ⟶ H) :
  kernel f ≅ AddCommGroup.of f.ker :=
{ hom :=
  { to_fun := λ g, ⟨kernel.ι f g,
    begin
      -- TODO where is this `has_coe_t_aux.coe` coming from? can we prevent it appearing?
      change (kernel.ι f) g ∈ f.ker,
      simp [add_monoid_hom.mem_ker],
    end⟩,
    map_zero' := by { ext, simp, },
    map_add' := λ g g', by { ext, simp, }, },
  inv := kernel.lift f (add_subgroup.subtype f.ker) (by tidy),
  hom_inv_id' := by { apply equalizer.hom_ext _, ext, simp, },
  inv_hom_id' :=
  begin
    apply AddCommGroup.ext,
    simp only [add_monoid_hom.coe_mk, coe_id, coe_comp],
    rintro ⟨x, mem⟩,
    simp,
  end, }.

@[simp]
lemma kernel_iso_ker_hom_comp_subtype {G H : AddCommGroup} (f : G ⟶ H) :
  (kernel_iso_ker f).hom ≫ add_subgroup.subtype f.ker = kernel.ι f :=
by ext; refl

@[simp]
lemma kernel_iso_ker_inv_comp_ι {G H : AddCommGroup} (f : G ⟶ H) :
  (kernel_iso_ker f).inv ≫ kernel.ι f = add_subgroup.subtype f.ker :=
begin
  ext,
  simp [kernel_iso_ker],
end

/--
The categorical kernel inclusion for `f : G ⟶ H`, as an object over `G`,
agrees with the `subtype` map.
-/
@[simps]
def kernel_iso_ker_over {G H : AddCommGroup.{u}} (f : G ⟶ H) :
  over.mk (kernel.ι f) ≅ @over.mk _ _ G (AddCommGroup.of f.ker) (add_subgroup.subtype f.ker) :=
over.iso_mk (kernel_iso_ker f) (by simp)

end AddCommGroup


import algebra.ring group_theory.submonoid ring_theory.ideal_operations linear_algebra.basic

namespace localization_alt

universes u v w
variables {A : Type u} {B : Type v} {C : Type w}
variables [comm_ring A] [comm_ring B] [comm_ring C]
variables (S : set A) [is_submonoid S] (f : A → B) [is_ring_hom f]

/- This is essentially the same logic as units.ext, but in more
   convenient form.
-/
lemma comm_monoid.inv_unique {M : Type*} [comm_monoid M]
  {a ai₁ ai₂ : M} (e₁ : a * ai₁ = 1) (e₂ : a * ai₂ = 1) : ai₁ = ai₂ :=
by rw [← mul_one ai₁, ← e₂, ← mul_assoc, mul_comm ai₁, e₁, one_mul]

/-- preserve definitional equality -/
def ideal.mk (I : set A) (J : ideal A) (H : I = J) : ideal A :=
{ carrier := I,
  zero := H.symm ▸ J.zero,
  add := H.symm ▸ J.add,
  smul := H.symm ▸ J.smul }

def ker : ideal A :=
ideal.mk {x | f x = 0} (ideal.comap f ⊥) $
set.ext $ λ x, submodule.mem_bot.symm

def inverts_data (S : set A) (f : A → B) : Type* :=
Π s : S, {si : B // (f s) * si = 1}

def inverts (S : set A) (f : A → B) : Prop :=
∀ s : S, ∃ si : B, (f s) * si = 1

lemma inverts_subsingleton (S : set A) (f : A → B) :
  subsingleton (inverts_data S f) :=
⟨λ fi1 fi2, funext $ λ s, subtype.eq $ comm_monoid.inv_unique (fi1 s).2 (fi2 s).2⟩

def inverts_of_data (h : inverts_data S f) : inverts S f :=
λ s, ⟨(h s).1,(h s).2⟩

noncomputable def inverts_some (h : inverts S f) : inverts_data S f :=
λ s, classical.indefinite_description _ (h s)

def has_denom_data (S : set A) (f : A → B) :=
Π b : B, {sa : S × A // (f sa.1) * b = f sa.2 }

def has_denom (S : set A) (f : A → B) : Prop :=
∀ b : B, ∃ (sa : S × A), (f sa.1) * b = (f sa.2)

def has_denom_of_data (h : has_denom_data S f) : has_denom S f :=
λ b, subtype.exists_of_subtype (h b)

noncomputable def has_denom_some (h : has_denom S f) : has_denom_data S f :=
λ b, classical.indefinite_description _ (h b)

def ann_aux (S : set A) [is_submonoid S] : Type* :=
{ as : A × S // as.1 * as.2 = 0 }

namespace ann_aux

def zero : ann_aux S := ⟨(0, 1), mul_one _⟩

def add (as bt : ann_aux S) : ann_aux S :=
⟨(as.1.1 + bt.1.1, as.1.2 * bt.1.2), show (as.1.1 + bt.1.1) * (as.1.2 * bt.1.2) = 0,
by rw [add_mul, ← mul_assoc, as.2, zero_mul, zero_add, mul_left_comm, bt.2, mul_zero]⟩

def smul (a : A) (bt : ann_aux S) : ann_aux S :=
⟨(a * bt.1.1, bt.1.2), show (a * bt.1.1) * bt.1.2 = 0, by rw [mul_assoc, bt.2, mul_zero]⟩

end ann_aux

def submonoid_ann (S : set A) [is_submonoid S] : ideal A :=
{ carrier := set.range (λ as : ann_aux S, as.1.1),
  zero := ⟨ann_aux.zero S, rfl⟩,
  add := λ _ _ ⟨as,has⟩ ⟨bt,hbt⟩, ⟨ann_aux.add S as bt, has ▸ hbt ▸ rfl⟩,
  smul := λ a _ ⟨bt,h⟩, ⟨ann_aux.smul S a bt, h ▸ rfl⟩ }

lemma inverts_ker (hf : inverts S f) : submonoid_ann S ≤ ker f :=
λ x ⟨⟨⟨a,s⟩,asz⟩,rfl⟩, let ⟨si,e1⟩ := hf s in show f x = 0,
by rw [← mul_one (f x), ← e1, ← mul_assoc, ← is_ring_hom.map_mul f, asz, is_ring_hom.map_zero f, zero_mul]

structure is_localization_data :=
(inverts : inverts_data S f)
(has_denom : has_denom_data S f)
(ker_le : ker f ≤ submonoid_ann S)

def is_localization : Prop :=
(inverts S f) ∧ (has_denom S f) ∧ (ker f = submonoid_ann S)

lemma localization_epi (hf : is_localization S f)
  (g₁ g₂ : B → C) [is_ring_hom g₁] [is_ring_hom g₂]
  (e : g₁ ∘ f = g₂ ∘ f) : g₁ = g₂ :=
begin
  have e' : ∀ x, g₁ (f x) = g₂ (f x) := λ x, by convert congr_fun e x,
  ext b,
  rcases hf.2.1 b with ⟨⟨s,a⟩,e1⟩,
  rcases hf.1 s with ⟨si,e2⟩,
  have e4 : g₁ (f s) * (g₁ si) = 1,
  { rw [← is_ring_hom.map_mul g₁, e2, is_ring_hom.map_one g₁] },
  have e5 : g₁ (f s) * (g₂ si) = 1,
  { rw [e', ← is_ring_hom.map_mul g₂, e2, is_ring_hom.map_one g₂] },
  rw [← mul_one b, ← e2, mul_left_comm, ← mul_assoc, e1],
  rw [is_ring_hom.map_mul g₁, is_ring_hom.map_mul g₂, e', comm_monoid.inv_unique e4 e5]
end

section localization_initial
variables (hf : is_localization_data S f) (g : A → C) [is_ring_hom g] (hg : inverts_data S g)

def is_localization_initial (hf : is_localization_data S f)
  (g : A → C) [is_ring_hom g] (hg : inverts_data S g) : B → C :=
λ b, g (hf.has_denom b).1.2 * hg (hf.has_denom b).1.1

lemma useful (hf : is_localization_data S f) (g : A → C) [is_ring_hom g] (hg : inverts_data S g)
  {a₁ a₂ : A} (H : f a₁ = f a₂) : g a₁ = g a₂ :=
begin
  rw [← sub_eq_zero, ← is_ring_hom.map_sub f] at H,
  rw [← sub_eq_zero, ← is_ring_hom.map_sub g],
  generalize_hyp : a₁ - a₂ = a at H ⊢,
  rcases hf.3 H with ⟨⟨as,h1⟩,h2⟩,
  rw [← h2],
  cases hg as.2 with c h3,
  rw [← mul_one (g as.1), ← h3, ← mul_assoc, ← is_ring_hom.map_mul g, h1, is_ring_hom.map_zero g, zero_mul]
end

lemma useful2 {x y z w : A} (h : x * y = 1) : z * x = w * x ↔ z = w :=
⟨λ H, have _ := congr_arg (* y) H, by rwa [mul_assoc, h, mul_one, mul_assoc, h, mul_one] at this,
λ H, by rw H⟩

instance (hf : is_localization_data S f) (g : A → C) [is_ring_hom g] (hg : inverts_data S g) :
  is_ring_hom (is_localization_initial S f hf g hg) :=
{ map_one := begin
    unfold is_localization_initial,
    rcases hf.has_denom 1 with ⟨⟨s,a⟩,h⟩,
    dsimp only at *,
    rw mul_one at h, replace h := useful S f hf g hg h,
    cases hg s with c hc,
    rw ← h, exact hc
  end,
  map_mul := λ x y, begin
    unfold is_localization_initial,
    rcases hf.has_denom x with ⟨⟨sx,ax⟩,h1⟩,
    rcases hf.has_denom y with ⟨⟨sy,ay⟩,h2⟩,
    rcases hf.has_denom (x*y) with ⟨⟨sxy,axy⟩,h3⟩,
    cases hg sx with sigx h4,
    cases hg sy with sigy h5,
    cases hg sxy with sigxy h6,
    cases hf.inverts sx with sifx h7,
    cases hf.inverts sy with sify h8,
    cases hf.inverts sxy with sifxy h9,
    dsimp only [subtype.coe_mk] at *,
    replace h1 : _ * _ = _ * _ := by convert congr_arg (* sifx) h1,
    rw [mul_right_comm, h7, one_mul] at h1,
    replace h2 : _ * _ = _ * _ := by convert congr_arg (* sify) h2,
    rw [mul_right_comm, h8, one_mul] at h2,
    rw [h1, h2] at h3,
    rw [← useful2 h4, ← useful2 h5, ← useful2 h6],
    have : g axy * sigxy * g ↑sx * g ↑sy * g ↑sxy = g axy * g ↑sx * g ↑sy * (g ↑sxy * sigxy),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h6, mul_one], clear this,
    have : g ax * sigx * (g ay * sigy) * g ↑sx * g ↑sy * g ↑sxy = g ax * g ay * g ↑sxy * (g ↑sx * sigx) * (g ↑sy * sigy),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h4, h5, mul_one, mul_one], clear this,
    iterate 4 { rw ← is_ring_hom.map_mul g }, apply useful S f hf g hg,
    iterate 4 { rw is_ring_hom.map_mul f }, rw ← h3,
    have : f ↑sxy * (f ax * sifx * (f ay * sify)) * f ↑sx * f ↑sy = f ax * f ay * f ↑sxy * (f ↑sx * sifx) * (f ↑sy * sify),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h7, h8, mul_one, mul_one]
  end,
  map_add := λ x y, begin
    unfold is_localization_initial,
    rcases hf.has_denom x with ⟨⟨sx,ax⟩,h1⟩,
    rcases hf.has_denom y with ⟨⟨sy,ay⟩,h2⟩,
    rcases hf.has_denom (x+y) with ⟨⟨sxy,axy⟩,h3⟩,
    cases hg sx with sigx h4,
    cases hg sy with sigy h5,
    cases hg sxy with sigxy h6,
    cases hf.inverts sx with sifx h7,
    cases hf.inverts sy with sify h8,
    cases hf.inverts sxy with sifxy h9,
    dsimp only [subtype.coe_mk] at *,
    replace h1 : _ * _ = _ * _ := by convert congr_arg (* sifx) h1,
    rw [mul_right_comm, h7, one_mul] at h1,
    replace h2 : _ * _ = _ * _ := by convert congr_arg (* sify) h2,
    rw [mul_right_comm, h8, one_mul] at h2,
    rw [h1, h2] at h3,
    rw [← useful2 h4, ← useful2 h5, ← useful2 h6],
    have : g axy * sigxy * g ↑sx * g ↑sy * g ↑sxy = g axy * g ↑sx * g ↑sy * (g ↑sxy * sigxy),
    { simp only [mul_assoc, mul_comm, mul_left_comm] }, rw [this, h6, mul_one], clear this,
    have : (g ax * sigx + g ay * sigy) * g ↑sx * g ↑sy * g ↑sxy =
      g ax * g ↑sy * g ↑sxy * (g ↑sx * sigx) + g ay * g ↑sx * g ↑sxy * (g ↑sy * sigy),
    { simp only [add_mul, mul_add, mul_assoc, mul_comm, mul_left_comm] }, rw [this, h4, h5, mul_one, mul_one], clear this,
    iterate 6 { rw ← is_ring_hom.map_mul g }, rw ← is_ring_hom.map_add g, apply useful S f hf g hg,
    rw is_ring_hom.map_add f, iterate 6 { rw is_ring_hom.map_mul f }, rw ← h3,
    have : f ↑sxy * (f ax * sifx + f ay * sify) * f ↑sx * f ↑sy =
      f ax * f ↑sy * f ↑sxy * (f ↑sx * sifx) + f ay * f ↑sx * f ↑sxy * (f ↑sy * sify),
    { simp only [add_mul, mul_add, mul_assoc, mul_comm, mul_left_comm] }, rw [this, h7, h8, mul_one, mul_one]
  end }

lemma is_localization_initial_comp (hf : is_localization_data S f)
  (g : A → C) [is_ring_hom g] (hg : inverts_data S g) (a : A) :
  is_localization_initial S f hf g hg (f a) = g a :=
begin
  unfold is_localization_initial,
  rcases hf.has_denom (f a) with ⟨⟨s,x⟩,h1⟩,
  cases hg s with si h2,
  dsimp only [subtype.coe_mk] at *,
  rw [← useful2 h2, mul_right_comm, mul_assoc, h2, mul_one, ← is_ring_hom.map_mul g],
  apply useful S f hf g hg,
  rw [← h1, is_ring_hom.map_mul f, mul_comm]
end

end localization_initial

end localization_alt


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/

import ring_theory.integrally_closed
import ring_theory.valuation.integers

/-!
# Integral elements over the ring of integers of a valution

The ring of integers is integrally closed inside the original ring.
-/

universes u v w

open_locale big_operators

namespace valuation

namespace integers

section comm_ring

variables {R : Type u} {Γ₀ : Type v} [comm_ring R] [linear_ordered_comm_group_with_zero Γ₀]
variables {v : valuation R Γ₀} {O : Type w} [comm_ring O] [algebra O R] (hv : integers v O)
include hv

open polynomial

lemma mem_of_integral {x : R} (hx : is_integral O x) : x ∈ v.integer :=
let ⟨p, hpm, hpx⟩ := hx in le_of_not_lt $ λ hvx, begin
  rw [hpm.as_sum, eval₂_add, eval₂_pow, eval₂_X, eval₂_finset_sum, add_eq_zero_iff_eq_neg] at hpx,
  replace hpx := congr_arg v hpx, refine ne_of_gt _ hpx,
  rw [v.map_neg, v.map_pow],
  refine v.map_sum_lt' (zero_lt_one₀.trans_le (one_le_pow_of_one_le' hvx.le _)) (λ i hi, _),
  rw [eval₂_mul, eval₂_pow, eval₂_C, eval₂_X, v.map_mul, v.map_pow, ← one_mul (v x ^ p.nat_degree)],
  cases (hv.2 $ p.coeff i).lt_or_eq with hvpi hvpi,
  { exact mul_lt_mul₀ hvpi (pow_lt_pow₀ hvx $ finset.mem_range.1 hi) },
  { erw hvpi, rw [one_mul, one_mul], exact pow_lt_pow₀ hvx (finset.mem_range.1 hi) }
end

protected lemma integral_closure : integral_closure O R = ⊥ :=
bot_unique $ λ r hr, let ⟨x, hx⟩ := hv.3 (hv.mem_of_integral hr) in algebra.mem_bot.2 ⟨x, hx⟩

end comm_ring

section fraction_field

variables {K : Type u} {Γ₀ : Type v} [field K] [linear_ordered_comm_group_with_zero Γ₀]
variables {v : valuation K Γ₀} {O : Type w} [comm_ring O] [is_domain O]
variables [algebra O K] [is_fraction_ring O K]
variables (hv : integers v O)

lemma integrally_closed : is_integrally_closed O :=
(is_integrally_closed.integral_closure_eq_bot_iff K).mp (valuation.integers.integral_closure hv)

end fraction_field

end integers

end valuation


import order.bounded_lattice
import data.set.intervals.basic
import data.fin
import .fin
import data.set_like.basic
import data.list.sort
import data.equiv.fin
import data.equiv.option

universe u

open set

class jordan_hoelder_class (X : Type u) [lattice X] :=
(is_maximal : X → X → Prop)
(lt_of_is_maximal : ∀ {x y}, is_maximal x y → x < y)
(sup_eq_of_is_maximal : ∀ {x y z}, is_maximal x z → is_maximal y z →
  x ≠ y → x ⊔ y = z)
(is_maximal_inf : ∀ {x y z}, is_maximal x z → is_maximal y z → x ≠ y →
  is_maximal (x ⊓ y) y)
(isom : (X × X) → (X × X) → Prop)
(isom_refl : ∀ x, isom x x)
(isom_symm : ∀ {x y}, isom x y → isom y x)
(isom_trans : ∀ {x y z}, isom x y → isom y z → isom x z)
(second_iso : ∀ x y, isom (y, x ⊔ y) (x ⊓ y, x))

open jordan_hoelder_class

attribute [refl] isom_refl
attribute [symm] isom_symm
attribute [trans] isom_trans

structure composition_series (X : Type u) [lattice X] [jordan_hoelder_class X] : Type u :=
(length : ℕ)
(series : fin length.succ → X)
(step' : ∀ i : fin length, is_maximal (series i.cast_succ) (series i.succ))

namespace composition_series

variables {X : Type u} [lattice X] [jordan_hoelder_class X]

instance : has_coe_to_fun (composition_series X) :=
{ F := _, coe := composition_series.series }

variables {X}

lemma step (s : composition_series X) : ∀ i : fin s.length,
  is_maximal (s i.cast_succ) (s i.succ) := s.step'

@[simp] lemma coe_fn_mk (length : ℕ) (series step) :
  (@composition_series.mk X _ _ length series step : fin length.succ → X) = series := rfl

theorem lt_succ (s : composition_series X) (i : fin s.length) :
  s i.cast_succ < s i.succ :=
lt_of_is_maximal (s.step _)

protected theorem strict_mono (s : composition_series X) : strict_mono s :=
fin.strict_mono_iff_lt_succ.2 (λ i h, s.lt_succ ⟨i, nat.lt_of_succ_lt_succ h⟩)

protected theorem injective (s : composition_series X) : function.injective s :=
s.strict_mono.injective

@[simp] protected theorem inj (s : composition_series X) {i j : fin s.length.succ} :
  s i = s j ↔ i = j :=
s.injective.eq_iff

instance : has_mem X (composition_series X) :=
⟨λ x s, x ∈ set.range s⟩

lemma mem_def {x : X} {s : composition_series X} : x ∈ s ↔ x ∈ set.range s := iff.rfl

lemma total {s : composition_series X} {x y : X} (hx : x ∈ s) (hy : y ∈ s) : x ≤ y ∨ y ≤ x :=
begin
  rcases set.mem_range.1 hx with ⟨i, rfl⟩,
  rcases set.mem_range.1 hy with ⟨j, rfl⟩,
  rw [s.strict_mono.le_iff_le, s.strict_mono.le_iff_le],
  exact le_total i j
end

def to_list (s : composition_series X) : list X := list.of_fn s

lemma ext_fun {s₁ s₂ : composition_series X}
  (hl : s₁.length = s₂.length)
  (h : ∀ i, s₁ i = s₂ (fin.cast (congr_arg nat.succ hl) i)) :
  s₁ = s₂ :=
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst hl,
  simpa [function.funext_iff] using h
end

lemma length_to_list (s : composition_series X) : s.to_list.length = s.length.succ :=
by rw [to_list, list.length_of_fn]

lemma to_list_injective : function.injective (@composition_series.to_list X _ _) :=
λ s₁ s₂ (h : list.of_fn s₁ = list.of_fn s₂),
have h₁ : s₁.length = s₂.length,
  from nat.succ_injective
    ((list.length_of_fn s₁).symm.trans $
      (congr_arg list.length h).trans $
      list.length_of_fn s₂),
have h₂ : ∀ i : fin s₁.length.succ, (s₁ i) = s₂ (fin.cast (congr_arg nat.succ h₁) i),
  begin
    assume i,
    rw [← list.nth_le_of_fn s₁ i, ← list.nth_le_of_fn s₂],
    simp [h]
  end,
begin
  cases s₁, cases s₂,
  dsimp at *,
  subst h₁,
  simp only [heq_iff_eq, eq_self_iff_true, true_and],
  simp only [fin.cast_refl] at h₂,
  exact funext h₂
end

lemma to_list_sorted (s : composition_series X) : s.to_list.sorted (<) :=
list.pairwise_iff_nth_le.2 (λ i j hi hij,
  begin
    dsimp [to_list],
    rw [list.nth_le_of_fn', list.nth_le_of_fn'],
    exact s.strict_mono hij
  end)

lemma to_list_nodup (s : composition_series X) : s.to_list.nodup :=
list.nodup_iff_nth_le_inj.2
  (λ i j hi hj,
    begin
      delta to_list,
      rw [list.nth_le_of_fn', list.nth_le_of_fn', s.injective.eq_iff, fin.ext_iff, fin.coe_mk, fin.coe_mk],
      exact id
    end)

@[simp] lemma mem_to_list {s : composition_series X} {x : X} : x ∈ s.to_list ↔ x ∈ s :=
begin
  rw [to_list, list.mem_of_fn],
  refl
end

@[ext] lemma ext {s₁ s₂ : composition_series X} (h : ∀ x, x ∈ s₁ ↔ x ∈ s₂) : s₁ = s₂ :=
to_list_injective $ list.eq_of_perm_of_sorted
  (by classical; exact list.perm_of_nodup_nodup_to_finset_eq
    s₁.to_list_nodup
    s₂.to_list_nodup
    (finset.ext $ by simp *))
  s₁.to_list_sorted s₂.to_list_sorted

def top (s : composition_series X) : X := s (fin.last _)

lemma top_mem (s : composition_series X) : s.top ∈ s :=
mem_def.2 (set.mem_range.2 ⟨fin.last _, rfl⟩)

lemma le_top {s : composition_series X} {x : X} (hx : x ∈ s) : x ≤ s.top :=
let ⟨i, hi⟩ := set.mem_range.1 hx in hi ▸ s.strict_mono.monotone (fin.le_last _)

def bot (s : composition_series X) : X := s 0

lemma bot_mem (s : composition_series X) : s.bot ∈ s :=
mem_def.2 (set.mem_range.2 ⟨0, rfl⟩)

lemma bot_le {s : composition_series X} {x : X} (hx : x ∈ s) : s.bot ≤ x :=
let ⟨i, hi⟩ := set.mem_range.1 hx in hi ▸ s.strict_mono.monotone (fin.zero_le _)

instance : set_like (composition_series X) X :=
{ coe := λ s, set.range s,
  coe_injective' := λ s₁ s₂ h, ext $ λ x, begin
    dsimp at h,
    rw [mem_def, mem_def, h]
  end }

@[simps] def erase_top (s : composition_series X) : composition_series X :=
{ length := s.length - 1,
  series := λ i, s ⟨i, lt_of_lt_of_le i.2 (nat.succ_le_succ (nat.sub_le_self _ _))⟩,
  step' := λ i, begin
    have := s.step ⟨i, lt_of_lt_of_le i.2 (nat.sub_le_self _ _)⟩,
    cases i,
    exact this
  end }

lemma top_erase_top (s : composition_series X) :
  s.erase_top.top = s ⟨s.length - 1, lt_of_le_of_lt (nat.sub_le_self _ _) (nat.lt_succ_self _)⟩ :=
show s _ = s _, from congr_arg s
begin
  ext,
  simp only [erase_top_length, fin.coe_last, fin.coe_cast_succ, fin.coe_of_nat_eq_mod,
    fin.coe_mk, coe_coe]
end

@[simp] lemma bot_erase_top (s : composition_series X) : s.erase_top.bot = s.bot := rfl

lemma length_pos_of_mem_ne {s : composition_series X}
  {x y : X} (hx : x ∈ s) (hy : y ∈ s) (hxy : x ≠ y) :
  0 < s.length :=
let ⟨i, hi⟩ := hx, ⟨j, hj⟩ := hy in
have hij : i ≠ j, from mt s.inj.2 $ λ h, hxy (hi ▸ hj ▸ h),
hij.lt_or_lt.elim
  (λ hij, (lt_of_le_of_lt (zero_le i)
    (lt_of_lt_of_le hij (nat.le_of_lt_succ j.2))))
  (λ hji, (lt_of_le_of_lt (zero_le j)
    (lt_of_lt_of_le hji (nat.le_of_lt_succ i.2))))

lemma forall_mem_eq_of_length_eq_zero {s : composition_series X}
  (hs : s.length = 0) {x y} (hx : x ∈ s) (hy : y ∈ s) : x = y :=
by_contradiction (λ hxy, pos_iff_ne_zero.1 (length_pos_of_mem_ne hx hy hxy) hs)

lemma mem_erase_top_of_ne_of_mem {s : composition_series X} {x : X}
  (hx : x ≠ s.top) (hxs : x ∈ s) : x ∈ s.erase_top :=
begin
  { rcases hxs with ⟨i, rfl⟩,
    have hi : (i : ℕ) < (s.length - 1).succ,
    { conv_rhs { rw [← nat.succ_sub (length_pos_of_mem_ne ⟨i, rfl⟩ s.top_mem hx),
        nat.succ_sub_one] },
      exact lt_of_le_of_ne
        (nat.le_of_lt_succ i.2)
        (by simpa [top, s.inj, fin.ext_iff] using hx) },
    refine ⟨i.cast_succ, _⟩,
    simp [fin.ext_iff, nat.mod_eq_of_lt hi] }
end

lemma erase_top_le (s : composition_series X) : s.erase_top ≤ s :=
begin
  rintros x ⟨i, rfl⟩,
  simp [mem_def],
end

lemma mem_erase_top {s : composition_series X} {x : X}
  (h : 0 < s.length) : x ∈ s.erase_top ↔ x ≠ s.top ∧ x ∈ s :=
begin
  simp only [mem_def],
  dsimp only [erase_top, coe_fn_mk],
  split,
  { rintros ⟨i, rfl⟩,
    have hi : (i : ℕ) < s.length,
    { conv_rhs { rw [← nat.succ_sub_one s.length, nat.succ_sub h] },
      exact i.2 },
    simp [top, fin.ext_iff, (ne_of_lt hi)] },
  { intro h,
    exact mem_erase_top_of_ne_of_mem h.1 h.2 }
end

lemma lt_top_of_mem_erase_top
  {s : composition_series X} {x : X}
  (h : 0 < s.length)
  (hx : x ∈ s.erase_top) :
  x < s.top :=
lt_of_le_of_ne
  (le_top ((mem_erase_top h).1 hx).2)
  ((mem_erase_top h).1 hx).1

lemma is_maximal_erase_top_top {s : composition_series X} (h : 0 < s.length) :
  is_maximal s.erase_top.top s.top :=
have s.length - 1 + 1 = s.length,
  by conv_rhs { rw [← nat.succ_sub_one s.length] }; rw nat.succ_sub h,
begin
  rw [top_erase_top, top],
  convert s.step ⟨s.length - 1, nat.sub_lt h zero_lt_one⟩;
  ext; simp [this]
end

lemma append_cast_add_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₁.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
by { cases i, simp [fin.append, *] }

lemma append_succ_cast_add_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₁.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add s₂.length i).succ = s₁ i.succ :=
begin
  cases i with i hi,
  simp only [fin.append, hi, fin.succ_mk, function.comp_app, fin.cast_succ_mk,
    fin.coe_mk, fin.cast_add_mk],
  split_ifs,
  { refl },
  { have : i + 1 = s₁.length, from le_antisymm hi (le_of_not_gt h_1),
    calc s₂ ⟨i + 1 - s₁.length, by simp [this]⟩
        = s₂ 0 : congr_arg s₂ (by simp [fin.ext_iff, this])
    ... = s₁ (fin.last _) : h.symm
    ... = _ : congr_arg s₁ (by simp [fin.ext_iff, this]) }
end

lemma append_cast_add_right_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₂.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add_right s₁.length i).cast_succ = s₂ i.cast_succ :=
by { cases i, simp [fin.append, *] }

lemma append_succ_cast_add_right_aux
  {s₁ s₂ : composition_series X}
  (h : s₁ (fin.last _) = s₂ 0)
  (i : fin s₂.length) :
  fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂
  (fin.cast_add_right s₁.length i).succ = s₂ i.succ :=
begin
  cases i with i hi,
  simp [fin.append, add_assoc]
end

@[simps length] def append {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot) :
  composition_series X :=
{ length := s₁.length + s₂.length,
  series := fin.append (nat.add_succ _ _).symm (s₁ ∘ fin.cast_succ) s₂,
  step' := λ i, begin
    refine fin.add_cases  _ _ i,
    { intro i,
      rw [append_succ_cast_add_aux h, append_cast_add_aux h],
      exact s₁.step i },
    { intro i,
      rw [append_cast_add_right_aux h, append_succ_cast_add_right_aux h],
      exact s₂.step i }
  end }

@[simp] lemma append_cast_add
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₁.length) :
  append h (fin.cast_add s₂.length i).cast_succ = s₁ i.cast_succ :=
append_cast_add_aux h i

@[simp] lemma append_succ_cast_add
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₁.length) :
  append h (fin.cast_add s₂.length i).succ = s₁ i.succ :=
append_succ_cast_add_aux h i

@[simp] lemma append_cast_add_right
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₂.length) :
  append h (fin.cast_add_right s₁.length i).cast_succ = s₂ i.cast_succ :=
append_cast_add_right_aux h i

@[simp] lemma append_succ_cast_add_right
  {s₁ s₂ : composition_series X}
  (h : s₁.top = s₂.bot)
  (i : fin s₂.length) :
  append h (fin.cast_add_right s₁.length i).succ = s₂ i.succ :=
append_succ_cast_add_right_aux h i

@[simps] def insert
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  composition_series X :=
{ length := s.length + 1,
  series := fin.snoc s x,
  step' := λ i, begin
    refine fin.last_cases _ _ i,
    { rwa [fin.snoc_cast_succ, fin.succ_last, fin.snoc_last, ← top] },
    { intro i,
      rw [fin.snoc_cast_succ, ← fin.cast_succ_fin_succ, fin.snoc_cast_succ],
      exact s.step _ }
  end }

-- @[simp] lemma insert_series'
--   (s : composition_series X)
--   (x : X)
--   (hlt : ∀ y ∈ s, y < x)
--   (hsat : is_maximal s.top x) :
--   @eq (fin (s.length + 2) → X) (insert s x hlt hsat) (fin.snoc s x) :=
-- rfl

@[simp] lemma top_insert
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  (insert s x hsat).top = x :=
fin.snoc_last _ _

@[simp] lemma insert_last
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  insert s x hsat (fin.last _) = x :=
fin.snoc_last _ _

@[simp] lemma insert_cast_succ
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) (i : fin (s.length + 1)) :
  insert s x hsat (i.cast_succ) = s i :=
fin.snoc_cast_succ _ _ _

@[simp] lemma bot_insert
  (s : composition_series X)
  (x : X)
  (hsat : is_maximal s.top x) :
  (insert s x hsat).bot = s.bot :=
by rw [bot, bot, ← fin.cast_succ_zero, insert_cast_succ]

lemma mem_insert
  {s : composition_series X}
  {x y: X}
  {hsat : is_maximal s.top x} :
  y ∈ insert s x hsat ↔ y ∈ s ∨ y = x :=
begin
  simp only [insert, mem_def],
  split,
  { rintros ⟨i, rfl⟩,
    refine fin.last_cases _ (λ i, _) i,
    { right, simp },
    { left, simp } },
  { intro h,
    rcases h with ⟨i, rfl⟩ | rfl,
    { use i.cast_succ, simp },
    { use (fin.last _), simp } }
end

lemma eq_insert_erase_top
  {s : composition_series X}
  (h : 0 < s.length) :
  s = insert (erase_top s) s.top
    (is_maximal_erase_top_top h) :=
begin
  ext x,
  simp [mem_insert, mem_erase_top h],
  by_cases h : x = s.top; simp [*, s.top_mem]
end

@[simp] lemma insert_erase_top_top {s : composition_series X}
  (h : is_maximal s.erase_top.top s.top) :
  s.erase_top.insert s.top h = s :=
have h : 0 < s.length,
  from nat.pos_of_ne_zero begin
    assume hs,
    refine ne_of_gt (lt_of_is_maximal h) _,
    simp [top, fin.ext_iff, hs]
  end,
(eq_insert_erase_top h).symm

def equivalent (s₁ s₂ : composition_series X) : Prop :=
∃ f : fin s₁.length ≃ fin s₂.length,
  ∀ i : fin s₁.length,
    isom (s₁ i.cast_succ, s₁ i.succ)
    (s₂ (f i).cast_succ, s₂ (f i).succ)

namespace equivalent

@[refl] lemma refl (s : composition_series X) : equivalent s s :=
⟨equiv.refl _, λ _, isom_refl _⟩

@[symm] lemma symm {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) :
  equivalent s₂ s₁ :=
⟨h.some.symm, λ i, isom_symm (by simpa using h.some_spec (h.some.symm i))⟩

@[trans] lemma trans {s₁ s₂ s₃ : composition_series X}
  (h₁ : equivalent s₁ s₂)
  (h₂ : equivalent s₂ s₃) :
  equivalent s₁ s₃ :=
⟨h₁.some.trans h₂.some, λ i, isom_trans (h₁.some_spec i) (h₂.some_spec (h₁.some i))⟩

def append
  {s₁ s₂ t₁ t₂ : composition_series X}
  (hs : s₁.top = s₂.bot)
  (ht : t₁.top = t₂.bot)
  (h₁ : equivalent s₁ t₁)
  (h₂ : equivalent s₂ t₂) :
  equivalent (append hs) (append ht) :=
let e : fin (s₁.length + s₂.length) ≃ fin (t₁.length + t₂.length) :=
  calc fin (s₁.length + s₂.length) ≃ fin s₁.length ⊕ fin s₂.length : fin_sum_fin_equiv.symm
  ... ≃ fin t₁.length ⊕ fin t₂.length : equiv.sum_congr h₁.some h₂.some
  ... ≃ fin (t₁.length + t₂.length) : fin_sum_fin_equiv in
⟨e, begin
  assume i,
  refine fin.add_cases _ _ i,
  { assume i,
    simpa [top, bot] using h₁.some_spec i },
  { assume i,
    simpa [top, bot] using h₂.some_spec i }
end⟩

lemma fin.succ_cast_succ {n : ℕ} (i : fin n) :
  i.cast_succ.succ = i.succ.cast_succ :=
fin.ext (by simp)

protected lemma insert
  {s₁ s₂ : composition_series X}
  {x₁ x₂ : X}
  {hsat₁ : is_maximal s₁.top x₁}
  {hsat₂ : is_maximal s₂.top x₂}
  (hequiv : equivalent s₁ s₂)
  (htop : isom (s₁.top, x₁) (s₂.top, x₂)) :
  equivalent (s₁.insert x₁ hsat₁) (s₂.insert x₂ hsat₂) :=
let e : fin s₁.length.succ ≃ fin s₂.length.succ :=
  calc fin (s₁.length + 1) ≃ option (fin s₁.length) : fin_succ_equiv_last
  ... ≃ option (fin s₂.length) : functor.map_equiv option hequiv.some
  ... ≃ fin (s₂.length + 1) : fin_succ_equiv_last.symm in
⟨e,  λ i, begin
  refine fin.last_cases _ _ i,
  { simpa [top] using htop },
  { assume i,
    simpa [fin.succ_cast_succ] using hequiv.some_spec i }
end⟩

variables {α β : Type*} (e : α ≃ β)

def swap_top_two_fin {m n : ℕ} (e : fin m ≃ fin n) : fin (m + 2) ≃ fin (n + 2) :=
calc fin (m + 2)
    ≃ fin m ⊕ fin 2 : fin_sum_fin_equiv.symm
... ≃ fin n ⊕ fin 2 : equiv.sum_congr e (equiv.swap 0 1)
... ≃ fin (n + 2) : fin_sum_fin_equiv

@[simp] lemma swap_top_two_fin_last {m n : ℕ} (e : fin m ≃ fin n) :
  swap_top_two_fin e (fin.last _) = fin.cast_succ (fin.last _) :=
by simp [swap_top_two_fin, fin.ext_iff]

@[simp] lemma swap_top_two_fin_cast_succ_last {m n : ℕ} (e : fin m ≃ fin n) :
  swap_top_two_fin e (fin.cast_succ (fin.last _)) = fin.last _ :=
by simp [swap_top_two_fin, fin.ext_iff]

@[simp] lemma swap_top_two_fin_cast_succ_cast_succ {m n : ℕ} (e : fin m ≃ fin n) (i : fin m) :
  swap_top_two_fin e i.cast_succ.cast_succ = (e i).cast_succ.cast_succ :=
have ∀ {m : ℕ} {i : fin m}, i.cast_succ.cast_succ = fin.cast_add 2 i := λ _ _, fin.ext rfl,
by simp [swap_top_two_fin, this]

lemma insert_insert_swap
  {s₁ s₂ : composition_series X}
  {x₁ x₂ y₁ y₂ : X}
  {hsat₁ : is_maximal s₁.top x₁}
  {hsat₂ : is_maximal s₂.top x₂}
  {hsaty₁ : is_maximal (insert s₁ x₁ hsat₁).top y₁}
  {hsaty₂ : is_maximal (insert s₂ x₂ hsat₂).top y₂}
  (hequiv : equivalent s₁ s₂)
  (hr₁ : isom (s₁.top, x₁) (x₂, y₂))
  (hr₂ : isom (x₁, y₁) (s₂.top, x₂)) :
  equivalent
    (insert (insert s₁ x₁ hsat₁) y₁ hsaty₁)
    (insert (insert s₂ x₂ hsat₂) y₂ hsaty₂) :=
let e : fin (s₁.length + 1 + 1) ≃ fin (s₂.length + 1 + 1) :=
swap_top_two_fin hequiv.some in
⟨e, begin
  intro i,
  dsimp only [e],
  refine fin.last_cases _ (λ i, _) i,
  { erw [swap_top_two_fin_last, insert_cast_succ, insert_last, fin.succ_last, insert_last,
      insert_cast_succ, insert_cast_succ, fin.succ_cast_succ, insert_cast_succ,
      fin.succ_last, insert_last],
    exact hr₂ },
  { refine fin.last_cases _ (λ i, _) i,
    { erw [swap_top_two_fin_cast_succ_last, insert_cast_succ, insert_cast_succ,
        insert_cast_succ, fin.succ_cast_succ, insert_cast_succ,
        fin.succ_last, insert_last, insert_last, fin.succ_last, insert_last],
      exact hr₁ },
    { erw [swap_top_two_fin_cast_succ_cast_succ, insert_cast_succ, insert_cast_succ,
        insert_cast_succ, insert_cast_succ, fin.succ_cast_succ, insert_cast_succ,
        fin.succ_cast_succ, insert_cast_succ, fin.succ_cast_succ, insert_cast_succ,
        fin.succ_cast_succ, insert_cast_succ],
      exact hequiv.some_spec i } }
end⟩

lemma length_eq {s₁ s₂ : composition_series X} (h : equivalent s₁ s₂) : s₁.length = s₂.length :=
by simpa using fintype.card_congr h.some

end equivalent

lemma length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁ : s₁.length = 0) : s₂.length = 0 :=
begin
  have : s₁.bot = s₁.top,
    from congr_arg s₁ (fin.ext (by simp [hs₁])),
  have : (fin.last s₂.length) = (0 : fin s₂.length.succ),
    from s₂.injective (hb.symm.trans (this.trans ht)).symm,
  simpa [fin.ext_iff]
end

lemma length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  0 < s₁.length → 0 < s₂.length :=
not_imp_not.1 begin
  simp only [pos_iff_ne_zero, ne.def, not_iff_not, not_not],
  exact length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb.symm ht.symm
end

lemma eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero
  {s₁ s₂ : composition_series X}
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top)
  (hs₁0 : s₁.length = 0) :
  s₁ = s₂ :=
have ∀ x, x ∈ s₁ ↔ x = s₁.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero hs₁0 hx s₁.top_mem, λ hx, hx.symm ▸ s₁.top_mem⟩,
have ∀ x, x ∈ s₂ ↔ x = s₂.top,
  from λ x, ⟨λ hx, forall_mem_eq_of_length_eq_zero
      (length_eq_zero_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hs₁0)
    hx s₂.top_mem, λ hx, hx.symm ▸ s₂.top_mem⟩,
by { ext, simp * }

lemma intersection (s : composition_series X) (x : X)
  (hm : is_maximal x s.top) (hb : s.bot ≤ x) :
  ∃ t : composition_series X, t.bot = s.bot ∧ t.length + 1 = s.length ∧
    ∃ htx : t.top = x, equivalent s (insert t s.top (htx.symm ▸ hm)) :=
begin
  induction hn : s.length with n ih generalizing s x,
  { exact (ne_of_gt (lt_of_le_of_lt hb (lt_of_is_maximal hm))
      (forall_mem_eq_of_length_eq_zero hn s.top_mem s.bot_mem)).elim },
  { have h0s : 0 < s.length, from hn.symm ▸ nat.succ_pos _,
    by_cases hetx : s.erase_top.top = x,
    { use s.erase_top,
      simp [← hetx, hn] },
    { have imxs : is_maximal (x ⊓ s.erase_top.top) s.erase_top.top,
        from is_maximal_inf hm (is_maximal_erase_top_top h0s) (ne.symm hetx),
      have := ih _ _ imxs (le_inf (by simpa) (le_top s.erase_top.bot_mem)) (by simp [hn]),
      rcases this with ⟨t, htb, htl, htt, hteqv⟩,
      have hmtx : is_maximal t.top x,
      { rw [htt, inf_comm],
        exact is_maximal_inf (is_maximal_erase_top_top h0s) hm  hetx },
      use insert t x hmtx,
      refine ⟨by simp [htb], by simp [htl], by simp, _⟩,
      have : s.equivalent ((insert t s.erase_top.top (htt.symm ▸ imxs)).insert s.top
        (by simpa using is_maximal_erase_top_top h0s)),
      { conv_lhs { rw eq_insert_erase_top h0s },
        exact equivalent.insert hteqv (by simp) },
      refine this.trans _,
      refine equivalent.insert_insert_swap (by refl) _ _,
      { rw [← sup_eq_of_is_maximal (is_maximal_erase_top_top h0s) hm hetx, htt, inf_comm],
        exact isom_symm (second_iso s.erase_top.top x) },
      { rw [← sup_eq_of_is_maximal (is_maximal_erase_top_top h0s) hm hetx, htt, sup_comm],
        exact second_iso _ _ } } }
end

theorem jordan_hoelder (s₁ s₂ : composition_series X)
  (hb : s₁.bot = s₂.bot) (ht : s₁.top = s₂.top) :
  equivalent s₁ s₂ :=
begin
  induction hle : s₁.length with n ih generalizing s₁ s₂,
  { rw [eq_of_bot_eq_bot_of_top_eq_top_of_length_eq_zero hb ht hle] },
  { have h0s₂ : 0 < s₂.length,
      from length_pos_of_bot_eq_bot_of_top_eq_top_of_length_pos hb ht (hle.symm ▸ nat.succ_pos _),
    rcases intersection s₁ s₂.erase_top.top
      (ht.symm ▸ is_maximal_erase_top_top h0s₂)
      (hb.symm ▸ s₂.bot_erase_top ▸ bot_le (top_mem _)) with ⟨t₂, htb₂, htl₂, htt₂, hteq₂⟩,
    have := ih t₂ s₂.erase_top (by simp [htb₂, ← hb]) htt₂ (nat.succ_inj'.1 (htl₂.trans hle)),
    refine hteq₂.trans _,
    conv_rhs { rw [eq_insert_erase_top h0s₂] },
    simp only [ht],
    refine equivalent.insert this (by simp [htt₂]) }
end

end composition_series


import data.nat.basic

example (u w x y z : ℕ) (h₁ : x = y + z) (h₂ : w = u + x) :
  w = z + y + u :=
by simp [*, add_assoc, add_comm, add_left_comm]

variables (p q r : Prop)

example (hp : p) : p ∧ q ↔ q :=
by simp *

example (hp : p) : p ∨ q :=
by simp *

example (hp : p) (hq : q) : p ∧ (q ∨ r) :=
by simp *


import SciLean.Prelude
import SciLean.Algebra
import SciLean.Mathlib.Data.PowType

def Nat.toInt (n : ℕ) : Int := Int.ofNat n

namespace SciLean

instance : PowType ℤ where
  powType n := {u : Array ℤ // u.size = n}
  intro {n} f := Id.run do
    let mut u : Array ℤ := Array.mkEmpty n
    for i in [0:n] do
      u := u.push (f ⟨i, sorry⟩)
    ⟨u, sorry⟩
  get v i := v.1.get ⟨i, by rw[v.2] apply i.2⟩
  set v i val := ⟨v.1.set ⟨i, by rw[v.2] apply i.2⟩ val, sorry⟩
  ext := sorry

inductive Node (LeafData NodeData : Type) : Type where
| leaf  (data : LeafData) : Node LeafData NodeData
| node  (data : NodeData) (children : Array (Node LeafData NodeData)) : Node LeafData NodeData

namespace VDB_LIKE

  structure GridNode (dim : Nat) (size : Nat) where
    pos : ℤ^dim
    lvl : Nat

  abbrev Index (dim : Nat) (size : Nat) := Fin (size^dim)

  def Index.toPos (idx : Index dim size) : ℤ^dim := Id.run do
    let mut pos : ℤ^dim := 0
    let mut idx := idx.1
    for i in [0:dim] do
      pos[!i] := (idx % size).toInt
      idx := idx / size
    pos
    -- let mask := (2^scl) - 1
    -- PowType.intro λ i => ((idx.1 >>> (i.1 * scl)) &&& mask).toInt

  def toIndex {dim : Nat} (p : ℤ^dim) : Index dim scl :=
    let size := 2^scl
    ⟨∑ i, (p[i].fmod size).toNat <<< (i.1 * scl), sorry⟩

  def test : IO Unit := do
    let dim := 2
    let scl := 3
    let N := 2^(dim * scl)
    for i in [0:N] do
      let idx : Index dim scl := ⟨i, sorry⟩
      IO.println s!"{i} {idx.toPos} {((idx.toPos |> toIndex) : Index dim scl)}"

  #eval test

  namespace GridNode

    variable {dim scl : Nat}

    def count (node : GridNode dim scl) := 2^(dim * scl)
    def size  (node : GridNode dim scl) := 2^(scl * node.lvl)
    def originOffset (lvl scl : Nat) : ℤ := ∑ i : Fin (lvl+1), if (i.1 % 2 = 1) then - ((1:ℕ) <<< (i.1 - 1) * scl).toInt else 0

    #eval originOffset 1 2
    def min (node : GridNode dim scl) : ℤ^dim := node.size.toInt * node.pos
    def max (node : GridNode dim scl) : ℤ^dim := node.pos.map (λ x => node.size.toInt * x - 1) -- node.size.toInt * (node.pos + 1) - 1

    def parent (node : GridNode dim scl) : GridNode dim scl :=
      ⟨node.pos.map (λ x => x.fdiv scl), node.lvl+1⟩
    def child  (node : GridNode dim scl) (idx : Index dim scl) : GridNode dim scl :=
      if node.lvl = 0
      then node
      else ⟨((1:ℕ) <<< scl).toInt * node.pos + idx.toPos, node.lvl-1⟩
    def localPos (node : GridNode dim scl) : ℤ^dim :=
      let size := (1:ℕ) <<< scl
      node.pos.map λ x => x.fmod size
    def index (node : GridNode dim scl) : Index dim scl :=
      node.pos |> toIndex

    -- def node : GridNode 2 2 := ⟨^[-1,0], 0⟩
    -- #eval node.index

    theorem parent_child_index (node : GridNode dim scl) : node.parent.child node.index = node := sorry

    def common_index (i j : ℤ) (scl : ℕ) : ℤ×ℕ := Id.run do
      let upper_bound := (Nat.max i.natAbs j.natAbs).log2 + 10
      dbg_trace s!"upper bound := {upper_bound}"
      let mut i := i
      let mut j := j
      let size := (1:ℕ) <<< scl
      for l in [0:upper_bound] do
        if i = j then
          return (i, l)
        else
          i := i.fdiv size
          j := j.fdiv size
      panic! "This should be unreachable"

    #eval common_index (8) (-13) 2

    #eval (2^4) - 1
    #check (2^4) - 1

    #eval (2:ℕ).log2 + 1

    -- def min (node : GridNode dim scl) := ((1:ℕ) <<< scl).toInt * pos

  end GridNode

end VDB_LIKE

namespace NewApproach

  structure GridCell (dim size lvl : Nat) where
    pos : ℤ^dim

  namespace GridCell

    def Impl {α} (a : α) := α

    -- Origin of level `lvl+lvlInc` w.r.t. origin of level `lvl`
    -- really not sure if this is correct ...
    -- What is the proper definition ???
    def originOffset (size lvl lvlInc : Nat) : ℤ :=
      if lvl%2 = 0
      then
        let e := 2*((lvlInc+1)/2)
        (1 - (-size.toInt)^e) / (1 + size)
      else
        let e := 2*((lvlInc)/2)
        size*(1 - (-size.toInt)^e) / (1 + size)

    theorem originOffset_by_one (size lvl)
      : originOffset size lvl 1 = if lvl%2=0 then 1 - size else 0 := sorry

    def nparent (n : Nat) : GridCell dim size lvl → GridCell dim size (lvl+n) :=
      let offset := originOffset size lvl n
      let nsize := size^n
      λ ⟨p⟩ => ⟨p.map λ xi => (xi - offset).fdiv nsize⟩

    def child (idx : Fin (size^dim)) : GridCell dim size (lvl+1) → GridCell dim size lvl :=
      let offset := originOffset size lvl 1
      let loc_p : ℤ^dim := sorry
      λ ⟨p⟩ => ⟨size.toInt * p + offset * (1:ℤ^dim) + loc_p⟩

    def inParentIdx : GridCell dim size lvl → Fin (size^dim) := sorry
    def inParentPos (node : GridCell dim size lvl) : ℤ^dim := (sorry : Impl $ node.nparent 1 |>.child (!0) |>.pos)
    -- optimize by
    --   finish_opt

    theorem nchild_parentIdx (node : GridCell dim size lvl) : (node.nparent 1).child node.inParentIdx = node := sorry

  end GridCell

  #eval  2*((3)/2)

end NewApproach


import category_theory.category.default
import game.world1.level3

universes v u  -- The order in this declaration matters: v often needs to be explicitly specified while u often can be omitted

namespace category_theory

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

/-
# Category world

## Level 5: More tactic reviews
-/

/-blah blah

-/

/- Lemma
If $$f : X ⟶ Y$$ and $$g : X ⟶ Y$$ are morphisms such that $$f = g$$, then $$f ≫ h = g ≫ h$$.
-/
lemma id_of_comp_left_id' (X : C) (f : X ⟶ X) (w : ∀ {Y : C} (g : X ⟶ Y), f ≫ g = g) : f = 𝟙 X :=
begin
    apply eq_of_comp_left_eq'',
    intros Z h,
    rw category.id_comp h,
    apply w,
end

end category_theory


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

! This file was ported from Lean 3 source module category_theory.subobject.factor_thru
! leanprover-community/mathlib commit 829895f162a1f29d0133f4b3538f4cd1fb5bffd3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Subobject.Basic
import Mathbin.CategoryTheory.Preadditive.Basic

/-!
# Factoring through subobjects

The predicate `h : P.factors f`, for `P : subobject Y` and `f : X ⟶ Y`
asserts the existence of some `P.factor_thru f : X ⟶ (P : C)` making the obvious diagram commute.

-/

universe v₁ v₂ u₁ u₂

noncomputable section

open CategoryTheory CategoryTheory.Category CategoryTheory.Limits

variable {C : Type u₁} [Category.{v₁} C] {X Y Z : C}

variable {D : Type u₂} [Category.{v₂} D]

namespace CategoryTheory

namespace MonoOver

/-- When `f : X ⟶ Y` and `P : mono_over Y`,
`P.factors f` expresses that there exists a factorisation of `f` through `P`.
Given `h : P.factors f`, you can recover the morphism as `P.factor_thru f h`.
-/
def Factors {X Y : C} (P : MonoOver Y) (f : X ⟶ Y) : Prop :=
  ∃ g : X ⟶ (P : C), g ≫ P.arrow = f
#align category_theory.mono_over.factors CategoryTheory.MonoOver.Factors

theorem factors_congr {X : C} {f g : MonoOver X} {Y : C} (h : Y ⟶ X) (e : f ≅ g) :
    f.Factors h ↔ g.Factors h :=
  ⟨fun ⟨u, hu⟩ => ⟨u ≫ ((MonoOver.forget _).map e.Hom).left, by simp [hu]⟩, fun ⟨u, hu⟩ =>
    ⟨u ≫ ((MonoOver.forget _).map e.inv).left, by simp [hu]⟩⟩
#align category_theory.mono_over.factors_congr CategoryTheory.MonoOver.factors_congr

/-- `P.factor_thru f h` provides a factorisation of `f : X ⟶ Y` through some `P : mono_over Y`,
given the evidence `h : P.factors f` that such a factorisation exists. -/
def factorThru {X Y : C} (P : MonoOver Y) (f : X ⟶ Y) (h : Factors P f) : X ⟶ (P : C) :=
  Classical.choose h
#align category_theory.mono_over.factor_thru CategoryTheory.MonoOver.factorThru

end MonoOver

namespace Subobject

/-- When `f : X ⟶ Y` and `P : subobject Y`,
`P.factors f` expresses that there exists a factorisation of `f` through `P`.
Given `h : P.factors f`, you can recover the morphism as `P.factor_thru f h`.
-/
def Factors {X Y : C} (P : Subobject Y) (f : X ⟶ Y) : Prop :=
  Quotient.liftOn' P (fun P => P.Factors f)
    (by
      rintro P Q ⟨h⟩
      apply propext
      constructor
      · rintro ⟨i, w⟩
        exact ⟨i ≫ h.hom.left, by erw [category.assoc, over.w h.hom, w]⟩
      · rintro ⟨i, w⟩
        exact ⟨i ≫ h.inv.left, by erw [category.assoc, over.w h.inv, w]⟩)
#align category_theory.subobject.factors CategoryTheory.Subobject.Factors

@[simp]
theorem mk_factors_iff {X Y Z : C} (f : Y ⟶ X) [Mono f] (g : Z ⟶ X) :
    (Subobject.mk f).Factors g ↔ (MonoOver.mk' f).Factors g :=
  Iff.rfl
#align category_theory.subobject.mk_factors_iff CategoryTheory.Subobject.mk_factors_iff

theorem mk_factors_self (f : X ⟶ Y) [Mono f] : (mk f).Factors f :=
  ⟨𝟙 _, by simp⟩
#align category_theory.subobject.mk_factors_self CategoryTheory.Subobject.mk_factors_self

theorem factors_iff {X Y : C} (P : Subobject Y) (f : X ⟶ Y) :
    P.Factors f ↔ (representative.obj P).Factors f :=
  Quot.inductionOn P fun a => MonoOver.factors_congr _ (representativeIso _).symm
#align category_theory.subobject.factors_iff CategoryTheory.Subobject.factors_iff

theorem factors_self {X : C} (P : Subobject X) : P.Factors P.arrow :=
  (factors_iff _ _).mpr ⟨𝟙 P, by simp⟩
#align category_theory.subobject.factors_self CategoryTheory.Subobject.factors_self

theorem factors_comp_arrow {X Y : C} {P : Subobject Y} (f : X ⟶ P) : P.Factors (f ≫ P.arrow) :=
  (factors_iff _ _).mpr ⟨f, rfl⟩
#align category_theory.subobject.factors_comp_arrow CategoryTheory.Subobject.factors_comp_arrow

theorem factors_of_factors_right {X Y Z : C} {P : Subobject Z} (f : X ⟶ Y) {g : Y ⟶ Z}
    (h : P.Factors g) : P.Factors (f ≫ g) := by
  revert P
  refine' Quotient.ind' _
  intro P
  rintro ⟨g, rfl⟩
  exact ⟨f ≫ g, by simp⟩
#align category_theory.subobject.factors_of_factors_right CategoryTheory.Subobject.factors_of_factors_right

theorem factors_zero [HasZeroMorphisms C] {X Y : C} {P : Subobject Y} : P.Factors (0 : X ⟶ Y) :=
  (factors_iff _ _).mpr ⟨0, by simp⟩
#align category_theory.subobject.factors_zero CategoryTheory.Subobject.factors_zero

theorem factors_of_le {Y Z : C} {P Q : Subobject Y} (f : Z ⟶ Y) (h : P ≤ Q) :
    P.Factors f → Q.Factors f := by
  simp only [factors_iff]
  exact fun ⟨u, hu⟩ => ⟨u ≫ of_le _ _ h, by simp [← hu]⟩
#align category_theory.subobject.factors_of_le CategoryTheory.Subobject.factors_of_le

/-- `P.factor_thru f h` provides a factorisation of `f : X ⟶ Y` through some `P : subobject Y`,
given the evidence `h : P.factors f` that such a factorisation exists. -/
def factorThru {X Y : C} (P : Subobject Y) (f : X ⟶ Y) (h : Factors P f) : X ⟶ P :=
  Classical.choose ((factors_iff _ _).mp h)
#align category_theory.subobject.factor_thru CategoryTheory.Subobject.factorThru

@[simp, reassoc.1]
theorem factorThru_arrow {X Y : C} (P : Subobject Y) (f : X ⟶ Y) (h : Factors P f) :
    P.factorThru f h ≫ P.arrow = f :=
  Classical.choose_spec ((factors_iff _ _).mp h)
#align category_theory.subobject.factor_thru_arrow CategoryTheory.Subobject.factorThru_arrow

@[simp]
theorem factorThru_self {X : C} (P : Subobject X) (h) : P.factorThru P.arrow h = 𝟙 P :=
  by
  ext
  simp
#align category_theory.subobject.factor_thru_self CategoryTheory.Subobject.factorThru_self

@[simp]
theorem factorThru_mk_self (f : X ⟶ Y) [Mono f] :
    (mk f).factorThru f (mk_factors_self f) = (underlyingIso f).inv :=
  by
  ext
  simp
#align category_theory.subobject.factor_thru_mk_self CategoryTheory.Subobject.factorThru_mk_self

@[simp]
theorem factorThru_comp_arrow {X Y : C} {P : Subobject Y} (f : X ⟶ P) (h) :
    P.factorThru (f ≫ P.arrow) h = f := by
  ext
  simp
#align category_theory.subobject.factor_thru_comp_arrow CategoryTheory.Subobject.factorThru_comp_arrow

@[simp]
theorem factorThru_eq_zero [HasZeroMorphisms C] {X Y : C} {P : Subobject Y} {f : X ⟶ Y}
    {h : Factors P f} : P.factorThru f h = 0 ↔ f = 0 :=
  by
  fconstructor
  · intro w
    replace w := w =≫ P.arrow
    simpa using w
  · rintro rfl
    ext
    simp
#align category_theory.subobject.factor_thru_eq_zero CategoryTheory.Subobject.factorThru_eq_zero

theorem factorThru_right {X Y Z : C} {P : Subobject Z} (f : X ⟶ Y) (g : Y ⟶ Z) (h : P.Factors g) :
    f ≫ P.factorThru g h = P.factorThru (f ≫ g) (factors_of_factors_right f h) :=
  by
  apply (cancel_mono P.arrow).mp
  simp
#align category_theory.subobject.factor_thru_right CategoryTheory.Subobject.factorThru_right

@[simp]
theorem factorThru_zero [HasZeroMorphisms C] {X Y : C} {P : Subobject Y}
    (h : P.Factors (0 : X ⟶ Y)) : P.factorThru 0 h = 0 := by simp
#align category_theory.subobject.factor_thru_zero CategoryTheory.Subobject.factorThru_zero

-- `h` is an explicit argument here so we can use
-- `rw factor_thru_le h`, obtaining a subgoal `P.factors f`.
-- (While the reverse direction looks plausible as a simp lemma, it seems to be unproductive.)
theorem factorThru_ofLe {Y Z : C} {P Q : Subobject Y} {f : Z ⟶ Y} (h : P ≤ Q) (w : P.Factors f) :
    Q.factorThru f (factors_of_le f h w) = P.factorThru f w ≫ ofLe P Q h :=
  by
  ext
  simp
#align category_theory.subobject.factor_thru_of_le CategoryTheory.Subobject.factorThru_ofLe

section Preadditive

variable [Preadditive C]

theorem factors_add {X Y : C} {P : Subobject Y} (f g : X ⟶ Y) (wf : P.Factors f)
    (wg : P.Factors g) : P.Factors (f + g) :=
  (factors_iff _ _).mpr ⟨P.factorThru f wf + P.factorThru g wg, by simp⟩
#align category_theory.subobject.factors_add CategoryTheory.Subobject.factors_add

-- This can't be a `simp` lemma as `wf` and `wg` may not exist.
-- However you can `rw` by it to assert that `f` and `g` factor through `P` separately.
theorem factorThru_add {X Y : C} {P : Subobject Y} (f g : X ⟶ Y) (w : P.Factors (f + g))
    (wf : P.Factors f) (wg : P.Factors g) :
    P.factorThru (f + g) w = P.factorThru f wf + P.factorThru g wg :=
  by
  ext
  simp
#align category_theory.subobject.factor_thru_add CategoryTheory.Subobject.factorThru_add

theorem factors_left_of_factors_add {X Y : C} {P : Subobject Y} (f g : X ⟶ Y)
    (w : P.Factors (f + g)) (wg : P.Factors g) : P.Factors f :=
  (factors_iff _ _).mpr ⟨P.factorThru (f + g) w - P.factorThru g wg, by simp⟩
#align category_theory.subobject.factors_left_of_factors_add CategoryTheory.Subobject.factors_left_of_factors_add

@[simp]
theorem factorThru_add_sub_factorThru_right {X Y : C} {P : Subobject Y} (f g : X ⟶ Y)
    (w : P.Factors (f + g)) (wg : P.Factors g) :
    P.factorThru (f + g) w - P.factorThru g wg =
      P.factorThru f (factors_left_of_factors_add f g w wg) :=
  by
  ext
  simp
#align category_theory.subobject.factor_thru_add_sub_factor_thru_right CategoryTheory.Subobject.factorThru_add_sub_factorThru_right

theorem factors_right_of_factors_add {X Y : C} {P : Subobject Y} (f g : X ⟶ Y)
    (w : P.Factors (f + g)) (wf : P.Factors f) : P.Factors g :=
  (factors_iff _ _).mpr ⟨P.factorThru (f + g) w - P.factorThru f wf, by simp⟩
#align category_theory.subobject.factors_right_of_factors_add CategoryTheory.Subobject.factors_right_of_factors_add

@[simp]
theorem factorThru_add_sub_factorThru_left {X Y : C} {P : Subobject Y} (f g : X ⟶ Y)
    (w : P.Factors (f + g)) (wf : P.Factors f) :
    P.factorThru (f + g) w - P.factorThru f wf =
      P.factorThru g (factors_right_of_factors_add f g w wf) :=
  by
  ext
  simp
#align category_theory.subobject.factor_thru_add_sub_factor_thru_left CategoryTheory.Subobject.factorThru_add_sub_factorThru_left

end Preadditive

end Subobject

end CategoryTheory


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.group_action.basic
import Mathlib.algebra.group_action_hom
import Mathlib.algebra.module.basic
import Mathlib.PostPort

universes u v l

namespace Mathlib

/-!

# Sets invariant to a `mul_action`

In this file we define `sub_mul_action R M`; a subset of a `mul_action M` which is closed with
respect to scalar multiplication.

For most uses, typically `submodule R M` is more powerful.

## Tags

submodule, mul_action
-/

/-- A sub_mul_action is a set which is closed under scalar multiplication.  -/
structure sub_mul_action (R : Type u) (M : Type v) [has_scalar R M] where
  carrier : set M
  smul_mem' : ∀ (c : R) {x : M}, x ∈ carrier → c • x ∈ carrier

namespace sub_mul_action

protected instance set.has_coe_t {R : Type u} {M : Type v} [has_scalar R M] :
    has_coe_t (sub_mul_action R M) (set M) :=
  has_coe_t.mk fun (s : sub_mul_action R M) => carrier s

protected instance has_mem {R : Type u} {M : Type v} [has_scalar R M] :
    has_mem M (sub_mul_action R M) :=
  has_mem.mk fun (x : M) (p : sub_mul_action R M) => x ∈ ↑p

protected instance has_coe_to_sort {R : Type u} {M : Type v} [has_scalar R M] :
    has_coe_to_sort (sub_mul_action R M) :=
  has_coe_to_sort.mk (Type (max 0 v)) fun (p : sub_mul_action R M) => Subtype fun (x : M) => x ∈ p

protected instance has_top {R : Type u} {M : Type v} [has_scalar R M] :
    has_top (sub_mul_action R M) :=
  has_top.mk (mk set.univ sorry)

protected instance has_bot {R : Type u} {M : Type v} [has_scalar R M] :
    has_bot (sub_mul_action R M) :=
  has_bot.mk (mk ∅ sorry)

protected instance inhabited {R : Type u} {M : Type v} [has_scalar R M] :
    Inhabited (sub_mul_action R M) :=
  { default := ⊥ }

@[simp] theorem coe_sort_coe {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M) :
    ↥↑p = ↥p :=
  rfl

protected theorem exists {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    {q : ↥p → Prop} : (∃ (x : ↥p), q x) ↔ ∃ (x : M), ∃ (H : x ∈ p), q { val := x, property := H } :=
  set_coe.exists

protected theorem forall {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    {q : ↥p → Prop} : (∀ (x : ↥p), q x) ↔ ∀ (x : M) (H : x ∈ p), q { val := x, property := H } :=
  set_coe.forall

theorem coe_injective {R : Type u} {M : Type v} [has_scalar R M] : function.injective coe := sorry

@[simp] theorem coe_set_eq {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    {q : sub_mul_action R M} : ↑p = ↑q ↔ p = q :=
  function.injective.eq_iff coe_injective

theorem ext'_iff {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    {q : sub_mul_action R M} : p = q ↔ ↑p = ↑q :=
  iff.symm coe_set_eq

theorem ext {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    {q : sub_mul_action R M} (h : ∀ (x : M), x ∈ p ↔ x ∈ q) : p = q :=
  coe_injective (set.ext h)

end sub_mul_action

namespace sub_mul_action

@[simp] theorem mem_coe {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M)
    {x : M} : x ∈ ↑p ↔ x ∈ p :=
  iff.rfl

theorem smul_mem {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M) {x : M} (r : R)
    (h : x ∈ p) : r • x ∈ p :=
  smul_mem' p r h

protected instance has_scalar {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M) :
    has_scalar R ↥p :=
  has_scalar.mk fun (c : R) (x : ↥p) => { val := c • subtype.val x, property := sorry }

@[simp] theorem coe_eq_coe {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    {x : ↥p} {y : ↥p} : ↑x = ↑y ↔ x = y :=
  iff.symm subtype.ext_iff_val

@[simp] theorem coe_smul {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M} (r : R)
    (x : ↥p) : ↑(r • x) = r • ↑x :=
  rfl

@[simp] theorem coe_mk {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M} (x : M)
    (hx : x ∈ p) : ↑{ val := x, property := hx } = x :=
  rfl

@[simp] theorem coe_mem {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    (x : ↥p) : ↑x ∈ p :=
  subtype.property x

@[simp] protected theorem eta {R : Type u} {M : Type v} [has_scalar R M] {p : sub_mul_action R M}
    (x : ↥p) (hx : ↑x ∈ p) : { val := ↑x, property := hx } = x :=
  subtype.eta x hx

/-- Embedding of a submodule `p` to the ambient space `M`. -/
protected def subtype {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M) :
    mul_action_hom R (↥p) M :=
  mul_action_hom.mk coe sorry

@[simp] theorem subtype_apply {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M)
    (x : ↥p) : coe_fn (sub_mul_action.subtype p) x = ↑x :=
  rfl

theorem subtype_eq_val {R : Type u} {M : Type v} [has_scalar R M] (p : sub_mul_action R M) :
    ⇑(sub_mul_action.subtype p) = subtype.val :=
  rfl

@[simp] theorem smul_mem_iff' {R : Type u} {M : Type v} [monoid R] [mul_action R M]
    (p : sub_mul_action R M) {x : M} (u : units R) : ↑u • x ∈ p ↔ x ∈ p :=
  sorry

/-- If the scalar product forms a `mul_action`, then the subset inherits this action -/
protected instance mul_action {R : Type u} {M : Type v} [monoid R] [mul_action R M]
    (p : sub_mul_action R M) : mul_action R ↥p :=
  mul_action.mk sorry sorry

theorem zero_mem {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M]
    (p : sub_mul_action R M) (h : set.nonempty ↑p) : 0 ∈ p :=
  sorry

/-- If the scalar product forms a `semimodule`, and the `sub_mul_action` is not `⊥`, then the
subset inherits the zero. -/
protected instance has_zero {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] (p : sub_mul_action R M) [n_empty : Nonempty ↥p] : HasZero ↥p :=
  { zero := { val := 0, property := sorry } }

theorem neg_mem {R : Type u} {M : Type v} [ring R] [add_comm_group M] [semimodule R M]
    (p : sub_mul_action R M) {x : M} (hx : x ∈ p) : -x ∈ p :=
  eq.mpr (id (Eq._oldrec (Eq.refl (-x ∈ p)) (Eq.symm (neg_one_smul R x)))) (smul_mem p (-1) hx)

@[simp] theorem neg_mem_iff {R : Type u} {M : Type v} [ring R] [add_comm_group M] [semimodule R M]
    (p : sub_mul_action R M) {x : M} : -x ∈ p ↔ x ∈ p :=
  { mp :=
      fun (h : -x ∈ p) =>
        eq.mpr (id (Eq._oldrec (Eq.refl (x ∈ p)) (Eq.symm (neg_neg x)))) (neg_mem p h),
    mpr := neg_mem p }

protected instance has_neg {R : Type u} {M : Type v} [ring R] [add_comm_group M] [semimodule R M]
    (p : sub_mul_action R M) : Neg ↥p :=
  { neg := fun (x : ↥p) => { val := -subtype.val x, property := sorry } }

@[simp] theorem coe_neg {R : Type u} {M : Type v} [ring R] [add_comm_group M] [semimodule R M]
    (p : sub_mul_action R M) (x : ↥p) : ↑(-x) = -↑x :=
  rfl

end sub_mul_action

namespace sub_mul_action

theorem smul_mem_iff {R : Type u} {M : Type v} [division_ring R] [add_comm_group M] [module R M]
    (p : sub_mul_action R M) {r : R} {x : M} (r0 : r ≠ 0) : r • x ∈ p ↔ x ∈ p :=
  smul_mem_iff' p (units.mk0 r r0)

end Mathlib


/-
Copyright (c) 2016 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Leonardo de Moura, Mario Carneiro, Johannes Hölzl
-/
import algebra.hom.group
import algebra.order.monoid.order_dual
import algebra.order.monoid.with_zero.basic
import data.nat.cast.defs

/-! # Adjoining top/bottom elements to ordered monoids.

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

universes u v
variables {α : Type u} {β : Type v}

open function

namespace with_top

section has_one

variables [has_one α]

@[to_additive] instance : has_one (with_top α) := ⟨(1 : α)⟩

@[simp, norm_cast, to_additive] lemma coe_one : ((1 : α) : with_top α) = 1 := rfl

@[simp, norm_cast, to_additive] lemma coe_eq_one {a : α} : (a : with_top α) = 1 ↔ a = 1 :=
coe_eq_coe

@[simp, to_additive] lemma untop_one : (1 : with_top α).untop coe_ne_top = 1 := rfl
@[simp, to_additive] lemma untop_one' (d : α) : (1 : with_top α).untop' d = 1 := rfl

@[simp, norm_cast, to_additive coe_nonneg]
lemma one_le_coe [has_le α] {a : α} : 1 ≤ (a : with_top α) ↔ 1 ≤ a := coe_le_coe

@[simp, norm_cast, to_additive coe_le_zero]
lemma coe_le_one [has_le α] {a : α} : (a : with_top α) ≤ 1 ↔ a ≤ 1 := coe_le_coe

@[simp, norm_cast, to_additive coe_pos]
lemma one_lt_coe [has_lt α] {a : α} : 1 < (a : with_top α) ↔ 1 < a := coe_lt_coe

@[simp, norm_cast, to_additive coe_lt_zero]
lemma coe_lt_one [has_lt α] {a : α} : (a : with_top α) < 1 ↔ a < 1 := coe_lt_coe

@[simp, to_additive] protected lemma map_one {β} (f : α → β) :
  (1 : with_top α).map f = (f 1 : with_top β) := rfl

@[simp, norm_cast, to_additive] theorem one_eq_coe {a : α} : 1 = (a : with_top α) ↔ a = 1 :=
trans eq_comm coe_eq_one

@[simp, to_additive] theorem top_ne_one : ⊤ ≠ (1 : with_top α) .
@[simp, to_additive] theorem one_ne_top : (1 : with_top α) ≠ ⊤ .

instance [has_zero α] [has_le α] [zero_le_one_class α] : zero_le_one_class (with_top α) :=
⟨some_le_some.2 zero_le_one⟩

end has_one

section has_add
variables [has_add α] {a b c d : with_top α} {x y : α}

instance : has_add (with_top α) := ⟨option.map₂ (+)⟩

@[norm_cast] lemma coe_add : ((x + y : α) : with_top α) = x + y := rfl
@[norm_cast] lemma coe_bit0 : ((bit0 x : α) : with_top α) = bit0 x := rfl
@[norm_cast] lemma coe_bit1 [has_one α] {a : α} : ((bit1 a : α) : with_top α) = bit1 a := rfl

@[simp] lemma top_add (a : with_top α) : ⊤ + a = ⊤ := rfl
@[simp]

@[simp] lemma add_eq_top : a + b = ⊤ ↔ a = ⊤ ∨ b = ⊤ :=
by cases a; cases b; simp [none_eq_top, some_eq_coe, ←with_top.coe_add]

lemma add_ne_top : a + b ≠ ⊤ ↔ a ≠ ⊤ ∧ b ≠ ⊤ := add_eq_top.not.trans not_or_distrib

lemma add_lt_top [has_lt α] {a b : with_top α} : a + b < ⊤ ↔ a < ⊤ ∧ b < ⊤ :=
by simp_rw [with_top.lt_top_iff_ne_top, add_ne_top]

lemma add_eq_coe : ∀ {a b : with_top α} {c : α},
  a + b = c ↔ ∃ (a' b' : α), ↑a' = a ∧ ↑b' = b ∧ a' + b' = c
| none b c := by simp [none_eq_top]
| (some a) none c := by simp [none_eq_top]
| (some a) (some b) c :=
    by simp only [some_eq_coe, ← coe_add, coe_eq_coe, exists_and_distrib_left, exists_eq_left]

@[simp] lemma add_coe_eq_top_iff {x : with_top α} {y : α} : x + y = ⊤ ↔ x = ⊤ :=
by { induction x using with_top.rec_top_coe; simp [← coe_add] }

@[simp] lemma coe_add_eq_top_iff {y : with_top α} : ↑x + y = ⊤ ↔ y = ⊤ :=
by { induction y using with_top.rec_top_coe; simp [← coe_add] }

instance covariant_class_add_le [has_le α] [covariant_class α α (+) (≤)] :
  covariant_class (with_top α) (with_top α) (+) (≤) :=
⟨λ a b c h, begin
  cases a; cases c; try { exact le_top },
  rcases le_coe_iff.1 h with ⟨b, rfl, h'⟩,
  exact coe_le_coe.2 (add_le_add_left (coe_le_coe.1 h) _)
end⟩

instance covariant_class_swap_add_le [has_le α] [covariant_class α α (swap (+)) (≤)] :
  covariant_class (with_top α) (with_top α) (swap (+)) (≤) :=
⟨λ a b c h, begin
  cases a; cases c; try { exact le_top },
  rcases le_coe_iff.1 h with ⟨b, rfl, h'⟩,
  exact coe_le_coe.2 (add_le_add_right (coe_le_coe.1 h) _)
end⟩

instance contravariant_class_add_lt [has_lt α] [contravariant_class α α (+) (<)] :
  contravariant_class (with_top α) (with_top α) (+) (<) :=
⟨λ a b c h, begin
  induction a using with_top.rec_top_coe, { exact (not_none_lt _ h).elim },
  induction b using with_top.rec_top_coe, { exact (not_none_lt _ h).elim },
  induction c using with_top.rec_top_coe,
  { exact coe_lt_top _ },
  { exact coe_lt_coe.2 (lt_of_add_lt_add_left $ coe_lt_coe.1 h) }
end⟩

instance contravariant_class_swap_add_lt [has_lt α] [contravariant_class α α (swap (+)) (<)] :
  contravariant_class (with_top α) (with_top α) (swap (+)) (<) :=
⟨λ a b c h, begin
  cases a; cases b; try { exact (not_none_lt _ h).elim },
  cases c,
  { exact coe_lt_top _ },
  { exact coe_lt_coe.2 (lt_of_add_lt_add_right $ coe_lt_coe.1 h) }
end⟩

protected lemma le_of_add_le_add_left [has_le α] [contravariant_class α α (+) (≤)] (ha : a ≠ ⊤)
  (h : a + b ≤ a + c) : b ≤ c :=
begin
  lift a to α using ha,
  induction c using with_top.rec_top_coe, { exact le_top },
  induction b using with_top.rec_top_coe, { exact (not_top_le_coe _ h).elim },
  simp only [← coe_add, coe_le_coe] at h ⊢,
  exact le_of_add_le_add_left h
end

protected lemma le_of_add_le_add_right [has_le α] [contravariant_class α α (swap (+)) (≤)]
  (ha : a ≠ ⊤) (h : b + a ≤ c + a) : b ≤ c :=
begin
  lift a to α using ha,
  cases c,
  { exact le_top },
  cases b,
  { exact (not_top_le_coe _ h).elim },
  { exact coe_le_coe.2 (le_of_add_le_add_right $ coe_le_coe.1 h) }
end

protected lemma add_lt_add_left [has_lt α] [covariant_class α α (+) (<)] (ha : a ≠ ⊤) (h : b < c) :
  a + b < a + c :=
begin
  lift a to α using ha,
  rcases lt_iff_exists_coe.1 h with ⟨b, rfl, h'⟩,
  cases c,
  { exact coe_lt_top _ },
  { exact coe_lt_coe.2 (add_lt_add_left (coe_lt_coe.1 h) _) }
end

protected lemma add_lt_add_right [has_lt α] [covariant_class α α (swap (+)) (<)]
  (ha : a ≠ ⊤) (h : b < c) :
  b + a < c + a :=
begin
  lift a to α using ha,
  rcases lt_iff_exists_coe.1 h with ⟨b, rfl, h'⟩,
  cases c,
  { exact coe_lt_top _ },
  { exact coe_lt_coe.2 (add_lt_add_right (coe_lt_coe.1 h) _) }
end

protected lemma add_le_add_iff_left [has_le α] [covariant_class α α (+) (≤)]
  [contravariant_class α α (+) (≤)]
  (ha : a ≠ ⊤) : a + b ≤ a + c ↔ b ≤ c :=
⟨with_top.le_of_add_le_add_left ha, λ h, add_le_add_left h a⟩

protected lemma add_le_add_iff_right [has_le α] [covariant_class α α (swap (+)) (≤)]
  [contravariant_class α α (swap (+)) (≤)] (ha : a ≠ ⊤) : b + a ≤ c + a ↔ b ≤ c :=
⟨with_top.le_of_add_le_add_right ha, λ h, add_le_add_right h a⟩

protected lemma add_lt_add_iff_left [has_lt α] [covariant_class α α (+) (<)]
  [contravariant_class α α (+) (<)] (ha : a ≠ ⊤) : a + b < a + c ↔ b < c :=
⟨lt_of_add_lt_add_left, with_top.add_lt_add_left ha⟩

protected lemma add_lt_add_iff_right [has_lt α] [covariant_class α α (swap (+)) (<)]
  [contravariant_class α α (swap (+)) (<)] (ha : a ≠ ⊤) : b + a < c + a ↔ b < c :=
⟨lt_of_add_lt_add_right, with_top.add_lt_add_right ha⟩

protected lemma add_lt_add_of_le_of_lt [preorder α] [covariant_class α α (+) (<)]
  [covariant_class α α (swap (+)) (≤)] (ha : a ≠ ⊤) (hab : a ≤ b) (hcd : c < d) : a + c < b + d :=
(with_top.add_lt_add_left ha hcd).trans_le $ add_le_add_right hab _

protected lemma add_lt_add_of_lt_of_le [preorder α] [covariant_class α α (+) (≤)]
  [covariant_class α α (swap (+)) (<)] (hc : c ≠ ⊤) (hab : a < b) (hcd : c ≤ d) : a + c < b + d :=
(with_top.add_lt_add_right hc hab).trans_le $ add_le_add_left hcd _

/-  There is no `with_top.map_mul_of_mul_hom`, since `with_top` does not have a multiplication. -/
@[simp] protected lemma map_add {F} [has_add β] [add_hom_class F α β] (f : F) (a b : with_top α) :
  (a + b).map f = a.map f + b.map f :=
begin
  induction a using with_top.rec_top_coe,
  { exact (top_add _).symm },
  { induction b using with_top.rec_top_coe,
    { exact (add_top _).symm },
    { rw [map_coe, map_coe, ← coe_add, ← coe_add, ← map_add],
      refl } },
end

end has_add

instance [add_semigroup α] : add_semigroup (with_top α) :=
{ add_assoc := λ _ _ _, option.map₂_assoc add_assoc,
  ..with_top.has_add }

instance [add_comm_semigroup α] : add_comm_semigroup (with_top α) :=
{ add_comm := λ _ _, option.map₂_comm add_comm,
  ..with_top.add_semigroup }

instance [add_zero_class α] : add_zero_class (with_top α) :=
{ zero_add := option.map₂_left_identity zero_add,
  add_zero := option.map₂_right_identity add_zero,
  ..with_top.has_zero,
  ..with_top.has_add }

instance [add_monoid α] : add_monoid (with_top α) :=
{ ..with_top.add_zero_class,
  ..with_top.has_zero,
  ..with_top.add_semigroup }

instance [add_comm_monoid α] : add_comm_monoid (with_top α) :=
{ ..with_top.add_monoid, ..with_top.add_comm_semigroup }

instance [add_monoid_with_one α] : add_monoid_with_one (with_top α) :=
{ nat_cast := λ n, ↑(n : α),
  nat_cast_zero := by rw [nat.cast_zero, with_top.coe_zero],
  nat_cast_succ := λ n, by rw [nat.cast_add_one, with_top.coe_add, with_top.coe_one],
  .. with_top.has_one, .. with_top.add_monoid }

instance [add_comm_monoid_with_one α] : add_comm_monoid_with_one (with_top α) :=
{ .. with_top.add_monoid_with_one, .. with_top.add_comm_monoid }

instance [ordered_add_comm_monoid α] : ordered_add_comm_monoid (with_top α) :=
{ add_le_add_left :=
    begin
      rintros a b h (_|c), { simp [none_eq_top] },
      rcases b with (_|b), { simp [none_eq_top] },
      rcases le_coe_iff.1 h with ⟨a, rfl, h⟩,
      simp only [some_eq_coe, ← coe_add, coe_le_coe] at h ⊢,
      exact add_le_add_left h c
    end,
  ..with_top.partial_order, ..with_top.add_comm_monoid }

instance [linear_ordered_add_comm_monoid α] :
  linear_ordered_add_comm_monoid_with_top (with_top α) :=
{ top_add' := with_top.top_add,
  ..with_top.order_top,
  ..with_top.linear_order,
  ..with_top.ordered_add_comm_monoid,
  ..option.nontrivial }

instance [has_le α] [has_add α] [has_exists_add_of_le α] : has_exists_add_of_le (with_top α) :=
⟨λ a b, match a, b with
  | ⊤, ⊤ := by simp
  | (a : α), ⊤ := λ _, ⟨⊤, rfl⟩
  | (a : α), (b : α) := λ h, begin
      obtain ⟨c, rfl⟩ := exists_add_of_le (with_top.coe_le_coe.1 h),
      exact ⟨c, rfl⟩
    end
  | ⊤, (b : α) := λ h, (not_top_le_coe _ h).elim
end⟩

instance [canonically_ordered_add_monoid α] : canonically_ordered_add_monoid (with_top α) :=
{ le_self_add := λ a b, match a, b with
  | ⊤, ⊤ := le_rfl
  | (a : α), ⊤ := le_top
  | (a : α), (b : α) := with_top.coe_le_coe.2 le_self_add
  | ⊤, (b : α) := le_rfl
  end,
  ..with_top.order_bot, ..with_top.ordered_add_comm_monoid, ..with_top.has_exists_add_of_le }

instance [canonically_linear_ordered_add_monoid α] :
  canonically_linear_ordered_add_monoid (with_top α) :=
{ ..with_top.canonically_ordered_add_monoid, ..with_top.linear_order }

@[simp, norm_cast] lemma coe_nat [add_monoid_with_one α] (n : ℕ) : ((n : α) : with_top α) = n := rfl
@[simp] lemma nat_ne_top [add_monoid_with_one α] (n : ℕ) : (n : with_top α) ≠ ⊤ := coe_ne_top
@[simp] lemma top_ne_nat [add_monoid_with_one α] (n : ℕ) : (⊤ : with_top α) ≠ n := top_ne_coe

/-- Coercion from `α` to `with_top α` as an `add_monoid_hom`. -/
def coe_add_hom [add_monoid α] : α →+ with_top α :=
⟨coe, rfl, λ _ _, rfl⟩

@[simp] lemma coe_coe_add_hom [add_monoid α] : ⇑(coe_add_hom : α →+ with_top α) = coe := rfl

@[simp] lemma zero_lt_top [ordered_add_comm_monoid α] : (0 : with_top α) < ⊤ :=
coe_lt_top 0

@[simp, norm_cast] lemma zero_lt_coe [ordered_add_comm_monoid α] (a : α) :
  (0 : with_top α) < a ↔ 0 < a :=
coe_lt_coe

/-- A version of `with_top.map` for `one_hom`s. -/
@[to_additive "A version of `with_top.map` for `zero_hom`s", simps { fully_applied := ff }]
protected def _root_.one_hom.with_top_map {M N : Type*} [has_one M] [has_one N] (f : one_hom M N) :
  one_hom (with_top M) (with_top N) :=
{ to_fun := with_top.map f,
  map_one' := by rw [with_top.map_one, map_one, coe_one] }

/-- A version of `with_top.map` for `add_hom`s. -/
@[simps { fully_applied := ff }] protected def _root_.add_hom.with_top_map
  {M N : Type*} [has_add M] [has_add N] (f : add_hom M N) :
  add_hom (with_top M) (with_top N) :=
{ to_fun := with_top.map f,
  map_add' := with_top.map_add f }

/-- A version of `with_top.map` for `add_monoid_hom`s. -/
@[simps { fully_applied := ff }] protected def _root_.add_monoid_hom.with_top_map
  {M N : Type*} [add_zero_class M] [add_zero_class N] (f : M →+ N) :
  with_top M →+ with_top N :=
{ to_fun := with_top.map f,
  .. f.to_zero_hom.with_top_map, .. f.to_add_hom.with_top_map }

end with_top

namespace with_bot

@[to_additive] instance [has_one α] : has_one (with_bot α) := with_top.has_one
instance [has_add α] : has_add (with_bot α) := with_top.has_add
instance [add_semigroup α] : add_semigroup (with_bot α) := with_top.add_semigroup
instance [add_comm_semigroup α] : add_comm_semigroup (with_bot α) := with_top.add_comm_semigroup
instance [add_zero_class α] : add_zero_class (with_bot α) := with_top.add_zero_class
instance [add_monoid α] : add_monoid (with_bot α) := with_top.add_monoid
instance [add_comm_monoid α] : add_comm_monoid (with_bot α) := with_top.add_comm_monoid
instance [add_monoid_with_one α] : add_monoid_with_one (with_bot α) := with_top.add_monoid_with_one

instance [add_comm_monoid_with_one α] : add_comm_monoid_with_one (with_bot α) :=
with_top.add_comm_monoid_with_one

instance [has_zero α] [has_one α] [has_le α] [zero_le_one_class α] :
  zero_le_one_class (with_bot α) :=
⟨some_le_some.2 zero_le_one⟩

-- `by norm_cast` proves this lemma, so I did not tag it with `norm_cast`
@[to_additive]
lemma coe_one [has_one α] : ((1 : α) : with_bot α) = 1 := rfl

-- `by norm_cast` proves this lemma, so I did not tag it with `norm_cast`
@[to_additive]
lemma coe_eq_one [has_one α] {a : α} : (a : with_bot α) = 1 ↔ a = 1 :=
with_top.coe_eq_one

@[simp, to_additive] lemma unbot_one [has_one α] : (1 : with_bot α).unbot coe_ne_bot = 1 := rfl
@[simp, to_additive] lemma unbot_one' [has_one α] (d : α) : (1 : with_bot α).unbot' d = 1 := rfl

@[simp, norm_cast, to_additive coe_nonneg]
lemma one_le_coe [has_one α] [has_le α] {a : α} : 1 ≤ (a : with_bot α) ↔ 1 ≤ a := coe_le_coe

@[simp, norm_cast, to_additive coe_le_zero]
lemma coe_le_one [has_one α] [has_le α] {a : α} : (a : with_bot α) ≤ 1 ↔ a ≤ 1 := coe_le_coe

@[simp, norm_cast, to_additive coe_pos]
lemma one_lt_coe [has_one α] [has_lt α] {a : α} : 1 < (a : with_bot α) ↔ 1 < a := coe_lt_coe

@[simp, norm_cast, to_additive coe_lt_zero]
lemma coe_lt_one [has_one α] [has_lt α] {a : α} : (a : with_bot α) < 1 ↔ a < 1 := coe_lt_coe

@[simp, to_additive] protected lemma map_one {β} [has_one α] (f : α → β) :
  (1 : with_bot α).map f = (f 1 : with_bot β) := rfl

@[norm_cast] lemma coe_nat [add_monoid_with_one α] (n : ℕ) : ((n : α) : with_bot α) = n := rfl
@[simp] lemma nat_ne_bot [add_monoid_with_one α] (n : ℕ) : (n : with_bot α) ≠ ⊥ := coe_ne_bot
@[simp] lemma bot_ne_nat [add_monoid_with_one α] (n : ℕ) : (⊥ : with_bot α) ≠ n := bot_ne_coe

section has_add
variables [has_add α] {a b c d : with_bot α} {x y : α}

-- `norm_cast` proves those lemmas, because `with_top`/`with_bot` are reducible
lemma coe_add (a b : α) : ((a + b : α) : with_bot α) = a + b := rfl
lemma coe_bit0 : ((bit0 x : α) : with_bot α) = bit0 x := rfl
lemma coe_bit1 [has_one α] {a : α} : ((bit1 a : α) : with_bot α) = bit1 a := rfl

@[simp] lemma bot_add (a : with_bot α) : ⊥ + a = ⊥ := rfl
@[simp] lemma add_bot (a : with_bot α) : a + ⊥ = ⊥ := by cases a; refl

@[simp] lemma add_eq_bot : a + b = ⊥ ↔ a = ⊥ ∨ b = ⊥ := with_top.add_eq_top
lemma add_ne_bot : a + b ≠ ⊥ ↔ a ≠ ⊥ ∧ b ≠ ⊥ := with_top.add_ne_top

lemma bot_lt_add [has_lt α] {a b : with_bot α} : ⊥ < a + b ↔ ⊥ < a ∧ ⊥ < b :=
@with_top.add_lt_top αᵒᵈ _ _ _ _

lemma add_eq_coe : a + b = x ↔ ∃ (a' b' : α), ↑a' = a ∧ ↑b' = b ∧ a' + b' = x := with_top.add_eq_coe

@[simp] lemma add_coe_eq_bot_iff : a + y = ⊥ ↔ a = ⊥ := with_top.add_coe_eq_top_iff
@[simp] lemma coe_add_eq_bot_iff : ↑x + b = ⊥ ↔ b = ⊥ := with_top.coe_add_eq_top_iff

/-  There is no `with_bot.map_mul_of_mul_hom`, since `with_bot` does not have a multiplication. -/
@[simp] protected lemma map_add {F} [has_add β] [add_hom_class F α β] (f : F) (a b : with_bot α) :
  (a + b).map f = a.map f + b.map f :=
with_top.map_add f a b

/-- A version of `with_bot.map` for `one_hom`s. -/
@[to_additive "A version of `with_bot.map` for `zero_hom`s", simps { fully_applied := ff }]
protected def _root_.one_hom.with_bot_map {M N : Type*} [has_one M] [has_one N] (f : one_hom M N) :
  one_hom (with_bot M) (with_bot N) :=
{ to_fun := with_bot.map f,
  map_one' := by rw [with_bot.map_one, map_one, coe_one] }

/-- A version of `with_bot.map` for `add_hom`s. -/
@[simps { fully_applied := ff }] protected def _root_.add_hom.with_bot_map
  {M N : Type*} [has_add M] [has_add N] (f : add_hom M N) :
  add_hom (with_bot M) (with_bot N) :=
{ to_fun := with_bot.map f,
  map_add' := with_bot.map_add f }

/-- A version of `with_bot.map` for `add_monoid_hom`s. -/
@[simps { fully_applied := ff }] protected def _root_.add_monoid_hom.with_bot_map
  {M N : Type*} [add_zero_class M] [add_zero_class N] (f : M →+ N) :
  with_bot M →+ with_bot N :=
{ to_fun := with_bot.map f,
  .. f.to_zero_hom.with_bot_map, .. f.to_add_hom.with_bot_map }

variables [preorder α]

instance covariant_class_add_le [covariant_class α α (+) (≤)] :
  covariant_class (with_bot α) (with_bot α) (+) (≤) :=
@order_dual.covariant_class_add_le (with_top αᵒᵈ) _ _ _

instance covariant_class_swap_add_le [covariant_class α α (swap (+)) (≤)] :
  covariant_class (with_bot α) (with_bot α) (swap (+)) (≤) :=
@order_dual.covariant_class_swap_add_le (with_top αᵒᵈ) _ _ _

instance contravariant_class_add_lt [contravariant_class α α (+) (<)] :
  contravariant_class (with_bot α) (with_bot α) (+) (<) :=
@order_dual.contravariant_class_add_lt (with_top αᵒᵈ) _ _ _

instance contravariant_class_swap_add_lt [contravariant_class α α (swap (+)) (<)] :
  contravariant_class (with_bot α) (with_bot α) (swap (+)) (<) :=
@order_dual.contravariant_class_swap_add_lt (with_top αᵒᵈ) _ _ _

protected lemma le_of_add_le_add_left [contravariant_class α α (+) (≤)] (ha : a ≠ ⊥)
  (h : a + b ≤ a + c) : b ≤ c :=
@with_top.le_of_add_le_add_left αᵒᵈ _ _ _ _ _ _ ha h

protected lemma le_of_add_le_add_right [contravariant_class α α (swap (+)) (≤)] (ha : a ≠ ⊥)
  (h : b + a ≤ c + a) : b ≤ c :=
@with_top.le_of_add_le_add_right αᵒᵈ _ _ _ _ _ _ ha h

protected lemma add_lt_add_left [covariant_class α α (+) (<)] (ha : a ≠ ⊥) (h : b < c) :
  a + b < a + c :=
@with_top.add_lt_add_left αᵒᵈ _ _ _ _ _ _ ha h

protected lemma add_lt_add_right [covariant_class α α (swap (+)) (<)] (ha : a ≠ ⊥) (h : b < c) :
  b + a < c + a :=
@with_top.add_lt_add_right αᵒᵈ _ _ _ _ _ _ ha h

protected lemma add_le_add_iff_left [covariant_class α α (+) (≤)] [contravariant_class α α (+) (≤)]
  (ha : a ≠ ⊥) : a + b ≤ a + c ↔ b ≤ c :=
⟨with_bot.le_of_add_le_add_left ha, λ h, add_le_add_left h a⟩

protected lemma add_le_add_iff_right [covariant_class α α (swap (+)) (≤)]
  [contravariant_class α α (swap (+)) (≤)] (ha : a ≠ ⊥) : b + a ≤ c + a ↔ b ≤ c :=
⟨with_bot.le_of_add_le_add_right ha, λ h, add_le_add_right h a⟩

protected lemma add_lt_add_iff_left [covariant_class α α (+) (<)] [contravariant_class α α (+) (<)]
  (ha : a ≠ ⊥) : a + b < a + c ↔ b < c :=
⟨lt_of_add_lt_add_left, with_bot.add_lt_add_left ha⟩

protected lemma add_lt_add_iff_right [covariant_class α α (swap (+)) (<)]
  [contravariant_class α α (swap (+)) (<)] (ha : a ≠ ⊥) : b + a < c + a ↔ b < c :=
⟨lt_of_add_lt_add_right, with_bot.add_lt_add_right ha⟩

protected lemma add_lt_add_of_le_of_lt [covariant_class α α (+) (<)]
  [covariant_class α α (swap (+)) (≤)] (hb : b ≠ ⊥) (hab : a ≤ b) (hcd : c < d) : a + c < b + d :=
@with_top.add_lt_add_of_le_of_lt αᵒᵈ _ _ _ _ _ _ _ _ hb hab hcd

protected lemma add_lt_add_of_lt_of_le [covariant_class α α (+) (≤)]
  [covariant_class α α (swap (+)) (<)] (hd : d ≠ ⊥) (hab : a < b) (hcd : c ≤ d) : a + c < b + d :=
@with_top.add_lt_add_of_lt_of_le αᵒᵈ _ _ _ _ _ _ _ _ hd hab hcd

end has_add

instance [ordered_add_comm_monoid α] : ordered_add_comm_monoid (with_bot α) :=
{ add_le_add_left := λ a b h c, add_le_add_left h c,
  ..with_bot.partial_order,
  ..with_bot.add_comm_monoid }

instance [linear_ordered_add_comm_monoid α] : linear_ordered_add_comm_monoid (with_bot α) :=
{ ..with_bot.linear_order, ..with_bot.ordered_add_comm_monoid }

end with_bot


set_option pp.motives.pi false

#print Nat.add

set_option pp.motives.pi true

#print Nat.add

theorem ex : ∀ {α β : Sort u} (h : α = β) (a : α), cast h a ≅ a
  | α, _, rfl, a => HEq.refl a

set_option pp.motives.nonConst false

#print ex

set_option pp.motives.nonConst true

#print ex

noncomputable def fact (n : Nat) : Nat :=
  Nat.recOn n 1 (fun n acc => (n+1)*acc)

set_option pp.motives.all false

#print fact

set_option pp.motives.all true

#print fact