import Lean.Data.Json
import Mathlib.Data.Nat.Basic
import Mathlib.Init.Algebra.Order
import Mathlib.Init.Data.Nat.Basic
import Mathlib.Init.Data.Nat.Lemmas
import Mathlib.Init.Data.Int.Basic
import Mathlib.Tactic.LibrarySearch
import Mathlib.Data.Equiv.Basic
import Mathlib.Init.Data.Int.Order
import Timelib.Date.Year
import Timelib.Date.Month

open Lean

structure Ymd where
  year : Year
  month : Month
  day : Nat
  dayGe : day >= 1
  dayLe : day <= month.numDays year
deriving Repr

instance : ToJson Ymd where
  toJson ymd := Json.mkObj [("year", ToJson.toJson ymd.year.val), ("month", ToJson.toJson ymd.month), ("day", ymd.day)]

instance : FromJson Ymd where
  fromJson? j := do
    let (year : Year) ← (fromJson? (← j.getObjVal? "year")).map Year.mk
    let (month : Month) ← (fromJson? (← j.getObjVal? "month"))
    let (day : Nat) ← fromJson? (← j.getObjVal? "day")
    if h : day >= 1 ∧ day <= month.numDays year
    then return Ymd.mk year month day h.left h.right
    else Except.error s!"Ymd day out of range: {day}"

theorem Ymd.eq_of_val_eq : ∀ {o₁ o₂ : Ymd} (h_year : o₁.year = o₂.year) (h_month : o₁.month = o₂.month) (h_day : o₁.day = o₂.day), o₁ = o₂
| ⟨y₁, m₁, d₁, hGt₁, hLt₁⟩, ⟨y₂, m₂, d₂, hGt₂, hLt₂⟩, hy, hm, hd => by simp [hy, hm, hd]

instance : Ord Ymd where
  compare d₁ d₂ :=
    match Ord.compare d₁.year d₂.year with
    | Ordering.eq =>
      match Ord.compare d₁.month d₂.month with
      | Ordering.eq => Ord.compare d₁.day d₂.day
      | owise => owise
    | owise => owise

instance : LE Ymd := leOfOrd
instance : LT Ymd := ltOfOrd

theorem Ymd.le_def (d₁ d₂ : Ymd) : (d₁ <= d₂) = (compare d₁ d₂).isLE := rfl
theorem Ymd.lt_def (d₁ d₂ : Ymd) : (d₁ < d₂) = (Ord.compare d₁ d₂ == Ordering.lt) := rfl

theorem Ymd.le_def' (d₁ d₂ : Ymd) :
  (d₁ <= d₂) =
  (d₁.year < d₂.year ∨ (d₁.year = d₂.year ∧ d₁.month < d₂.month) ∨ (d₁.year = d₂.year ∧ d₁.month = d₂.month ∧ d₁.day <= d₂.day)) := by
   simp [Ymd.le_def, Ordering.isLE, compare, compareOfLessAndEq]
   match lt_trichotomy d₁.year d₂.year with
   | .inl y_lt => simp [y_lt]
   | .inr (.inr y_gt) => simp [not_lt_of_gt y_gt, ne_of_gt y_gt]
   | .inr (.inl y_eq) =>
     simp [y_eq, lt_irrefl]
     match lt_trichotomy d₁.month d₂.month with
     | .inl m_lt => simp [m_lt]
     | .inr (.inr m_gt) => simp [not_lt_of_gt m_gt, ne_of_gt m_gt]
     | .inr (.inl m_eq) =>
       simp [m_eq, lt_irrefl]
       match lt_trichotomy d₁.day d₂.day with
       | .inl d_lt => simp [d_lt]; exact le_of_lt d_lt
       | .inr (.inr d_gt) => simp [not_lt_of_gt d_gt, ne_of_gt d_gt]; assumption
       | .inr (.inl d_eq) => simp [d_eq, lt_irrefl d₂.day]

theorem Ymd.lt_def' (d₁ d₂ : Ymd) :
  (d₁ < d₂) =
  (d₁.year < d₂.year
   ∨ (d₁.year = d₂.year ∧ d₁.month < d₂.month)
   ∨ (d₁.year = d₂.year ∧ d₁.month = d₂.month ∧ d₁.day < d₂.day)) := by
   simp [Ymd.lt_def, compare, compareOfLessAndEq]
   match lt_trichotomy d₁.year d₂.year with
   | .inl y_lt => simp [y_lt]
   | .inr (.inr y_gt) => simp [not_lt_of_gt y_gt, ne_of_gt y_gt]
   | .inr (.inl y_eq) =>
     simp [y_eq, lt_irrefl]
     match lt_trichotomy d₁.month d₂.month with
     | .inl m_lt => simp [m_lt]
     | .inr (.inr m_gt) => simp [not_lt_of_gt m_gt, ne_of_gt m_gt]
     | .inr (.inl m_eq) =>
       simp [m_eq, lt_irrefl]
       match lt_trichotomy d₁.day d₂.day with
       | .inl d_lt => simp [d_lt]
       | .inr (.inr d_gt) => simp [not_lt_of_gt d_gt, ne_of_gt d_gt]
       | .inr (.inl d_eq) => simp [d_eq, lt_irrefl d₂.day]

