/-
Copyright (c) 2021 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.binary_products
import category_theory.limits.shapes.pullbacks

/-!
# Disjoint coproducts

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

Defines disjoint coproducts: coproducts where the intersection is initial and the coprojections
are monic.
Shows that a category with disjoint coproducts is `initial_mono_class`.

## TODO

* Adapt this to the infinitary (small) version: This is one of the conditions in Giraud's theorem
  characterising sheaf topoi.
* Construct examples (and counterexamples?), eg Type, Vec.
* Define extensive categories, and show every extensive category has disjoint coproducts.
* Define coherent categories and use this to define positive coherent categories.
-/

universes v u u₂

namespace category_theory
namespace limits

open category

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

/--
Given any pullback diagram of the form

Z  ⟶  X₁
↓      ↓
X₂ ⟶  X

where `X₁ ⟶ X ← X₂` is a coproduct diagram, then `Z` is initial, and both `X₁ ⟶ X` and `X₂ ⟶ X`
are mono.
-/
class coproduct_disjoint (X₁ X₂ : C) :=
(is_initial_of_is_pullback_of_is_coproduct :
  ∀ {X Z} {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} {f : Z ⟶ X₁} {g : Z ⟶ X₂}
    (cX : is_colimit (binary_cofan.mk pX₁ pX₂)) {comm : f ≫ pX₁ = g ≫ pX₂},
    is_limit (pullback_cone.mk _ _ comm) → is_initial Z)
(mono_inl : ∀ X (X₁ : X₁ ⟶ X) (X₂ : X₂ ⟶ X) (cX : is_colimit (binary_cofan.mk X₁ X₂)), mono X₁)
(mono_inr : ∀ X (X₁ : X₁ ⟶ X) (X₂ : X₂ ⟶ X) (cX : is_colimit (binary_cofan.mk X₁ X₂)), mono X₂)

/--
If the coproduct of `X₁` and `X₂` is disjoint, then given any pullback square

Z  ⟶  X₁
↓      ↓
X₂ ⟶  X

where `X₁ ⟶ X ← X₂` is a coproduct, then `Z` is initial.
-/
def is_initial_of_is_pullback_of_is_coproduct {Z X₁ X₂ X : C} [coproduct_disjoint X₁ X₂]
  {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} (cX : is_colimit (binary_cofan.mk pX₁ pX₂))
  {f : Z ⟶ X₁} {g : Z ⟶ X₂} {comm : f ≫ pX₁ = g ≫ pX₂}
  (cZ : is_limit (pullback_cone.mk _ _ comm)) :
  is_initial Z :=
coproduct_disjoint.is_initial_of_is_pullback_of_is_coproduct cX cZ

/--
If the coproduct of `X₁` and `X₂` is disjoint, then given any pullback square

Z  ⟶  X₁
↓       ↓
X₂ ⟶  X₁ ⨿ X₂

`Z` is initial.
-/
noncomputable def is_initial_of_is_pullback_of_coproduct {Z X₁ X₂ : C}
  [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂]
  {f : Z ⟶ X₁} {g : Z ⟶ X₂} {comm : f ≫ (coprod.inl : X₁ ⟶ _ ⨿ X₂) = g ≫ coprod.inr}
  (cZ : is_limit (pullback_cone.mk _ _ comm)) :
  is_initial Z :=
coproduct_disjoint.is_initial_of_is_pullback_of_is_coproduct (coprod_is_coprod _ _) cZ

/--
If the coproduct of `X₁` and `X₂` is disjoint, then provided `X₁ ⟶ X ← X₂` is a coproduct the
pullback is an initial object:

        X₁
        ↓
X₂ ⟶  X
-/
noncomputable def is_initial_of_pullback_of_is_coproduct {X X₁ X₂ : C} [coproduct_disjoint X₁ X₂]
  {pX₁ : X₁ ⟶ X} {pX₂ : X₂ ⟶ X} [has_pullback pX₁ pX₂]
  (cX : is_colimit (binary_cofan.mk pX₁ pX₂)) :
  is_initial (pullback pX₁ pX₂) :=
coproduct_disjoint.is_initial_of_is_pullback_of_is_coproduct cX (pullback_is_pullback _ _)

/--
If the coproduct of `X₁` and `X₂` is disjoint, the pullback of `X₁ ⟶ X₁ ⨿ X₂` and `X₂ ⟶ X₁ ⨿ X₂`
is initial.
-/
noncomputable def is_initial_of_pullback_of_coproduct {X₁ X₂ : C}
  [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂]
    [has_pullback (coprod.inl : X₁ ⟶ _ ⨿ X₂) coprod.inr] :
  is_initial (pullback (coprod.inl : X₁ ⟶ _ ⨿ X₂) coprod.inr) :=
is_initial_of_is_pullback_of_coproduct (pullback_is_pullback _ _)

instance {X₁ X₂ : C} [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂] :
  mono (coprod.inl : X₁ ⟶ X₁ ⨿ X₂) :=
coproduct_disjoint.mono_inl _ _ _ (coprod_is_coprod _ _)
instance {X₁ X₂ : C} [has_binary_coproduct X₁ X₂] [coproduct_disjoint X₁ X₂] :
  mono (coprod.inr : X₂ ⟶ X₁ ⨿ X₂) :=
coproduct_disjoint.mono_inr _ _ _ (coprod_is_coprod _ _)

/-- `C` has disjoint coproducts if every coproduct is disjoint. -/
class coproducts_disjoint (C : Type u) [category.{v} C] :=
(coproduct_disjoint : ∀ (X Y : C), coproduct_disjoint X Y)

attribute [instance, priority 999] coproducts_disjoint.coproduct_disjoint