instance : LinearOrder Ymd where
  le_refl (a) := by simp [Ymd.le_def']
  le_trans (a b c) := by
    simp only [Ymd.le_def']
    rintro (ay_lt_by | ⟨ay_eq_by, am_lt_bm⟩ | ⟨ay_eq_by, am_eq_bm, ad_le_bd⟩)
    <;> rintro (by_lt_cy | ⟨by_eq_cy, bm_lt_cm⟩ | ⟨by_eq_cy, bm_eq_cm, bd_le_cd⟩)
    . exact .inl $ lt_trans ay_lt_by by_lt_cy
    . exact .inl $ by_eq_cy ▸ ay_lt_by
    . exact .inl $ by_eq_cy ▸ ay_lt_by
    . exact .inl $ ay_eq_by ▸ by_lt_cy
    . exact .inr $ .inl ⟨ay_eq_by ▸ by_eq_cy, lt_trans am_lt_bm bm_lt_cm⟩
    . exact .inr $ .inl ⟨ay_eq_by ▸ by_eq_cy, bm_eq_cm ▸ am_lt_bm⟩
    . exact .inl $ ay_eq_by ▸ by_lt_cy
    . exact .inr $ .inl ⟨ay_eq_by ▸ by_eq_cy, am_eq_bm ▸ bm_lt_cm⟩
    . exact .inr $ .inr ⟨ay_eq_by ▸ by_eq_cy, ⟨am_eq_bm ▸ bm_eq_cm, le_trans ad_le_bd bd_le_cd⟩⟩
  lt_iff_le_not_le (a b) := by
    simp only [Ymd.le_def', Ymd.lt_def']
    refine Iff.intro ?mp ?mpr
    case mp =>
      rintro (y_lt | ⟨y_eq, m_lt⟩ | ⟨y_eq, m_eq, d_le⟩)
      case inl =>
        have hr : ¬(b.year < a.year ∨ b.year = a.year ∧ b.month < a.month ∨ b.year = a.year ∧ b.month = a.month ∧ b.day ≤ a.day) := by
          rintro (y_lt' | ⟨y_eq', m_lt'⟩ | ⟨y_eq', m_lt', d_le'⟩)
          . exact (not_lt_of_gt y_lt) y_lt'
          . exact (lt_irrefl a.year (y_eq' ▸ y_lt))
          . exact (lt_irrefl a.year (y_eq' ▸ y_lt))
        exact ⟨Or.inl y_lt, hr⟩
      case inr.inl.intro =>
        have hr : ¬(b.year < a.year ∨ b.year = a.year ∧ b.month < a.month ∨ b.year = a.year ∧ b.month = a.month ∧ b.day ≤ a.day) := by
          rintro (y_lt' | ⟨y_eq', m_le⟩ | ⟨y_eq', m_eq', d_le'⟩)
          . exact (lt_irrefl a.year (y_eq ▸ y_lt'))
          . exact (not_lt_of_gt m_lt) m_le
          . exact (lt_irrefl a.month (m_eq' ▸ m_lt))
        exact ⟨.inr $ .inl ⟨y_eq, m_lt⟩, hr⟩
      case inr.inr.intro.intro =>
        have hr : ¬(b.year < a.year ∨ b.year = a.year ∧ b.month < a.month ∨ b.year = a.year ∧ b.month = a.month ∧ b.day ≤ a.day) := by
          rintro (y_lt' | ⟨y_eq', m_lt⟩ | ⟨y_eq', m_eq, d_le'⟩)
          . exact (lt_irrefl a.year (y_eq ▸ y_lt'))
          . exact (lt_irrefl a.month (m_eq ▸ m_lt))
          . exact (not_le_of_gt d_le d_le')
        exact ⟨.inr $ .inr ⟨y_eq, ⟨m_eq, le_of_lt d_le⟩⟩, hr⟩
    case mpr =>
      rintro (y_lt | ⟨y_eq, m_lt⟩ | ⟨y_eq, m_eq, d_le⟩)
      case intro.inl => exact .inl y_lt
      case intro.inr.inl.intro => exact .inr $ .inl ⟨y_eq, m_lt⟩
      case intro.inr.inr.intro.intro hnot =>
        match lt_or_eq_of_le d_le with
        | .inl d_lt => exact Or.inr $ .inr ⟨y_eq, ⟨m_eq, d_lt⟩⟩
        | .inr d_eq => exact False.elim $ hnot $ .inr $ .inr ⟨y_eq.symm, ⟨m_eq.symm, (le_of_eq d_eq.symm)⟩⟩
  le_antisymm (a b) := by
    simp [Ymd.le_def']
    rintro (ay_lt_by | ⟨ay_eq_by, am_lt_bm⟩ | ⟨ay_eq_by, am_eq_bm, ad_le_bd⟩)
    <;> rintro (by_lt_ay | ⟨by_eq_ay, bm_lt_am⟩ | ⟨by_eq_ay, bm_eq_am, bd_le_ad⟩)
    . exact absurd ay_lt_by (not_lt_of_gt by_lt_ay)
    . rw [by_eq_ay] at ay_lt_by; exact absurd (ay_lt_by) (lt_irrefl _)
    . rw [by_eq_ay] at ay_lt_by; exact absurd (ay_lt_by) (lt_irrefl _)
    . rw [ay_eq_by] at by_lt_ay; exact absurd (by_lt_ay) (lt_irrefl _)
    . exact absurd am_lt_bm (not_lt_of_gt bm_lt_am)
    . rw [bm_eq_am] at am_lt_bm; exact absurd (am_lt_bm) (lt_irrefl _)
    . rw [ay_eq_by] at by_lt_ay; exact absurd (by_lt_ay) (lt_irrefl _)
    . rw [am_eq_bm] at bm_lt_am; exact absurd (bm_lt_am) (lt_irrefl _)
    . exact Ymd.eq_of_val_eq ay_eq_by am_eq_bm (le_antisymm ad_le_bd bd_le_ad)
  le_total (a b) := by
    simp [Ymd.le_def']
    match lt_trichotomy a.year b.year with
    | .inl y_lt => simp [y_lt]
    | .inr (.inr y_gt) => simp [y_gt]
    | .inr (.inl y_eq) =>
      simp [y_eq, lt_irrefl]
      match lt_trichotomy a.month b.month with
      | .inl m_lt => simp [m_lt]
      | .inr (.inr m_gt) => simp [m_gt]
      | .inr (.inl m_eq) =>
        simp [m_eq, lt_irrefl]
        match lt_trichotomy a.day b.day with
        | .inl d_lt => simp [le_of_lt d_lt]
        | .inr (.inr d_gt) => simp [le_of_lt d_gt]
        | .inr (.inl d_eq) => simp [d_eq]
  decidable_le := inferInstance

theorem Ymd.numDays_pos (ymd : Ymd) : 0 < ymd.month.numDays ymd.year := by
  simp only [Month.numDays]
  by_cases hy : ymd.year.isLeapYear <;> (split <;> simp [hy, if_true, if_false])

theorem Ymd.numDays_lt_numDaysInGregorianYear (ymd : Ymd) : ymd.month.numDays ymd.year < ymd.year.numDaysInGregorianYear := by
  simp only [Month.numDays, Year.numDaysInGregorianYear]
  by_cases hy : ymd.year.isLeapYear <;> (split <;> simp [hy, if_true, if_false])

theorem Ymd.numDays_lt_31 (ymd : Ymd) : ymd.month.numDays ymd.year <= 31 := by
  simp only [Month.numDays, Year.numDaysInGregorianYear]
  by_cases hy : ymd.year.isLeapYear <;> (split <;> simp [hy, if_true, if_false])


import data.set.basic
import tactic.lift

/-! Some tests of the `lift` tactic. -/
example (n m k x z u : ℤ) (hn : 0 < n) (hk : 0 ≤ k + n) (hu : 0 ≤ u)
  (h : k + n = 2 + x) (f : false) :
  k + n = m + x :=
begin
  lift n to ℕ using le_of_lt hn,
    guard_target (k + ↑n = m + x), guard_hyp hn : (0 : ℤ) < ↑n,
  lift m to ℕ,
    guard_target (0 ≤ m), tactic.swap, guard_target (k + ↑n = ↑m + x),
    tactic.num_goals >>= λ n, guard (n = 2),
  lift (k + n) to ℕ using hk with l hl,
    guard_hyp l : ℕ, guard_hyp hl : ↑l = k + ↑n, guard_target (↑l = ↑m + x),
    tactic.success_if_fail (tactic.get_local `hk),
  lift x to ℕ with y hy,
    tactic.swap, guard_hyp y : ℕ, guard_hyp hy : ↑y = x, guard_target (↑l = ↑m + x), tactic.swap,
  lift z to ℕ with w,
    tactic.swap, guard_hyp w : ℕ, tactic.success_if_fail (tactic.get_local `z), tactic.swap,
  lift u to ℕ using hu with u rfl hu,
    guard_hyp hu : (0 : ℤ) ≤ ↑u,

  all_goals { exfalso, assumption },
end

-- test lift of functions
example (α : Type*) (f : α → ℤ) (hf : ∀ a, 0 ≤ f a) (hf' : ∀ a, f a < 1) (a : α) : 0 ≤ 2 * f a :=
begin
  lift f to α → ℕ using hf,
    guard_target ((0:ℤ) ≤ 2 * (λ i : α, (f i : ℤ)) a),
    guard_hyp hf' : ∀ a, ((λ i : α, (f i:ℤ)) a) < 1,
  constructor,
end

-- fail gracefully when the lifted variable is a local definition
example : let n : ℤ := 3 in n = n :=
begin
  intro n,
  success_if_fail_with_msg { lift n to ℕ }
    ("Cannot substitute variable n, it is a local definition. " ++
    "If you really want to do this, use `clear_value` first."),
  refl
end

instance can_lift_unit : can_lift unit unit id (λ _, true) := ⟨λ x _, ⟨x, rfl⟩⟩

/- test error messages -/
example (n : ℤ) (hn : 0 < n) : true :=
begin
  success_if_fail_with_msg {lift n to ℕ using hn} ("lift tactic failed.\n" ++
    "invalid type ascription, term has type\n  0 < n\nbut is expected to have type\n  0 ≤ n"),
  success_if_fail_with_msg {lift (n : option ℤ) to ℕ}
    ("Failed to find a lift from option ℤ to ℕ. " ++
    "Provide an instance of\n  can_lift (option ℤ) ℕ ?m_1 ?m_2"),
  trivial
end

example (n : ℤ) : ℕ :=
begin
  success_if_fail_with_msg {lift n to ℕ}
    "lift tactic failed. Tactic is only applicable when the target is a proposition.",
  exact 0
end

instance can_lift_set (R : Type*) (s : set R) : can_lift R s coe (λ x, x ∈ s) :=
{ prf := λ x hx, ⟨⟨x, hx⟩, rfl⟩ }

example {R : Type*} {P : R → Prop} (x : R) (hx : P x) : true :=
by { lift x to {x // P x} using hx with y, trivial }

/-! Test that `lift` elaborates `s` as a type, not as a set. -/
example {R : Type*} {s : set R} (x : R) (hx : x ∈ s) : true :=
by { lift x to s using hx with y, trivial }

example (n : ℤ) (hn : 0 ≤ n) : true :=
by { lift n to ℕ, exact hn, trivial }

example (n : ℤ) (hn : 0 ≤ n) : true :=
by { lift n to ℕ using hn, trivial }

example (n : ℤ) (hn : n ≥ 0) : true :=
by { lift n to ℕ using ge.le _, trivial, guard_target (n ≥ 0), exact hn }

example (n : ℤ) (hn : 0 ≤ 1 * n) : true :=
begin
  lift n to ℕ using by { simpa [int.one_mul] using hn } with k,
  -- the above braces are optional, but it would be bad style to remove them (see next example)
  guard_hyp hn : 0 ≤ 1 * ((k : ℕ) : ℤ),
  trivial
end

example (n : ℤ) (hn : 0 ≤ n ↔ true) : true :=
begin
  lift n to ℕ using by { simp [hn] } with k, -- the braces are not optional here
  trivial
end


/- Author: E.W.Ayers © 2019 -/
import ..equate
namespace rats
open robot

/- Example within the context of defining the rationals as ordered pairs of integers
quotiented by the relation (⟨a,b⟩ ~ ⟨c,d⟩) ↔ (a * d = c * b).
 -/

meta def blast : tactic unit :=
tactic.timetac "blast" $ (using_smt_with {cc_cfg := {ac:=ff}} $ tactic.intros >> smt_tactic.iterate (smt_tactic.ematch >> smt_tactic.try smt_tactic.close))
attribute [ematch] mul_comm mul_assoc

universes u
structure q (α : Type u) [integral_domain α] := (n : α) (d : α ) (nz : d ≠ 0)
lemma q.ext {α : Type u} [integral_domain α] : Π (q1 q2 : q α), q1.n = q2.n → q1.d = q2.d → q1 = q2
|⟨n,d,nz⟩ ⟨_,_,_⟩ rfl rfl := rfl

instance (α : Type u) [integral_domain α] : setoid (q α) :=
{ r := (λ a b, a.1 * b.2 = b.1 * a.2)
, iseqv :=
  ⟨ λ a, rfl
  , λ a b, eq.symm
  , λ ⟨a,b,_⟩ ⟨c,d,h⟩ ⟨e,f,_⟩
     (p : a * d = c * b)
     (q : c * f = e * d),
    suffices d * (a * f) = d * (e * b), from eq_of_mul_eq_mul_left h this,
    -- by blast -- takes about 2 seconds
    by equate -- also about 2 seconds, but much slower because implemented in Lean VM
  ⟩
}
def free (α : Type u) [integral_domain α] : Type* := @quotient (q α) (by apply_instance)
variables {α : Type u} [integral_domain α]

-- [TODO]
-- namespace free
-- def add : free α → free α → free α
-- := λ x y, quotient.lift_on₂ x y
--   (λ x y, ⟦(⟨x.1 * y.2 + y.1 * x.2, x.2 * y.2, mul_ne_zero x.nz y.nz⟩ : q α)⟧)
--   (λ a1 a2 b1 b2,
--       assume p : a1.n * b1.d = b1.1 * a1.2,
--       assume q : a2.1 * b2.2 = b2.1 * a2.2,
--       suffices (a1.1 * a2.2 + a2.1 * a1.2) * (b1.2 * b2.2)
--                 = (b1.1 * b2.2 + b2.1 * b1.2) * (a1.2 * a2.2),
--         from quotient.sound this,
--         calc ((a1.1 * a2.2) + (a2.1 * a1.2)) * (b1.2 * b2.2)
--               = ((b1.1 * a1.2) * (a2.2 * b2.2) + (b1.2 * a1.2) * (b2.1 * a2.2))
--                 : by equate
--          ...  = (b1.1 * b2.2 + b2.1 * b1.2) * (a1.2 * a2.2)
--                 : by symmetry; clear p q; equate
--   )
-- end free

end rats


/-
Copyright (c) 2020 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import algebra.group.hom
import category_theory.limits.shapes.kernels
import algebra.big_operators.basic
import category_theory.endomorphism

/-!
# Preadditive categories

A preadditive category is a category in which `X ⟶ Y` is an abelian group in such a way that
composition of morphisms is linear in both variables.

This file contains a definition of preadditive category that directly encodes the definition given
above. The definition could also be phrased as follows: A preadditive category is a category
enriched over the category of Abelian groups. Once the general framework to state this in Lean is
available, the contents of this file should become obsolete.

## Main results

* Definition of preadditive categories and basic properties
* In a preadditive category, `f : Q ⟶ R` is mono if and only if `g ≫ f = 0 → g = 0` for all
  composable `g`.
* A preadditive category with kernels has equalizers.

## Implementation notes

The simp normal form for negation and composition is to push negations as far as possible to
the outside. For example, `f ≫ (-g)` and `(-f) ≫ g` both become `-(f ≫ g)`, and `(-f) ≫ (-g)`
is simplified to `f ≫ g`.

## References

* [F. Borceux, *Handbook of Categorical Algebra 2*][borceux-vol2]

## Tags

additive, preadditive, Hom group, Ab-category, Ab-enriched
-/

universes v u

open category_theory.limits
open add_monoid_hom

namespace category_theory

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

/-- A category is called preadditive if `P ⟶ Q` is an abelian group such that composition is
    linear in both variables. -/
class preadditive :=
(hom_group : Π P Q : C, add_comm_group (P ⟶ Q) . tactic.apply_instance)
(add_comp' : ∀ (P Q R : C) (f f' : P ⟶ Q) (g : Q ⟶ R),
  (f + f') ≫ g = f ≫ g + f' ≫ g . obviously)
(comp_add' : ∀ (P Q R : C) (f : P ⟶ Q) (g g' : Q ⟶ R),
  f ≫ (g + g') = f ≫ g + f ≫ g' . obviously)

attribute [instance] preadditive.hom_group
restate_axiom preadditive.add_comp'
restate_axiom preadditive.comp_add'
attribute [simp,reassoc] preadditive.add_comp
attribute [reassoc] preadditive.comp_add -- (the linter doesn't like `simp` on this lemma)
attribute [simp] preadditive.comp_add

end category_theory

open category_theory

namespace category_theory.preadditive

section preadditive
variables {C : Type u} [category.{v} C] [preadditive C]

section induced_category
universes u'
variables {C} {D : Type u'} (F : D → C)

instance induced_category.category : preadditive.{v} (induced_category C F) :=
{ hom_group := λ P Q, @preadditive.hom_group C _ _ (F P) (F Q),
  add_comp' := λ P Q R f f' g, add_comp' _ _ _ _ _ _,
  comp_add' := λ P Q R f g g', comp_add' _ _ _ _ _ _, }

end induced_category

instance (X : C) : add_comm_group (End X) := by { dsimp [End], apply_instance, }

instance (X : C) : ring (End X) :=
{ left_distrib := λ f g h, preadditive.add_comp X X X g h f,
  right_distrib := λ f g h, preadditive.comp_add X X X h f g,
  ..(infer_instance : add_comm_group (End X)),
  ..(infer_instance : monoid (End X)) }

/-- Composition by a fixed left argument as a group homomorphism -/
def left_comp {P Q : C} (R : C) (f : P ⟶ Q) : (Q ⟶ R) →+ (P ⟶ R) :=
mk' (λ g, f ≫ g) $ λ g g', by simp

/-- Composition by a fixed right argument as a group homomorphism -/
def right_comp (P : C) {Q R : C} (g : Q ⟶ R) : (P ⟶ Q) →+ (P ⟶ R) :=
mk' (λ f, f ≫ g) $ λ f f', by simp

@[simp, reassoc] lemma sub_comp {P Q R : C} (f f' : P ⟶ Q) (g : Q ⟶ R) :
  (f - f') ≫ g = f ≫ g - f' ≫ g :=
map_sub (right_comp P g) f f'

-- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma.
@[reassoc, simp] lemma comp_sub {P Q R : C} (f : P ⟶ Q) (g g' : Q ⟶ R) :
  f ≫ (g - g') = f ≫ g - f ≫ g' :=
map_sub (left_comp R f) g g'

@[simp, reassoc] lemma neg_comp {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ g = -(f ≫ g) :=
map_neg (right_comp _ _) _

/- The redundant simp lemma linter says that simp can prove the reassoc version of this lemma. -/
@[reassoc, simp] lemma comp_neg {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : f ≫ (-g) = -(f ≫ g) :=
map_neg (left_comp _ _) _

@[reassoc] lemma neg_comp_neg {P Q R : C} (f : P ⟶ Q) (g : Q ⟶ R) : (-f) ≫ (-g) = f ≫ g :=
by simp

section big_operators

open_locale big_operators

@[reassoc] lemma comp_sum {P Q R : C} {J : Type*} {s : finset J} (f : P ⟶ Q) (g : J → (Q ⟶ R)) :
  f ≫ ∑ j in s, g j = ∑ j in s, f ≫ g j :=
begin
  change left_comp R f _ = _,
  rw [add_monoid_hom.map_sum],
  refl,
end

@[reassoc] lemma sum_comp {P Q R : C} {J : Type*} {s : finset J} (f : J → (P ⟶ Q)) (g : Q ⟶ R) :
  (∑ j in s, f j) ≫ g  = ∑ j in s, f j ≫ g :=
begin
  change right_comp P g _ = _,
  rw [add_monoid_hom.map_sum],
  refl,
end

end big_operators

instance {P Q : C} {f : P ⟶ Q} [epi f] : epi (-f) :=
⟨λ R g g' H, by rwa [neg_comp, neg_comp, ←comp_neg, ←comp_neg, cancel_epi, neg_inj] at H⟩

instance {P Q : C} {f : P ⟶ Q} [mono f] : mono (-f) :=
⟨λ R g g' H, by rwa [comp_neg, comp_neg, ←neg_comp, ←neg_comp, cancel_mono, neg_inj] at H⟩

@[priority 100]
instance preadditive_has_zero_morphisms : has_zero_morphisms C :=
{ has_zero := infer_instance,
  comp_zero' := λ P Q f R, map_zero $ left_comp R f,
  zero_comp' := λ P Q R f, map_zero $ right_comp P f }

lemma mono_of_cancel_zero {Q R : C} (f : Q ⟶ R) (h : ∀ {P : C} (g : P ⟶ Q), g ≫ f = 0 → g = 0) :
  mono f :=
⟨λ P g g' hg, sub_eq_zero.1 $ h _ $ (map_sub (right_comp P f) g g').trans $ sub_eq_zero.2 hg⟩

lemma mono_iff_cancel_zero {Q R : C} (f : Q ⟶ R) :
  mono f ↔ ∀ (P : C) (g : P ⟶ Q), g ≫ f = 0 → g = 0 :=
⟨λ m P g, by exactI zero_of_comp_mono _, mono_of_cancel_zero f⟩

lemma mono_of_kernel_zero {X Y : C} {f : X ⟶ Y} [has_limit (parallel_pair f 0)]
  (w : kernel.ι f = 0) : mono f :=
mono_of_cancel_zero f (λ P g h, by rw [←kernel.lift_ι f g h, w, limits.comp_zero])

lemma epi_of_cancel_zero {P Q : C} (f : P ⟶ Q) (h : ∀ {R : C} (g : Q ⟶ R), f ≫ g = 0 → g = 0) :
  epi f :=
⟨λ R g g' hg, sub_eq_zero.1 $ h _ $ (map_sub (left_comp R f) g g').trans $ sub_eq_zero.2 hg⟩

lemma epi_iff_cancel_zero {P Q : C} (f : P ⟶ Q) :
  epi f ↔ ∀ (R : C) (g : Q ⟶ R), f ≫ g = 0 → g = 0 :=
⟨λ e R g, by exactI zero_of_epi_comp _, epi_of_cancel_zero f⟩

lemma epi_of_cokernel_zero {X Y : C} (f : X ⟶ Y) [has_colimit (parallel_pair f 0 )]
  (w : cokernel.π f = 0) : epi f :=
epi_of_cancel_zero f (λ P g h, by rw [←cokernel.π_desc f g h, w, limits.zero_comp])

end preadditive

section equalizers
variables {C : Type u} [category.{v} C] [preadditive C]

section
variables {X Y : C} (f : X ⟶ Y) (g : X ⟶ Y)

/-- A kernel of `f - g` is an equalizer of `f` and `g`. -/
lemma has_limit_parallel_pair [has_kernel (f - g)] :
  has_limit (parallel_pair f g) :=
has_limit.mk { cone := fork.of_ι (kernel.ι (f - g)) (sub_eq_zero.1 $
    by { rw ←comp_sub, exact kernel.condition _ }),
  is_limit := fork.is_limit.mk _
    (λ s, kernel.lift (f - g) (fork.ι s) $
      by { rw comp_sub, apply sub_eq_zero.2, exact fork.condition _ })
    (λ s, by simp)
    (λ s m h, by { ext, simpa using h walking_parallel_pair.zero }) }

end

section

/-- If a preadditive category has all kernels, then it also has all equalizers. -/
lemma has_equalizers_of_has_kernels [has_kernels C] : has_equalizers C :=
@has_equalizers_of_has_limit_parallel_pair _ _ (λ _ _ f g, has_limit_parallel_pair f g)

end

section
variables {X Y : C} (f : X ⟶ Y) (g : X ⟶ Y)

/-- A cokernel of `f - g` is a coequalizer of `f` and `g`. -/
lemma has_colimit_parallel_pair [has_cokernel (f - g)] :
  has_colimit (parallel_pair f g) :=
has_colimit.mk { cocone := cofork.of_π (cokernel.π (f - g)) (sub_eq_zero.1 $
    by { rw ←sub_comp, exact cokernel.condition _ }),
  is_colimit := cofork.is_colimit.mk _
    (λ s, cokernel.desc (f - g) (cofork.π s) $
      by { rw sub_comp, apply sub_eq_zero.2, exact cofork.condition _ })
    (λ s, by simp)
    (λ s m h, by { ext, simpa using h walking_parallel_pair.one }) }

end

section

/-- If a preadditive category has all cokernels, then it also has all coequalizers. -/
lemma has_coequalizers_of_has_cokernels [has_cokernels C] : has_coequalizers C :=
@has_coequalizers_of_has_colimit_parallel_pair _ _ (λ _ _ f g, has_colimit_parallel_pair f g)

end

end equalizers
end category_theory.preadditive


opaque f : Nat → Nat
opaque g : Nat → Nat

namespace Foo

@[scoped simp] axiom ax1 (x : Nat) : f (g x) = x
@[scoped simp] axiom ax2 (x : Nat) : g (g x) = g x

end Foo

theorem ex1 : f (g (g (g x))) = x := by
  simp -- does not use ax1 and ax2
  simp [Foo.ax1, Foo.ax2]

theorem ex2 : f (g (g (g x))) = x :=
  have h₁ : f (g (g (g x))) = f (g x) := by simp; /- try again with `Foo` scoped lemmas -/ open Foo in simp
  have h₂ : f (g x) = x               := by simp; open Foo in simp
  Eq.trans h₁ h₂
  -- open Foo in simp -- works

theorem ex3 : f (g (g (g x))) = x := by
  simp
  simp [Foo.ax1, Foo.ax2]

open Foo in
theorem ex4 : f (g (g (g x))) = x := by
  simp

theorem ex5 : f (g (g (g x))) = x ∧ f (g x) = x := by
  apply And.intro
  { simp; open Foo in simp }
  { simp; open Foo in simp }


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sites.canonical
import Mathlib.category_theory.sites.sheaf_of_types
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Grothendieck Topology and Sheaves on the Category of Types

In this file we define a Grothendieck topology on the category of types,
and construct the canonical functor that sends a type to a sheaf over
the category of types, and make this an equivalence of categories.

Then we prove that the topology defined is the canonical topology.
-/

namespace category_theory

/-- A Grothendieck topology associated to the category of all types.
A sieve is a covering iff it is jointly surjective. -/
def types_grothendieck_topology : grothendieck_topology (Type u) :=
  grothendieck_topology.mk (fun (α : Type u) (S : sieve α) => ∀ (x : α), coe_fn S PUnit fun (_x : PUnit) => x) sorry sorry
    sorry

/-- The discrete sieve on a type, which only includes arrows whose image is a subsingleton. -/
@[simp] theorem discrete_sieve_apply (α : Type u) (β : Type u) (f : β ⟶ α) : coe_fn (discrete_sieve α) β f = ∃ (x : α), ∀ (y : β), f y = x :=
  Eq.refl (coe_fn (discrete_sieve α) β f)

theorem discrete_sieve_mem (α : Type u) : discrete_sieve α ∈ coe_fn types_grothendieck_topology α :=
  fun (x : α) => Exists.intro x fun (y : PUnit) => rfl

/-- The discrete presieve on a type, which only includes arrows whose domain is a singleton. -/
def discrete_presieve (α : Type u) : presieve α :=
  fun (β : Type u) (f : β ⟶ α) => ∃ (x : β), ∀ (y : β), y = x

theorem generate_discrete_presieve_mem (α : Type u) : sieve.generate (discrete_presieve α) ∈ coe_fn types_grothendieck_topology α := sorry

theorem is_sheaf_yoneda' {α : Type u} : presieve.is_sheaf types_grothendieck_topology (functor.obj yoneda α) := sorry

/-- The yoneda functor that sends a type to a sheaf over the category of types -/
@[simp] theorem yoneda'_map (α : Type u) (β : Type u) (f : α ⟶ β) : functor.map yoneda' f = functor.map yoneda f :=
  Eq.refl (functor.map yoneda' f)

@[simp] theorem yoneda'_comp : yoneda' ⋙ induced_functor subtype.val = yoneda :=
  rfl

/-- Given a presheaf `P` on the category of types, construct
a map `P(α) → (α → P(*))` for all type `α`. -/
def eval (P : Type uᵒᵖ ⥤ Type u) (α : Type u) (s : functor.obj P (opposite.op α)) (x : α) : functor.obj P (opposite.op PUnit) :=
  functor.map P (has_hom.hom.op (↾fun (_x : PUnit) => x)) s

/-- Given a sheaf `S` on the category of types, construct a map
`(α → S(*)) → S(α)` that is inverse to `eval`. -/
def types_glue (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) (α : Type u) (f : α → functor.obj S (opposite.op PUnit)) : functor.obj S (opposite.op α) :=
  presieve.is_sheaf_for.amalgamate sorry
    (fun (β : Type u) (g : β ⟶ α) (hg : discrete_presieve α g) =>
      functor.map S (has_hom.hom.op (↾fun (x : β) => PUnit.unit)) (f (g (classical.some hg))))
    sorry

theorem eval_types_glue {S : Type uᵒᵖ ⥤ Type u} {hs : presieve.is_sheaf types_grothendieck_topology S} {α : Type u} (f : α → functor.obj S (opposite.op PUnit)) : eval S α (types_glue S hs α f) = f := sorry

theorem types_glue_eval {S : Type uᵒᵖ ⥤ Type u} {hs : presieve.is_sheaf types_grothendieck_topology S} {α : Type u} (s : functor.obj S (opposite.op α)) : types_glue S hs α (eval S α s) = s := sorry

/-- Given a sheaf `S`, construct an equivalence `S(α) ≃ (α → S(*))`. -/
def eval_equiv (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) (α : Type u) : functor.obj S (opposite.op α) ≃ (α → functor.obj S (opposite.op PUnit)) :=
  equiv.mk (eval S α) (types_glue S hs α) types_glue_eval eval_types_glue

theorem eval_map (S : Type uᵒᵖ ⥤ Type u) (α : Type u) (β : Type u) (f : β ⟶ α) (s : functor.obj S (opposite.op α)) (x : β) : eval S β (functor.map S (has_hom.hom.op f) s) x = eval S α s (f x) := sorry

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
def equiv_yoneda (S : Type uᵒᵖ ⥤ Type u) (hs : presieve.is_sheaf types_grothendieck_topology S) : S ≅ functor.obj yoneda (functor.obj S (opposite.op PUnit)) :=
  nat_iso.of_components (fun (α : Type uᵒᵖ) => equiv.to_iso (eval_equiv S hs (opposite.unop α))) sorry

/-- Given a sheaf `S`, construct an isomorphism `S ≅ [-, S(*)]`. -/
@[simp] theorem equiv_yoneda'_inv (S : SheafOfTypes types_grothendieck_topology) : iso.inv (equiv_yoneda' S) = iso.inv (equiv_yoneda (subtype.val S) (equiv_yoneda'._proof_1 S)) :=
  Eq.refl (iso.inv (equiv_yoneda' S))

theorem eval_app (S₁ : SheafOfTypes types_grothendieck_topology) (S₂ : SheafOfTypes types_grothendieck_topology) (f : S₁ ⟶ S₂) (α : Type u) (s : functor.obj (subtype.val S₁) (opposite.op α)) (x : α) : eval (subtype.val S₂) α (nat_trans.app f (opposite.op α) s) x =
  nat_trans.app f (opposite.op PUnit) (eval (subtype.val S₁) α s x) :=
  Eq.symm (congr_fun (nat_trans.naturality' f (has_hom.hom.op (↾fun (_x : PUnit) => x))) s)

/-- `yoneda'` induces an equivalence of category between `Type u` and
`Sheaf types_grothendieck_topology`. -/
@[simp] theorem type_equiv_inverse_obj (X : SheafOfTypes types_grothendieck_topology) : functor.obj (equivalence.inverse type_equiv) X = functor.obj (↑X) (opposite.op PUnit) :=
  Eq.refl (functor.obj (↑X) (opposite.op PUnit))

theorem subcanonical_types_grothendieck_topology : sheaf.subcanonical types_grothendieck_topology :=
  sheaf.subcanonical.of_yoneda_is_sheaf types_grothendieck_topology fun (X : Type u) => is_sheaf_yoneda'

theorem types_grothendieck_topology_eq_canonical : types_grothendieck_topology = sheaf.canonical_topology (Type u) := sorry


import ground_zero.types.heq

/-
  Integers ℤ as a quotient of ℕ × ℕ.
  * HoTT 6.10, remark 6.10.7
-/

abbreviation builtin.int := int

namespace ground_zero.HITs

def int.rel : ℕ × ℕ → ℕ × ℕ → Prop
| ⟨a, b⟩ ⟨c, d⟩ := a + d = b + c

def int := quot int.rel
local notation ℤ := int

namespace nat.product
  def add (x y : ℕ × ℕ) : ℕ × ℕ := begin
    cases x with a b, cases y with c d,
    split, apply a + c, apply b + d
  end
  instance : has_add (ℕ × ℕ) := ⟨add⟩

  def mul (x y : ℕ × ℕ) : ℕ × ℕ := begin
    cases x with a b, cases y with c d,
    split, apply a * c + b * d,
    apply a * d + b * c
  end
  instance : has_mul (ℕ × ℕ) := ⟨mul⟩

  lemma add_comm (x y : ℕ × ℕ) : x + y = y + x := begin
    cases x with a b, cases y with c d,
    simp [has_add.add], simp [add]
  end

  lemma mul_comm (x y : ℕ × ℕ) : x * y = y * x := begin
    cases x with a b, cases y with c d,
    simp [has_mul.mul], simp [mul], split,
    { rw [nat.mul_comm c a], rw [nat.mul_comm d b] },
    { rw [nat.mul_comm c b], rw [nat.mul_comm d a],
      rw [nat.add_comm (b * c) (a * d)] }
  end

  lemma rw.add (a b : ℕ × ℕ) : nat.product.add a b = a + b :=
  by trivial

  lemma rw.mul (a b : ℕ × ℕ) : nat.product.mul a b = a * b :=
  by trivial
end nat.product

namespace int
  universes u v

  def mk : ℕ × ℕ → ℤ := quot.mk rel
  def elem (a b : ℕ) : ℤ := quot.mk rel ⟨a, b⟩

  def pos (n : ℕ) := mk ⟨n, 0⟩
  instance : has_coe ℕ ℤ := ⟨pos⟩

  def neg (n : ℕ) := mk ⟨0, n⟩

  instance : has_zero int := ⟨mk ⟨0, 0⟩⟩
  instance : has_one int := ⟨mk ⟨1, 0⟩⟩

  def knife {a b c d : ℕ} (H : a + d = b + c :> ℕ) :
    mk ⟨a, b⟩ = mk ⟨c, d⟩ :> ℤ :=
  ground_zero.support.inclusion $ @quot.sound _ int.rel
    ⟨a, b⟩ ⟨c, d⟩ (ground_zero.support.truncation H)

  def ind {π : ℤ → Sort u}
    (mk₁ : Π (x : ℕ × ℕ), π (mk x))
    (knife₁ : Π {a b c d : ℕ} (H : a + d = b + c :> ℕ),
      mk₁ ⟨a, b⟩ =[knife H] mk₁ ⟨c, d⟩) (x : ℤ) : π x := begin
    refine quot.hrec_on x _ _,
    exact mk₁, intros x y p,
    cases x with a b, cases y with c d,
    refine ground_zero.types.eq.rec _
      (ground_zero.types.equiv.subst_from_pathover
        (knife₁ (ground_zero.support.inclusion p))),
    apply ground_zero.types.heq.eq_subst_heq
  end

  def injs {β : Sort u} (pos₁ : ℕ → β) (zero₁ : β) (neg₁ : ℕ → β) :
    ℕ × ℕ → β
  | ⟨0, 0⟩ := zero₁
  | ⟨n, 0⟩ := pos₁ n
  | ⟨0, n⟩ := neg₁ n
  | ⟨n + 1, m + 1⟩ := if n > m
    then injs ⟨n + 1, m⟩
    else injs ⟨n, m + 1⟩

  def simplify : ℕ × ℕ → ℕ × ℕ
  | ⟨0, 0⟩ := ⟨0, 0⟩
  | ⟨n + 1, 0⟩ := ⟨n + 1, 0⟩
  | ⟨0, n + 1⟩ := ⟨0, n + 1⟩
  | ⟨n + 1, m + 1⟩ := if n > m then ⟨n - m, 0⟩ else ⟨0, m - n⟩

  lemma ite.left {c : Prop} [decidable c] {α : Sort u} {x y : α}
    (h : not c) : ite c x y = y := begin
    unfold ite, tactic.unfreeze_local_instances,
    cases _inst_1 with u v, trivial, contradiction
  end

  lemma ite.right {c : Prop} [decidable c] {α : Sort u} {x y : α}
    (h : c) : ite c x y = x := begin
    unfold ite, tactic.unfreeze_local_instances,
    cases _inst_1 with u v, contradiction, trivial
  end

  /- theorem simplify_correct (x : ℕ × ℕ) : mk x = mk (simplify x) := begin
    apply quot.sound, cases x with u v,
    induction u with u ih₁,
    { induction v with v ih,
      repeat { simp [simplify, rel] } },
    { induction v with v ih₂,
      { simp [simplify, rel] },
      { simp [simplify],
        have H := nat.decidable_le (v + 1) u, induction H;
        unfold gt; unfold has_lt.lt; unfold nat.lt;
        unfold has_le.le at H,
        { rw [ite.left H], unfold rel,
          admit },
        { rw [ite.right H], unfold rel,
          admit } } }
  end

  def blade {π : ℤ → Sort u}
    (pos₁ : Π (n : ℕ), π (elem n 0))
    (zero₁ : π 0)
    (neg₁ : Π (n : ℕ), π (elem 0 n)) :
    Π x, π x := begin
    fapply ind,
    { intro x, cases x with u v, rw [simplify_correct],
      admit },
    admit
  end -/

  instance : has_neg int :=
  ⟨quot.lift
    (λ (x : ℕ × ℕ), mk ⟨x.pr₂, x.pr₁⟩)
    (begin
      intros x y H, simp,
      cases x with a b,
      cases y with c d,
      simp, apply quot.sound,
      simp [rel], simp [rel] at H,
      symmetry, assumption
    end)⟩

  lemma nat_rw (a b : ℕ) : nat.add a b = a + b :=
  by trivial

  def lift₂ (f : ℕ × ℕ → ℕ × ℕ → ℕ × ℕ)
    (h₁ : Π (a b x : ℕ × ℕ) (H : rel a b),
      mk (f x a) = mk (f x b))
    (h₂ : Π (a b : ℕ × ℕ),
      mk (f a b) = mk (f b a))
    (x y : int) : int :=
  quot.lift
    (λ x, quot.lift
          (λ y, mk (f x y))
          (begin intros a b H, simp, apply h₁, assumption end) y)
    (begin
      intros a b H, simp,
      induction y, simp,
      rw [h₂ a y], rw [h₂ b y], apply h₁,
      assumption, trivial
    end) x

  lemma add_saves_int {a b c d : ℕ} (H : a + d = b + c)
    (y : ℕ × ℕ) :
    mk (⟨a, b⟩ + y) = mk (⟨c, d⟩ + y) := begin
    cases y with u v,
    simp [has_add.add],
    apply quot.sound, simp [nat.product.add], simp [rel],
    rw [←nat.add_assoc], rw [H],
    rw [nat.add_assoc]
  end

  def eq_map {α : Sort u} {β : Sort v} {a b : α}
    (f : α → β) (p : a = b) : f a = f b :=
  begin induction p, reflexivity end

  def add : int → int → int := begin
    apply lift₂ nat.product.add,
    { intros x y u H,
      cases x with a b, cases y with c d,
      repeat { rw [nat.product.rw.add] },
      rw [nat.product.add_comm u ⟨a, b⟩],
      rw [nat.product.add_comm u ⟨c, d⟩],
      apply add_saves_int, assumption },
    { intros x y,
      apply eq_map mk,
      apply nat.product.add_comm }
  end

  instance : has_add int := ⟨add⟩
  instance : has_sub int := ⟨λ a b, a + (-b)⟩

  theorem inv_append (a : ℤ) : a + (-a) = 0 := begin
    induction a, cases a with u v,
    simp [has_neg.neg], apply quot.sound,
    simp [nat.product.add], simp [rel],
  end

  theorem send_to_right {a b c : ℤ} : (a + b = c) → (a = c - b) := begin
    intro h, induction a, induction b, induction c,
    cases a with x y, cases b with u v, cases c with p q,
    simp [has_sub.sub, has_neg.neg],
    rw [←h], simp [mk],
    simp [has_add.add] at *, apply quot.sound,
    simp [nat.product.add], simp [rel],
    repeat { trivial }
  end

  def mul : ℤ → ℤ → ℤ := begin
    apply lift₂ nat.product.mul,
    { intros x y z H,
      cases x with a b, cases y with c d,
      cases z with u v, simp [nat.product.mul],
      apply quot.sound, simp [rel],
      rw [←nat.add_assoc (u * a)],
      rw [←nat.add_assoc (u * b)],

      rw [←nat.left_distrib u a d],
      rw [←nat.left_distrib v b c],

      rw [←nat.left_distrib u b c],
      rw [←nat.left_distrib v a d],

      simp [rel] at H, rw [H] },
    { intros x y,
      apply eq_map mk,
      apply nat.product.mul_comm }
  end
  instance : has_mul int := ⟨mul⟩

  theorem k_equiv (a b k : ℕ) : mk ⟨a, b⟩ = mk ⟨a + k, b + k⟩ :=
  begin apply quot.sound, simp [rel] end
end int

end ground_zero.HITs


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.group_theory.submonoid.basic
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes u_2 l u_1

namespace Mathlib

/-!
# Submonoids

This file defines unbundled multiplicative and additive submonoids (deprecated). For bundled form
see `group_theory/submonoid`.

We some results about images and preimages of submonoids under monoid homomorphisms. These theorems
use unbundled monoid homomorphisms (also deprecated).

There are also theorems about the submonoids generated by an element or a subset of a monoid,
defined inductively.

## Implementation notes

Unbundled submonoids will slowly be removed from mathlib.

## Tags
submonoid, submonoids, is_submonoid
-/

/-- `s` is an additive submonoid: a set containing 0 and closed under addition. -/
class is_add_submonoid {A : Type u_2} [add_monoid A] (s : set A) where
  zero_mem : 0 ∈ s
  add_mem : ∀ {a b : A}, a ∈ s → b ∈ s → a + b ∈ s

/-- `s` is a submonoid: a set containing 1 and closed under multiplication. -/
class is_submonoid {M : Type u_1} [monoid M] (s : set M) where
  one_mem : 1 ∈ s
  mul_mem : ∀ {a b : M}, a ∈ s → b ∈ s → a * b ∈ s

theorem additive.is_add_submonoid {M : Type u_1} [monoid M] (s : set M) [is_submonoid s] :
    is_add_submonoid s :=
  is_submonoid.dcases_on _inst_3
    fun (one_mem : 1 ∈ s) (mul_mem : ∀ {a b : M}, a ∈ s → b ∈ s → a * b ∈ s) =>
      idRhs (is_add_submonoid s) (is_add_submonoid.mk one_mem mul_mem)

theorem additive.is_add_submonoid_iff {M : Type u_1} [monoid M] {s : set M} :
    is_add_submonoid s ↔ is_submonoid s :=
  sorry

theorem multiplicative.is_submonoid {A : Type u_2} [add_monoid A] (s : set A) [is_add_submonoid s] :
    is_submonoid s :=
  is_add_submonoid.dcases_on _inst_3
    fun (zero_mem : 0 ∈ s) (add_mem : ∀ {a b : A}, a ∈ s → b ∈ s → a + b ∈ s) =>
      idRhs (is_submonoid s) (is_submonoid.mk zero_mem add_mem)

theorem multiplicative.is_submonoid_iff {A : Type u_2} [add_monoid A] {s : set A} :
    is_submonoid s ↔ is_add_submonoid s :=
  sorry

/-- The intersection of two submonoids of a monoid `M` is a submonoid of `M`. -/
protected instance is_submonoid.inter {M : Type u_1} [monoid M] (s₁ : set M) (s₂ : set M)
    [is_submonoid s₁] [is_submonoid s₂] : is_submonoid (s₁ ∩ s₂) :=
  is_submonoid.mk { left := is_submonoid.one_mem, right := is_submonoid.one_mem }
    fun (x y : M) (hx : x ∈ s₁ ∩ s₂) (hy : y ∈ s₁ ∩ s₂) =>
      { left := is_submonoid.mul_mem (and.left hx) (and.left hy),
        right := is_submonoid.mul_mem (and.right hx) (and.right hy) }

/-- The intersection of an indexed set of submonoids of a monoid `M` is a submonoid of `M`. -/
protected instance is_add_submonoid.Inter {M : Type u_1} [add_monoid M] {ι : Sort u_2}
    (s : ι → set M) [h : ∀ (y : ι), is_add_submonoid (s y)] : is_add_submonoid (set.Inter s) :=
  is_add_submonoid.mk (iff.mpr set.mem_Inter fun (y : ι) => is_add_submonoid.zero_mem)
    fun (x₁ x₂ : M) (h₁ : x₁ ∈ set.Inter s) (h₂ : x₂ ∈ set.Inter s) =>
      iff.mpr set.mem_Inter
        fun (y : ι) =>
          is_add_submonoid.add_mem (iff.mp set.mem_Inter h₁ y) (iff.mp set.mem_Inter h₂ y)

/-- The union of an indexed, directed, nonempty set of submonoids of a monoid `M` is a submonoid
    of `M`. -/
theorem is_add_submonoid_Union_of_directed {M : Type u_1} [add_monoid M] {ι : Type u_2}
    [hι : Nonempty ι] (s : ι → set M) [∀ (i : ι), is_add_submonoid (s i)]
    (directed : ∀ (i j : ι), ∃ (k : ι), s i ⊆ s k ∧ s j ⊆ s k) :
    is_add_submonoid (set.Union fun (i : ι) => s i) :=
  sorry

/-- The set of natural number powers `1, x, x², ...` of an element `x` of a monoid. -/
/-- The set of natural number multiples `0, x, 2x, ...` of an element `x` of an `add_monoid`. -/
def powers {M : Type u_1} [monoid M] (x : M) : set M := set_of fun (y : M) => ∃ (n : ℕ), x ^ n = y

def multiples {A : Type u_2} [add_monoid A] (x : A) : set A :=
  set_of fun (y : A) => ∃ (n : ℕ), n •ℕ x = y

/-- 1 is in the set of natural number powers of an element of a monoid. -/
theorem powers.one_mem {M : Type u_1} [monoid M] {x : M} : 1 ∈ powers x :=
  Exists.intro 0 (pow_zero x)

/-- 0 is in the set of natural number multiples of an element of an `add_monoid`. -/
theorem multiples.zero_mem {A : Type u_2} [add_monoid A] {x : A} : 0 ∈ multiples x :=
  Exists.intro 0 (zero_nsmul x)

/-- An element of a monoid is in the set of that element's natural number powers. -/
theorem powers.self_mem {M : Type u_1} [monoid M] {x : M} : x ∈ powers x :=
  Exists.intro 1 (pow_one x)

/-- An element of an `add_monoid` is in the set of that element's natural number multiples. -/
theorem multiples.self_mem {A : Type u_2} [add_monoid A] {x : A} : x ∈ multiples x :=
  Exists.intro 1 (one_nsmul x)

/-- The set of natural number powers of an element of a monoid is closed under multiplication. -/
theorem powers.mul_mem {M : Type u_1} [monoid M] {x : M} {y : M} {z : M} :
    y ∈ powers x → z ∈ powers x → y * z ∈ powers x :=
  sorry

/-- The set of natural number multiples of an element of an `add_monoid` is closed under
    addition. -/
theorem multiples.add_mem {A : Type u_2} [add_monoid A] {x : A} {y : A} {z : A} :
    y ∈ multiples x → z ∈ multiples x → y + z ∈ multiples x :=
  powers.mul_mem

/-- The set of natural number powers of an element of a monoid `M` is a submonoid of `M`. -/
protected instance multiples.is_add_submonoid {M : Type u_1} [add_monoid M] (x : M) :
    is_add_submonoid (multiples x) :=
  is_add_submonoid.mk multiples.zero_mem fun (y z : M) => multiples.add_mem

/-- A monoid is a submonoid of itself. -/
protected instance univ.is_submonoid {M : Type u_1} [monoid M] : is_submonoid set.univ :=
  is_submonoid.mk
    (eq.mpr (id (propext ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) 1)))
      trivial)
    (eq.mpr
      (id
        (Eq.trans
          (Eq.trans
            (forall_congr_eq
              fun (a : M) =>
                forall_congr_eq
                  fun (b : M) =>
                    Eq.trans
                      (imp_congr_eq
                        (propext
                          ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) a))
                        (Eq.trans
                          (imp_congr_eq
                            (propext
                              ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x)) b))
                            (propext
                              ((fun {α : Type u_1} (x : α) => iff_true_intro (set.mem_univ x))
                                (a * b))))
                          (propext (forall_prop_of_true True.intro))))
                      (propext (forall_prop_of_true True.intro)))
            (propext (forall_const M)))
          (propext (forall_const M))))
      trivial)

/-- The preimage of a submonoid under a monoid hom is a submonoid of the domain. -/
protected instance preimage.is_add_submonoid {M : Type u_1} [add_monoid M] {N : Type u_2}
    [add_monoid N] (f : M → N) [is_add_monoid_hom f] (s : set N) [is_add_submonoid s] :
    is_add_submonoid (f ⁻¹' s) :=
  is_add_submonoid.mk
    ((fun (this : f 0 ∈ s) => this)
      (eq.mpr (id (Eq._oldrec (Eq.refl (f 0 ∈ s)) (is_add_monoid_hom.map_zero f)))
        is_add_submonoid.zero_mem))
    fun (a b : M) (ha : f a ∈ s) (hb : f b ∈ s) =>
      (fun (this : f (a + b) ∈ s) => this)
        (eq.mpr (id (Eq._oldrec (Eq.refl (f (a + b) ∈ s)) (is_add_monoid_hom.map_add f a b)))
          (is_add_submonoid.add_mem ha hb))

/-- The image of a submonoid under a monoid hom is a submonoid of the codomain. -/
instance image.is_add_submonoid {M : Type u_1} [add_monoid M] {γ : Type u_2} [add_monoid γ]
    (f : M → γ) [is_add_monoid_hom f] (s : set M) [is_add_submonoid s] :
    is_add_submonoid (f '' s) :=
  sorry

/-- The image of a monoid hom is a submonoid of the codomain. -/
protected instance range.is_add_submonoid {M : Type u_1} [add_monoid M] {γ : Type u_2}
    [add_monoid γ] (f : M → γ) [is_add_monoid_hom f] : is_add_submonoid (set.range f) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (is_add_submonoid (set.range f))) (Eq.symm set.image_univ)))
    (image.is_add_submonoid f set.univ)

/-- Submonoids are closed under natural powers. -/
theorem is_submonoid.pow_mem {M : Type u_1} [monoid M] {s : set M} {a : M} [is_submonoid s]
    (h : a ∈ s) {n : ℕ} : a ^ n ∈ s :=
  sorry

/-- An `add_submonoid` is closed under multiplication by naturals. -/
theorem is_add_submonoid.smul_mem {A : Type u_2} [add_monoid A] {t : set A} {a : A}
    [is_add_submonoid t] (h : a ∈ t) {n : ℕ} : n •ℕ a ∈ t :=
  is_submonoid.pow_mem

/-- The set of natural number powers of an element of a submonoid is a subset of the submonoid. -/
theorem is_submonoid.power_subset {M : Type u_1} [monoid M] {s : set M} {a : M} [is_submonoid s]
    (h : a ∈ s) : powers a ⊆ s :=
  sorry

/-- The set of natural number multiples of an element of an `add_submonoid` is a subset of the
    `add_submonoid`. -/
theorem is_add_submonoid.multiple_subset {A : Type u_2} [add_monoid A] {t : set A} {a : A}
    [is_add_submonoid t] : a ∈ t → multiples a ⊆ t :=
  is_submonoid.power_subset

namespace is_submonoid

/-- The product of a list of elements of a submonoid is an element of the submonoid. -/
theorem list_prod_mem {M : Type u_1} [monoid M] {s : set M} [is_submonoid s] {l : List M} :
    (∀ (x : M), x ∈ l → x ∈ s) → list.prod l ∈ s :=
  sorry

/-- The product of a multiset of elements of a submonoid of a `comm_monoid` is an element of
the submonoid. -/
theorem Mathlib.is_add_submonoid.multiset_sum_mem {M : Type u_1} [add_comm_monoid M] (s : set M)
    [is_add_submonoid s] (m : multiset M) : (∀ (a : M), a ∈ m → a ∈ s) → multiset.sum m ∈ s :=
  sorry

/-- The product of elements of a submonoid of a `comm_monoid` indexed by a `finset` is an element
of the submonoid. -/
theorem finset_prod_mem {M : Type u_1} {A : Type u_2} [comm_monoid M] (s : set M) [is_submonoid s]
    (f : A → M) (t : finset A) :
    (∀ (b : A), b ∈ t → f b ∈ s) → (finset.prod t fun (b : A) => f b) ∈ s :=
  sorry

end is_submonoid

-- TODO: modify `subtype_instance` to produce this definition, then use it here

--  and for `subtype.group`

/-- Submonoids are themselves monoids. -/
def subtype.add_monoid {M : Type u_1} [add_monoid M] {s : set M} [is_add_submonoid s] :
    add_monoid ↥s :=
  add_monoid.mk (fun (x y : ↥s) => { val := ↑x + ↑y, property := sorry }) sorry
    { val := 0, property := is_add_submonoid.zero_mem } sorry sorry

/-- Submonoids of commutative monoids are themselves commutative monoids. -/
def subtype.add_comm_monoid {M : Type u_1} [add_comm_monoid M] {s : set M} [is_add_submonoid s] :
    add_comm_monoid ↥s :=
  add_comm_monoid.mk add_monoid.add sorry add_monoid.zero sorry sorry sorry

/-- Submonoids inherit the 1 of the monoid. -/
@[simp] theorem is_submonoid.coe_one {M : Type u_1} [monoid M] {s : set M} [is_submonoid s] :
    ↑1 = 1 :=
  rfl

/-- Submonoids inherit the multiplication of the monoid. -/
@[simp] theorem is_add_submonoid.coe_add {M : Type u_1} [add_monoid M] {s : set M}
    [is_add_submonoid s] (a : ↥s) (b : ↥s) : ↑(a + b) = ↑a + ↑b :=
  rfl

/-- Submonoids inherit the exponentiation by naturals of the monoid. -/
@[simp] theorem is_submonoid.coe_pow {M : Type u_1} [monoid M] {s : set M} [is_submonoid s] (a : ↥s)
    (n : ℕ) : ↑(a ^ n) = ↑a ^ n :=
  sorry

/-- An `add_submonoid` inherits the multiplication by naturals of the `add_monoid`. -/
@[simp] theorem is_add_submonoid.smul_coe {A : Type u_1} [add_monoid A] {s : set A}
    [is_add_submonoid s] (a : ↥s) (n : ℕ) : ↑(n •ℕ a) = n •ℕ ↑a :=
  sorry

/-- The natural injection from a submonoid into the monoid is a monoid hom. -/
protected instance subtype_val.is_add_monoid_hom {M : Type u_1} [add_monoid M] {s : set M}
    [is_add_submonoid s] : is_add_monoid_hom subtype.val :=
  is_add_monoid_hom.mk rfl

/-- The natural injection from a submonoid into the monoid is a monoid hom. -/
protected instance coe.is_add_monoid_hom {M : Type u_1} [add_monoid M] {s : set M}
    [is_add_submonoid s] : is_add_monoid_hom coe :=
  subtype_val.is_add_monoid_hom

/-- Given a monoid hom `f : γ → M` whose image is contained in a submonoid `s`, the induced map
    from `γ` to `s` is a monoid hom. -/
protected instance subtype_mk.is_add_monoid_hom {M : Type u_1} [add_monoid M] {s : set M}
    {γ : Type u_2} [add_monoid γ] [is_add_submonoid s] (f : γ → M) [is_add_monoid_hom f]
    (h : ∀ (x : γ), f x ∈ s) : is_add_monoid_hom fun (x : γ) => { val := f x, property := h x } :=
  is_add_monoid_hom.mk (subtype.eq (is_add_monoid_hom.map_zero f))

/-- Given two submonoids `s` and `t` such that `s ⊆ t`, the natural injection from `s` into `t` is
    a monoid hom. -/
protected instance set_inclusion.is_monoid_hom {M : Type u_1} [monoid M] {s : set M} (t : set M)
    [is_submonoid s] [is_submonoid t] (h : s ⊆ t) : is_monoid_hom (set.inclusion h) :=
  subtype_mk.is_monoid_hom (fun (x : ↥s) => ↑x) fun (x : ↥s) => set.inclusion._proof_1 h x

namespace add_monoid

/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive in_closure {A : Type u_2} [add_monoid A] (s : set A) : A → Prop where
| basic : ∀ {a : A}, a ∈ s → in_closure s a
| zero : in_closure s 0
| add : ∀ {a b : A}, in_closure s a → in_closure s b → in_closure s (a + b)

end add_monoid

namespace monoid

/-- The inductively defined membership predicate for the `add_submonoid` generated by a subset of an
    add_monoid. -/
inductive in_closure {M : Type u_1} [monoid M] (s : set M) : M → Prop where
| basic : ∀ {a : M}, a ∈ s → in_closure s a
| one : in_closure s 1
| mul : ∀ {a b : M}, in_closure s a → in_closure s b → in_closure s (a * b)

/-- The inductively defined submonoid generated by a subset of a monoid. -/
def Mathlib.add_monoid.closure {M : Type u_1} [add_monoid M] (s : set M) : set M :=
  set_of fun (a : M) => add_monoid.in_closure s a

protected instance Mathlib.add_monoid.closure.is_add_submonoid {M : Type u_1} [add_monoid M]
    (s : set M) : is_add_submonoid (add_monoid.closure s) :=
  is_add_submonoid.mk add_monoid.in_closure.zero fun (a b : M) => add_monoid.in_closure.add

/-- A subset of a monoid is contained in the submonoid it generates. -/
theorem Mathlib.add_monoid.subset_closure {M : Type u_1} [add_monoid M] {s : set M} :
    s ⊆ add_monoid.closure s :=
  fun (a : M) => add_monoid.in_closure.basic

/-- The submonoid generated by a set is contained in any submonoid that contains the set. -/
theorem Mathlib.add_monoid.closure_subset {M : Type u_1} [add_monoid M] {s : set M} {t : set M}
    [is_add_submonoid t] (h : s ⊆ t) : add_monoid.closure s ⊆ t :=
  sorry

/-- Given subsets `t` and `s` of a monoid `M`, if `s ⊆ t`, the submonoid of `M` generated by `s` is
    contained in the submonoid generated by `t`. -/
theorem Mathlib.add_monoid.closure_mono {M : Type u_1} [add_monoid M] {s : set M} {t : set M}
    (h : s ⊆ t) : add_monoid.closure s ⊆ add_monoid.closure t :=
  add_monoid.closure_subset (set.subset.trans h add_monoid.subset_closure)

/-- The submonoid generated by an element of a monoid equals the set of natural number powers of
    the element. -/
theorem closure_singleton {M : Type u_1} [monoid M] {x : M} : closure (singleton x) = powers x :=
  set.eq_of_subset_of_subset (closure_subset (iff.mpr set.singleton_subset_iff powers.self_mem))
    (is_submonoid.power_subset (iff.mp set.singleton_subset_iff subset_closure))

/-- The image under a monoid hom of the submonoid generated by a set equals the submonoid generated
    by the image of the set under the monoid hom. -/
theorem Mathlib.add_monoid.image_closure {M : Type u_1} [add_monoid M] {A : Type u_2} [add_monoid A]
    (f : M → A) [is_add_monoid_hom f] (s : set M) :
    f '' add_monoid.closure s = add_monoid.closure (f '' s) :=
  sorry

/-- Given an element `a` of the submonoid of a monoid `M` generated by a set `s`, there exists
a list of elements of `s` whose product is `a`. -/
theorem Mathlib.add_monoid.exists_list_of_mem_closure {M : Type u_1} [add_monoid M] {s : set M}
    {a : M} (h : a ∈ add_monoid.closure s) :
    ∃ (l : List M), (∀ (x : M), x ∈ l → x ∈ s) ∧ list.sum l = a :=
  sorry

/-- Given sets `s, t` of a commutative monoid `M`, `x ∈ M` is in the submonoid of `M` generated by
    `s ∪ t` iff there exists an element of the submonoid generated by `s` and an element of the
    submonoid generated by `t` whose product is `x`. -/
theorem Mathlib.add_monoid.mem_closure_union_iff {M : Type u_1} [add_comm_monoid M] {s : set M}
    {t : set M} {x : M} :
    x ∈ add_monoid.closure (s ∪ t) ↔
        ∃ (y : M),
          ∃ (H : y ∈ add_monoid.closure s),
            ∃ (z : M), ∃ (H : z ∈ add_monoid.closure t), y + z = x :=
  sorry

end monoid

/-- Create a bundled submonoid from a set `s` and `[is_submonoid s]`. -/
def add_submonoid.of {M : Type u_1} [add_monoid M] (s : set M) [h : is_add_submonoid s] :
    add_submonoid M :=
  add_submonoid.mk s is_add_submonoid.zero_mem is_add_submonoid.add_mem

protected instance submonoid.is_submonoid {M : Type u_1} [monoid M] (S : submonoid M) :
    is_submonoid ↑S :=
  is_submonoid.mk (submonoid.one_mem' S) (submonoid.mul_mem' S)

end Mathlib


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import data.set.pairwise
import data.set_like.basic

/-!
# Chains and flags

This file defines chains for an arbitrary relation and flags for an order and proves Hausdorff's
Maximality Principle.

## Main declarations

* `is_chain s`: A chain `s` is a set of comparable elements.
* `max_chain_spec`: Hausdorff's Maximality Principle.
* `flag`: The type of flags, aka maximal chains, of an order.

## Notes

Originally ported from Isabelle/HOL. The
[original file](https://isabelle.in.tum.de/dist/library/HOL/HOL/Zorn.html) was written by Jacques D.
Fleuriot, Tobias Nipkow, Christian Sternagel.
-/

open classical set

variables {α β : Type*}

/-! ### Chains -/

section chain
variables (r : α → α → Prop)

local infix ` ≺ `:50 := r

/-- A chain is a set `s` satisfying `x ≺ y ∨ x = y ∨ y ≺ x` for all `x y ∈ s`. -/
def is_chain (s : set α) : Prop := s.pairwise (λ x y, x ≺ y ∨ y ≺ x)

/-- `super_chain s t` means that `t` is a chain that strictly includes `s`. -/
def super_chain (s t : set α) : Prop := is_chain r t ∧ s ⊂ t

/-- A chain `s` is a maximal chain if there does not exists a chain strictly including `s`. -/
def is_max_chain (s : set α) : Prop := is_chain r s ∧ ∀ ⦃t⦄, is_chain r t → s ⊆ t → s = t

variables {r} {c c₁ c₂ c₃ s t : set α} {a b x y : α}

lemma is_chain_empty : is_chain r ∅ := set.pairwise_empty _

lemma set.subsingleton.is_chain (hs : s.subsingleton) : is_chain r s := hs.pairwise _

lemma is_chain.mono : s ⊆ t → is_chain r t → is_chain r s := set.pairwise.mono

lemma is_chain.mono_rel {r' : α → α → Prop} (h : is_chain r s)
  (h_imp : ∀ x y, r x y → r' x y) : is_chain r' s :=
h.mono' $ λ x y, or.imp (h_imp x y) (h_imp y x)

/-- This can be used to turn `is_chain (≥)` into `is_chain (≤)` and vice-versa. -/
lemma is_chain.symm (h : is_chain r s) : is_chain (flip r) s := h.mono' $ λ _ _, or.symm

lemma is_chain_of_trichotomous [is_trichotomous α r] (s : set α) : is_chain r s :=
λ a _ b _ hab, (trichotomous_of r a b).imp_right $ λ h, h.resolve_left hab

lemma is_chain.insert (hs : is_chain r s) (ha : ∀ b ∈ s, a ≠ b → a ≺ b ∨ b ≺ a) :
  is_chain r (insert a s) :=
hs.insert_of_symmetric (λ _ _, or.symm) ha

lemma is_chain_univ_iff : is_chain r (univ : set α) ↔ is_trichotomous α r :=
begin
  refine ⟨λ h, ⟨λ a b , _⟩, λ h, @is_chain_of_trichotomous _ _ h univ⟩,
  rw [or.left_comm, or_iff_not_imp_left],
  exact h trivial trivial,
end

lemma is_chain.image (r : α → α → Prop) (s : β → β → Prop) (f : α → β)
  (h : ∀ x y, r x y → s (f x) (f y)) {c : set α} (hrc : is_chain r c) :
  is_chain s (f '' c) :=
λ x ⟨a, ha₁, ha₂⟩ y ⟨b, hb₁, hb₂⟩, ha₂ ▸ hb₂ ▸ λ hxy,
  (hrc ha₁ hb₁ $ ne_of_apply_ne f hxy).imp (h _ _) (h _ _)

section total
variables [is_refl α r]

lemma is_chain.total (h : is_chain r s) (hx : x ∈ s) (hy : y ∈ s) : x ≺ y ∨ y ≺ x :=
(eq_or_ne x y).elim (λ e, or.inl $ e ▸ refl _) (h hx hy)

lemma is_chain.directed_on (H : is_chain r s) : directed_on r s :=
λ x hx y hy, (H.total hx hy).elim (λ h, ⟨y, hy, h, refl _⟩) $ λ h, ⟨x, hx, refl _, h⟩

protected lemma is_chain.directed {f : β → α} {c : set β} (h : is_chain (f ⁻¹'o r) c) :
  directed r (λ x : {a : β // a ∈ c}, f x) :=
λ ⟨a, ha⟩ ⟨b, hb⟩, by_cases
  (λ hab : a = b, by simp only [hab, exists_prop, and_self, subtype.exists];
    exact ⟨b, hb, refl _⟩) $
  λ hab, (h ha hb hab).elim (λ h, ⟨⟨b, hb⟩, h, refl _⟩) $ λ h, ⟨⟨a, ha⟩, refl _, h⟩

end total

lemma is_max_chain.is_chain (h : is_max_chain r s) : is_chain r s := h.1
lemma is_max_chain.not_super_chain (h : is_max_chain r s) : ¬super_chain r s t :=
λ ht, ht.2.ne $ h.2 ht.1 ht.2.1

lemma is_max_chain.bot_mem [has_le α] [order_bot α] (h : is_max_chain (≤) s) : ⊥ ∈ s :=
(h.2 (h.1.insert $ λ a _ _, or.inl bot_le) $ subset_insert _ _).symm ▸ mem_insert _ _

lemma is_max_chain.top_mem [has_le α] [order_top α] (h : is_max_chain (≤) s) : ⊤ ∈ s :=
(h.2 (h.1.insert $ λ a _ _, or.inr le_top) $ subset_insert _ _).symm ▸ mem_insert _ _

open_locale classical

/-- Given a set `s`, if there exists a chain `t` strictly including `s`, then `succ_chain s`
is one of these chains. Otherwise it is `s`. -/
def succ_chain (r : α → α → Prop) (s : set α) : set α :=
if h : ∃ t, is_chain r s ∧ super_chain r s t then some h else s

lemma succ_chain_spec (h : ∃ t, is_chain r s ∧ super_chain r s t) :
  super_chain r s (succ_chain r s) :=
let ⟨t, hc'⟩ := h in
have is_chain r s ∧ super_chain r s (some h),
  from @some_spec _ (λ t, is_chain r s ∧ super_chain r s t) _,
by simp [succ_chain, dif_pos, h, this.right]

lemma is_chain.succ (hs : is_chain r s) : is_chain r (succ_chain r s) :=
if h : ∃ t, is_chain r s ∧ super_chain r s t then (succ_chain_spec h).1
  else by { simp [succ_chain, dif_neg, h], exact hs }

lemma is_chain.super_chain_succ_chain (hs₁ : is_chain r s) (hs₂ : ¬ is_max_chain r s) :
  super_chain r s (succ_chain r s) :=
begin
  simp [is_max_chain, not_and_distrib, not_forall_not] at hs₂,
  obtain ⟨t, ht, hst⟩ := hs₂.neg_resolve_left hs₁,
  exact succ_chain_spec ⟨t, hs₁, ht, ssubset_iff_subset_ne.2 hst⟩,
end

lemma subset_succ_chain : s ⊆ succ_chain r s :=
if h : ∃ t, is_chain r s ∧ super_chain r s t then (succ_chain_spec h).2.1
  else by simp [succ_chain, dif_neg, h, subset.rfl]

/-- Predicate for whether a set is reachable from `∅` using `succ_chain` and `⋃₀`. -/
inductive chain_closure (r : α → α → Prop) : set α → Prop
| succ : ∀ {s}, chain_closure s → chain_closure (succ_chain r s)
| union : ∀ {s}, (∀ a ∈ s, chain_closure a) → chain_closure (⋃₀ s)

/-- An explicit maximal chain. `max_chain` is taken to be the union of all sets in `chain_closure`.
-/
def max_chain (r : α → α → Prop) := ⋃₀ set_of (chain_closure r)

lemma chain_closure_empty : chain_closure r ∅ :=
have chain_closure r (⋃₀ ∅),
  from chain_closure.union $ λ a h, h.rec _,
by simpa using this

lemma chain_closure_max_chain : chain_closure r (max_chain r) := chain_closure.union $ λ s, id

private lemma chain_closure_succ_total_aux (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂)
  (h : ∀ ⦃c₃⦄, chain_closure r c₃ → c₃ ⊆ c₂ → c₂ = c₃ ∨ succ_chain r c₃ ⊆ c₂) :
  succ_chain r c₂ ⊆ c₁ ∨ c₁ ⊆ c₂ :=
begin
  induction hc₁,
  case succ : c₃ hc₃ ih
  { cases ih with ih ih,
    { exact or.inl (ih.trans subset_succ_chain) },
    { exact (h hc₃ ih).imp_left (λ h, h ▸ subset.rfl) } },
  case union : s hs ih
  { refine (or_iff_not_imp_left.2 $ λ hn, sUnion_subset $ λ a ha, _),
    exact (ih a ha).resolve_left (λ h, hn $ h.trans $ subset_sUnion_of_mem ha) }
end

private lemma chain_closure_succ_total (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂)
  (h : c₁ ⊆ c₂) :
  c₂ = c₁ ∨ succ_chain r c₁ ⊆ c₂ :=
begin
  induction hc₂ generalizing c₁ hc₁ h,
  case succ : c₂ hc₂ ih
  { refine (chain_closure_succ_total_aux hc₁ hc₂ $ λ c₁, ih).imp h.antisymm' (λ h₁, _),
    obtain rfl | h₂ := ih hc₁ h₁,
    { exact subset.rfl },
    { exact h₂.trans subset_succ_chain } },
  case union : s hs ih
  { apply or.imp_left h.antisymm',
    apply classical.by_contradiction,
    simp [not_or_distrib, sUnion_subset_iff, not_forall],
    intros c₃ hc₃ h₁ h₂,
    obtain h | h := chain_closure_succ_total_aux hc₁ (hs c₃ hc₃) (λ c₄, ih _ hc₃),
    { exact h₁ (subset_succ_chain.trans h) },
    obtain h' | h' := ih c₃ hc₃ hc₁ h,
    { exact h₁ h'.subset },
    { exact h₂ (h'.trans $ subset_sUnion_of_mem hc₃) } }
end

lemma chain_closure.total (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂) :
  c₁ ⊆ c₂ ∨ c₂ ⊆ c₁ :=
(chain_closure_succ_total_aux hc₂ hc₁ $ λ c₃ hc₃, chain_closure_succ_total hc₃ hc₁).imp_left
  subset_succ_chain.trans

lemma chain_closure.succ_fixpoint (hc₁ : chain_closure r c₁) (hc₂ : chain_closure r c₂)
  (hc : succ_chain r c₂ = c₂) :
  c₁ ⊆ c₂ :=
begin
  induction hc₁,
  case succ : s₁ hc₁ h
  { exact (chain_closure_succ_total hc₁ hc₂ h).elim (λ h, h ▸ hc.subset) id },
  case union : s hs ih
  { exact sUnion_subset ih }
end

lemma chain_closure.succ_fixpoint_iff (hc : chain_closure r c) :
  succ_chain r c = c ↔ c = max_chain r :=
⟨λ h, (subset_sUnion_of_mem hc).antisymm $ chain_closure_max_chain.succ_fixpoint hc h,
  λ h, subset_succ_chain.antisymm' $ (subset_sUnion_of_mem hc.succ).trans h.symm.subset⟩

lemma chain_closure.is_chain (hc : chain_closure r c) : is_chain r c :=
begin
  induction hc,
  case succ : c hc h
  { exact h.succ },
  case union : s hs h
  { change ∀ c ∈ s, is_chain r c at h,
    exact λ c₁ ⟨t₁, ht₁, (hc₁ : c₁ ∈ t₁)⟩ c₂ ⟨t₂, ht₂, (hc₂ : c₂ ∈ t₂)⟩ hneq,
      ((hs _ ht₁).total $ hs _ ht₂).elim
        (λ ht, h t₂ ht₂ (ht hc₁) hc₂ hneq)
        (λ ht, h t₁ ht₁ hc₁ (ht hc₂) hneq) }
end

/-- **Hausdorff's maximality principle**

There exists a maximal totally ordered set of `α`.
Note that we do not require `α` to be partially ordered by `r`. -/
lemma max_chain_spec : is_max_chain r (max_chain r) :=
classical.by_contradiction $ λ h,
let ⟨h₁, H⟩ := chain_closure_max_chain.is_chain.super_chain_succ_chain h in
  H.ne (chain_closure_max_chain.succ_fixpoint_iff.mpr rfl).symm

end chain

/-! ### Flags -/

/-- The type of flags, aka maximal chains, of an order. -/
structure flag (α : Type*) [has_le α] :=
(carrier : set α)
(chain' : is_chain (≤) carrier)
(max_chain' : ∀ ⦃s⦄, is_chain (≤) s → carrier ⊆ s → carrier = s)

namespace flag
section has_le
variables [has_le α] {s t : flag α} {a : α}

instance : set_like (flag α) α :=
{ coe := carrier,
  coe_injective' := λ s t h, by { cases s, cases t, congr' } }

@[ext] lemma ext : (s : set α) = t → s = t := set_like.ext'
@[simp] lemma mem_coe_iff : a ∈ (s : set α) ↔ a ∈ s := iff.rfl
@[simp] lemma coe_mk (s : set α) (h₁ h₂) : (mk s h₁ h₂ : set α) = s := rfl
@[simp] lemma mk_coe (s : flag α) : mk (s : set α) s.chain' s.max_chain' = s := ext rfl

lemma chain_le (s : flag α) : is_chain (≤) (s : set α) := s.chain'
protected lemma max_chain (s : flag α) : is_max_chain (≤) (s : set α) := ⟨s.chain_le, s.max_chain'⟩

lemma top_mem [order_top α] (s : flag α) : (⊤ : α) ∈ s := s.max_chain.top_mem
lemma bot_mem [order_bot α] (s : flag α) : (⊥ : α) ∈ s := s.max_chain.bot_mem

end has_le

section preorder
variables [preorder α] {a b : α}

protected lemma le_or_le (s : flag α) (ha : a ∈ s) (hb : b ∈ s) : a ≤ b ∨ b ≤ a :=
s.chain_le.total ha hb

instance [order_top α] (s : flag α) : order_top s := subtype.order_top s.top_mem
instance [order_bot α] (s : flag α) : order_bot s := subtype.order_bot s.bot_mem
instance [bounded_order α] (s : flag α) : bounded_order s :=
subtype.bounded_order s.bot_mem s.top_mem

end preorder

section partial_order
variables [partial_order α]

lemma chain_lt (s : flag α) : is_chain (<) (s : set α) :=
λ a ha b hb h, (s.le_or_le ha hb).imp h.lt_of_le h.lt_of_le'

instance [decidable_eq α] [@decidable_rel α (≤)] [@decidable_rel α (<)] (s : flag α) :
  linear_order s :=
{ le_total := λ a b, s.le_or_le a.2 b.2,
  decidable_eq := subtype.decidable_eq,
  decidable_le := subtype.decidable_le,
  decidable_lt := subtype.decidable_lt,
  ..subtype.partial_order _ }

end partial_order

instance [linear_order α] : unique (flag α) :=
{ default := ⟨univ, is_chain_of_trichotomous _, λ s _, s.subset_univ.antisymm'⟩,
  uniq := λ s, set_like.coe_injective $ s.3 (is_chain_of_trichotomous _) $ subset_univ _ }

end flag


section
variables {α : Type*} [semiring α]

theorem mul_two_eq_add_self (x : α) : x * 2 = x + x :=
show x * (1 + 1) = x + x, by rw [mul_add, mul_one]

theorem two_mul_eq_add_self (x : α) : 2 * x = x + x :=
show (1 + 1) * x = x + x, by rw [add_mul, one_mul]

end

namespace linear_ordered_ring
variables (α : Type*) [i : linear_ordered_ring α]
include i

lemma one_pos : (0:α) < 1 := zero_lt_one α

lemma two_pos : (0:α) < 2 := _root_.add_pos (one_pos α) (one_pos α)

variable {α}

lemma add_pos (x y : α) : 0 < x → 0 < y → 0 < x + y := _root_.add_pos

lemma succ_pos (x : α) : 0 < x → 0 < x + 1 := λ h, add_pos x 1 h (one_pos α)

-- linear_ordered_ring.mul_pos (x y : α) : 0 < x → 0 < y → 0 < x * y

lemma bit0_pos (x : α) : 0 < x → 0 < bit0 x := λ h, add_pos x x h h

lemma bit1_pos (x : α) : 0 < x → 0 < bit1 x := λ h, succ_pos (bit0 x) (bit0_pos x h)

class num_pos (x : α) := (elim : (0:α) < x)

namespace num_pos
variable {i}

@[priority 30] instance one : @num_pos α i (1:α) := ⟨one_pos α⟩
@[priority 30] instance two : @num_pos α i (2:α) := ⟨two_pos α⟩
@[priority 30] instance bit0 (x : α) [@num_pos α i x] : @num_pos α i (bit0 x) := ⟨bit0_pos x (elim x)⟩
@[priority 30] instance bit1 (x : α) [@num_pos α i x] : @num_pos α i (bit1 x) := ⟨bit1_pos x (elim x)⟩
@[priority 10] instance succ (x : α) [@num_pos α i x] : @num_pos α i (x+1) := ⟨succ_pos x (elim x)⟩
@[priority 20] instance add (x y : α) [@num_pos α i x] [@num_pos α i y] : @num_pos α i (x + y) := ⟨add_pos x y (elim x) (elim y)⟩
@[priority 30] instance mul (x y : α) [@num_pos α i x] [@num_pos α i y] : @num_pos α i (x * y) := ⟨mul_pos x y (elim x) (elim y)⟩

end num_pos

class num_nonzero (x : α) := (elim : x ≠ (0:α))

@[priority 30] instance of_pos (x : α) {i : linear_ordered_ring α} [@num_pos α i x] : num_nonzero x := ⟨ne_of_gt $ num_pos.elim x⟩

end linear_ordered_ring

theorem pos_trivial {α : Type*} [linear_ordered_ring α] (x : α) [linear_ordered_ring.num_pos x] : (0:α) < x := linear_ordered_ring.num_pos.elim x
theorem nonzero_trivial {α : Type*} [linear_ordered_ring α] (x : α) [linear_ordered_ring.num_nonzero x] : x ≠ 0 := linear_ordered_ring.num_nonzero.elim x

section
variables {α : Type*} [linear_ordered_ring α]

theorem le_of_mul_ge_mul_left {a b c : α} : c * b ≤ c * a → c < 0 → a ≤ b :=
begin
intros h hc,
have hc : -c > 0 := neg_pos_of_neg hc,
apply le_of_mul_le_mul_left _ hc,
apply le_of_neg_le_neg,
rw [neg_mul_eq_neg_mul, neg_mul_eq_neg_mul, neg_neg],
assumption,
end

theorem le_of_mul_ge_mul_right {a b c : α} : b * c ≤ a * c → c < 0 → a ≤ b :=
begin
intros h hc,
have hc : -c > 0 := neg_pos_of_neg hc,
apply le_of_mul_le_mul_right _ hc,
apply le_of_neg_le_neg,
rw [neg_mul_eq_mul_neg, neg_mul_eq_mul_neg, neg_neg],
assumption,
end

end

section
variables {α : Type*} [linear_ordered_field α]

theorem div_le_of_le_mul_of_pos {x y : α} (z : α) : x ≤ y*z → 0 < z → x/z ≤ y :=
begin
intros hm hz,
apply le_of_mul_le_mul_right _ hz,
transitivity x,
{ apply le_of_eq,
  apply div_mul_cancel,
  apply ne_of_gt,
  assumption },
{ assumption },
end

theorem le_div_of_mul_le_of_pos {x y : α} (z : α) : x*z ≤ y → 0 < z → x ≤ y/z :=
begin
intros hm hz,
apply le_of_mul_le_mul_right _ hz,
transitivity y,
{ assumption },
{ apply le_of_eq,
  symmetry,
  apply div_mul_cancel,
  apply ne_of_gt,
  assumption },
end

theorem le_div_of_mul_ge_of_neg {x y : α} (z : α) : y ≤ x*z → z < 0 → x ≤ y/z :=
begin
intros hm hz,
apply le_of_mul_ge_mul_right _ hz,
transitivity y,
{ apply le_of_eq,
  apply div_mul_cancel,
  apply ne_of_lt,
  assumption },
{ assumption },
end

theorem div_le_of_ge_mul_of_neg {x y : α} (z : α) : y*z ≤ x → z < 0 → x/z ≤ y :=
begin
intros hm hz,
apply le_of_mul_ge_mul_right _ hz,
transitivity x,
{ assumption },
{ apply le_of_eq,
  symmetry,
  apply div_mul_cancel,
  apply ne_of_lt,
  assumption },
end

end

namespace order

inductive {u} lt_cmp {α : Type u} [has_lt α] (x y : α) : Type u
| eq : x = y → lt_cmp
| lt : x < y → lt_cmp
| gt : y < x → lt_cmp

inductive {u} le_cmp {α : Type u} [has_le α] (x y : α) : Type u
| le : x ≤ y → le_cmp
| ge : y ≤ x → le_cmp

variables {α : Type*} [decidable_linear_order α]

def lt_compare (x y : α) : lt_cmp x y :=
if hlt : x < y then
lt_cmp.lt hlt
else if hgt : y < x then
lt_cmp.gt hgt
else
lt_cmp.eq $ le_antisymm (le_of_not_gt hgt) (le_of_not_gt hlt)

def le_compare (x y : α) : le_cmp x y :=
if h : x < y then
le_cmp.le (le_of_lt h)
else
le_cmp.ge (le_of_not_gt h)

@[elab_as_eliminator]
def trichotomy_on (x y : α) {C : Sort*} : (x = y → C) → (x < y → C) → (y < x → C) → C :=
λ heq hlt hgt, lt_cmp.cases_on (lt_compare x y) heq hlt hgt

@[elab_as_eliminator]
def dichotomy_on (x y : α) {C : Sort*} : (x ≤ y → C) → (y ≤ x → C) → C :=
λ hle hge, le_cmp.cases_on (le_compare x y) hle hge

end order

namespace tactic
open interactive

/--
`by_trichotomy (x, y)` splits the goal into three branches, the first assuming `x = y`,
the second assuming `x < y` and the third assuming `y < x`.

This tactic requires that terms `x` and `y` have the same type and that this type has
`decidable_linear_order` instance.
-/
meta def interactive.by_trichotomy : parse types.texpr → tactic unit :=
λ e, do {
  `(@prod.mk %%t %%.(t) %%x %%y) ← to_expr e,
  d ← to_expr ``(decidable_linear_order %%t) >>= mk_instance
    <|> fail ("cannot find decidable_linear_order instance for type " ++ to_string t),
  to_expr ``(@order.trichotomy_on %%t %%d %%x %%y) >>= apply >> skip
}

/--
`by_trichotomy (x, y)` splits the goal into two branches, the first assuming `x ≤ y`
and the second assuming `y ≤ x`.

This tactic requires that terms `x` and `y` have the same type and that this type has
`decidable_linear_order` instance.
-/
meta def interactive.by_dichotomy : parse types.texpr → tactic unit :=
λ e, do {
  `(@prod.mk %%t %%.(t) %%x %%y) ← to_expr e,
  d ← to_expr ``(decidable_linear_order %%t) >>= mk_instance
    <|> fail ("cannot find decidable_linear_order instance for " ++ to_string t),
  to_expr ``(@order.dichotomy_on %%t %%d %%x %%y) >>= apply >> skip
}

end tactic


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import algebra.group_action_hom
import algebra.module.basic
import data.set_like.basic
import group_theory.group_action.basic
/-!

# Sets invariant to a `mul_action`

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

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

## Main definitions

* `sub_mul_action.mul_action` - the `mul_action R M` transferred to the subtype.
* `sub_mul_action.mul_action'` - the `mul_action S M` transferred to the subtype when
  `is_scalar_tower S R M`.
* `sub_mul_action.is_scalar_tower` - the `is_scalar_tower S R M` transferred to the subtype.

## Tags

submodule, mul_action
-/

open function

universes u u' u'' v
variables {S : Type u'} {T : Type u''} {R : Type u} {M : Type v}

set_option old_structure_cmd true

/-- 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] : Type v :=
(carrier : set M)
(smul_mem' : ∀ (c : R) {x : M}, x ∈ carrier → c • x ∈ carrier)

namespace sub_mul_action

variables [has_scalar R M]

instance : set_like (sub_mul_action R M) M :=
⟨sub_mul_action.carrier, λ p q h, by cases p; cases q; congr'⟩

@[simp] lemma mem_carrier {p : sub_mul_action R M} {x : M} : x ∈ p.carrier ↔ x ∈ (p : set M) :=
iff.rfl

@[ext] theorem ext {p q : sub_mul_action R M} (h : ∀ x, x ∈ p ↔ x ∈ q) : p = q := set_like.ext h

/-- Copy of a sub_mul_action with a new `carrier` equal to the old one. Useful to fix definitional
equalities.-/
protected def copy (p : sub_mul_action R M) (s : set M) (hs : s = ↑p) : sub_mul_action R M :=
{ carrier := s,
  smul_mem' := hs.symm ▸ p.smul_mem' }

@[simp] lemma coe_copy (p : sub_mul_action R M) (s : set M) (hs : s = ↑p) :
  (p.copy s hs : set M) = s := rfl

lemma copy_eq (p : sub_mul_action R M) (s : set M) (hs : s = ↑p) : p.copy s hs = p :=
set_like.coe_injective hs

instance : has_bot (sub_mul_action R M) :=
⟨{ carrier := ∅, smul_mem' := λ c, set.not_mem_empty}⟩

instance : inhabited (sub_mul_action R M) := ⟨⊥⟩

end sub_mul_action

namespace sub_mul_action

section has_scalar

variables [has_scalar R M]
variables (p : sub_mul_action R M)
variables {r : R} {x : M}

lemma smul_mem (r : R) (h : x ∈ p) : r • x ∈ p := p.smul_mem' r h

instance : has_scalar R p :=
{ smul := λ c x, ⟨c • x.1, smul_mem _ c x.2⟩ }

variables {p}
@[simp, norm_cast] lemma coe_smul (r : R) (x : p) : ((r • x : p) : M) = r • ↑x := rfl
@[simp, norm_cast] lemma coe_mk (x : M) (hx : x ∈ p) : ((⟨x, hx⟩ : p) : M) = x := rfl

variables (p)

/-- Embedding of a submodule `p` to the ambient space `M`. -/
protected def subtype : p →[R] M :=
by refine {to_fun := coe, ..}; simp [coe_smul]

@[simp] theorem subtype_apply (x : p) : p.subtype x = x := rfl

lemma subtype_eq_val : ((sub_mul_action.subtype p) : p → M) = subtype.val := rfl

end has_scalar

section mul_action

variables [monoid R] [mul_action R M]

section
variables [has_scalar S R] [has_scalar S M] [is_scalar_tower S R M]
variables (p : sub_mul_action R M)

lemma smul_of_tower_mem (s : S) {x : M} (h : x ∈ p) : s • x ∈ p :=
by { rw [←one_smul R x, ←smul_assoc], exact p.smul_mem _ h }

instance has_scalar' : has_scalar S p :=
{ smul := λ c x, ⟨c • x.1, smul_of_tower_mem _ c x.2⟩ }

instance : is_scalar_tower S R p :=
{ smul_assoc := λ s r x, subtype.ext $ smul_assoc s r ↑x }

@[simp, norm_cast] lemma coe_smul_of_tower (s : S) (x : p) : ((s • x : p) : M) = s • ↑x := rfl

@[simp] lemma smul_mem_iff' {G} [group G] [has_scalar G R] [mul_action G M]
  [is_scalar_tower G R M] (g : G) {x : M} :
  g • x ∈ p ↔ x ∈ p :=
⟨λ h, inv_smul_smul g x ▸ p.smul_of_tower_mem g⁻¹ h, p.smul_of_tower_mem g⟩

end

section
variables [monoid S] [has_scalar S R] [mul_action S M] [is_scalar_tower S R M]
variables (p : sub_mul_action R M)

/-- If the scalar product forms a `mul_action`, then the subset inherits this action -/
instance mul_action' : mul_action S p :=
{ smul := (•),
  one_smul := λ x, subtype.ext $ one_smul _ x,
  mul_smul := λ c₁ c₂ x, subtype.ext $ mul_smul c₁ c₂ x }

instance : mul_action R p := p.mul_action'

end

end mul_action

section module

variables [semiring R] [add_comm_monoid M]
variables [module R M]
variables (p : sub_mul_action R M)

lemma zero_mem (h : (p : set M).nonempty) : (0 : M) ∈ p :=
let ⟨x, hx⟩ := h in zero_smul R (x : M) ▸ p.smul_mem 0 hx

/-- If the scalar product forms a `module`, and the `sub_mul_action` is not `⊥`, then the
subset inherits the zero. -/
instance [n_empty : nonempty p] : has_zero p :=
{ zero := ⟨0, n_empty.elim $ λ x, p.zero_mem ⟨x, x.prop⟩⟩ }

end module

section add_comm_group

variables [ring R] [add_comm_group M]
variables [module R M]
variables (p p' : sub_mul_action R M)
variables {r : R} {x y : M}

lemma neg_mem (hx : x ∈ p) : -x ∈ p := by { rw ← neg_one_smul R, exact p.smul_mem _ hx }

@[simp] lemma neg_mem_iff : -x ∈ p ↔ x ∈ p :=
⟨λ h, by { rw ←neg_neg x, exact neg_mem _ h}, neg_mem _⟩

instance : has_neg p := ⟨λx, ⟨-x.1, neg_mem _ x.2⟩⟩

@[simp, norm_cast] lemma coe_neg (x : p) : ((-x : p) : M) = -x := rfl

end add_comm_group

end sub_mul_action

namespace sub_mul_action

variables [division_ring S] [semiring R] [mul_action R M]
variables [has_scalar S R] [mul_action S M] [is_scalar_tower S R M]
variables (p : sub_mul_action R M) {s : S} {x y : M}

theorem smul_mem_iff (s0 : s ≠ 0) : s • x ∈ p ↔ x ∈ p :=
p.smul_mem_iff' (units.mk0 s s0)

end sub_mul_action


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Sébastien Gouëzel, Zhouhang Zhou, Reid Barton
-/
import topology.dense_embedding

open set filter
open_locale topological_space

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

/-- Homeomorphism between `α` and `β`, also called topological isomorphism -/
@[nolint has_inhabited_instance] -- not all spaces are homeomorphic to each other
structure homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends α ≃ β :=
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')
(continuous_inv_fun : continuous inv_fun . tactic.interactive.continuity')

infix ` ≃ₜ `:25 := homeomorph

namespace homeomorph
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

instance : has_coe_to_fun (α ≃ₜ β) := ⟨λ_, α → β, λe, e.to_equiv⟩

@[simp] lemma homeomorph_mk_coe (a : equiv α β) (b c) :
  ((homeomorph.mk a b c) : α → β) = a :=
rfl

@[simp] lemma coe_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv = h := rfl

/-- Inverse of a homeomorphism. -/
protected def symm (h : α ≃ₜ β) : β ≃ₜ α :=
{ continuous_to_fun  := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  to_equiv := h.to_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : α ≃ₜ β) : α → β := h
/-- See Note [custom simps projection] -/
def simps.symm_apply (h : α ≃ₜ β) : β → α := h.symm

initialize_simps_projections homeomorph
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

lemma to_equiv_injective : function.injective (to_equiv : α ≃ₜ β → α ≃ β)
| ⟨e, h₁, h₂⟩ ⟨e', h₁', h₂'⟩ rfl := rfl

@[ext] lemma ext {h h' : α ≃ₜ β} (H : ∀ x, h x = h' x) : h = h' :=
to_equiv_injective $ equiv.ext H

/-- Identity map as a homeomorphism. -/
@[simps apply {fully_applied := ff}]
protected def refl (α : Type*) [topological_space α] : α ≃ₜ α :=
{ continuous_to_fun := continuous_id,
  continuous_inv_fun := continuous_id,
  to_equiv := equiv.refl α }

/-- Composition of two homeomorphisms. -/
protected def trans (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
{ continuous_to_fun  := h₂.continuous_to_fun.comp h₁.continuous_to_fun,
  continuous_inv_fun := h₁.continuous_inv_fun.comp h₂.continuous_inv_fun,
  to_equiv := equiv.trans h₁.to_equiv h₂.to_equiv }

@[simp] lemma homeomorph_mk_coe_symm (a : equiv α β) (b c) :
  ((homeomorph.mk a b c).symm : β → α) = a.symm :=
rfl

@[simp] lemma refl_symm : (homeomorph.refl α).symm = homeomorph.refl α := rfl

@[continuity]
protected lemma continuous (h : α ≃ₜ β) : continuous h := h.continuous_to_fun

@[continuity] -- otherwise `by continuity` can't prove continuity of `h.to_equiv.symm`
protected lemma continuous_symm (h : α ≃ₜ β) : continuous (h.symm) := h.continuous_inv_fun

@[simp] lemma apply_symm_apply (h : α ≃ₜ β) (x : β) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (h : α ≃ₜ β) (x : α) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

protected lemma bijective (h : α ≃ₜ β) : function.bijective h := h.to_equiv.bijective
protected lemma injective (h : α ≃ₜ β) : function.injective h := h.to_equiv.injective
protected lemma surjective (h : α ≃ₜ β) : function.surjective h := h.to_equiv.surjective

/-- Change the homeomorphism `f` to make the inverse function definitionally equal to `g`. -/
def change_inv (f : α ≃ₜ β) (g : β → α) (hg : function.right_inverse g f) : α ≃ₜ β :=
have g = f.symm, from funext (λ x, calc g x = f.symm (f (g x)) : (f.left_inv (g x)).symm
                                        ... = f.symm x : by rw hg x),
{ to_fun := f,
  inv_fun := g,
  left_inv := by convert f.left_inv,
  right_inv := by convert f.right_inv,
  continuous_to_fun := f.continuous,
  continuous_inv_fun := by convert f.symm.continuous }

@[simp] lemma symm_comp_self (h : α ≃ₜ β) : ⇑h.symm ∘ ⇑h = id :=
funext h.symm_apply_apply

@[simp] lemma self_comp_symm (h : α ≃ₜ β) : ⇑h ∘ ⇑h.symm = id :=
funext h.apply_symm_apply

@[simp] lemma range_coe (h : α ≃ₜ β) : range h = univ :=
h.surjective.range_eq

lemma image_symm (h : α ≃ₜ β) : image h.symm = preimage h :=
funext h.symm.to_equiv.image_eq_preimage

lemma preimage_symm (h : α ≃ₜ β) : preimage h.symm = image h :=
(funext h.to_equiv.image_eq_preimage).symm

@[simp] lemma image_preimage (h : α ≃ₜ β) (s : set β) : h '' (h ⁻¹' s) = s :=
h.to_equiv.image_preimage s

@[simp] lemma preimage_image (h : α ≃ₜ β) (s : set α) : h ⁻¹' (h '' s) = s :=
h.to_equiv.preimage_image s

protected lemma inducing (h : α ≃ₜ β) : inducing h :=
inducing_of_inducing_compose h.continuous h.symm.continuous $
  by simp only [symm_comp_self, inducing_id]

lemma induced_eq (h : α ≃ₜ β) : topological_space.induced h ‹_› = ‹_› := h.inducing.1.symm

protected lemma quotient_map (h : α ≃ₜ β) : quotient_map h :=
quotient_map.of_quotient_map_compose h.symm.continuous h.continuous $
  by simp only [self_comp_symm, quotient_map.id]

lemma coinduced_eq (h : α ≃ₜ β) : topological_space.coinduced h ‹_› = ‹_› :=
h.quotient_map.2.symm

protected lemma embedding (h : α ≃ₜ β) : embedding h :=
⟨h.inducing, h.injective⟩

protected lemma second_countable_topology [topological_space.second_countable_topology β]
  (h : α ≃ₜ β) :
  topological_space.second_countable_topology α :=
h.inducing.second_countable_topology

lemma compact_image {s : set α} (h : α ≃ₜ β) : is_compact (h '' s) ↔ is_compact s :=
h.embedding.compact_iff_compact_image.symm

lemma compact_preimage {s : set β} (h : α ≃ₜ β) : is_compact (h ⁻¹' s) ↔ is_compact s :=
by rw ← image_symm; exact h.symm.compact_image

protected lemma dense_embedding (h : α ≃ₜ β) : dense_embedding h :=
{ dense   := h.surjective.dense_range,
  .. h.embedding }

@[simp] lemma is_open_preimage (h : α ≃ₜ β) {s : set β} : is_open (h ⁻¹' s) ↔ is_open s :=
h.quotient_map.is_open_preimage

@[simp] lemma is_open_image (h : α ≃ₜ β) {s : set α} : is_open (h '' s) ↔ is_open s :=
by rw [← preimage_symm, is_open_preimage]

@[simp] lemma is_closed_preimage (h : α ≃ₜ β) {s : set β} : is_closed (h ⁻¹' s) ↔ is_closed s :=
by simp only [← is_open_compl_iff, ← preimage_compl, is_open_preimage]

@[simp] lemma is_closed_image (h : α ≃ₜ β) {s : set α} : is_closed (h '' s) ↔ is_closed s :=
by rw [← preimage_symm, is_closed_preimage]

lemma preimage_closure (h : α ≃ₜ β) (s : set β) : h ⁻¹' (closure s) = closure (h ⁻¹' s) :=
by rw [h.embedding.closure_eq_preimage_closure_image, h.image_preimage]

lemma image_closure (h : α ≃ₜ β) (s : set α) : h '' (closure s) = closure (h '' s) :=
by rw [← preimage_symm, preimage_closure]

protected lemma is_open_map (h : α ≃ₜ β) : is_open_map h := λ s, h.is_open_image.2

protected lemma is_closed_map (h : α ≃ₜ β) : is_closed_map h := λ s, h.is_closed_image.2

protected lemma closed_embedding (h : α ≃ₜ β) : closed_embedding h :=
closed_embedding_of_embedding_closed h.embedding h.is_closed_map

@[simp] lemma map_nhds_eq (h : α ≃ₜ β) (x : α) : map h (𝓝 x) = 𝓝 (h x) :=
h.embedding.map_nhds_of_mem _ (by simp)

lemma symm_map_nhds_eq (h : α ≃ₜ β) (x : α) : map h.symm (𝓝 (h x)) = 𝓝 x :=
by rw [h.symm.map_nhds_eq, h.symm_apply_apply]

lemma nhds_eq_comap (h : α ≃ₜ β) (x : α) : 𝓝 x = comap h (𝓝 (h x)) :=
h.embedding.to_inducing.nhds_eq_comap x

@[simp] lemma comap_nhds_eq (h : α ≃ₜ β) (y : β) : comap h (𝓝 y) = 𝓝 (h.symm y) :=
by rw [h.nhds_eq_comap, h.apply_symm_apply]

/-- If an bijective map `e : α ≃ β` is continuous and open, then it is a homeomorphism. -/
def homeomorph_of_continuous_open (e : α ≃ β) (h₁ : continuous e) (h₂ : is_open_map e) :
  α ≃ₜ β :=
{ continuous_to_fun := h₁,
  continuous_inv_fun := begin
    rw continuous_def,
    intros s hs,
    convert ← h₂ s hs using 1,
    apply e.image_eq_preimage
  end,
  to_equiv := e }

@[simp] lemma comp_continuous_on_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) :
  continuous_on (h ∘ f) s ↔ continuous_on f s :=
h.inducing.continuous_on_iff.symm

@[simp] lemma comp_continuous_iff (h : α ≃ₜ β) {f : γ → α} :
  continuous (h ∘ f) ↔ continuous f :=
h.inducing.continuous_iff.symm

@[simp] lemma comp_continuous_iff' (h : α ≃ₜ β) {f : β → γ} :
  continuous (f ∘ h) ↔ continuous f :=
h.quotient_map.continuous_iff.symm

/-- If two sets are equal, then they are homeomorphic. -/
def set_congr {s t : set α} (h : s = t) : s ≃ₜ t :=
{ continuous_to_fun := continuous_subtype_mk _ continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ continuous_subtype_val,
  to_equiv := equiv.set_congr h }

/-- Sum of two homeomorphisms. -/
def sum_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α ⊕ γ ≃ₜ β ⊕ δ :=
{ continuous_to_fun  :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.continuous)
      (continuous_inr.comp h₂.continuous),
    ext x, cases x; refl,
  end,
  continuous_inv_fun :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.symm.continuous)
      (continuous_inr.comp h₂.symm.continuous),
    ext x, cases x; refl
  end,
  to_equiv := h₁.to_equiv.sum_congr h₂.to_equiv }

/-- Product of two homeomorphisms. -/
def prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α × γ ≃ₜ β × δ :=
{ continuous_to_fun  := (h₁.continuous.comp continuous_fst).prod_mk
    (h₂.continuous.comp continuous_snd),
  continuous_inv_fun := (h₁.symm.continuous.comp continuous_fst).prod_mk
    (h₂.symm.continuous.comp continuous_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (α β γ)

/-- `α × β` is homeomorphic to `β × α`. -/
def prod_comm : α × β ≃ₜ β × α :=
{ continuous_to_fun  := continuous_snd.prod_mk continuous_fst,
  continuous_inv_fun := continuous_snd.prod_mk continuous_fst,
  to_equiv := equiv.prod_comm α β }

@[simp] lemma prod_comm_symm : (prod_comm α β).symm = prod_comm β α := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm α β) = prod.swap := rfl

/-- `(α × β) × γ` is homeomorphic to `α × (β × γ)`. -/
def prod_assoc : (α × β) × γ ≃ₜ α × (β × γ) :=
{ continuous_to_fun  := (continuous_fst.comp continuous_fst).prod_mk
    ((continuous_snd.comp continuous_fst).prod_mk continuous_snd),
  continuous_inv_fun := (continuous_fst.prod_mk (continuous_fst.comp continuous_snd)).prod_mk
    (continuous_snd.comp continuous_snd),
  to_equiv := equiv.prod_assoc α β γ }

/-- `α × {*}` is homeomorphic to `α`. -/
@[simps apply {fully_applied := ff}]
def prod_punit : α × punit ≃ₜ α :=
{ to_equiv := equiv.prod_punit α,
  continuous_to_fun := continuous_fst,
  continuous_inv_fun := continuous_id.prod_mk continuous_const }

/-- `{*} × α` is homeomorphic to `α`. -/
def punit_prod : punit × α ≃ₜ α :=
(prod_comm _ _).trans (prod_punit _)

@[simp] lemma coe_punit_prod : ⇑(punit_prod α) = prod.snd := rfl

end

/-- `ulift α` is homeomorphic to `α`. -/
def {u v} ulift {α : Type u} [topological_space α] : ulift.{v u} α ≃ₜ α :=
{ continuous_to_fun := continuous_ulift_down,
  continuous_inv_fun := continuous_ulift_up,
  to_equiv := equiv.ulift }

section distrib

/-- `(α ⊕ β) × γ` is homeomorphic to `α × γ ⊕ β × γ`. -/
def sum_prod_distrib : (α ⊕ β) × γ ≃ₜ α × γ ⊕ β × γ :=
begin
  refine (homeomorph.homeomorph_of_continuous_open (equiv.sum_prod_distrib α β γ).symm _ _).symm,
  { convert continuous_sum_rec
      ((continuous_inl.comp continuous_fst).prod_mk continuous_snd)
      ((continuous_inr.comp continuous_fst).prod_mk continuous_snd),
    ext1 x, cases x; refl, },
  { exact (is_open_map_sum
    (open_embedding_inl.prod open_embedding_id).is_open_map
    (open_embedding_inr.prod open_embedding_id).is_open_map) }
end

/-- `α × (β ⊕ γ)` is homeomorphic to `α × β ⊕ α × γ`. -/
def prod_sum_distrib : α × (β ⊕ γ) ≃ₜ α × β ⊕ α × γ :=
(prod_comm _ _).trans $
sum_prod_distrib.trans $
sum_congr (prod_comm _ _) (prod_comm _ _)

variables {ι : Type*} {σ : ι → Type*} [Π i, topological_space (σ i)]

/-- `(Σ i, σ i) × β` is homeomorphic to `Σ i, (σ i × β)`. -/
def sigma_prod_distrib : ((Σ i, σ i) × β) ≃ₜ (Σ i, (σ i × β)) :=
homeomorph.symm $
homeomorph_of_continuous_open (equiv.sigma_prod_distrib σ β).symm
  (continuous_sigma $ λ i,
    (continuous_sigma_mk.comp continuous_fst).prod_mk continuous_snd)
  (is_open_map_sigma $ λ i,
    (open_embedding_sigma_mk.prod open_embedding_id).is_open_map)

end distrib

/--
A subset of a topological space is homeomorphic to its image under a homeomorphism.
-/
def image (e : α ≃ₜ β) (s : set α) : s ≃ₜ e '' s :=
{ continuous_to_fun := by continuity!,
  continuous_inv_fun := by continuity!,
  ..e.to_equiv.image s, }

end homeomorph


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

! This file was ported from Lean 3 source module algebra.category.Module.change_of_rings
! leanprover-community/mathlib commit 8f66240cab125b938b327d3850169d490cfbcdd8
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Category.Module.Basic
import Mathbin.RingTheory.TensorProduct

/-!
# Change Of Rings

## Main definitions

* `category_theory.Module.restrict_scalars`: given rings `R, S` and a ring homomorphism `R ⟶ S`,
  then `restrict_scalars : Module S ⥤ Module R` is defined by `M ↦ M` where `M : S-module` is seen
  as `R-module` by `r • m := f r • m` and `S`-linear map `l : M ⟶ M'` is `R`-linear as well.

* `category_theory.Module.extend_scalars`: given **commutative** rings `R, S` and ring homomorphism
  `f : R ⟶ S`, then `extend_scalars : Module R ⥤ Module S` is defined by `M ↦ S ⨂ M` where the
  module structure is defined by `s • (s' ⊗ m) := (s * s') ⊗ m` and `R`-linear map `l : M ⟶ M'`
  is sent to `S`-linear map `s ⊗ m ↦ s ⊗ l m : S ⨂ M ⟶ S ⨂ M'`.

## List of notations
Let `R, S` be rings and `f : R →+* S`
* if `M` is an `R`-module, `s : S` and `m : M`, then `s ⊗ₜ[R, f] m` is the pure tensor
  `s ⊗ m : S ⊗[R, f] M`.
-/

namespace CategoryTheory.Module

universe v u₁ u₂

namespace RestrictScalars

variable {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)

variable (M : ModuleCat.{v} S)

/-- Any `S`-module M is also an `R`-module via a ring homomorphism `f : R ⟶ S` by defining
    `r • m := f r • m` (`module.comp_hom`). This is called restriction of scalars. -/
def obj' : ModuleCat R where
  carrier := M
  isModule := Module.compHom M f
#align category_theory.Module.restrict_scalars.obj' CategoryTheory.Module.RestrictScalars.obj'

/-- Given an `S`-linear map `g : M → M'` between `S`-modules, `g` is also `R`-linear between `M` and
`M'` by means of restriction of scalars.
-/
def map' {M M' : ModuleCat.{v} S} (g : M ⟶ M') : obj' f M ⟶ obj' f M' :=
  { g with map_smul' := fun r => g.map_smul (f r) }
#align category_theory.Module.restrict_scalars.map' CategoryTheory.Module.RestrictScalars.map'

end RestrictScalars

/-- The restriction of scalars operation is functorial. For any `f : R →+* S` a ring homomorphism,
* an `S`-module `M` can be considered as `R`-module by `r • m = f r • m`
* an `S`-linear map is also `R`-linear
-/
def restrictScalars {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S) :
    ModuleCat.{v} S ⥤ ModuleCat.{v} R
    where
  obj := RestrictScalars.obj' f
  map _ _ := RestrictScalars.map' f
  map_id' _ := LinearMap.ext fun m => rfl
  map_comp' _ _ _ g h := LinearMap.ext fun m => rfl
#align category_theory.Module.restrict_scalars CategoryTheory.Module.restrictScalars

@[simp]
theorem restrictScalars.map_apply {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)
    {M M' : ModuleCat.{v} S} (g : M ⟶ M') (x) : (restrictScalars f).map g x = g x :=
  rfl
#align category_theory.Module.restrict_scalars.map_apply CategoryTheory.Module.restrictScalars.map_apply

@[simp]
theorem restrictScalars.smul_def {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)
    {M : ModuleCat.{v} S} (r : R) (m : (restrictScalars f).obj M) : r • m = (f r • m : M) :=
  rfl
#align category_theory.Module.restrict_scalars.smul_def CategoryTheory.Module.restrictScalars.smul_def

theorem restrictScalars.smul_def' {R : Type u₁} {S : Type u₂} [Ring R] [Ring S] (f : R →+* S)
    {M : ModuleCat.{v} S} (r : R) (m : M) : (r • m : (restrictScalars f).obj M) = (f r • m : M) :=
  rfl
#align category_theory.Module.restrict_scalars.smul_def' CategoryTheory.Module.restrictScalars.smul_def'

instance (priority := 100) sMulCommClass_mk {R : Type u₁} {S : Type u₂} [Ring R] [CommRing S]
    (f : R →+* S) (M : Type v) [AddCommGroup M] [Module S M] :
    @SMulCommClass R S M (RestrictScalars.obj' f (ModuleCat.mk M)).isModule.toSMul _
    where smul_comm r s m := (by simp [← mul_smul, mul_comm] : f r • s • m = s • f r • m)
#align category_theory.Module.smul_comm_class_mk CategoryTheory.Module.sMulCommClass_mk

namespace ExtendScalars

open TensorProduct

variable {R : Type u₁} {S : Type u₂} [CommRing R] [CommRing S] (f : R →+* S)

section Unbundled

variable (M : Type v) [AddCommMonoid M] [Module R M]

-- mathport name: «expr ⊗ₜ[ , ] »
-- This notation is necessary because we need to reason about `s ⊗ₜ m` where `s : S` and `m : M`;
-- without this notation, one need to work with `s : (restrict_scalars f).obj ⟨S⟩`.
scoped[ChangeOfRings]
  notation s "⊗ₜ[" R "," f "]" m => @TensorProduct.tmul R _ _ _ _ _ (Module.compHom _ f) _ s m

end Unbundled

open ChangeOfRings

variable (M : ModuleCat.{v} R)

/-- Extension of scalars turn an `R`-module into `S`-module by M ↦ S ⨂ M
-/
def obj' : ModuleCat S :=
  ⟨TensorProduct R ((restrictScalars f).obj ⟨S⟩) M⟩
#align category_theory.Module.extend_scalars.obj' CategoryTheory.Module.ExtendScalars.obj'

/-- Extension of scalars is a functor where an `R`-module `M` is sent to `S ⊗ M` and
`l : M1 ⟶ M2` is sent to `s ⊗ m ↦ s ⊗ l m`
-/
def map' {M1 M2 : ModuleCat.{v} R} (l : M1 ⟶ M2) : obj' f M1 ⟶ obj' f M2 :=
  by-- The "by apply" part makes this require 75% fewer heartbeats to process (#16371).
  apply @LinearMap.baseChange R S M1 M2 _ _ ((algebraMap S _).comp f).toAlgebra _ _ _ _ l
#align category_theory.Module.extend_scalars.map' CategoryTheory.Module.ExtendScalars.map'

theorem map'_id {M : ModuleCat.{v} R} : map' f (𝟙 M) = 𝟙 _ :=
  LinearMap.ext fun x : obj' f M =>
    by
    dsimp only [map', ModuleCat.id_apply]
    induction' x using TensorProduct.induction_on with _ _ m s ihx ihy
    · simp only [map_zero]
    · rw [LinearMap.baseChange_tmul, ModuleCat.id_apply]
    · rw [map_add, ihx, ihy]
#align category_theory.Module.extend_scalars.map'_id CategoryTheory.Module.ExtendScalars.map'_id

theorem map'_comp {M₁ M₂ M₃ : ModuleCat.{v} R} (l₁₂ : M₁ ⟶ M₂) (l₂₃ : M₂ ⟶ M₃) :
    map' f (l₁₂ ≫ l₂₃) = map' f l₁₂ ≫ map' f l₂₃ :=
  LinearMap.ext fun x : obj' f M₁ => by
    dsimp only [map']
    induction' x using TensorProduct.induction_on with _ _ x y ihx ihy
    · rfl
    · rfl
    · simp only [map_add, ihx, ihy]
#align category_theory.Module.extend_scalars.map'_comp CategoryTheory.Module.ExtendScalars.map'_comp

end ExtendScalars

/-- Extension of scalars is a functor where an `R`-module `M` is sent to `S ⊗ M` and
`l : M1 ⟶ M2` is sent to `s ⊗ m ↦ s ⊗ l m`
-/
def extendScalars {R : Type u₁} {S : Type u₂} [CommRing R] [CommRing S] (f : R →+* S) :
    ModuleCat.{v} R ⥤ ModuleCat.{max v u₂} S
    where
  obj M := ExtendScalars.obj' f M
  map M1 M2 l := ExtendScalars.map' f l
  map_id' _ := ExtendScalars.map'_id f
  map_comp' _ _ _ := ExtendScalars.map'_comp f
#align category_theory.Module.extend_scalars CategoryTheory.Module.extendScalars

namespace ExtendScalars

open ChangeOfRings

variable {R : Type u₁} {S : Type u₂} [CommRing R] [CommRing S] (f : R →+* S)

@[simp]
protected theorem smul_tmul {M : ModuleCat.{v} R} (s s' : S) (m : M) :
    s • (s'⊗ₜ[R,f]m : (extendScalars f).obj M) = (s * s')⊗ₜ[R,f]m :=
  rfl
#align category_theory.Module.extend_scalars.smul_tmul CategoryTheory.Module.extendScalars.smul_tmul

@[simp]
theorem map_tmul {M M' : ModuleCat.{v} R} (g : M ⟶ M') (s : S) (m : M) :
    (extendScalars f).map g (s⊗ₜ[R,f]m) = s⊗ₜ[R,f]g m :=
  rfl
#align category_theory.Module.extend_scalars.map_tmul CategoryTheory.Module.extendScalars.map_tmul

end ExtendScalars

end CategoryTheory.Module