/-- If `C` has disjoint coproducts, any morphism out of initial is mono. Note it isn't true in
general that `C` has strict initial objects, for instance consider the category of types and
partial functions. -/
lemma initial_mono_class_of_disjoint_coproducts [coproducts_disjoint C] : initial_mono_class C :=
{ is_initial_mono_from := λ I X hI,
    coproduct_disjoint.mono_inl _ _ (𝟙 X)
      { desc := λ (s : binary_cofan _ _), s.inr,
        fac' := λ s j, discrete.cases_on j
          (λ j, walking_pair.cases_on j (hI.hom_ext _ _) (id_comp _)),
        uniq' := λ (s : binary_cofan _ _) m w, (id_comp _).symm.trans (w ⟨walking_pair.right⟩) } }

end limits
end category_theory


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Sean Leather

List folds generalized to `traversable`. Informally, we can think of
`foldl` as a special case of `traverse` where we do not care about the
reconstructed data structure and, in a state monad, we care about the
final state.

The obvious way to define `foldl` would be to use the state monad but it
is nicer to reason about a more abstract interface with `fold_map` as a
primitive and `fold_map_hom` as a defining property.

def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω := ...

lemma fold_map_hom (α β)
  [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
...

`fold_map` uses a monoid ω to accumulate a value for every element of
a data structure and `fold_map_hom` uses a monoid homomorphism to
substitute the monoid used by `fold_map`. The two are sufficient to
define `foldl`, `foldr` and `to_list`. `to_list` permits the
formulation of specifications in terms of operations on lists.

Each fold function can be defined using a specialized
monoid. `to_list` uses a free monoid represented as a list with
concatenation while `foldl` uses endofunctions together with function
composition.

The definition through monoids uses `traverse` together with the
applicative functor `const m` (where `m` is the monoid). As an
implementation, `const` guarantees that no resource is spent on
reconstructing the structure during traversal.

A special class could be defined for `foldable`, similarly to Haskell,
but the author cannot think of instances of `foldable` that are not also
`traversable`.

-/
import tactic.squeeze
import algebra.group
import data.list.basic
import category.traversable.instances category.traversable.lemmas
import category_theory.category category_theory.types category_theory.opposites category_theory.instances.kleisli
import category.applicative

universes u v

open ulift category_theory

namespace monoid
variables {m : Type u → Type u} [monad m]
variables {α β : Type u}
/--
For a list, foldl f x [y₀,y₁] reduces as follows
  calc  foldl f x [y₀,y₁]
      = foldl f (f x y₀) [y₁]      : rfl
  ... = foldl f (f (f x y₀) y₁) [] : rfl
  ... = f (f x y₀) y₁              : rfl

with f : α → β → α
     x : α
     [y₀,y₁] : list β

We can view the above as a composition of functions:

  ... = f (f x y₀) y₁              : rfl
  ... = flip f y₁ (flip f y₀ x)    : rfl
  ... = (flip f y₁ ∘ flip f y₀) x  : rfl

We can use traverse and const to construct this composition:

  calc   const.run (traverse (λ y, const.mk' (flip f y)) [y₀,y₁]) x
       = const.run ((::) <$> const.mk' (flip f y₀) <*> traverse (λ y, const.mk' (flip f y)) [y₁]) x
  ...  = const.run ((::) <$> const.mk' (flip f y₀) <*> ( (::) <$> const.mk' (flip f y₁) <*> traverse (λ y, const.mk' (flip f y)) [] )) x
  ...  = const.run ((::) <$> const.mk' (flip f y₀) <*> ( (::) <$> const.mk' (flip f y₁) <*> pure [] )) x
  ...  = const.run ( ((::) <$> const.mk' (flip f y₁) <*> pure []) ∘ ((::) <$> const.mk' (flip f y₀)) ) x
  ...  = const.run ( const.mk' (flip f y₁) ∘ const.mk' (flip f y₀) ) x
  ...  = const.run ( flip f y₁ ∘ flip f y₀ ) x
  ...  = f (f x y₀) y₁

And this is how `const` turns a monoid into an applicative functor and
how the monoid of endofunctions define `foldl`.
-/
@[reducible] def foldl (α : Type u) : Type u := End α
def foldl.mk (f : α → α) : foldl α := f
def foldl.of_free_monoid (f : β → α → β) (xs : free_monoid α) : monoid.foldl β :=
flip (list.foldl f) xs

@[reducible] def foldr (α : Type u) : Type u := (End α)ᵒᵖ
def foldr.mk (f : α → α) : foldr α := op f
def foldr.get (x : foldr α) : α → α := unop x
def foldr.of_free_monoid (f : α → β → β) (xs : free_monoid α) : monoid.foldr β :=
op $ flip (list.foldr f) xs

@[reducible] def mfoldl (m : Type u → Type u) [monad m] (α : Type u) : Type u := End $ Kleisli.mk m α
def mfoldl.mk (f : α → m α) : mfoldl m α := f
def mfoldl.of_free_monoid (f : β → α → m β) (xs : free_monoid α) : monoid.mfoldl m β :=
flip (list.mfoldl f) xs

@[reducible] def mfoldr (m : Type u → Type u) [monad m] (α : Type u) : Type u := (End $ Kleisli.mk m α)ᵒᵖ
def mfoldr.mk (f : α → m α) : mfoldr m α := op f
def mfoldr.get (x : mfoldr m α) : α → m α := unop x
def mfoldr.of_free_monoid (f : α → β → m β) (xs : free_monoid α) : monoid.mfoldr m β :=
op $ flip (list.mfoldr f) xs

end monoid

namespace traversable
open monoid functor

section defs
variables {α β : Type u} {t : Type u → Type u} [traversable t]

def fold_map {α ω} [has_one ω] [has_mul ω] (f : α → ω) : t α → ω :=
traverse (const.mk' ∘ f)

def foldl (f : α → β → α) (x : α) (xs : t β) : α :=
fold_map (foldl.mk ∘ flip f) xs x

def foldr (f : α → β → β) (x : β) (xs : t α) : β :=
unop (fold_map (foldr.mk ∘ f) xs) x

/--
Conceptually, `to_list` collects all the elements of a collection
in a list. This idea is formalized by

  `lemma to_list_spec (x : t α) : to_list x = fold_map free_monoid.mk x`.

The definition of `to_list` is based on `foldl` and `list.cons` for
speed. It is faster than using `fold_map free_monoid.mk` because, by
using `foldl` and `list.cons`, each insertion is done in constant
time. As a consequence, `to_list` performs in linear.

On the other hand, `fold_map free_monoid.mk` creates a singleton list
around each element and concatenates all the resulting lists. In
`xs ++ ys`, concatenation takes a time proportional to `length xs`. Since
the order in which concatenation is evaluated is unspecified, nothing
prevents each element of the traversable to be appended at the end
`xs ++ [x]` which would yield a `O(n²)` run time. -/
def to_list : t α → list α :=
list.reverse ∘ foldl (flip list.cons) []

def length (xs : t α) : ℕ :=
down $ foldl (λ l _, up $ l.down + 1) (up 0) xs

variables {m : Type u → Type u} [monad m]

def mfoldl (f : α → β → m α) (x : α) (xs : t β) : m α :=
fold_map (mfoldl.mk ∘ flip f) xs x

def mfoldr (f : α → β → m β) (x : β) (xs : t α) : m β :=
unop (fold_map (mfoldr.mk ∘ f) xs) x

end defs

section applicative_transformation
variables {α β γ : Type u}

open function (hiding const) is_monoid_hom

def map_fold [monoid α] [monoid β] (f : α → β) [is_monoid_hom f] :
  applicative_transformation (const α) (const β) :=
{ app := λ x, f,
  preserves_seq'  := by { intros, simp only [map_mul f], },
  preserves_pure' := by { intros, simp only [map_one f] } }

def free.mk : α → free_monoid α := list.ret

def free.map (f : α → β) : free_monoid α → free_monoid β := list.map f

lemma free.map_eq_map (f : α → β) (xs : list α) :
  f <$> xs = free.map f xs := rfl

instance (f : α → β) : is_monoid_hom (free.map f) :=
by constructor; simp only [free.map, list.map_append, forall_2_true_iff, free_add_monoid.add_def, list.map, free_add_monoid.zero_def, list.map, eq_self_iff_true]

instance fold_foldl (f : β → α → β) :
  is_monoid_hom (foldl.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by { intros, unfold_projs, simp only [foldl.of_free_monoid, flip, list.foldl_append], } }

lemma foldr.unop_of_free_monoid  (f : α → β → β) (xs : free_monoid α) (a : β) :
  unop (foldr.of_free_monoid f xs) a = list.foldr f a xs := rfl

instance fold_foldr (f : α → β → β) :
  is_monoid_hom (foldr.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by { intros, apply unop_inj, ext, simp only [foldr.of_free_monoid,flip,free_add_monoid.add_def, list.foldr_append], refl } }

variables (m : Type u → Type u) [monad m] [is_lawful_monad m]

instance fold_mfoldl (f : β → α → m β) :
  is_monoid_hom (mfoldl.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by { intros, unfold_projs, simp only [mfoldl.of_free_monoid,flip, list.mfoldl_append] } }

@[simp]
lemma mfoldr.unop_of_free_monoid  (f : α → β → m β) (xs : free_monoid α) (a : β) :
  unop (mfoldr.of_free_monoid f xs) a = list.mfoldr f a xs := rfl

instance fold_mfoldr (f : α → β → m β) :
  is_monoid_hom (mfoldr.of_free_monoid f) :=
{ map_one := rfl,
  map_mul := by { intros, apply unop_inj, ext, simp only [list.mfoldr_append, mfoldr.unop_of_free_monoid, free_add_monoid.add_def],
                  apply bind_ext_congr, simp only [mfoldr.unop_of_free_monoid, eq_self_iff_true, forall_true_iff], } }

variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]
open is_lawful_traversable

lemma fold_map_hom
  [monoid α] [monoid β] (f : α → β) [is_monoid_hom f]
  (g : γ → α) (x : t γ) :
  f (fold_map g x) = fold_map (f ∘ g) x :=
calc  f (fold_map g x)
    = f (traverse (const.mk' ∘ g) x)  : rfl
... = (map_fold f).app _ (traverse (const.mk' ∘ g) x) : rfl
... = traverse ((map_fold f).app _ ∘ (const.mk' ∘ g)) x : naturality (map_fold f) _ _
... = fold_map (f ∘ g) x : rfl

lemma fold_map_hom_free
  [monoid β] (f : free_monoid α → β) [is_monoid_hom f] (x : t α) :
  f (fold_map free.mk x) = fold_map (f ∘ free.mk) x :=
fold_map_hom _ _ x

variable {m}

lemma fold_mfoldl_cons (f : α → β → m α) (x : β) (y : α) :
  list.mfoldl f y (free.mk x) = f y x :=
by simp only [free.mk, list.ret, list.mfoldl, bind_pure]

lemma fold_mfoldr_cons (f : β → α → m α) (x : β) (y : α) :
  list.mfoldr f y (free.mk x) = f x y :=
by simp only [free.mk, list.ret, list.mfoldr, pure_bind]

end applicative_transformation

section equalities
open is_lawful_traversable list (cons)
variables {α β γ : Type u}
variables {t : Type u → Type u} [traversable t] [is_lawful_traversable t]

@[simp]
lemma foldl.of_free_monoid_comp_free_mk (f : α → β → α) : foldl.of_free_monoid f ∘ free.mk = foldl.mk ∘ flip f := rfl

@[simp]
lemma foldr.of_free_monoid_comp_free_mk (f : β → α → α) : foldr.of_free_monoid f ∘ free.mk = foldr.mk ∘ f := rfl

@[simp]
lemma mfoldl.of_free_monoid_comp_free_mk {m} [monad m] [is_lawful_monad m] (f : α → β → m α) : mfoldl.of_free_monoid f ∘ free.mk = mfoldl.mk ∘ flip f :=
by { ext, simp only [(∘), mfoldl.of_free_monoid, mfoldl.mk, flip, fold_mfoldl_cons] }

@[simp]
lemma mfoldr.of_free_monoid_comp_free_mk {m} [monad m] [is_lawful_monad m] (f : β → α → m α) : mfoldr.of_free_monoid f ∘ free.mk = mfoldr.mk ∘ f :=
by { ext, apply unop_inj, ext, simp only [(∘),mfoldr.of_free_monoid,mfoldr.mk,flip,fold_mfoldr_cons] }

lemma to_list_spec (xs : t α) :
  to_list xs = (fold_map free.mk xs : free_monoid _) :=
eq.symm $
calc  fold_map free.mk xs
    = (fold_map free.mk xs).reverse.reverse : by simp only [list.reverse_reverse]
... = (list.foldr cons [] (fold_map free.mk xs).reverse).reverse
                 : by simp only [list.foldr_eta]
... = (foldl.of_free_monoid (flip cons) (fold_map free.mk xs) []).reverse
                 : by simp only [flip,list.foldr_reverse,foldl.of_free_monoid]
... = to_list xs : by { rw fold_map_hom_free (foldl.of_free_monoid (flip cons)),
                        simp only [to_list, foldl, list.reverse_inj, foldl.of_free_monoid_comp_free_mk],
                        all_goals { apply_instance } }

lemma fold_map_map [monoid γ]  (f : α → β) (g : β → γ) (xs : t α) :
  fold_map g (f <$> xs) = fold_map (g ∘ f) xs :=
by simp only [fold_map,traverse_map]

lemma foldl_to_list (f : α → β → α) (xs : t β) (x : α) :
  foldl f x xs = list.foldl f x (to_list xs) :=
by { change _ = foldl.of_free_monoid _ _ _,
     simp only [foldl, to_list_spec, fold_map_hom_free (foldl.of_free_monoid f), foldl.of_free_monoid_comp_free_mk] }

lemma foldr_to_list (f : α → β → β) (xs : t α) (x : β) :
  foldr f x xs = list.foldr f x (to_list xs) :=
by { rw ← foldr.unop_of_free_monoid,
     simp only [foldr, to_list_spec, fold_map_hom_free (foldr.of_free_monoid f), foldr.of_free_monoid_comp_free_mk] }

lemma to_list_map (f : α → β) (xs : t α) :
  to_list (f <$> xs) = f <$> to_list xs :=
by simp only [to_list_spec,free.map_eq_map,fold_map_hom (free.map f), fold_map_map]; refl

@[simp] theorem foldl_map (g : β → γ) (f : α → γ → α) (a : α) (l : t β) :
  foldl f a (g <$> l) = foldl (λ x y, f x (g y)) a l :=
by simp only [foldl, fold_map_map, (∘), flip]

@[simp] theorem foldr_map (g : β → γ) (f : γ → α → α) (a : α) (l : t β) :
  foldr f a (g <$> l) = foldr (f ∘ g) a l :=
by simp only [foldr, fold_map_map, (∘), flip]

@[simp] theorem to_list_eq_self {xs : list α} : to_list xs = xs :=
begin
  simp only [to_list_spec, fold_map, traverse],
  induction xs,
  case list.nil { refl },
  case list.cons : _ _ ih { unfold list.traverse list.ret, rw ih, refl }
end

theorem length_to_list {xs : t α} : length xs = list.length (to_list xs) :=
begin
  unfold length,
  rw foldl_to_list,
  generalize : to_list xs = ys,
  let f := λ (n : ℕ) (a : α), n + 1,
  transitivity list.foldl f 0 ys,
  { generalize : 0 = n,
    induction ys with _ _ ih generalizing n,
    { simp only [list.foldl_nil] },
    { simp only [list.foldl, ih (n+1)] } },
  { induction ys with _ tl ih,
    { simp only [list.length, list.foldl_nil] },
    { simp only [list.foldl, list.length],
      transitivity list.foldl f 0 tl + 1,
      { exact eq.symm (list.foldl_hom (+1) f f 0 (λ _ _, rfl) _) },
      { rw ih } } }
end

variables {m : Type u → Type u} [monad m] [is_lawful_monad m]

lemma mfoldl_to_list {f : α → β → m α} {x : α} {xs : t β} :
  mfoldl f x xs = list.mfoldl f x (to_list xs) :=
by { change _ = mfoldl.of_free_monoid f (to_list xs) x,
     simp only [mfoldl, to_list_spec, fold_map_hom_free (mfoldl.of_free_monoid f),mfoldl.of_free_monoid_comp_free_mk] }

lemma mfoldr_to_list (f : α → β → m β) (x : β) (xs : t α) :
  mfoldr f x xs = list.mfoldr f x (to_list xs) :=
by { change _ = unop (mfoldr.of_free_monoid f (to_list xs)) x,
     simp only [mfoldr, to_list_spec, fold_map_hom_free (mfoldr.of_free_monoid f),mfoldr.of_free_monoid_comp_free_mk] }

@[simp] theorem mfoldl_map (g : β → γ) (f : α → γ → m α) (a : α) (l : t β) :
  mfoldl f a (g <$> l) = mfoldl (λ x y, f x (g y)) a l :=
by simp only [mfoldl, fold_map_map, (∘), flip]

@[simp] theorem mfoldr_map (g : β → γ) (f : γ → α → m α) (a : α) (l : t β) :
  mfoldr f a (g <$> l) = mfoldr (f ∘ g) a l :=
by simp only [mfoldr, fold_map_map, (∘), flip]

end equalities

end traversable


/-
Copyright (c) 2021 Bhavik Mehta, Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Alena Gusakov, Yaël Dillies

! This file was ported from Lean 3 source module data.finset.slice
! leanprover-community/mathlib commit 68d1483e8a718ec63219f0e227ca3f0140361086
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.BigOperators.Basic
import Mathbin.Data.Nat.Interval
import Mathbin.Order.Antichain

/-!
# `r`-sets and slice

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

This file defines the `r`-th slice of a set family and provides a way to say that a set family is
made of `r`-sets.

An `r`-set is a finset of cardinality `r` (aka of *size* `r`). The `r`-th slice of a set family is
the set family made of its `r`-sets.

## Main declarations

* `set.sized`: `A.sized r` means that `A` only contains `r`-sets.
* `finset.slice`: `A.slice r` is the set of `r`-sets in `A`.

## Notation

`A # r` is notation for `A.slice r` in locale `finset_family`.
-/

open Finset Nat

open BigOperators

variable {α : Type _} {ι : Sort _} {κ : ι → Sort _}

namespace Set

variable {A B : Set (Finset α)} {r : ℕ}

/-! ### Families of `r`-sets -/

#print Set.Sized /-
/-- `sized r A` means that every finset in `A` has size `r`. -/
def Sized (r : ℕ) (A : Set (Finset α)) : Prop :=
  ∀ ⦃x⦄, x ∈ A → card x = r
#align set.sized Set.Sized
-/

#print Set.Sized.mono /-
theorem Sized.mono (h : A ⊆ B) (hB : B.Sized r) : A.Sized r := fun x hx => hB <| h hx
#align set.sized.mono Set.Sized.mono
-/

/- warning: set.sized_union -> Set.sized_union is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {A : Set.{u1} (Finset.{u1} α)} {B : Set.{u1} (Finset.{u1} α)} {r : Nat}, Iff (Set.Sized.{u1} α r (Union.union.{u1} (Set.{u1} (Finset.{u1} α)) (Set.hasUnion.{u1} (Finset.{u1} α)) A B)) (And (Set.Sized.{u1} α r A) (Set.Sized.{u1} α r B))
but is expected to have type
  forall {α : Type.{u1}} {A : Set.{u1} (Finset.{u1} α)} {B : Set.{u1} (Finset.{u1} α)} {r : Nat}, Iff (Set.Sized.{u1} α r (Union.union.{u1} (Set.{u1} (Finset.{u1} α)) (Set.instUnionSet.{u1} (Finset.{u1} α)) A B)) (And (Set.Sized.{u1} α r A) (Set.Sized.{u1} α r B))
Case conversion may be inaccurate. Consider using '#align set.sized_union Set.sized_unionₓ'. -/
theorem sized_union : (A ∪ B).Sized r ↔ A.Sized r ∧ B.Sized r :=
  ⟨fun hA => ⟨hA.mono <| subset_union_left _ _, hA.mono <| subset_union_right _ _⟩, fun hA x hx =>
    hx.elim (fun h => hA.1 h) fun h => hA.2 h⟩
#align set.sized_union Set.sized_union

/- warning: set.sized.union -> Set.sized.union is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {A : Set.{u1} (Finset.{u1} α)} {B : Set.{u1} (Finset.{u1} α)} {r : Nat}, (And (Set.Sized.{u1} α r A) (Set.Sized.{u1} α r B)) -> (Set.Sized.{u1} α r (Union.union.{u1} (Set.{u1} (Finset.{u1} α)) (Set.hasUnion.{u1} (Finset.{u1} α)) A B))
but is expected to have type
  forall {α : Type.{u1}} {A : Set.{u1} (Finset.{u1} α)} {B : Set.{u1} (Finset.{u1} α)} {r : Nat}, (And (Set.Sized.{u1} α r A) (Set.Sized.{u1} α r B)) -> (Set.Sized.{u1} α r (Union.union.{u1} (Set.{u1} (Finset.{u1} α)) (Set.instUnionSet.{u1} (Finset.{u1} α)) A B))
Case conversion may be inaccurate. Consider using '#align set.sized.union Set.sized.unionₓ'. -/
alias sized_union ↔ _ sized.union
#align set.sized.union Set.sized.union

/- warning: set.sized_Union -> Set.sized_unionᵢ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Sort.{u2}} {r : Nat} {f : ι -> (Set.{u1} (Finset.{u1} α))}, Iff (Set.Sized.{u1} α r (Set.unionᵢ.{u1, u2} (Finset.{u1} α) ι (fun (i : ι) => f i))) (forall (i : ι), Set.Sized.{u1} α r (f i))
but is expected to have type
  forall {α : Type.{u2}} {ι : Sort.{u1}} {r : Nat} {f : ι -> (Set.{u2} (Finset.{u2} α))}, Iff (Set.Sized.{u2} α r (Set.unionᵢ.{u2, u1} (Finset.{u2} α) ι (fun (i : ι) => f i))) (forall (i : ι), Set.Sized.{u2} α r (f i))
Case conversion may be inaccurate. Consider using '#align set.sized_Union Set.sized_unionᵢₓ'. -/
--TODO: A `forall_Union` lemma would be handy here.
@[simp]
theorem sized_unionᵢ {f : ι → Set (Finset α)} : (⋃ i, f i).Sized r ↔ ∀ i, (f i).Sized r :=
  by
  simp_rw [Set.Sized, Set.mem_unionᵢ, forall_exists_index]
  exact forall_swap
#align set.sized_Union Set.sized_unionᵢ

/- warning: set.sized_Union₂ -> Set.sized_unionᵢ₂ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {ι : Sort.{u2}} {κ : ι -> Sort.{u3}} {r : Nat} {f : forall (i : ι), (κ i) -> (Set.{u1} (Finset.{u1} α))}, Iff (Set.Sized.{u1} α r (Set.unionᵢ.{u1, u2} (Finset.{u1} α) ι (fun (i : ι) => Set.unionᵢ.{u1, u3} (Finset.{u1} α) (κ i) (fun (j : κ i) => f i j)))) (forall (i : ι) (j : κ i), Set.Sized.{u1} α r (f i j))
but is expected to have type
  forall {α : Type.{u3}} {ι : Sort.{u2}} {κ : ι -> Sort.{u1}} {r : Nat} {f : forall (i : ι), (κ i) -> (Set.{u3} (Finset.{u3} α))}, Iff (Set.Sized.{u3} α r (Set.unionᵢ.{u3, u2} (Finset.{u3} α) ι (fun (i : ι) => Set.unionᵢ.{u3, u1} (Finset.{u3} α) (κ i) (fun (j : κ i) => f i j)))) (forall (i : ι) (j : κ i), Set.Sized.{u3} α r (f i j))
Case conversion may be inaccurate. Consider using '#align set.sized_Union₂ Set.sized_unionᵢ₂ₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:107:6: warning: expanding binder group (i j) -/
@[simp]
theorem sized_unionᵢ₂ {f : ∀ i, κ i → Set (Finset α)} :
    (⋃ (i) (j), f i j).Sized r ↔ ∀ i j, (f i j).Sized r := by simp_rw [sized_Union]
#align set.sized_Union₂ Set.sized_unionᵢ₂

#print Set.Sized.isAntichain /-
protected theorem Sized.isAntichain (hA : A.Sized r) : IsAntichain (· ⊆ ·) A :=
  fun s hs t ht h hst => h <| Finset.eq_of_subset_of_card_le hst ((hA ht).trans (hA hs).symm).le
#align set.sized.is_antichain Set.Sized.isAntichain
-/

#print Set.Sized.subsingleton /-
protected theorem Sized.subsingleton (hA : A.Sized 0) : A.Subsingleton :=
  subsingleton_of_forall_eq ∅ fun s hs => card_eq_zero.1 <| hA hs
#align set.sized.subsingleton Set.Sized.subsingleton
-/

#print Set.Sized.subsingleton' /-
theorem Sized.subsingleton' [Fintype α] (hA : A.Sized (Fintype.card α)) : A.Subsingleton :=
  subsingleton_of_forall_eq Finset.univ fun s hs => s.card_eq_iff_eq_univ.1 <| hA hs
#align set.sized.subsingleton' Set.Sized.subsingleton'
-/

#print Set.Sized.empty_mem_iff /-
theorem Sized.empty_mem_iff (hA : A.Sized r) : ∅ ∈ A ↔ A = {∅} :=
  hA.IsAntichain.bot_mem_iff
#align set.sized.empty_mem_iff Set.Sized.empty_mem_iff
-/

#print Set.Sized.univ_mem_iff /-
theorem Sized.univ_mem_iff [Fintype α] (hA : A.Sized r) : Finset.univ ∈ A ↔ A = {Finset.univ} :=
  hA.IsAntichain.top_mem_iff
#align set.sized.univ_mem_iff Set.Sized.univ_mem_iff
-/

#print Set.sized_powersetLen /-
theorem sized_powersetLen (s : Finset α) (r : ℕ) : (powersetLen r s : Set (Finset α)).Sized r :=
  fun t ht => (mem_powersetLen.1 ht).2
#align set.sized_powerset_len Set.sized_powersetLen
-/

end Set

namespace Finset

section Sized

variable [Fintype α] {𝒜 : Finset (Finset α)} {s : Finset α} {r : ℕ}

#print Finset.subset_powersetLen_univ_iff /-
theorem subset_powersetLen_univ_iff : 𝒜 ⊆ powersetLen r univ ↔ (𝒜 : Set (Finset α)).Sized r :=
  forall_congr' fun A => by rw [mem_powerset_len_univ_iff, mem_coe]
#align finset.subset_powerset_len_univ_iff Finset.subset_powersetLen_univ_iff
-/

alias subset_powerset_len_univ_iff ↔ _ _root_.set.sized.subset_powerset_len_univ
#align set.sized.subset_powerset_len_univ Set.Sized.subset_powersetLen_univ

#print Finset.Set.Sized.card_le /-
theorem Finset.Set.Sized.card_le (h𝒜 : (𝒜 : Set (Finset α)).Sized r) :
    card 𝒜 ≤ (Fintype.card α).choose r :=
  by
  rw [Fintype.card, ← card_powerset_len]
  exact card_le_of_subset h𝒜.subset_powerset_len_univ
#align set.sized.card_le Finset.Set.Sized.card_le
-/

end Sized

/-! ### Slices -/

section Slice

variable {𝒜 : Finset (Finset α)} {A A₁ A₂ : Finset α} {r r₁ r₂ : ℕ}

#print Finset.slice /-
/-- The `r`-th slice of a set family is the subset of its elements which have cardinality `r`. -/
def slice (𝒜 : Finset (Finset α)) (r : ℕ) : Finset (Finset α) :=
  𝒜.filterₓ fun i => i.card = r
#align finset.slice Finset.slice
-/

-- mathport name: finset.slice
scoped[FinsetFamily] infixl:90 " # " => Finset.slice

#print Finset.mem_slice /-
/-- `A` is in the `r`-th slice of `𝒜` iff it's in `𝒜` and has cardinality `r`. -/
theorem mem_slice : A ∈ 𝒜 # r ↔ A ∈ 𝒜 ∧ A.card = r :=
  mem_filter
#align finset.mem_slice Finset.mem_slice
-/

#print Finset.slice_subset /-
/-- The `r`-th slice of `𝒜` is a subset of `𝒜`. -/
theorem slice_subset : 𝒜 # r ⊆ 𝒜 :=
  filter_subset _ _
#align finset.slice_subset Finset.slice_subset
-/

#print Finset.sized_slice /-
/-- Everything in the `r`-th slice of `𝒜` has size `r`. -/
theorem sized_slice : (𝒜 # r : Set (Finset α)).Sized r := fun _ => And.right ∘ mem_slice.mp
#align finset.sized_slice Finset.sized_slice
-/

#print Finset.eq_of_mem_slice /-
theorem eq_of_mem_slice (h₁ : A ∈ 𝒜 # r₁) (h₂ : A ∈ 𝒜 # r₂) : r₁ = r₂ :=
  (sized_slice h₁).symm.trans <| sized_slice h₂
#align finset.eq_of_mem_slice Finset.eq_of_mem_slice
-/

#print Finset.ne_of_mem_slice /-
/-- Elements in distinct slices must be distinct. -/
theorem ne_of_mem_slice (h₁ : A₁ ∈ 𝒜 # r₁) (h₂ : A₂ ∈ 𝒜 # r₂) : r₁ ≠ r₂ → A₁ ≠ A₂ :=
  mt fun h => (sized_slice h₁).symm.trans ((congr_arg card h).trans (sized_slice h₂))
#align finset.ne_of_mem_slice Finset.ne_of_mem_slice
-/

/- warning: finset.pairwise_disjoint_slice -> Finset.pairwiseDisjoint_slice is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {𝒜 : Finset.{u1} (Finset.{u1} α)}, Set.PairwiseDisjoint.{u1, 0} (Finset.{u1} (Finset.{u1} α)) Nat (Finset.partialOrder.{u1} (Finset.{u1} α)) (Finset.orderBot.{u1} (Finset.{u1} α)) (Set.univ.{0} Nat) (Finset.slice.{u1} α 𝒜)
but is expected to have type
  forall {α : Type.{u1}} {𝒜 : Finset.{u1} (Finset.{u1} α)}, Set.PairwiseDisjoint.{u1, 0} (Finset.{u1} (Finset.{u1} α)) Nat (Finset.partialOrder.{u1} (Finset.{u1} α)) (Finset.instOrderBotFinsetToLEToPreorderPartialOrder.{u1} (Finset.{u1} α)) (Set.univ.{0} Nat) (Finset.slice.{u1} α 𝒜)
Case conversion may be inaccurate. Consider using '#align finset.pairwise_disjoint_slice Finset.pairwiseDisjoint_sliceₓ'. -/
theorem pairwiseDisjoint_slice : (Set.univ : Set ℕ).PairwiseDisjoint (slice 𝒜) := fun m _ n _ hmn =>
  disjoint_filter.2 fun s hs hm hn => hmn <| hm.symm.trans hn
#align finset.pairwise_disjoint_slice Finset.pairwiseDisjoint_slice

variable [Fintype α] (𝒜)

#print Finset.bunionᵢ_slice /-
@[simp]
theorem bunionᵢ_slice [DecidableEq α] : (Iic <| Fintype.card α).bunionᵢ 𝒜.slice = 𝒜 :=
  Subset.antisymm (bunionᵢ_subset.2 fun r _ => slice_subset) fun s hs =>
    mem_bunionᵢ.2 ⟨s.card, mem_Iic.2 <| s.card_le_univ, mem_slice.2 <| ⟨hs, rfl⟩⟩
#align finset.bUnion_slice Finset.bunionᵢ_slice
-/

#print Finset.sum_card_slice /-
@[simp]
theorem sum_card_slice : (∑ r in Iic (Fintype.card α), (𝒜 # r).card) = 𝒜.card :=
  by
  letI := Classical.decEq α
  rw [← card_bUnion, bUnion_slice]
  exact finset.pairwise_disjoint_slice.subset (Set.subset_univ _)
#align finset.sum_card_slice Finset.sum_card_slice
-/

end Slice

end Finset


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.int.basic
import ring_theory.localization

/-!
# Gauss's Lemma

Gauss's Lemma is one of a few results pertaining to irreducibility of primitive polynomials.

## Main Results
 - `polynomial.is_primitive.irreducible_iff_irreducible_map_fraction_map`:
  A primitive polynomial is irreducible iff it is irreducible in a fraction field.
 - `polynomial.is_primitive.int.irreducible_iff_irreducible_map_cast`:
  A primitive polynomial over `ℤ` is irreducible iff it is irreducible over `ℚ`.
 - `polynomial.is_primitive.dvd_iff_fraction_map_dvd_fraction_map`:
  Two primitive polynomials divide each other iff they do in a fraction field.
 - `polynomial.is_primitive.int.dvd_iff_map_cast_dvd_map_cast`:
  Two primitive polynomials over `ℤ` divide each other if they do in `ℚ`.

-/

variables {R : Type*} [integral_domain R]

namespace polynomial
section gcd_monoid
variable [gcd_monoid R]

section
variables {S : Type*} [integral_domain S] {φ : R →+* S} (hinj : function.injective φ)
variables {f : polynomial R} (hf : f.is_primitive)
include hinj hf

lemma is_primitive.is_unit_iff_is_unit_map_of_injective :
  is_unit f ↔ is_unit (map φ f) :=
begin
  refine ⟨(ring_hom.of (map φ)).is_unit_map, λ h, _⟩,
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  have hdeg := degree_C u.ne_zero,
  rw [hu, degree_map' hinj] at hdeg,
  rw [eq_C_of_degree_eq_zero hdeg, is_primitive_iff_content_eq_one,
      content_C, normalize_eq_one] at hf,
  rwa [eq_C_of_degree_eq_zero hdeg, is_unit_C],
end

lemma is_primitive.irreducible_of_irreducible_map_of_injective (h_irr : irreducible (map φ f)) :
  irreducible f :=
begin
  refine ⟨λ h, h_irr.not_unit (is_unit.map (monoid_hom.of (map φ)) h), _⟩,
  intros a b h,
  rcases h_irr.is_unit_or_is_unit (by rw [h, map_mul]) with hu | hu,
  { left,
    rwa (hf.is_primitive_of_dvd (dvd.intro _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj },
  right,
  rwa (hf.is_primitive_of_dvd (dvd.intro_left _ h.symm)).is_unit_iff_is_unit_map_of_injective hinj
end

end

section fraction_map
variables {K : Type*} [field K] (f : fraction_map R K)

lemma is_primitive.is_unit_iff_is_unit_map {p : polynomial R} (hp : p.is_primitive) :
  is_unit p ↔ is_unit (p.map f.to_map) :=
hp.is_unit_iff_is_unit_map_of_injective f.injective

open localization_map

lemma is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part
  {p : polynomial K} (h0 : p ≠ 0) (h : is_unit (f.integer_normalization p).prim_part) :
  is_unit p :=
begin
  rcases is_unit_iff.1 h with ⟨_, ⟨u, rfl⟩, hu⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := @integer_normalization_map_to_map _ _ _ _ _ f p,
  rw [algebra.smul_def, ← C_eq_algebra_map, subtype.coe_mk] at hc,
  apply is_unit_of_mul_is_unit_right,
  rw [← hc, (f.integer_normalization p).eq_C_content_mul_prim_part, ← hu,
    ← ring_hom.map_mul, is_unit_iff],
  refine ⟨f.to_map ((f.integer_normalization p).content * ↑u),
    is_unit_iff_ne_zero.2 (λ con, _), by simp⟩,
  replace con := (ring_hom.injective_iff f.to_map).1 f.injective _ con,
  rw [mul_eq_zero, content_eq_zero_iff, fraction_map.integer_normalization_eq_zero_iff] at con,
  rcases con with con | con,
  { apply h0 con },
  { apply units.ne_zero _ con },
end

/-- Gauss's Lemma states that a primitive polynomial is irreducible iff it is irreducible in the
  fraction field. -/
theorem is_primitive.irreducible_iff_irreducible_map_fraction_map
  {p : polynomial R} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map f.to_map) :=
begin
  refine ⟨λ hi, ⟨λ h, hi.not_unit ((hp.is_unit_iff_is_unit_map f).2 h), λ a b hab, _⟩,
    hp.irreducible_of_irreducible_map_of_injective f.injective⟩,
  obtain ⟨⟨c, c0⟩, hc⟩ := @integer_normalization_map_to_map _ _ _ _ _ f a,
  obtain ⟨⟨d, d0⟩, hd⟩ := @integer_normalization_map_to_map _ _ _ _ _ f b,
  rw [algebra.smul_def, ← C_eq_algebra_map, subtype.coe_mk] at hc hd,
  rw mem_non_zero_divisors_iff_ne_zero at c0 d0,
  have hcd0 : c * d ≠ 0 := mul_ne_zero c0 d0,
  rw [ne.def, ← C_eq_zero] at hcd0,
  have h1 : C c * C d * p = f.integer_normalization a * f.integer_normalization b,
  { apply (map_injective _ f.injective _),
    rw [map_mul, map_mul, map_mul, hc, hd, map_C, map_C, hab],
    ring },
  obtain ⟨u, hu⟩ : associated (c * d) (content (f.integer_normalization a) *
            content (f.integer_normalization b)),
  { rw [← dvd_dvd_iff_associated, ← normalize_eq_normalize_iff, normalize.map_mul,
        normalize.map_mul, normalize_content, normalize_content,
        ← mul_one (normalize c * normalize d), ← hp.content_eq_one, ← content_C, ← content_C,
        ← content_mul, ← content_mul, ← content_mul, h1] },
  rw [← ring_hom.map_mul, eq_comm,
    (f.integer_normalization a).eq_C_content_mul_prim_part,
    (f.integer_normalization b).eq_C_content_mul_prim_part, mul_assoc,
    mul_comm _ (C _ * _), ← mul_assoc, ← mul_assoc, ← ring_hom.map_mul, ← hu, ring_hom.map_mul,
    mul_assoc, mul_assoc, ← mul_assoc (C ↑u)] at h1,
  have h0 : (a ≠ 0) ∧ (b ≠ 0),
  { classical,
    rw [ne.def, ne.def, ← decidable.not_or_iff_and_not, ← mul_eq_zero, ← hab],
    intro con,
    apply hp.ne_zero (map_injective _ f.injective _),
    simp [con] },
  rcases hi.is_unit_or_is_unit (mul_left_cancel' hcd0 h1).symm with h | h,
  { right,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part f h0.2
      (is_unit_of_mul_is_unit_right h) },
  { left,
    apply is_unit_or_eq_zero_of_is_unit_integer_normalization_prim_part f h0.1 h },
end

lemma is_primitive.dvd_of_fraction_map_dvd_fraction_map {p q : polynomial R}
  (hp : p.is_primitive) (hq : q.is_primitive) (h_dvd : p.map f.to_map ∣ q.map f.to_map) :
  (p ∣ q) :=
begin
  rcases h_dvd with ⟨r, hr⟩,
  obtain ⟨⟨s, s0⟩, hs⟩ := @integer_normalization_map_to_map _ _ _ _ _ f r,
  rw [algebra.smul_def, ← C_eq_algebra_map, subtype.coe_mk] at hs,
  have h : p ∣ q * C s,
  { use (f.integer_normalization r),
    apply map_injective _ f.injective,
    rw [map_mul, map_mul, hs, hr, mul_assoc, mul_comm r],
    simp },
  rw [← hp.dvd_prim_part_iff_dvd, prim_part_mul, hq.prim_part_eq, dvd_iff_dvd_of_rel_right] at h,
  { exact h },
  { symmetry,
    rcases is_unit_prim_part_C s with ⟨u, hu⟩,
    use u,
    simp [hu], },
  iterate 2 { apply mul_ne_zero hq.ne_zero,
    rw [ne.def, C_eq_zero],
    contrapose! s0,
    simp [s0, mem_non_zero_divisors_iff_ne_zero] }
end

lemma is_primitive.dvd_iff_fraction_map_dvd_fraction_map {p q : polynomial R}
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map f.to_map ∣ q.map f.to_map) :=
⟨λ ⟨a,b⟩, ⟨a.map f.to_map, b.symm ▸ (map_mul f.to_map)⟩,
  λ h, hp.dvd_of_fraction_map_dvd_fraction_map f hq h⟩

end fraction_map

/-- Gauss's Lemma for `ℤ` states that a primitive integer polynomial is irreducible iff it is
  irreducible over `ℚ`. -/
theorem is_primitive.int.irreducible_iff_irreducible_map_cast
  {p : polynomial ℤ} (hp : p.is_primitive) :
  irreducible p ↔ irreducible (p.map (int.cast_ring_hom ℚ)) :=
hp.irreducible_iff_irreducible_map_fraction_map fraction_map.int.fraction_map

lemma is_primitive.int.dvd_iff_map_cast_dvd_map_cast (p q : polynomial ℤ)
  (hp : p.is_primitive) (hq : q.is_primitive) :
  (p ∣ q) ↔ (p.map (int.cast_ring_hom ℚ) ∣ q.map (int.cast_ring_hom ℚ)) :=
hp.dvd_iff_fraction_map_dvd_fraction_map fraction_map.int.fraction_map hq

end gcd_monoid
end polynomial


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.shapes.equalizers

/-!
# Split coequalizers

We define what it means for a triple of morphisms `f g : X ⟶ Y`, `π : Y ⟶ Z` to be a split
coequalizer: there is a section `s` of `π` and a section `t` of `g`, which additionally satisfy
`t ≫ f = π ≫ s`.

In addition, we show that every split coequalizer is a coequalizer
(`category_theory.is_split_coequalizer.is_coequalizer`) and absolute
(`category_theory.is_split_coequalizer.map`)

A pair `f g : X ⟶ Y` has a split coequalizer if there is a `Z` and `π : Y ⟶ Z` making `f,g,π` a
split coequalizer.
A pair `f g : X ⟶ Y` has a `G`-split coequalizer if `G f, G g` has a split coequalizer.

These definitions and constructions are useful in particular for the monadicity theorems.

## TODO

Dualise to split equalizers.
-/

namespace category_theory

universes v v₂ u u₂

variables {C : Type u} [category.{v} C]
variables {D : Type u₂} [category.{v₂} D]
variables (G : C ⥤ D)
variables {X Y : C} (f g : X ⟶ Y)

/--
A split coequalizer diagram consists of morphisms

      f   π
    X ⇉ Y → Z
      g

satisfying `f ≫ π = g ≫ π` together with morphisms

      t   s
    X ← Y ← Z

satisfying `s ≫ π = 𝟙 Z`, `t ≫ g = 𝟙 Y` and `t ≫ f = π ≫ s`.

The name "coequalizer" is appropriate, since any split coequalizer is a coequalizer, see
`category_theory.is_split_coequalizer.is_coequalizer`.
Split coequalizers are also absolute, since a functor preserves all the structure above.
-/
structure is_split_coequalizer {Z : C} (π : Y ⟶ Z) :=
(right_section : Z ⟶ Y)
(left_section : Y ⟶ X)
(condition : f ≫ π = g ≫ π)
(right_section_π : right_section ≫ π = 𝟙 Z)
(left_section_bottom : left_section ≫ g = 𝟙 Y)
(left_section_top : left_section ≫ f = π ≫ right_section)

instance {X : C} : inhabited (is_split_coequalizer (𝟙 X) (𝟙 X) (𝟙 X)) :=
⟨⟨𝟙 _, 𝟙 _, rfl, category.id_comp _, category.id_comp _, rfl⟩⟩

open is_split_coequalizer
attribute [reassoc] condition
attribute [simp, reassoc] right_section_π left_section_bottom left_section_top

variables {f g}

/-- Split coequalizers are absolute: they are preserved by any functor. -/
@[simps]
def is_split_coequalizer.map {Z : C} {π : Y ⟶ Z} (q : is_split_coequalizer f g π) (F : C ⥤ D) :
  is_split_coequalizer (F.map f) (F.map g) (F.map π) :=
{ right_section := F.map q.right_section,
  left_section := F.map q.left_section,
  condition := by rw [←F.map_comp, q.condition, F.map_comp],
  right_section_π := by rw [←F.map_comp, q.right_section_π, F.map_id],
  left_section_bottom := by rw [←F.map_comp, q.left_section_bottom, F.map_id],
  left_section_top := by rw [←F.map_comp, q.left_section_top, F.map_comp] }

section

open limits

/-- A split coequalizer clearly induces a cofork. -/
@[simps X]
def is_split_coequalizer.as_cofork {Z : C} {h : Y ⟶ Z} (t : is_split_coequalizer f g h) :
  cofork f g :=
cofork.of_π h t.condition

@[simp] lemma is_split_coequalizer.as_cofork_π  {Z : C} {h : Y ⟶ Z}
  (t : is_split_coequalizer f g h) : t.as_cofork.π = h := rfl

/--
The cofork induced by a split coequalizer is a coequalizer, justifying the name. In some cases it
is more convenient to show a given cofork is a coequalizer by showing it is split.
-/
def is_split_coequalizer.is_coequalizer
  {Z : C} {h : Y ⟶ Z} (t : is_split_coequalizer f g h) :
  is_colimit t.as_cofork :=
cofork.is_colimit.mk' _ $ λ s,
⟨t.right_section ≫ s.π,
 by { dsimp, rw [← t.left_section_top_assoc, s.condition, t.left_section_bottom_assoc] },
 λ m hm, by { simp [←hm] }⟩

end

variables (f g)
/--
The pair `f,g` is a split pair if there is a `h : Y ⟶ Z` so that `f, g, h` forms a split coequalizer
in `C`.
-/
class has_split_coequalizer : Prop :=
(splittable [] : ∃ {Z : C} (h : Y ⟶ Z), nonempty (is_split_coequalizer f g h))

/--
The pair `f,g` is a `G`-split pair if there is a `h : G Y ⟶ Z` so that `G f, G g, h` forms a split
coequalizer in `D`.
-/
abbreviation functor.is_split_pair : Prop := has_split_coequalizer (G.map f) (G.map g)

/-- Get the coequalizer object from the typeclass `is_split_pair`. -/
noncomputable def has_split_coequalizer.coequalizer_of_split [has_split_coequalizer f g] : C :=
(has_split_coequalizer.splittable f g).some

/-- Get the coequalizer morphism from the typeclass `is_split_pair`. -/
noncomputable def has_split_coequalizer.coequalizer_π [has_split_coequalizer f g] :
  Y ⟶ has_split_coequalizer.coequalizer_of_split f g :=
(has_split_coequalizer.splittable f g).some_spec.some

/-- The coequalizer morphism `coequalizer_ι` gives a split coequalizer on `f,g`. -/
noncomputable def has_split_coequalizer.is_split_coequalizer [has_split_coequalizer f g] :
  is_split_coequalizer f g (has_split_coequalizer.coequalizer_π f g) :=
classical.choice (has_split_coequalizer.splittable f g).some_spec.some_spec

/-- If `f, g` is split, then `G f, G g` is split. -/
instance map_is_split_pair [has_split_coequalizer f g] :
  has_split_coequalizer (G.map f) (G.map g) :=
{ splittable :=
  ⟨_, _, ⟨is_split_coequalizer.map (has_split_coequalizer.is_split_coequalizer f g) _⟩⟩ }

namespace limits

/-- If a pair has a split coequalizer, it has a coequalizer. -/
@[priority 1]
instance has_coequalizer_of_has_split_coequalizer [has_split_coequalizer f g] :
  has_coequalizer f g :=
has_colimit.mk ⟨_, (has_split_coequalizer.is_split_coequalizer f g).is_coequalizer⟩

end limits

end category_theory


import data.nat.gcd
import data.nat.prime

import pyth

open nat

local attribute [simp] mul_comm mul_left_comm mul_assoc

section fermat
  parameters x y z : ℕ
  parameter fmt : x^4 = y^4 + z^2
  parameter pos : x > 0 ∧ y > 0 ∧ z > 0
  include fmt pos

  lemma x_pos : x > 0 := pos.1
  lemma y_pos : y > 0 := pos.2.1
  lemma z_pos : z > 0 := pos.2.2

  lemma y_lt_x : y < x := begin
    cases nat.lt_or_ge y x with _ ge, { assumption },
    { have z2pos : z^2 > 0 := begin
        rw nat.pow_two,
        exact nat.mul_self_lt_mul_self_iff.mp z_pos
      end,
      have : y^4 < y^4 :=
      calc y^4 < y^4 + z^2  : nat.lt_add_of_pos_right z2pos
           ... = x^4        : by rw fmt
           ... ≤ y^4        : pow_le_pow_of_le_left ge 4,
      exact absurd this (not_lt_of_ge (le_refl (y^4)))
    }
  end
  lemma y_le_x : y ≤ x := le_of_lt y_lt_x

  lemma l1 : (x^2 + y^2) * (x^2 - y^2) = z^2 :=
  calc (x^2 + y^2) * (x^2 - y^2) = x^2 * x^2 - y^2 * y^2  : by rw ←nat.mul_self_sub_mul_self_eq
       ...                       = x^(2 + 2) - y^(2 + 2)  : by simp [nat.pow_add]
       ...                       = y^4 + z^2 - y^4        : by simp [fmt]
       ...                       = z^2                    : by rw nat.add_sub_cancel_left

  section x_y
    parameter x_y : coprime x y
    include x_y

    lemma x2_y2 : coprime (x^2) (y^2) := coprime.pow 2 2 x_y
    lemma l2 : gcd (x^2 - y^2) (x^2 + y^2) ∣ 2 :=
      gcd.sum_difference_of_coprime (y^2) (x^2) (pow_le_pow_of_le_left y_le_x 2) (coprime.pow 2 2 x_y.symm)

    section case_a
    parameter gmp2 : gcd (x^2 - y^2) (x^2 + y^2) = 2
    include gmp2

    lemma x2py2_even : 2 ∣ x^2 + y^2 := begin
      have := (gcd_dvd (x^2 - y^2) (x^2 + y^2)).right,
      rwa gmp2 at this,
    end

    lemma odd_x : odd x := begin
      apply even_xor_odd.resolve_left.mp, intro even_x,
      have := not_both_even_if_coprime x_y,
      cases even_or_odd y with even_y odd_y,
      { exact this ⟨even_x, even_y⟩ },
      { have x2py2_odd : odd (x^2 + y^2) :=
          even_plus_odd_is_odd (even_square_is_even even_x)
                               (odd_square_is_odd odd_y),
        exact not_even_and_odd (x^2 + y^2) ⟨even_iff_two_dvd.mpr x2py2_even, x2py2_odd⟩
      }
    end
    lemma odd_y : odd y := begin
      apply even_xor_odd.resolve_left.mp, intro even_y,
      have x2py2_odd : odd (x^2 + y^2) :=
        odd_plus_even_is_odd (odd_square_is_odd odd_x)
                             (even_square_is_even even_y),
        exact not_even_and_odd (x^2 + y^2) ⟨even_iff_two_dvd.mpr x2py2_even, x2py2_odd⟩
    end

    lemma case_a :
      ∃ x' y' z' : ℕ,
      0 < x' ∧ 0 < y' ∧ 0 < z' ∧ x' < x ∧ x'^4 = y'^4 + z'^2 :=
    begin
      have py : (y^2)^2 + z^2 = (x^2)^2 :=
      calc (y^2)^2 + z^2 = y^4 + z^2  : by rw square_twice
           ...           = x^4        : fmt.symm
           ...           = (x^2)^2    : by rw square_twice,
      have ppos : y^2 > 0 ∧ z > 0 ∧ x^2 > 0 :=
        ⟨ pos_pow_of_pos 2 y_pos, z_pos, pos_pow_of_pos 2 x_pos ⟩,
      have even_z : even z := or.resolve_right (even_or_odd z) (begin
          intro odd_z,
          have ex4 : even (x^4) := begin
            rw fmt,
            rw ←square_twice,
            apply odd_plus_odd_is_even,
            exact (odd_square_is_odd (odd_square_is_odd odd_y)),
            exact (odd_square_is_odd odd_z)
          end,
          have ox4 : odd (x^4) := begin
            rw ←square_twice,
            exact (odd_square_is_odd (odd_square_is_odd odd_x))
          end,
          exact absurd (and.intro ex4 ox4) (not_even_and_odd (x^4))
        end),
      have y2_z : coprime (y^2) z := begin
        have x4_y4 : coprime (x^4) (y^4) := coprime.pow 4 4 x_y,
        rw fmt at x4_y4,
        have y4_z2 : coprime (y^4) (z^2) := begin
          rw coprime at *,
          have : gcd (y^4) (z^2) = gcd (y^4) (y^4 * 1 + z^2) := gcd.gcd_row_op (y^4) (z^2) 1,
          rw gcd_comm at x4_y4,
          rewrite [nat.mul_one, x4_y4] at this,
          assumption
        end,
        rw ←square_twice at y4_z2,
        exact gcd.coprime_iff_squares_coprime.mp y4_z2,
      end,
      rcases ex (y^2) z (x^2) py y2_z even_z ppos
        with ⟨d,e,d_pos,e_pos,d_gt_e,_,Hy,Hz,Hx⟩,

      have e2_pos : e^2 > 0 := pos_pow_of_pos 2 e_pos,

      have d_ge_e : d ≥ e := le_of_lt d_gt_e,

      existsi [d, e, x*y],
      repeat { split },
      { exact d_pos }, { exact e_pos }, { exact mul_pos x_pos y_pos },
      { apply (nat.lt_or_ge d x).resolve_right,
        intro d_ge_x,
        have : x^2 < x^2 :=
        calc x^2 = d^2 + e^2  : by rw Hx
             ... ≥ x^2 + e^2  : nat.add_le_add_right (pow_le_pow_of_le_left d_ge_x 2) (e^2)
             ... > x^2        : nat.lt_add_of_pos_right e2_pos,
        exact absurd this (lt_irrefl _)
      },
      { have : d^4 - e^4 = (x * y)^2 :=
        calc d^4 - e^4 = (d^2)^2 - (e^2)^2  : by rw [square_twice, square_twice]
             ...       = (d^2)*(d^2) - (e^2)*(e^2)  : by rw [@nat.pow_two (d^2), @nat.pow_two (e^2)]
             ...       = (d^2 + e^2) * (d^2 - e^2)  : nat.mul_self_sub_mul_self_eq (d^2) (e^2)
             ...       = x^2 * y^2          : by rw [←Hx, ←Hy]
      -- Why is there no (a * b)^n = a^n * b^n
             ...       = (x * x) * (y * y)  : by simp [nat.pow_two]
             ...       = (x * y) * (x * y)  : by simp
             ...       = (x * y)^2          : by rw ←nat.pow_two,
        exact
        calc d^4 = (d^4 - e^4) + e^4  : (nat.sub_add_cancel (pow_le_pow_of_le_left d_ge_e 4)).symm
             ... = (x * y)^2 + e^4    : by rw this
             ... = e^4 + (x * y)^2    : by simp,
      }
    end
    end case_a

    section case_b
      parameter g : gcd (x^2 - y^2) (x^2 + y^2) = 1
      include g

      -- From (x^2 - y^2) * (x^2 + y^2) = z^2
      parameters s t : ℕ
      parameter Hs : x^2 + y^2 = s^2
      parameter Ht : x^2 - y^2 = t^2
      include Hs Ht

      def s_pos : s > 0 := begin
        apply (eq_zero_or_pos s).resolve_left, intro s_zero,
        simp [s_zero] at Hs,
        have : 0^2 > 0^2 :=
        calc 0^2 = x^2 + y^2  : by rw Hs
             ... ≥ x^2        : le_add_right _ _
             ... > 0^2        : pow_lt_pow_of_lt_left x_pos dec_trivial,
        exact absurd this (lt_irrefl _)
      end

      def s_odd : odd s := c_odd x y s Hs x_y
      def t_odd : odd t :=
        have l : s^2 + t^2 = 2 * x^2, from
        calc s^2 + t^2 = (x^2 - y^2) + (x^2 + y^2)  : by rw [add_comm, Hs, Ht]
             ...       = 2 * x^2                    : by rw ←gcd.sum_difference_sum (pow_le_pow_of_le_left y_le_x 2),

        begin
          cases even_or_odd t with t_even _,
          { have : odd (s^2 + t^2) :=
              odd_plus_even_is_odd (odd_square_is_odd s_odd)
                                   (even_square_is_even t_even),
            rw l at this,
            have e : even (2 * x^2) := even_times_any_is_even (dec_trivial : 2 ≡ 0 [MOD 2]),
            exact absurd (and.intro e this) (not_even_and_odd _)
          },
          assumption
        end

      def t_lt_s : t < s := lt_of_not_ge $ begin
        by_contradiction h,
        have :=
        calc x^2 + y^2 = s^2        : Hs
             ...       ≤ t^2        : pow_le_pow_of_le_left h 2
             ...       = x^2 - y^2  : Ht.symm
             ...       ≤ x^2        : sub_le _ _
             ...       < x^2 + y^2  : nat.lt_add_of_pos_right
                                      (pos_pow_of_pos 2 y_pos),
        exact absurd this (lt_irrefl _) -- @[irrefl]?
      end
      def t_le_s := le_of_lt t_lt_s

      def spt_even : even (s + t) := odd_plus_odd_is_even s_odd t_odd
      def smt_even : even (s - t) := odd_minus_odd_is_even t_le_s t_odd s_odd

      -- These definitions are in core lean :(
      local attribute [trans] dvd_trans
      local attribute [refl] dvd_refl

      def s_t : coprime s t := begin
        apply coprime_of_dvd', intros k ks kt,
        have x2_y2 := gcd.coprime_iff_squares_coprime.mpr x_y,
        have := gcd.sum_difference_of_coprime (y^2) (x^2)
                (pow_le_pow_of_le_left y_le_x 2) x2_y2.symm,
        have k2_div_sub :=
        calc k^2 ∣ t^2  : pow_dvd_pow_of_dvd kt
             ... = x^2 - y^2  : Ht.symm,
        have k2_div_add :=
        calc k^2 ∣ s^2  : pow_dvd_pow_of_dvd ks
             ... = x^2 + y^2  : Hs.symm,
        have k2_div_2 := dvd.trans (dvd_gcd k2_div_sub k2_div_add) this,
        cases (dvd_prime dec_trivial).mp
              (dvd.trans self_divides_square k2_div_2) with k_1 k_2,
        { rw k_1 },
        { rw k_2 at k2_div_2, have : ¬(4 ∣ 2) := dec_trivial, contradiction }
      end

      def u := (s + t) / 2
      lemma lu : 2 * u = s + t :=
        nat.mul_div_cancel' (even_iff_two_dvd.mp spt_even)
      def v := (s - t) / 2
      lemma lv : 2 * v = s - t :=
        nat.mul_div_cancel' (even_iff_two_dvd.mp smt_even)
      lemma u_v : coprime u v := begin
        have g_div_two := gcd.sum_difference_of_coprime t s t_le_s s_t.symm,
        have two_div_g := dvd_gcd (even_iff_two_dvd.mp smt_even) (even_iff_two_dvd.mp spt_even),
        have g_eq_two := dvd_antisymm g_div_two two_div_g,
        rw [←lu, ←lv] at g_eq_two,
        have :=
        calc 2 * gcd u v = gcd (2 * u) (2 * v)  : by rw gcd_mul_left
             ...         = gcd (2 * v) (2 * u)  : gcd_comm _ _
             ...         = 2                    : g_eq_two
             ...         = 2 * 1                : by simp,
        exact eq_of_mul_eq_mul_left dec_trivial this
      end

      lemma y2_2uv : y^2 = 2 * u * v := begin
      have :=
      calc 2 * y^2 = (x^2 + y^2) - (x^2 - y^2)
        : (gcd.sum_difference_difference (pow_le_pow_of_le_left y_le_x 2)).symm
           ...     = s^2 - t^2  : by rw [Hs, Ht]
           ...     = s*s - t*t  : by repeat { rw nat.pow_two }
           ...     = (s + t) * (s - t)  : by rw nat.mul_self_sub_mul_self_eq
           ...     = (2 * u) * (2 * v)  : by rw [lu, lv]
           ...     = 2 * (2 * u * v)    : by ac_refl,
      exact eq_of_mul_eq_mul_left dec_trivial this
      end

      lemma u2_v2_x2 : u^2 + v^2 = x^2 := begin
      have :=
      calc (2^2) * x^2
                   = (2 * 2) * x^2  : by reflexivity
           ...     = 2 * (2 * x^2)  : by rw [mul_assoc]
           ...     = 2 * ((x^2 - y^2) + (x^2 + y^2))
        : by rw (gcd.sum_difference_sum (pow_le_pow_of_le_left y_le_x 2))
           ...     = 2 * (s^2 + t^2)  : by rw [Hs, Ht, add_comm]
           ...     = (s + t)^2 + (s - t)^2  : nat.polarization t_le_s
           ...     = (2 * u)^2 + (2 * v)^2  : by rw [lu, lv]
           ...     = 2^2 * u^2 + 2^2 * v^2  : by rw [nat.mul_pow, nat.mul_pow]
           ...     = 2^2 * (u^2 + v^2)  : by rw mul_add,
      exact eq_of_mul_eq_mul_left dec_trivial this.symm
      end

      lemma y_even : even y := begin
        apply even_iff_square_even.mpr,
        rw [y2_2uv, mul_assoc],
        apply two_n_even
      end
      def half_y := y / 2
      lemma ly : 2 * half_y = y :=
        nat.mul_div_cancel' (even_iff_two_dvd.mp y_even)
      lemma u_or_v_even : even u ∨ even v := begin
        by_contradiction a,
        cases (decidable.not_or_iff_and_not (even u) (even v)).mp a
          with neu nev,
        rw [even_xor_odd.resolve_left] at neu nev,
        have :=
        calc 2 * (u * v) = 2 * u * v  : by ac_refl
             ... = y^2       : y2_2uv.symm
             ... = (2 * half_y)^2  : by rw ly
             ... = (2 * half_y) * (2 * half_y)  : pow_two
             ... = 2 * (2 * (half_y * half_y))  : by ac_refl,
        have := nat.eq_of_mul_eq_mul_left dec_trivial this,
        have odd_uv : odd (u * v) := odd_times_odd_is_odd neu nev,
        have also_even : even (2 * (half_y * half_y)) := two_n_even _,
        rw ←this at also_even,
        exact not_even_and_odd _ ⟨also_even, odd_uv⟩
      end
      lemma uvx_pos : u > 0 ∧ v > 0 ∧ x > 0 := begin
        repeat { split },
        { apply pos_of_pos_mul, rw lu,
          exact calc s + t ≥ s  : le_add_right _ _
                     ...   > 0  : s_pos
        },
        { apply pos_of_pos_mul, rw lv,
          exact nat.sub_pos_of_lt t_lt_s
        },
        { exact x_pos }
      end
      -- have u_v, u^2 + v^2 = x^2, y^2 = 2 * u * v, u > 0 ∧ v > 0
      -- If u is even, swap u & v
      section even_v
        parameters u' v' : ℕ
        parameter u'_pos : u' > 0
        parameter v'_pos : v' > 0
        parameter u'_v' : coprime u' v'
        parameter u'2_v'2_x2 : u'^2 + v'^2 = x^2
        parameter y2_2u'v' : y^2 = 2 * u' * v'
        include u'_pos v'_pos u'_v' u'2_v'2_x2 y2_2u'v'

        parameter even_v' : even v'
        include even_v'

        lemma u'v'x_pos : u' > 0 ∧ v' > 0 ∧ x > 0 := ⟨u'_pos, v'_pos, x_pos⟩
        lemma u'_2v' : coprime u' (2 * v') := begin
          refine coprime.mul_right _ u'_v',
          exact coprime.coprime_dvd_right (even_iff_two_dvd.mp even_v') u'_v'
        end
        lemma v'_twice_square_etc : ∃ m k, u' = m^2 ∧ v' = 2 * k^2 := begin
          have u'2v'_y2 : u' * (2 * v') = y^2 :=
          calc u' * (2 * v') = 2 * u' * v'  : by ac_refl
               ...         = y^2        : y2_2u'v'.symm,
          rcases coprime_square_product u'2v'_y2 u'_2v' with ⟨m, k1, Hm, Hk1⟩,
          have even_k1 : even k1 := begin
            apply or.resolve_right (even_or_odd k1),
            intro odd_k1, have := odd_square_is_odd odd_k1, rw ←Hk1 at this,
            have := two_n_not_odd v', contradiction
          end,
          let k := k1 / 2,
          have H' := nat.mul_div_cancel' (even_iff_two_dvd.mp even_k1),
          existsi [m, k],
          split, { exact Hm }, {
          have :=
          calc 2 * v' = k1^2         : Hk1
               ...   = (2 * k)^2    : by rw H'
               ...   = (2*k)*(2*k)  : nat.pow_two
               ...   = 2*(2*(k*k))  : by ac_refl
               ...   = 2*(2*k^2)    : by rw ←nat.pow_two,
          exact nat.eq_of_mul_eq_mul_left dec_trivial this }
        end

        lemma case_b : ∃ g h k,
          0 < g ∧ 0 < h ∧ 0 < k ∧ g < x ∧ g^4 = h^4 + k^2 :=
        begin
          rcases ex u' v' x u'2_v'2_x2 u'_v' even_v' u'v'x_pos
            with ⟨d, e, dpos, epos, d_gt_e, d_e, Hu', Hv', Hx⟩,
          rcases v'_twice_square_etc with ⟨m, k, Hm, Hk⟩,
          have : k^2 = d * e := nat.eq_of_mul_eq_mul_left (dec_trivial : 2 > 0) (
          calc 2 * k^2 = v'            : Hk.symm
               ...     = 2 * d * e    : Hv'
               ...     = 2 * (d * e)  : by rw mul_assoc),
          rcases coprime_square_product this.symm d_e with ⟨g_, h, Hg, Hh⟩,
          -- Weird shadowing behavior if we use "g", because u depends on the
          -- assuption "g" defined way above.
          existsi [g_, h, m], repeat { split },
          { exact pos_of_square_pos (Hg ▸ dpos) },
          { exact pos_of_square_pos (Hh ▸ epos) },
          { exact pos_of_square_pos (Hm ▸ u'v'x_pos.1) },
          { exact
            calc g_ ≤ g_^2  : le_square
                ... = d     : Hg.symm
                ... ≤ d^2   : le_square
                ... < d^2 + e^2  : nat.lt_add_of_pos_right
                                   (pos_pow_of_pos 2 epos)
                ... = x     : Hx.symm
          },
          { exact calc g_^4 = (g_^2)^2  : by rw square_twice
                       ...  = d^2      : by rw Hg
                       ...  = d^2 - e^2 + e^2
                    : by rw nat.sub_add_cancel (pow_le_pow_of_le_left (le_of_lt d_gt_e) 2)
                       ...  = u' + e^2  : by rw Hu'
                       ...  = m^2 + (h^2)^2  : by rw [Hm, Hh]
                       ...  = h^4 + m^2  : by rw [square_twice, add_comm] }
        end
      end even_v
    end case_b
  end x_y

  set_option trace.simplify.rewrite true

  lemma descent : ∃ x' y' z',
    0 < x' ∧ 0 < y' ∧ 0 < z' ∧ x' < x ∧ x'^4 = y'^4 + z'^2 := begin
    let g := gcd x y,
    have g_pos : g > 0 := gcd_pos_of_pos_left y x_pos,
    cases eq_or_lt_of_le (succ_le_of_lt g_pos) with g_eq_1 g_gt_1,
    swap,
    { -- g > 1
      have g_dvd_x : g ∣ x := (gcd_dvd x y).left,
      have g_dvd_y : g ∣ y := (gcd_dvd x y).right,
      let x' := x/g,
      have Hx' : g * x' = x := nat.mul_div_cancel' g_dvd_x,
      let y' := y/g,
      have Hy' : g * y' = y := nat.mul_div_cancel' g_dvd_y,
      have g2_dvd_z : g^2 ∣ z := begin
        -- nat.dvd_sub doesn't actually need the (H : n ≤ m) hypothesis
        have : g^4 ∣ z^2 :=
          (nat.dvd_add_iff_right (pow_dvd_pow_of_dvd g_dvd_y)).mpr
          (fmt ▸ pow_dvd_pow_of_dvd g_dvd_x),
        apply dvd_of_pow_dvd_pow (dec_trivial : 2 > 0),
        rwa square_twice
      end,
      let z' := z/(g^2),
      have Hz' : g^2 * z' = z := nat.mul_div_cancel' g2_dvd_z,
      existsi [x', y', z'], repeat { split },
      { apply pos_of_pos_mul, rw Hx', exact x_pos },
      { apply pos_of_pos_mul, rw Hy', exact y_pos },
      { apply pos_of_pos_mul, rw Hz', exact z_pos },
      { exact div_lt_self x_pos g_gt_1 },
      { have :=
        calc g^4 * x'^4 = (g * x')^4  : by rw nat.mul_pow
             ...        = x^4         : by rw Hx'
             ...        = y^4 + z^2   : by rw fmt
             ...        = (g * y')^4 + (g^2 * z')^2  : by rw [Hy', Hz']
             ...        = g^4 * y'^4 + g^4 * z'^2  : by rw [nat.mul_pow, nat.mul_pow, square_twice]
             ...        = g^4 * (y'^4 + z'^2)  : by rw mul_add,
        exact nat.eq_of_mul_eq_mul_left (pos_pow_of_pos 4 g_pos) this
      }
    },
    { -- g = 1
      have x_y : coprime x y := g_eq_1.symm,
      let gmp := gcd (x^2 - y^2) (x^2 + y^2),
      have : gmp ∣ 2 := l2 x_y,
      cases (dvd_prime dec_trivial).mp this with gmp1 gmp2, swap,
      { -- gmp = 2
        exact case_a x_y gmp2   -- planning!!
      },
      { -- gmp = 1
        rcases coprime_square_product l1 ((gcd_comm _ _).trans gmp1)
          with ⟨s,t,Hs,Ht⟩,
        -- this got a bit out of control
        let u0 := u x_y gmp1 s t Hs Ht,
        let v0 := v x_y gmp1 s t Hs Ht,
        let uvx_pos0 := uvx_pos x_y gmp1 s t Hs Ht,
        let u_v0 := u_v x_y gmp1 s t Hs Ht,
        let u2_v2_x2_0 := u2_v2_x2 x_y gmp1 s t Hs Ht,
        let y2_2uv_0 := y2_2uv x_y gmp1 s t Hs Ht,
        have : even u0 ∨ even v0 := u_or_v_even x_y gmp1 s t Hs Ht,
        cases this with even_u0 even_v0,
        { have u2_v2_x2' : v0^2 + u0^2 = x^2 :=
          calc v0^2 + u0^2 = u0^2 + v0^2  : by ac_refl
               ...         = x^2  : u2_v2_x2_0,
          have y2_2uv' : y^2 = 2 * v0 * u0 :=
          calc y^2 = 2 * u0 * v0  : y2_2uv_0
               ... = 2 * v0 * u0  : by ac_refl,
          refine case_b x_y gmp1 s t Hs Ht v0 u0 uvx_pos0.2.1 uvx_pos0.1 (coprime.symm u_v0) u2_v2_x2' y2_2uv' even_u0
        },
        { exact case_b x_y gmp1 s t Hs Ht u0 v0 uvx_pos0.1 uvx_pos0.2.1 u_v0 u2_v2_x2_0 y2_2uv_0 even_v0 },
      }
    }
  end
end fermat

lemma no_solutions' : ∀ x, ¬(∃ y z, 0 < x ∧ 0 < y ∧ 0 < z ∧ x^4 = y^4 + z^2) :=
begin
  intro x0,
  refine nat.strong_induction_on x0 _,
  intros x iH a,
  rcases a with ⟨y,z,x_pos,y_pos,z_pos,fmt⟩,
  rcases descent x y z fmt ⟨x_pos,y_pos,z_pos⟩
    with ⟨x',y',z',x'_pos,y'_pos,z'_pos,x'_lt_x,fmt'⟩,
  exact iH x' x'_lt_x ⟨y',z',x'_pos,y'_pos,z'_pos,fmt'⟩,
end

theorem no_solutions : ¬(∃ x y z, 0 < x ∧ 0 < y ∧ 0 < z ∧ x^4 = y^4 + z^2) :=
  not_exists_of_forall_not no_solutions'

theorem fermat4 : ¬(∃ a b c, 0 < a ∧ 0 < b ∧ 0 < c ∧ a^4 + b^4 = c^4) := begin
  intros H,
  rcases H with ⟨a,b,c,a_pos,b_pos,c_pos,fmt⟩,
  have fmt' : c^4 = a^4 + (b^2)^2 :=
  calc c^4 = a^4 + b^4  : fmt.symm
       ... = a^4 + (b^2)^2  : by rw square_twice,
  have b2_pos := pos_pow_of_pos 2 b_pos,
  exact no_solutions ⟨c,a,b^2,c_pos,a_pos,b2_pos,fmt'⟩
end


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.sort
import Mathlib.data.multiset.basic
import Mathlib.data.string.basic
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Construct a sorted list from a multiset.
-/

namespace multiset

/-- `sort s` constructs a sorted list from the multiset `s`.
  (Uses merge sort algorithm.) -/
def sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r] [is_antisymm α r]
    [is_total α r] (s : multiset α) : List α :=
  quot.lift_on s (list.merge_sort r) sorry

@[simp] theorem coe_sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r]
    [is_antisymm α r] [is_total α r] (l : List α) : sort r ↑l = list.merge_sort r l :=
  rfl

@[simp] theorem sort_sorted {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r]
    [is_antisymm α r] [is_total α r] (s : multiset α) : list.sorted r (sort r s) :=
  quot.induction_on s fun (l : List α) => list.sorted_merge_sort r l

@[simp] theorem sort_eq {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r]
    [is_antisymm α r] [is_total α r] (s : multiset α) : ↑(sort r s) = s :=
  quot.induction_on s fun (l : List α) => quot.sound (list.perm_merge_sort r l)

@[simp] theorem mem_sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r]
    [is_antisymm α r] [is_total α r] {s : multiset α} {a : α} : a ∈ sort r s ↔ a ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ sort r s ↔ a ∈ s)) (Eq.symm (propext mem_coe))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a ∈ ↑(sort r s) ↔ a ∈ s)) (sort_eq r s))) (iff.refl (a ∈ s)))

@[simp] theorem length_sort {α : Type u_1} (r : α → α → Prop) [DecidableRel r] [is_trans α r]
    [is_antisymm α r] [is_total α r] {s : multiset α} : list.length (sort r s) = coe_fn card s :=
  quot.induction_on s (list.length_merge_sort r)

protected instance has_repr {α : Type u_1} [has_repr α] : has_repr (multiset α) :=
  has_repr.mk
    fun (s : multiset α) =>
      string.str string.empty (char.of_nat (bit1 (bit1 (bit0 (bit1 (bit1 (bit1 1))))))) ++
          string.intercalate
            (string.str (string.str string.empty (char.of_nat (bit0 (bit0 (bit1 (bit1 (bit0 1)))))))
              (char.of_nat (bit0 (bit0 (bit0 (bit0 (bit0 1)))))))
            (sort LessEq (map repr s)) ++
        string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit1 (bit1 (bit1 1)))))))

end Mathlib


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

/-!
# Normed groups homomorphisms

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

This file gathers definitions and elementary constructions about bounded group homomorphisms
between normed (abelian) groups (abbreviated to "normed group homs").

The main lemmas relate the boundedness condition to continuity and Lipschitzness.

The main construction is to endow the type of normed group homs between two given normed groups
with a group structure and a norm, giving rise to a normed group structure. We provide several
simple constructions for normed group homs, like kernel, range and equalizer.

Some easy other constructions are related to subgroups of normed groups.

Since a lot of elementary properties don't require `‖x‖ = 0 → x = 0` we start setting up the
theory of `seminormed_add_group_hom` and we specialize to `normed_add_group_hom` when needed.
-/

noncomputable theory
open_locale nnreal big_operators

/-- A morphism of seminormed abelian groups is a bounded group homomorphism. -/
structure normed_add_group_hom (V W : Type*) [seminormed_add_comm_group V]
  [seminormed_add_comm_group W] :=
(to_fun : V → W)
(map_add' : ∀ v₁ v₂, to_fun (v₁ + v₂) = to_fun v₁ + to_fun v₂)
(bound' : ∃ C, ∀ v, ‖to_fun v‖ ≤ C * ‖v‖)

namespace add_monoid_hom

variables {V W : Type*} [seminormed_add_comm_group V] [seminormed_add_comm_group W]
  {f g : normed_add_group_hom V W}

/-- Associate to a group homomorphism a bounded group homomorphism under a norm control condition.

See `add_monoid_hom.mk_normed_add_group_hom'` for a version that uses `ℝ≥0` for the bound. -/
def mk_normed_add_group_hom (f : V →+ W)
  (C : ℝ) (h : ∀ v, ‖f v‖ ≤ C * ‖v‖) : normed_add_group_hom V W :=
{ bound' := ⟨C, h⟩, ..f }

/-- Associate to a group homomorphism a bounded group homomorphism under a norm control condition.

See `add_monoid_hom.mk_normed_add_group_hom` for a version that uses `ℝ` for the bound. -/
def mk_normed_add_group_hom' (f : V →+ W) (C : ℝ≥0) (hC : ∀ x, ‖f x‖₊ ≤ C * ‖x‖₊) :
  normed_add_group_hom V W :=
{ bound' := ⟨C, hC⟩ .. f}

end add_monoid_hom

lemma exists_pos_bound_of_bound {V W : Type*} [seminormed_add_comm_group V]
  [seminormed_add_comm_group W]
  {f : V → W} (M : ℝ) (h : ∀x, ‖f x‖ ≤ M * ‖x‖) :
  ∃ N, 0 < N ∧ ∀x, ‖f x‖ ≤ N * ‖x‖ :=
⟨max M 1, lt_of_lt_of_le zero_lt_one (le_max_right _ _), λx, calc
  ‖f x‖ ≤ M * ‖x‖ : h x
  ... ≤ max M 1 * ‖x‖ : mul_le_mul_of_nonneg_right (le_max_left _ _) (norm_nonneg _) ⟩

namespace normed_add_group_hom

variables {V V₁ V₂ V₃ : Type*} [seminormed_add_comm_group V] [seminormed_add_comm_group V₁]
  [seminormed_add_comm_group V₂] [seminormed_add_comm_group V₃]
variables {f g : normed_add_group_hom V₁ V₂}

instance : has_coe_to_fun (normed_add_group_hom V₁ V₂) (λ _, V₁ → V₂) :=
⟨normed_add_group_hom.to_fun⟩

initialize_simps_projections normed_add_group_hom (to_fun → apply)

lemma coe_inj (H : (f : V₁ → V₂) = g) : f = g :=
by cases f; cases g; congr'; exact funext H

lemma coe_injective : @function.injective (normed_add_group_hom V₁ V₂) (V₁ → V₂) coe_fn :=
by apply coe_inj

lemma coe_inj_iff : f = g ↔ (f : V₁ → V₂) = g := ⟨congr_arg _, coe_inj⟩

@[ext] lemma ext (H : ∀ x, f x = g x) : f = g := coe_inj $ funext H

lemma ext_iff : f = g ↔ ∀ x, f x = g x := ⟨by rintro rfl x; refl, ext⟩

variables (f g)

@[simp] lemma to_fun_eq_coe : f.to_fun = f := rfl

@[simp] lemma coe_mk (f) (h₁) (h₂) (h₃) : ⇑(⟨f, h₁, h₂, h₃⟩ : normed_add_group_hom V₁ V₂) = f := rfl

@[simp] lemma coe_mk_normed_add_group_hom (f : V₁ →+ V₂) (C) (hC) :
  ⇑(f.mk_normed_add_group_hom C hC) = f := rfl

@[simp] lemma coe_mk_normed_add_group_hom' (f : V₁ →+ V₂) (C) (hC) :
  ⇑(f.mk_normed_add_group_hom' C hC) = f := rfl

/-- The group homomorphism underlying a bounded group homomorphism. -/
def to_add_monoid_hom (f : normed_add_group_hom V₁ V₂) : V₁ →+ V₂ :=
add_monoid_hom.mk' f f.map_add'

@[simp] lemma coe_to_add_monoid_hom : ⇑f.to_add_monoid_hom = f := rfl

lemma to_add_monoid_hom_injective :
  function.injective (@normed_add_group_hom.to_add_monoid_hom V₁ V₂ _ _) :=
λ f g h, coe_inj $ show ⇑f.to_add_monoid_hom = g, by { rw h, refl }

@[simp]

instance : add_monoid_hom_class (normed_add_group_hom V₁ V₂) V₁ V₂ :=
{ coe := coe_fn,
  coe_injective' := coe_injective,
  map_add := λ f, f.to_add_monoid_hom.map_add,
  map_zero := λ f, f.to_add_monoid_hom.map_zero }

lemma bound : ∃ C, 0 < C ∧ ∀ x, ‖f x‖ ≤ C * ‖x‖ :=
let ⟨C, hC⟩ := f.bound' in exists_pos_bound_of_bound _ hC

theorem antilipschitz_of_norm_ge {K : ℝ≥0} (h : ∀ x, ‖x‖ ≤ K * ‖f x‖) :
  antilipschitz_with K f :=
antilipschitz_with.of_le_mul_dist $
λ x y, by simpa only [dist_eq_norm, map_sub] using h (x - y)

/-- A normed group hom is surjective on the subgroup `K` with constant `C` if every element
`x` of `K` has a preimage whose norm is bounded above by `C*‖x‖`. This is a more
abstract version of `f` having a right inverse defined on `K` with operator norm
at most `C`. -/
def surjective_on_with (f : normed_add_group_hom V₁ V₂) (K : add_subgroup V₂) (C : ℝ) : Prop :=
  ∀ h ∈ K, ∃ g, f g = h ∧ ‖g‖ ≤ C*‖h‖

lemma surjective_on_with.mono {f : normed_add_group_hom V₁ V₂} {K : add_subgroup V₂} {C C' : ℝ}
  (h : f.surjective_on_with K C) (H : C ≤ C') : f.surjective_on_with K C' :=
begin
  intros k k_in,
  rcases h k k_in with ⟨g, rfl, hg⟩,
  use [g, rfl],
  by_cases Hg : ‖f g‖ = 0,
  { simpa [Hg] using hg },
  { exact hg.trans ((mul_le_mul_right $ (ne.symm Hg).le_iff_lt.mp (norm_nonneg _)).mpr H) }
end

lemma surjective_on_with.exists_pos {f : normed_add_group_hom V₁ V₂} {K : add_subgroup V₂} {C : ℝ}
  (h : f.surjective_on_with K C) : ∃ C' > 0, f.surjective_on_with K C' :=
begin
  refine ⟨|C| + 1, _, _⟩,
  { linarith [abs_nonneg C] },
  { apply h.mono,
    linarith [le_abs_self C] }
end

lemma surjective_on_with.surj_on {f : normed_add_group_hom V₁ V₂} {K : add_subgroup V₂} {C : ℝ}
  (h : f.surjective_on_with K C) : set.surj_on f set.univ K :=
λ x hx, (h x hx).imp $ λ a ⟨ha, _⟩, ⟨set.mem_univ _, ha⟩

/-! ### The operator norm -/

/-- The operator norm of a seminormed group homomorphism is the inf of all its bounds. -/
def op_norm (f : normed_add_group_hom V₁ V₂) := Inf {c | 0 ≤ c ∧ ∀ x, ‖f x‖ ≤ c * ‖x‖}
instance has_op_norm : has_norm (normed_add_group_hom V₁ V₂) := ⟨op_norm⟩

lemma norm_def : ‖f‖ = Inf {c | 0 ≤ c ∧ ∀ x, ‖f x‖ ≤ c * ‖x‖} := rfl

-- So that invocations of `le_cInf` make sense: we show that the set of
-- bounds is nonempty and bounded below.
lemma bounds_nonempty {f : normed_add_group_hom V₁ V₂} :
  ∃ c, c ∈ { c | 0 ≤ c ∧ ∀ x, ‖f x‖ ≤ c * ‖x‖ } :=
let ⟨M, hMp, hMb⟩ := f.bound in ⟨M, le_of_lt hMp, hMb⟩

lemma bounds_bdd_below {f : normed_add_group_hom V₁ V₂} :
  bdd_below {c | 0 ≤ c ∧ ∀ x, ‖f x‖ ≤ c * ‖x‖} :=
⟨0, λ _ ⟨hn, _⟩, hn⟩

lemma op_norm_nonneg : 0 ≤ ‖f‖ :=
le_cInf bounds_nonempty (λ _ ⟨hx, _⟩, hx)

/-- The fundamental property of the operator norm: `‖f x‖ ≤ ‖f‖ * ‖x‖`. -/
theorem le_op_norm (x : V₁) : ‖f x‖ ≤ ‖f‖ * ‖x‖ :=
begin
  obtain ⟨C, Cpos, hC⟩ := f.bound,
  replace hC := hC x,
  by_cases h : ‖x‖ = 0,
  { rwa [h, mul_zero] at ⊢ hC },
  have hlt : 0 < ‖x‖ := lt_of_le_of_ne (norm_nonneg x) (ne.symm h),
  exact (div_le_iff hlt).mp (le_cInf bounds_nonempty (λ c ⟨_, hc⟩,
    (div_le_iff hlt).mpr $ by { apply hc })),
end

theorem le_op_norm_of_le {c : ℝ} {x} (h : ‖x‖ ≤ c) : ‖f x‖ ≤ ‖f‖ * c :=
le_trans (f.le_op_norm x) (mul_le_mul_of_nonneg_left h f.op_norm_nonneg)

theorem le_of_op_norm_le {c : ℝ} (h : ‖f‖ ≤ c) (x : V₁) : ‖f x‖ ≤ c * ‖x‖ :=
(f.le_op_norm x).trans (mul_le_mul_of_nonneg_right h (norm_nonneg x))

/-- continuous linear maps are Lipschitz continuous. -/
theorem lipschitz : lipschitz_with ⟨‖f‖, op_norm_nonneg f⟩ f :=
lipschitz_with.of_dist_le_mul $ λ x y,
  by { rw [dist_eq_norm, dist_eq_norm, ←map_sub], apply le_op_norm }

protected lemma uniform_continuous (f : normed_add_group_hom V₁ V₂) :
  uniform_continuous f := f.lipschitz.uniform_continuous

@[continuity]
protected lemma continuous (f : normed_add_group_hom V₁ V₂) : continuous f :=
f.uniform_continuous.continuous

lemma ratio_le_op_norm (x : V₁) : ‖f x‖ / ‖x‖ ≤ ‖f‖ :=
div_le_of_nonneg_of_le_mul (norm_nonneg _) f.op_norm_nonneg (le_op_norm _ _)

/-- If one controls the norm of every `f x`, then one controls the norm of `f`. -/
lemma op_norm_le_bound {M : ℝ} (hMp: 0 ≤ M) (hM : ∀ x, ‖f x‖ ≤ M * ‖x‖) :
  ‖f‖ ≤ M :=
cInf_le bounds_bdd_below ⟨hMp, hM⟩

lemma op_norm_eq_of_bounds {M : ℝ} (M_nonneg : 0 ≤ M)
  (h_above : ∀ x, ‖f x‖ ≤ M*‖x‖) (h_below : ∀ N ≥ 0, (∀ x, ‖f x‖ ≤ N*‖x‖) → M ≤ N) :
  ‖f‖ = M :=
le_antisymm (f.op_norm_le_bound M_nonneg h_above)
  ((le_cInf_iff normed_add_group_hom.bounds_bdd_below ⟨M, M_nonneg, h_above⟩).mpr $
   λ N ⟨N_nonneg, hN⟩, h_below N N_nonneg hN)

theorem op_norm_le_of_lipschitz {f : normed_add_group_hom V₁ V₂} {K : ℝ≥0}
  (hf : lipschitz_with K f) :
  ‖f‖ ≤ K :=
f.op_norm_le_bound K.2 $ λ x, by simpa only [dist_zero_right, map_zero] using hf.dist_le_mul x 0

/-- If a bounded group homomorphism map is constructed from a group homomorphism via the constructor
`mk_normed_add_group_hom`, then its norm is bounded by the bound given to the constructor if it is
nonnegative. -/
lemma mk_normed_add_group_hom_norm_le (f : V₁ →+ V₂) {C : ℝ} (hC : 0 ≤ C)
  (h : ∀ x, ‖f x‖ ≤ C * ‖x‖) :
  ‖f.mk_normed_add_group_hom C h‖ ≤ C :=
op_norm_le_bound _ hC h

/-- If a bounded group homomorphism map is constructed from a group homomorphism
via the constructor `mk_normed_add_group_hom`, then its norm is bounded by the bound
given to the constructor or zero if this bound is negative. -/
lemma mk_normed_add_group_hom_norm_le' (f : V₁ →+ V₂) {C : ℝ} (h : ∀x, ‖f x‖ ≤ C * ‖x‖) :
  ‖f.mk_normed_add_group_hom C h‖ ≤ max C 0 :=
op_norm_le_bound _ (le_max_right _ _) $ λ x, (h x).trans $
  mul_le_mul_of_nonneg_right (le_max_left _ _) (norm_nonneg x)

alias mk_normed_add_group_hom_norm_le ← _root_.add_monoid_hom.mk_normed_add_group_hom_norm_le
alias mk_normed_add_group_hom_norm_le' ← _root_.add_monoid_hom.mk_normed_add_group_hom_norm_le'

/-! ### Addition of normed group homs -/

/-- Addition of normed group homs. -/
instance : has_add (normed_add_group_hom V₁ V₂) :=
⟨λ f g, (f.to_add_monoid_hom + g.to_add_monoid_hom).mk_normed_add_group_hom (‖f‖ + ‖g‖) $ λ v, calc
  ‖f v + g v‖
      ≤ ‖f v‖ + ‖g v‖ : norm_add_le _ _
  ... ≤ ‖f‖ * ‖v‖ + ‖g‖ * ‖v‖ : add_le_add (le_op_norm f v) (le_op_norm g v)
  ... = (‖f‖ + ‖g‖) * ‖v‖ : by rw add_mul⟩

/-- The operator norm satisfies the triangle inequality. -/
theorem op_norm_add_le : ‖f + g‖ ≤ ‖f‖ + ‖g‖ :=
mk_normed_add_group_hom_norm_le _ (add_nonneg (op_norm_nonneg _) (op_norm_nonneg _)) _

/--
Terms containing `@has_add.add (has_coe_to_fun.F ...) pi.has_add`
seem to cause leanchecker to [crash due to an out-of-memory
condition](https://github.com/leanprover-community/lean/issues/543).
As a workaround, we add a type annotation: `(f + g : V₁ → V₂)`
-/
library_note "addition on function coercions"

-- see Note [addition on function coercions]
@[simp] lemma coe_add (f g : normed_add_group_hom V₁ V₂) : ⇑(f + g) = (f + g : V₁ → V₂) := rfl
@[simp] lemma add_apply (f g : normed_add_group_hom V₁ V₂) (v : V₁) :
  (f + g : normed_add_group_hom V₁ V₂) v = f v + g v := rfl

/-! ### The zero normed group hom -/

instance : has_zero (normed_add_group_hom V₁ V₂) :=
⟨(0 : V₁ →+ V₂).mk_normed_add_group_hom 0 (by simp)⟩

instance : inhabited (normed_add_group_hom V₁ V₂) := ⟨0⟩

/-- The norm of the `0` operator is `0`. -/
theorem op_norm_zero : ‖(0 : normed_add_group_hom V₁ V₂)‖ = 0 :=
le_antisymm (cInf_le bounds_bdd_below
    ⟨ge_of_eq rfl, λ _, le_of_eq (by { rw [zero_mul], exact norm_zero })⟩)
    (op_norm_nonneg _)

/-- For normed groups, an operator is zero iff its norm vanishes. -/
theorem op_norm_zero_iff {V₁ V₂ : Type*} [normed_add_comm_group V₁] [normed_add_comm_group V₂]
  {f : normed_add_group_hom V₁ V₂} : ‖f‖ = 0 ↔ f = 0 :=
iff.intro
  (λ hn, ext (λ x, norm_le_zero_iff.1
    (calc _ ≤ ‖f‖ * ‖x‖ : le_op_norm _ _
     ...     = _ : by rw [hn, zero_mul])))
  (λ hf, by rw [hf, op_norm_zero] )

-- see Note [addition on function coercions]
@[simp] lemma coe_zero : ⇑(0 : normed_add_group_hom V₁ V₂) = (0 : V₁ → V₂) := rfl
@[simp] lemma zero_apply (v : V₁) : (0 : normed_add_group_hom V₁ V₂) v = 0 := rfl

variables {f g}

/-! ### The identity normed group hom -/

variable (V)

/-- The identity as a continuous normed group hom. -/
@[simps]
def id : normed_add_group_hom V V :=
(add_monoid_hom.id V).mk_normed_add_group_hom 1 (by simp [le_refl])

/-- The norm of the identity is at most `1`. It is in fact `1`, except when the norm of every
element vanishes, where it is `0`. (Since we are working with seminorms this can happen even if the
space is non-trivial.) It means that one can not do better than an inequality in general. -/
lemma norm_id_le : ‖(id V : normed_add_group_hom V V)‖ ≤ 1 :=
op_norm_le_bound _ zero_le_one (λx, by simp)

/-- If there is an element with norm different from `0`, then the norm of the identity equals `1`.
(Since we are working with seminorms supposing that the space is non-trivial is not enough.) -/
lemma norm_id_of_nontrivial_seminorm (h : ∃ (x : V), ‖x‖ ≠ 0 ) :
  ‖(id V)‖ = 1 :=
le_antisymm (norm_id_le V) $ let ⟨x, hx⟩ := h in
have _ := (id V).ratio_le_op_norm x,
by rwa [id_apply, div_self hx] at this

/-- If a normed space is non-trivial, then the norm of the identity equals `1`. -/
lemma norm_id {V : Type*} [normed_add_comm_group V] [nontrivial V] : ‖(id V)‖ = 1 :=
begin
  refine norm_id_of_nontrivial_seminorm V _,
  obtain ⟨x, hx⟩ := exists_ne (0 : V),
  exact ⟨x, ne_of_gt (norm_pos_iff.2 hx)⟩,
end

lemma coe_id : ((normed_add_group_hom.id V) : V → V) = (_root_.id : V → V) := rfl

/-! ### The negation of a normed group hom -/

/-- Opposite of a normed group hom. -/
instance : has_neg (normed_add_group_hom V₁ V₂) :=
⟨λ f, (-f.to_add_monoid_hom).mk_normed_add_group_hom (‖f‖) (λ v, by simp [le_op_norm f v])⟩

-- see Note [addition on function coercions]
@[simp] lemma coe_neg (f : normed_add_group_hom V₁ V₂) : ⇑(-f) = (-f : V₁ → V₂) := rfl
@[simp] lemma neg_apply (f : normed_add_group_hom V₁ V₂) (v : V₁) :
  (-f : normed_add_group_hom V₁ V₂) v = - (f v) := rfl

lemma op_norm_neg (f : normed_add_group_hom V₁ V₂) : ‖-f‖ = ‖f‖ :=
by simp only [norm_def, coe_neg, norm_neg, pi.neg_apply]

/-! ### Subtraction of normed group homs -/

/-- Subtraction of normed group homs. -/
instance : has_sub (normed_add_group_hom V₁ V₂) :=
⟨λ f g,
{ bound' :=
  begin
    simp only [add_monoid_hom.sub_apply, add_monoid_hom.to_fun_eq_coe, sub_eq_add_neg],
    exact (f + -g).bound'
  end,
  .. (f.to_add_monoid_hom - g.to_add_monoid_hom) }⟩

-- see Note [addition on function coercions]
@[simp] lemma coe_sub (f g : normed_add_group_hom V₁ V₂) : ⇑(f - g) = (f - g : V₁ → V₂) := rfl
@[simp] lemma sub_apply (f g : normed_add_group_hom V₁ V₂) (v : V₁) :
  (f - g : normed_add_group_hom V₁ V₂) v = f v - g v := rfl

/-! ### Scalar actions on normed group homs -/

section has_smul

variables {R R' : Type*}
  [monoid_with_zero R] [distrib_mul_action R V₂] [pseudo_metric_space R] [has_bounded_smul R V₂]
  [monoid_with_zero R'] [distrib_mul_action R' V₂] [pseudo_metric_space R'] [has_bounded_smul R' V₂]

instance : has_smul R (normed_add_group_hom V₁ V₂) :=
{ smul := λ r f,
  { to_fun := r • f,
    map_add' := (r • f.to_add_monoid_hom).map_add',
    bound' := let ⟨b, hb⟩ := f.bound' in  ⟨dist r 0 * b, λ x, begin
      have := dist_smul_pair r (f x) (f 0),
      rw [map_zero, smul_zero, dist_zero_right, dist_zero_right] at this,
      rw mul_assoc,
      refine this.trans _,
      refine mul_le_mul_of_nonneg_left _ dist_nonneg,
      exact hb x
    end⟩ } }

@[simp] lemma coe_smul (r : R) (f : normed_add_group_hom V₁ V₂) : ⇑(r • f) = r • f := rfl
@[simp] lemma smul_apply (r : R) (f : normed_add_group_hom V₁ V₂) (v : V₁) : (r • f) v = r • f v :=
rfl

instance [smul_comm_class R R' V₂] : smul_comm_class R R' (normed_add_group_hom V₁ V₂) :=
{ smul_comm := λ r r' f, ext $ λ v, smul_comm _ _ _ }

instance [has_smul R R'] [is_scalar_tower R R' V₂] :
  is_scalar_tower R R' (normed_add_group_hom V₁ V₂) :=
{ smul_assoc := λ r r' f, ext $ λ v, smul_assoc _ _ _ }

instance [distrib_mul_action Rᵐᵒᵖ V₂] [is_central_scalar R V₂] :
  is_central_scalar R (normed_add_group_hom V₁ V₂) :=
{ op_smul_eq_smul := λ r f, ext $ λ v, op_smul_eq_smul _ _ }

end has_smul

instance has_nat_scalar : has_smul ℕ (normed_add_group_hom V₁ V₂) :=
{ smul := λ n f,
  { to_fun := n • f,
    map_add' := (n • f.to_add_monoid_hom).map_add',
    bound' := let ⟨b, hb⟩ := f.bound' in ⟨n • b, λ v, begin
      rw [pi.smul_apply, nsmul_eq_mul, mul_assoc],
      exact (norm_nsmul_le _ _).trans (mul_le_mul_of_nonneg_left (hb _) (nat.cast_nonneg _)),
    end⟩ } }

@[simp] lemma coe_nsmul (r : ℕ) (f : normed_add_group_hom V₁ V₂) : ⇑(r • f) = r • f := rfl
@[simp] lemma nsmul_apply (r : ℕ) (f : normed_add_group_hom V₁ V₂) (v : V₁) : (r • f) v = r • f v :=
rfl

instance has_int_scalar : has_smul ℤ (normed_add_group_hom V₁ V₂) :=
{ smul := λ z f,
  { to_fun := z • f,
    map_add' := (z • f.to_add_monoid_hom).map_add',
    bound' := let ⟨b, hb⟩ := f.bound' in ⟨‖z‖ • b, λ v, begin
      rw [pi.smul_apply, smul_eq_mul, mul_assoc],
      exact (norm_zsmul_le _ _).trans  (mul_le_mul_of_nonneg_left (hb _) $ norm_nonneg _),
    end⟩ } }

@[simp] lemma coe_zsmul (r : ℤ) (f : normed_add_group_hom V₁ V₂) : ⇑(r • f) = r • f := rfl
@[simp] lemma zsmul_apply (r : ℤ) (f : normed_add_group_hom V₁ V₂) (v : V₁) : (r • f) v = r • f v :=
rfl

/-! ### Normed group structure on normed group homs -/

/-- Homs between two given normed groups form a commutative additive group. -/
instance : add_comm_group (normed_add_group_hom V₁ V₂) :=
coe_injective.add_comm_group _ rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl) (λ _ _, rfl) (λ _ _, rfl)

/-- Normed group homomorphisms themselves form a seminormed group with respect to
    the operator norm. -/
instance to_seminormed_add_comm_group : seminormed_add_comm_group (normed_add_group_hom V₁ V₂) :=
add_group_seminorm.to_seminormed_add_comm_group
{ to_fun := op_norm,
  map_zero' := op_norm_zero,
  neg' := op_norm_neg,
  add_le' := op_norm_add_le }

/-- Normed group homomorphisms themselves form a normed group with respect to
    the operator norm. -/
instance to_normed_add_comm_group {V₁ V₂ : Type*} [normed_add_comm_group V₁]
  [normed_add_comm_group V₂] :
  normed_add_comm_group (normed_add_group_hom V₁ V₂) :=
add_group_norm.to_normed_add_comm_group
{ to_fun := op_norm,
  map_zero' := op_norm_zero,
  neg' := op_norm_neg,
  add_le' := op_norm_add_le,
  eq_zero_of_map_eq_zero' := λ f, op_norm_zero_iff.1 }

/-- Coercion of a `normed_add_group_hom` is an `add_monoid_hom`. Similar to `add_monoid_hom.coe_fn`.
-/
@[simps]
def coe_fn_add_hom : normed_add_group_hom V₁ V₂ →+ (V₁ → V₂) :=
{ to_fun := coe_fn, map_zero' := coe_zero, map_add' := coe_add}

@[simp] lemma coe_sum {ι : Type*} (s : finset ι) (f : ι → normed_add_group_hom V₁ V₂) :
  ⇑(∑ i in s, f i) = ∑ i in s, (f i) :=
(coe_fn_add_hom : _ →+ (V₁ → V₂)).map_sum f s

lemma sum_apply {ι : Type*} (s : finset ι) (f : ι → normed_add_group_hom V₁ V₂) (v : V₁) :
  (∑ i in s, f i) v = ∑ i in s, (f i v) :=
by simp only [coe_sum, finset.sum_apply]

/-! ### Module structure on normed group homs -/

instance {R : Type*} [monoid_with_zero R] [distrib_mul_action R V₂]
  [pseudo_metric_space R] [has_bounded_smul R V₂] :
  distrib_mul_action R (normed_add_group_hom V₁ V₂) :=
function.injective.distrib_mul_action coe_fn_add_hom coe_injective coe_smul

instance {R : Type*} [semiring R] [module R V₂]
  [pseudo_metric_space R] [has_bounded_smul R V₂] :
  module R (normed_add_group_hom V₁ V₂) :=
function.injective.module _ coe_fn_add_hom coe_injective coe_smul

/-! ### Composition of normed group homs -/

/-- The composition of continuous normed group homs. -/
@[simps]
protected def comp (g : normed_add_group_hom V₂ V₃) (f : normed_add_group_hom V₁ V₂) :
  normed_add_group_hom V₁ V₃ :=
(g.to_add_monoid_hom.comp f.to_add_monoid_hom).mk_normed_add_group_hom (‖g‖ * ‖f‖) $ λ v, calc
‖g (f v)‖ ≤ ‖g‖ * ‖f v‖ : le_op_norm _ _
... ≤ ‖g‖ * (‖f‖ * ‖v‖) : mul_le_mul_of_nonneg_left (le_op_norm _ _) (op_norm_nonneg _)
... = ‖g‖ * ‖f‖ * ‖v‖   : by rw mul_assoc

lemma norm_comp_le (g : normed_add_group_hom V₂ V₃) (f : normed_add_group_hom V₁ V₂) :
  ‖g.comp f‖ ≤ ‖g‖ * ‖f‖ :=
mk_normed_add_group_hom_norm_le _ (mul_nonneg (op_norm_nonneg _) (op_norm_nonneg _)) _

lemma norm_comp_le_of_le {g : normed_add_group_hom V₂ V₃} {C₁ C₂ : ℝ} (hg : ‖g‖ ≤ C₂)
  (hf : ‖f‖ ≤ C₁) :
  ‖g.comp f‖ ≤ C₂ * C₁ :=
le_trans (norm_comp_le g f) $ mul_le_mul hg hf (norm_nonneg _) (le_trans (norm_nonneg _) hg)

lemma norm_comp_le_of_le' {g : normed_add_group_hom V₂ V₃} (C₁ C₂ C₃ : ℝ) (h : C₃ = C₂ * C₁)
  (hg : ‖g‖ ≤ C₂) (hf : ‖f‖ ≤ C₁) : ‖g.comp f‖ ≤ C₃ :=
by { rw h, exact norm_comp_le_of_le hg hf }

/-- Composition of normed groups hom as an additive group morphism. -/
def comp_hom :
  normed_add_group_hom V₂ V₃ →+ normed_add_group_hom V₁ V₂ →+ normed_add_group_hom V₁ V₃ :=
add_monoid_hom.mk' (λ g, add_monoid_hom.mk' (λ f, g.comp f)
  (by { intros, ext, exact map_add g _ _ }))
  (by { intros, ext, simp only [comp_apply, pi.add_apply, function.comp_app,
                                add_monoid_hom.add_apply, add_monoid_hom.mk'_apply, coe_add] })

@[simp] lemma comp_zero (f : normed_add_group_hom V₂ V₃) :
  f.comp (0 : normed_add_group_hom V₁ V₂) = 0 :=
by { ext, exact map_zero f }

@[simp] lemma zero_comp (f : normed_add_group_hom V₁ V₂) :
  (0 : normed_add_group_hom V₂ V₃).comp f = 0 :=
by { ext, refl }

lemma comp_assoc {V₄: Type* } [seminormed_add_comm_group V₄] (h : normed_add_group_hom V₃ V₄)
  (g : normed_add_group_hom V₂ V₃) (f : normed_add_group_hom V₁ V₂) :
  (h.comp g).comp f = h.comp (g.comp f) :=
by { ext, refl }

lemma coe_comp (f : normed_add_group_hom V₁ V₂) (g : normed_add_group_hom V₂ V₃) :
  (g.comp f : V₁ → V₃) = (g : V₂ → V₃) ∘ (f : V₁ → V₂) := rfl

end normed_add_group_hom

namespace normed_add_group_hom

variables {V W V₁ V₂ V₃ : Type*} [seminormed_add_comm_group V] [seminormed_add_comm_group W]
  [seminormed_add_comm_group V₁] [seminormed_add_comm_group V₂] [seminormed_add_comm_group V₃]

/-- The inclusion of an `add_subgroup`, as bounded group homomorphism. -/
@[simps] def incl (s : add_subgroup V) : normed_add_group_hom s V :=
{ to_fun := (coe : s → V),
  map_add' := λ v w, add_subgroup.coe_add _ _ _,
  bound' := ⟨1, λ v, by { rw [one_mul], refl }⟩ }

lemma norm_incl {V' : add_subgroup V} (x : V') : ‖incl _ x‖ = ‖x‖ :=
rfl

/-!### Kernel -/
section kernels
variables (f : normed_add_group_hom V₁ V₂) (g : normed_add_group_hom V₂ V₃)

/-- The kernel of a bounded group homomorphism. Naturally endowed with a
`seminormed_add_comm_group` instance. -/
def ker : add_subgroup V₁ := f.to_add_monoid_hom.ker

lemma mem_ker (v : V₁) : v ∈ f.ker ↔ f v = 0 :=
by { erw f.to_add_monoid_hom.mem_ker, refl }

/-- Given a normed group hom `f : V₁ → V₂` satisfying `g.comp f = 0` for some `g : V₂ → V₃`,
    the corestriction of `f` to the kernel of `g`. -/
@[simps] def ker.lift (h : g.comp f = 0) :
  normed_add_group_hom V₁ g.ker :=
{ to_fun := λ v, ⟨f v, by { erw g.mem_ker, show (g.comp f) v = 0, rw h, refl }⟩,
  map_add' := λ v w, by { simp only [map_add], refl },
  bound' := f.bound' }

@[simp] lemma ker.incl_comp_lift (h : g.comp f = 0) :
  (incl g.ker).comp (ker.lift f g h) = f :=
by { ext, refl }

@[simp]
lemma ker_zero : (0 : normed_add_group_hom V₁ V₂).ker = ⊤ :=
by { ext, simp [mem_ker] }

lemma coe_ker : (f.ker : set V₁) = (f : V₁ → V₂) ⁻¹' {0} := rfl

lemma is_closed_ker {V₂ : Type*} [normed_add_comm_group V₂] (f : normed_add_group_hom V₁ V₂) :
  is_closed (f.ker : set V₁) :=
f.coe_ker ▸ is_closed.preimage f.continuous (t1_space.t1 0)

end kernels

/-! ### Range -/
section range

variables (f : normed_add_group_hom V₁ V₂) (g : normed_add_group_hom V₂ V₃)

/-- The image of a bounded group homomorphism. Naturally endowed with a
`seminormed_add_comm_group` instance. -/
def range : add_subgroup V₂ := f.to_add_monoid_hom.range

lemma mem_range (v : V₂) : v ∈ f.range ↔ ∃ w, f w = v :=
by { rw [range, add_monoid_hom.mem_range], refl }

@[simp]
lemma mem_range_self (v : V₁) : f v ∈ f.range :=
⟨v, rfl⟩

lemma comp_range : (g.comp f).range = add_subgroup.map g.to_add_monoid_hom f.range :=
by { erw add_monoid_hom.map_range, refl }

lemma incl_range (s : add_subgroup V₁) : (incl s).range = s :=
by { ext x, exact ⟨λ ⟨y, hy⟩, by { rw ← hy; simp }, λ hx, ⟨⟨x, hx⟩, by simp⟩⟩ }

@[simp]
lemma range_comp_incl_top : (f.comp (incl (⊤ : add_subgroup V₁))).range = f.range :=
by simpa [comp_range, incl_range, ← add_monoid_hom.range_eq_map]

end range

variables {f : normed_add_group_hom V W}

/-- A `normed_add_group_hom` is *norm-nonincreasing* if `‖f v‖ ≤ ‖v‖` for all `v`. -/
def norm_noninc (f : normed_add_group_hom V W) : Prop :=
∀ v, ‖f v‖ ≤ ‖v‖

namespace norm_noninc

lemma norm_noninc_iff_norm_le_one : f.norm_noninc ↔ ‖f‖ ≤ 1 :=
begin
  refine ⟨λ h, _, λ h, λ v, _⟩,
  { refine op_norm_le_bound _ (zero_le_one) (λ v, _),
    simpa [one_mul] using h v },
  { simpa using le_of_op_norm_le f h v }
end

lemma zero : (0 : normed_add_group_hom V₁ V₂).norm_noninc :=
λ v, by simp

lemma id : (id V).norm_noninc :=
λ v, le_rfl

lemma comp {g : normed_add_group_hom V₂ V₃} {f : normed_add_group_hom V₁ V₂}
  (hg : g.norm_noninc) (hf : f.norm_noninc) :
  (g.comp f).norm_noninc :=
λ v, (hg (f v)).trans (hf v)

@[simp] lemma neg_iff {f : normed_add_group_hom V₁ V₂} : (-f).norm_noninc ↔ f.norm_noninc :=
⟨λ h x, by { simpa using h x }, λ h x, (norm_neg (f x)).le.trans (h x)⟩

end norm_noninc

section isometry

lemma norm_eq_of_isometry {f : normed_add_group_hom V W} (hf : isometry f) (v : V) :
  ‖f v‖ = ‖v‖ :=
(add_monoid_hom_class.isometry_iff_norm f).mp hf v

lemma isometry_id : @isometry V V _ _ (id V) :=
isometry_id

lemma isometry_comp {g : normed_add_group_hom V₂ V₃} {f : normed_add_group_hom V₁ V₂}
  (hg : isometry g) (hf : isometry f) :
  isometry (g.comp f) :=
hg.comp hf

lemma norm_noninc_of_isometry (hf : isometry f) : f.norm_noninc :=
λ v, le_of_eq $ norm_eq_of_isometry hf v

end isometry

variables {W₁ W₂ W₃ : Type*} [seminormed_add_comm_group W₁] [seminormed_add_comm_group W₂]
  [seminormed_add_comm_group W₃]
variables (f) (g : normed_add_group_hom V W)
variables {f₁ g₁ : normed_add_group_hom V₁ W₁}
variables {f₂ g₂ : normed_add_group_hom V₂ W₂}
variables {f₃ g₃ : normed_add_group_hom V₃ W₃}

/-- The equalizer of two morphisms `f g : normed_add_group_hom V W`. -/
def equalizer := (f - g).ker

namespace equalizer

/-- The inclusion of `f.equalizer g` as a `normed_add_group_hom`. -/
def ι : normed_add_group_hom (f.equalizer g) V := incl _

lemma comp_ι_eq : f.comp (ι f g) = g.comp (ι f g) :=
by { ext, rw [comp_apply, comp_apply, ← sub_eq_zero, ← normed_add_group_hom.sub_apply], exact x.2 }

variables {f g}

/-- If `φ : normed_add_group_hom V₁ V` is such that `f.comp φ = g.comp φ`, the induced morphism
`normed_add_group_hom V₁ (f.equalizer g)`. -/
@[simps]
def lift (φ : normed_add_group_hom V₁ V) (h : f.comp φ = g.comp φ) :
  normed_add_group_hom V₁ (f.equalizer g) :=
{ to_fun := λ v, ⟨φ v, show (f - g) (φ v) = 0,
    by rw [normed_add_group_hom.sub_apply, sub_eq_zero, ← comp_apply, h, comp_apply]⟩,
  map_add' := λ v₁ v₂, by { ext, simp only [map_add, add_subgroup.coe_add, subtype.coe_mk] },
  bound' := by { obtain ⟨C, C_pos, hC⟩ := φ.bound, exact ⟨C, hC⟩ } }

@[simp] lemma ι_comp_lift (φ : normed_add_group_hom V₁ V) (h : f.comp φ = g.comp φ) :
  (ι _ _).comp (lift φ h) = φ :=
by { ext, refl }

/-- The lifting property of the equalizer as an equivalence. -/
@[simps]
def lift_equiv : {φ : normed_add_group_hom V₁ V // f.comp φ = g.comp φ} ≃
  normed_add_group_hom V₁ (f.equalizer g) :=
{ to_fun := λ φ, lift φ φ.prop,
  inv_fun := λ ψ, ⟨(ι f g).comp ψ, by { rw [← comp_assoc, ← comp_assoc, comp_ι_eq] }⟩,
  left_inv := λ φ, by simp,
  right_inv := λ ψ, by { ext, refl } }

/-- Given `φ : normed_add_group_hom V₁ V₂` and `ψ : normed_add_group_hom W₁ W₂` such that
`ψ.comp f₁ = f₂.comp φ` and `ψ.comp g₁ = g₂.comp φ`, the induced morphism
`normed_add_group_hom (f₁.equalizer g₁) (f₂.equalizer g₂)`. -/
def map (φ : normed_add_group_hom V₁ V₂) (ψ : normed_add_group_hom W₁ W₂)
  (hf : ψ.comp f₁ = f₂.comp φ) (hg : ψ.comp g₁ = g₂.comp φ) :
  normed_add_group_hom (f₁.equalizer g₁) (f₂.equalizer g₂) :=
lift (φ.comp $ ι _ _) $
by { simp only [← comp_assoc, ← hf, ← hg], simp only [comp_assoc, comp_ι_eq] }

variables {φ : normed_add_group_hom V₁ V₂} {ψ : normed_add_group_hom W₁ W₂}
variables {φ' : normed_add_group_hom V₂ V₃} {ψ' : normed_add_group_hom W₂ W₃}

@[simp] lemma ι_comp_map (hf : ψ.comp f₁ = f₂.comp φ) (hg : ψ.comp g₁ = g₂.comp φ) :
  (ι f₂ g₂).comp (map φ ψ hf hg) = φ.comp (ι _ _) :=
ι_comp_lift _ _

@[simp] lemma map_id : map (id V₁) (id W₁) rfl rfl = id (f₁.equalizer g₁) :=
by { ext, refl }

lemma comm_sq₂ (hf : ψ.comp f₁ = f₂.comp φ) (hf' : ψ'.comp f₂ = f₃.comp φ') :
  (ψ'.comp ψ).comp f₁ = f₃.comp (φ'.comp φ) :=
by rw [comp_assoc, hf, ← comp_assoc, hf', comp_assoc]

lemma map_comp_map (hf : ψ.comp f₁ = f₂.comp φ) (hg : ψ.comp g₁ = g₂.comp φ)
  (hf' : ψ'.comp f₂ = f₃.comp φ') (hg' : ψ'.comp g₂ = g₃.comp φ') :
  (map φ' ψ' hf' hg').comp (map φ ψ hf hg) =
    map (φ'.comp φ) (ψ'.comp ψ) (comm_sq₂ hf hf') (comm_sq₂ hg hg') :=
by { ext, refl }

lemma ι_norm_noninc : (ι f g).norm_noninc := λ v, le_rfl

/-- The lifting of a norm nonincreasing morphism is norm nonincreasing. -/
lemma lift_norm_noninc (φ : normed_add_group_hom V₁ V) (h : f.comp φ = g.comp φ)
  (hφ : φ.norm_noninc) :
  (lift φ h).norm_noninc :=
hφ

/-- If `φ` satisfies `‖φ‖ ≤ C`, then the same is true for the lifted morphism. -/
lemma norm_lift_le (φ : normed_add_group_hom V₁ V) (h : f.comp φ = g.comp φ)
  (C : ℝ) (hφ : ‖φ‖ ≤ C) : ‖(lift φ h)‖ ≤ C := hφ

lemma map_norm_noninc (hf : ψ.comp f₁ = f₂.comp φ) (hg : ψ.comp g₁ = g₂.comp φ)
  (hφ : φ.norm_noninc) : (map φ ψ hf hg).norm_noninc :=
lift_norm_noninc _ _ $ hφ.comp ι_norm_noninc

lemma norm_map_le (hf : ψ.comp f₁ = f₂.comp φ) (hg : ψ.comp g₁ = g₂.comp φ)
  (C : ℝ) (hφ : ‖φ.comp (ι f₁ g₁)‖ ≤ C) : ‖map φ ψ hf hg‖ ≤ C :=
norm_lift_le _ _ _ hφ

end equalizer

end normed_add_group_hom


-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic

namespace algebra

signature left_action (α : Type*) (β : Type*) :=
(act : α → β → β)

class left_action {α : Type*} {β : Type*} (s : left_action_sig α β) : Prop := intro [] ::

namespace left_action
variables {α : Type*} {β : Type*} (s : left_action_sig α β)

abbreviation infer : left_action s := left_action.intro s

definition fold : list α → β → β
| [] x := x
| (y::ys) x := s.act y (fold ys x)

@[simp] theorem fold_nil (x) : fold s [] x = x := rfl

@[simp] theorem fold_cons (x y ys) : fold s (y::ys) x = s.act y (fold s ys x) := rfl

@[simp] theorem fold_append (x) : ∀ ys zs, fold s (ys ++ zs) x = fold s ys (fold s zs x)
| [] zs := rfl
| (y::ys) zs :=
  show s.act y (fold s (ys ++ zs) x) = s.act y (fold s ys (fold s zs x)),
  by rw fold_append

end left_action

signature right_action (α : Type*) (β : Type*) :=
(act : β → α → β)

class right_action {α : Type*} {β : Type*} (s : right_action_sig α β) : Prop := intro [] ::

namespace right_action
variables {α : Type*} {β : Type*} (s : right_action_sig α β)

abbreviation infer : right_action s := right_action.intro s

definition fold : β → list α → β
| x [] := x
| x (y::ys) := s.act (fold x ys) y

@[simp] theorem fold_nil (x) : fold s x [] = x := rfl

@[simp] theorem fold_cons (x y ys) : fold s x (y::ys) = s.act (fold s x ys) y := rfl

@[simp] theorem fold_append (x) : ∀ ys zs, fold s x (ys ++ zs) = fold s (fold s x zs) ys
| [] zs := rfl
| (y::ys) zs :=
  show s.act (fold s x (ys ++ zs)) y = s.act (fold s (fold s x zs) ys) y,
  by rw fold_append

end right_action

end algebra