import .homology_of_spheres
import algebra.quadratic_discriminant

lemma connected_to_disconnected_surjection_nogo {α β : Type*}
  [topological_space α] [topological_space β] (h1 : connected_space α) (h2 : ¬ connected_space β)
  : ¬ ∃ (r : C(α, β)), function.surjective r :=
begin
  rintros ⟨r, h⟩,
  have : is_connected (set.range r) := is_connected_range r.continuous_to_fun,
  rw h.range_eq at this,
  refine h2 _,
  exact @connected_space.mk _ _ ⟨this.right⟩ (set.nonempty_iff_univ_nonempty.mpr this.left)
end

lemma ball_to_sphere_retraction_nogo (n : ℕ)
  : ¬ ∃ (r : C(metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1,
               metric.sphere (0 : euclidean_space ℝ (fin n)) 1)),
      ∀ x h, (r ⟨x, metric.sphere_subset_closed_ball h⟩ : euclidean_space ℝ (fin n)) = x :=
begin
  rw not_exists,
  intros r H,
  let i : C(metric.sphere (0 : euclidean_space ℝ (fin n)) 1,
            metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1)
        := ⟨_, continuous_inclusion metric.sphere_subset_closed_ball⟩,
  have : r.comp i = continuous_map.id _,
  { ext : 2, cases a with a ha, exact H a ha },
  by_cases n > 0,
  { let i' : Top.of (metric.sphere (0 : euclidean_space ℝ (fin n)) 1)
          ⟶ Top.of (metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1)
        := i,
    let r' : Top.of (metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1)
          ⟶ Top.of (metric.sphere (0 : euclidean_space ℝ (fin n)) 1)
        := r,
    cases n, { exact lt_irrefl 0 h },
    by_cases n > 0,
    { change i' ≫ r' = 𝟙 (Top.of (metric.sphere (0 : euclidean_space ℝ (fin (n + 1))) 1)) at this,
      replace this := congr_arg (@category_theory.functor.map _ _ _ _ (singular_homology ℤ n) _ _) this,
      simp at this,
      have H : category_theory.limits.is_zero ((singular_homology ℤ n).obj (Top.of (metric.closed_ball (0 : euclidean_space ℝ (fin (n + 1))) 1))),
      { obtain ⟨P⟩ := homology_of_contractible_space ℤ (Top.of (metric.closed_ball (0 : euclidean_space ℝ (fin (n + 1))) 1)) _ n h,
        exact category_theory.limits.is_zero_of_iso_of_zero (category_theory.limits.is_zero_zero _) P.symm,
        exact convex.contractible_space (strict_convex_closed_ball ℝ _ _).convex
                                        ⟨0, metric.mem_closed_ball_self zero_le_one⟩ },
      refine absurd (category_theory.limits.is_zero_of_iso_of_zero H (category_theory.iso.mk _ _ _ this)) _,
      { exact category_theory.limits.is_zero.eq_of_src H _ _ },
      { obtain ⟨P⟩ := @nth_homology_of_n_sphere ℤ _ _ n h,
        intro H',
        have H'' := category_theory.limits.is_zero_of_iso_of_zero H' P,
        rw category_theory.limits.is_zero_iff_id_eq_zero at H'',
        have H''' : (𝟙 (Module.of ℤ ℤ) : ℤ → ℤ) 1 = 0, { rw H'', refl },
        exact @one_ne_zero ℤ _ _ H''' } },
    { simp at h, subst h,
      refine connected_to_disconnected_surjection_nogo _ _ ⟨r, _⟩,
      { rw ← is_connected_iff_connected_space,
        refine convex.is_connected (strict_convex_closed_ball ℝ _ _).convex
                                   ⟨0, metric.mem_closed_ball_self zero_le_one⟩ },
      { let x0 : (metric.sphere (0 : euclidean_space ℝ (fin 1)) 1) := ⟨(λ _, (-1) : fin 1 → ℝ), _⟩,
        swap, { simp [euclidean_space.norm_eq] },
        let x1 : (metric.sphere (0 : euclidean_space ℝ (fin 1)) 1) := ⟨(λ _, 1 : fin 1 → ℝ), _⟩,
        swap, { simp [euclidean_space.norm_eq] },
        let F := two_point_t2_space_homeo_coprod_two_points x0 x1 _ _,
        { intro h, haveI := h,
          have h' : is_connected (set.range F.symm) := is_connected_range F.symm.continuous_to_fun,
          rw [F.symm.range_coe, sum.is_connected_iff] at h',
          cases h',
          { obtain ⟨t, _, ht⟩ := h',
            have := @set.mem_univ (punit.{1} ⊕ punit.{1}), rw ht at this,
            specialize this (sum.inr ()), cases this with _ h'', simp at h'', exact h'' },
          { obtain ⟨t, _, ht⟩ := h',
            have := @set.mem_univ (punit.{1} ⊕ punit.{1}), rw ht at this,
            specialize this (sum.inl ()), cases this with _ h'', simp at h'', exact h'' } },
        { simp [x0, x1], refine ne.symm _, rw [ne.def, eq_neg_self_iff], exact one_ne_zero },
        { rintro ⟨x, hx⟩, simp [euclidean_space.norm_eq] at hx, simp [x0, x1],
          refine or.imp _ _ (or.symm hx); intro; ext i; fin_cases i; assumption } },
      { refine @function.right_inverse.surjective _ _ r i _,
        intro x, rw [← continuous_map.comp_apply, this], refl } } },
  { simp at h, subst h,
    suffices : is_empty ↥(metric.sphere (0 : euclidean_space ℝ (fin 0)) 1),
    { obtain ⟨h⟩ := this, exact h (r ⟨0, metric.mem_closed_ball_self zero_le_one⟩) },
    apply_with metric.sphere_is_empty_of_subsingleton {instances:=ff},
    { dsimp [euclidean_space, pi_Lp], apply_instance },
    { exact zero_ne_one.symm } }
end.

notation `⟪`x`, `y`⟫` := @inner ℝ _ _ x y

noncomputable
def time_to_boundary (n : ℕ) (p q : euclidean_space ℝ (fin n)) : ℝ :=
  (2 * ⟪q - p, q⟫ - real.sqrt (4 * ⟪q - p, q⟫^2 + 4 * ∥p - q∥^2 * (1 - ∥q∥^2))) / (2 * ∥p - q∥^2)

noncomputable
def time_to_boundary_aux (x : { tuple : ℝ × ℝ × ℝ // tuple.snd.fst > 0 ∧ tuple.snd.snd ≤ 1 }) : ℝ :=
  (2 * x.val.fst - real.sqrt (4 * x.val.fst^2 + 4 * x.val.snd.fst^2 * (1 - x.val.snd.snd^2))) / (2 * x.val.snd.fst^2)

noncomputable
def time_to_boundary' (n : ℕ) (pair : { x : metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
                                           × metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
                                           // x.fst ≠ x.snd })
  := time_to_boundary n pair.val.fst pair.val.snd

noncomputable
def time_to_boundary'_aux (n : ℕ) (pair : { x : metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
                                              × metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
                                              // x.fst ≠ x.snd })
  : { tuple : ℝ × ℝ × ℝ // tuple.snd.fst > 0 ∧ tuple.snd.snd ≤ 1 } := {
    val := ⟨⟪pair.val.snd.val - pair.val.fst.val, pair.val.snd⟫,
            ∥pair.val.fst.val - pair.val.snd.val∥,
            ∥pair.val.snd.val∥⟩,
    property := by { split; simp, { rw [sub_eq_zero, ← subtype.ext_iff], exact pair.property },
                     { have := pair.val.snd.property, simp at this, exact this } }
  }.

lemma time_to_boundary'_fact (n : ℕ)
  : time_to_boundary' n  = time_to_boundary_aux ∘ time_to_boundary'_aux n :=
begin
  ext x, rcases x with ⟨⟨⟨x1, h1⟩, ⟨x2, h2⟩⟩, h⟩, refl
end.

lemma time_to_boundary'_continuous (n : ℕ) : continuous (time_to_boundary' n) :=
begin
  rw time_to_boundary'_fact,
  refine continuous.comp _ _,
  { refine continuous.div _ _ _, { continuity }, { continuity },
    { rintro ⟨⟨a, b, c⟩, h1, h2⟩, rw mul_ne_zero_iff, simp, exact ne_of_gt h1 } },
  { refine continuous_subtype_mk _ _,
    refine continuous.prod_mk _ ((continuous_norm.comp _).prod_mk (continuous_norm.comp _)),
    { refine continuous.inner _ _,
      { exact continuous.sub (continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val))
                             (continuous_subtype_val.comp (continuous_fst.comp continuous_subtype_val)) },
      { exact continuous_subtype_coe.comp (continuous_snd.comp continuous_subtype_val) } },
    { exact continuous.sub (continuous_subtype_val.comp (continuous_fst.comp continuous_subtype_val))
                             (continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val)) },
    { exact continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val) } }
end.

lemma real.quadratic_eq_zero_iff {a b c : ℝ} (ha : a ≠ 0) (h : discrim a b c ≥ 0) (x : ℝ) :
  a * x * x + b * x + c = 0
  ↔ x = (-b + real.sqrt (discrim a b c)) / (2 * a) ∨ x = (-b - real.sqrt (discrim a b c)) / (2 * a) :=
  quadratic_eq_zero_iff ha (by { rw [← pow_two, real.sq_sqrt h] }) x

lemma real.AM_GM2 (a b : ℝ) : 2 * a * b ≤ a^2 + b^2 :=
  sub_nonneg.mp (eq.subst (sub_sq' a b) (sq_nonneg (a - b)))

lemma time_to_boundary'_lands_in_sphere (n : ℕ) (pair)
  : time_to_boundary' n pair • pair.val.fst.val + (1 - time_to_boundary' n pair) • pair.val.snd.val
  ∈ metric.sphere (0 : euclidean_space ℝ (fin n)) 1 :=
begin
  simp, generalize h : time_to_boundary' n pair = t,
  rw [norm_eq_sqrt_real_inner, real_inner_add_add_self,
      real_inner_smul_left, real_inner_smul_left, real_inner_smul_left,
      real_inner_smul_right, real_inner_smul_right, real_inner_smul_right,
      real.sqrt_eq_iff_sq_eq _ zero_le_one, one_pow],
  { ring_nf SOP,
    rw [mul_assoc, ← mul_neg, ← mul_add, ← mul_add, mul_assoc, mul_assoc, ← mul_sub],
    symmetry,
    rw [mul_comm t _, mul_comm, pow_two, ← mul_assoc, ← sub_eq_zero, add_sub_assoc],
    rw real.quadratic_eq_zero_iff,
    { right,
      rw ← h, delta time_to_boundary' time_to_boundary discrim,
      congr' 2,
      { rw [neg_sub, mul_comm, inner_sub_left, sub_mul], refl },
      { refine congr_arg _ _,
        rw [← real_inner_self_eq_norm_sq, real_inner_sub_sub_self, inner_sub_left],
        rw [← neg_sq, neg_sub, ← sub_mul, mul_pow, mul_comm],
        congr, norm_cast,
        rw [← mul_neg, neg_sub, ← real_inner_self_eq_norm_sq,
            sub_eq_add_neg, add_assoc, mul_comm (2 : ℝ)], refl },
      { rw [← real_inner_self_eq_norm_sq, real_inner_sub_sub_self,
            sub_eq_add_neg, add_assoc, mul_comm (2 : ℝ)], refl } },
    { refine ne_of_eq_of_ne _ (sq_eq_zero_iff.not.mpr (norm_ne_zero_iff.mpr (sub_ne_zero.mpr (subtype.ext_iff.not.mp pair.property)))),
      rw [← real_inner_self_eq_norm_sq, real_inner_sub_sub_self], ring },
    { delta discrim,
      rw [ge_iff_le, sub_nonneg, sub_sq],
      transitivity (0 : ℝ),
      { rw [← neg_nonneg, ← mul_neg, neg_sub],
        refine mul_nonneg (mul_nonneg zero_le_four _) _,
        { rw [← sub_eq_neg_add, add_sub_left_comm, add_comm, mul_comm, ← real_inner_sub_sub_self,
              real_inner_self_eq_norm_sq],
         apply sq_nonneg },
        { rw [sub_nonneg, real_inner_self_eq_norm_sq, sq_le_one_iff (norm_nonneg _),
              ← mem_closed_ball_zero_iff],
          exact subtype.mem _ } },
      { rw [add_comm, ← add_sub_assoc, sub_nonneg, add_comm], apply real.AM_GM2 } } },
  { ring_nf SOP,
    rw [mul_assoc, ← mul_neg, ← mul_add, ← mul_add, mul_assoc, mul_assoc, ← mul_sub],
    rw [← sub_eq_neg_add, add_sub_left_comm, add_comm _ (_ - _), mul_comm _ (2 : ℝ),
        ← real_inner_sub_sub_self, real_inner_self_eq_norm_sq],
    rw [mul_comm _ (2 : ℝ), ← mul_sub, ← inner_sub_left, add_right_comm,
        ← sub_neg_eq_add, sub_nonneg],
    refine le_trans (neg_le_abs_self _) _,
    rw [← real_inner_smul_left, ← real_inner_smul_left, smul_smul, mul_comm, ← smul_smul],
    refine le_trans (abs_real_inner_le_norm _ _) _,
    rw [norm_smul, real.norm_eq_abs, abs_eq_self.mpr (zero_le_two : (0 : ℝ) ≤ (2 : ℝ))],
    refine le_trans (real.AM_GM2 _ _) (le_of_eq _),
    rw [norm_smul, real.norm_eq_abs, mul_pow, sq_abs, real_inner_self_eq_norm_sq] }
end.

-- rcases pair with ⟨⟨⟨p, hp⟩, ⟨q, hq⟩⟩, h⟩,
-- rw [subtype.val_eq_coe],
-- simp only [prod.fst, prod.snd, subtype.coe_mk],

lemma time_to_boundary_eq_zero_if_in_boundary (n : ℕ) (p q : euclidean_space ℝ (fin n))
  (h1 : p ∈ metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1)
  (h2 : q ∈ metric.sphere (0 : euclidean_space ℝ (fin n)) 1)
  : time_to_boundary n p q = 0 :=
begin
  simp at h1 h2,
  simp only [div_eq_zero_iff, time_to_boundary],
  left,
  rw [h2, one_pow, sub_self, mul_zero, add_zero, real.sqrt_mul, sub_eq_zero],
  symmetry, congr,
  { rw real.sqrt_eq_iff_sq_eq; norm_cast; apply nat.zero_le },
  { apply real.sqrt_sq,
    rw [inner_sub_left, sub_nonneg, real_inner_self_eq_norm_mul_norm],
    refine le_trans (real_inner_le_norm _ _) _,
    rw h2, simp, exact h1 },
  { norm_cast, exact nat.zero_le 4 }
end

/-
Proof sketch, due to Ivo Vekemans (see https://www.ivovekemans.net/mathematical-art):

I slept.
And slumbering dreamt.
And dreaming, I ambled clockwise around a great circular lake in an infinite desert.
And ambling, caught my sweater on a thorn, and began to unravel.
And unravelling, I saw all the points of the lake.
And observed, the lake began to stir.
And stirring, the surface did not break, remaining contained.
And contained, the visited a violent vortex, but STILL the surface did not break.
And unbroken, the whirring pool... ...subsided, as the last sweater thread unwound.
And unwound in the setting sun I spied again the thorn.
And spying, noticed that no point on the lake was where it began.
And beginning at each point emanated a single ray of light, through the point it was prior perturbation, each ray illuminating a spot on the shore.
And sure that the points perturbed from the bank illuminated those points from whence they came, I tied the ends of my sweater together and HEAVED. And heaved and heaved.
And, so heft, the thread, without breaking or crossing the lake, rewound unto me a complete sweater.
And sweating from the exertion, I woke.
And waking, recalled that one is not zero, snapping the thread.
-/

lemma brouwer_fixed_point_for_sphere (n : ℕ)
  (f : C(metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1,
         metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1))
  : ∃ x : metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1, f x = x :=
begin
  by_contra, rw not_exists at h,
  apply ball_to_sphere_retraction_nogo n,
  let mk_pair : metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
              → { x : metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
                    × metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1
                    // x.fst ≠ x.snd } := λ p, ⟨⟨f p, p⟩, h p⟩,
  have mk_pair_cont : continuous mk_pair :=
    continuous_subtype_mk _ (continuous.prod_mk f.continuous_to_fun continuous_id),
  let r :  C(metric.closed_ball (0 : euclidean_space ℝ (fin n)) 1,
             metric.sphere (0 : euclidean_space ℝ (fin n)) 1) :=
    continuous_map.comp ⟨(λ p, ⟨time_to_boundary' n p • p.val.fst.val
                                + (1 - time_to_boundary' n p) • p.val.snd.val,
                                time_to_boundary'_lands_in_sphere n p⟩), _⟩
                        ⟨mk_pair, mk_pair_cont⟩,
  swap,
  { refine continuous_subtype_mk _ (continuous.add _ _);
    refine continuous.smul _ _,
    { exact time_to_boundary'_continuous n },
    { exact continuous_subtype_val.comp (continuous_fst.comp continuous_subtype_val) },
    { exact continuous.sub (continuous_const) (time_to_boundary'_continuous n) },
    { exact continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val) } },
  refine ⟨r, _⟩,
  intros x h,
  simp [r, mk_pair, time_to_boundary'],
  rw time_to_boundary_eq_zero_if_in_boundary n _ _ (subtype.mem _) h,
  simp
end.

theorem brouwer_fixed_point {V : Type*}
  [normed_add_comm_group V] [normed_space ℝ V] [finite_dimensional ℝ V]
  : ∀ (s : set V), convex ℝ s → is_compact s → set.nonempty s →
    ∀ (f : C(s, s)), ∃ x, f x = x :=
begin
  intros s h1 h2 h3,
  have : affine_dim ℝ s < cardinal.aleph_0,
  { apply @lt_of_le_of_lt _ _ _ (module.rank ℝ V),
    { dsimp [affine_dim],
      rw [← finite_dimensional.finrank_eq_dim, ← finite_dimensional.finrank_eq_dim],
      norm_cast,
      apply submodule.finrank_le },
    { rw ← finite_dimensional.finrank_eq_dim, exact cardinal.nat_lt_aleph_0 _ } },
  rw cardinal.lt_aleph_0 at this,
  obtain ⟨n, hn⟩ := this,
  obtain ⟨F⟩ := convex_compact_homeo_to_ball s h1 h2 h3 n hn,
  intro f,
  let g := F.to_continuous_map.comp (f.comp F.symm.to_continuous_map),
  obtain ⟨y, hy⟩ := brouwer_fixed_point_for_sphere n g,
  refine ⟨F.symm y, _⟩,
  rw [← homeomorph.coe_symm_to_equiv, equiv.eq_symm_apply],
  exact hy
end


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import init.data.nat.basic

open nat
@[reducible] def is_valid_char (n : nat) : Prop :=
n < 0xd800 ∨ (0xdfff < n ∧ n < 0x110000)

lemma is_valid_char_range_1 (n : nat) (h : n < 0xd800) : is_valid_char n :=
or.inl h

lemma is_valid_char_range_2 (n : nat) (h₁ : 0xdfff < n) (h₂ : n < 0x110000) : is_valid_char n :=
or.inr ⟨h₁, h₂⟩

/-- The `char` type represents an unicode scalar value.
    See http://www.unicode.org/glossary/#unicode_scalar_value). -/
structure char :=
(val : nat) (valid : is_valid_char val)

instance : has_sizeof char :=
⟨λ c, c.val⟩

namespace char
protected def lt (a b : char) : Prop := a.val < b.val
protected def le (a b : char) : Prop := a.val ≤ b.val

instance : has_lt char := ⟨char.lt⟩
instance : has_le char := ⟨char.le⟩

instance decidable_lt (a b : char) :  decidable (a < b) :=
nat.decidable_lt _ _

instance decidable_le (a b : char) : decidable (a ≤ b) :=
nat.decidable_le _ _

/-
We cannot use tactics dec_trivial or comp_val here because the tactic framework has not been defined yet.
We also do not use `zero_lt_succ _` as a proof term because this proof may not be trivial to check by
external type checkers. See discussion at: https://github.com/leanprover/tc/issues/8
-/
lemma zero_lt_d800 : 0 < 0xd800 :=
nat.zero_lt_bit0 $ nat.bit0_ne_zero $ nat.bit0_ne_zero $ nat.bit0_ne_zero $
nat.bit0_ne_zero $ nat.bit0_ne_zero $ nat.bit0_ne_zero $ nat.bit0_ne_zero $
nat.bit0_ne_zero $ nat.bit0_ne_zero $ nat.bit0_ne_zero $ nat.bit1_ne_zero 13

@[pattern] def of_nat (n : nat) : char :=
if h : is_valid_char n then {val := n, valid := h} else {val := 0, valid := or.inl zero_lt_d800}

def to_nat (c : char) : nat :=
c.val

lemma eq_of_veq : ∀ {c d : char}, c.val = d.val → c = d
| ⟨v, h⟩ ⟨_, _⟩ rfl := rfl

lemma veq_of_eq : ∀ {c d : char}, c = d → c.val = d.val
| _ _ rfl := rfl

lemma ne_of_vne {c d : char} (h : c.val ≠ d.val) : c ≠ d :=
λ h', absurd (veq_of_eq h') h

lemma vne_of_ne {c d : char} (h : c ≠ d) : c.val ≠ d.val :=
λ h', absurd (eq_of_veq h') h

end char

instance : decidable_eq char :=
λ i j, decidable_of_decidable_of_iff
  (nat.decidable_eq i.val j.val) ⟨char.eq_of_veq, char.veq_of_eq⟩

instance : inhabited char :=
⟨'A'⟩


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.limits.shapes.biproducts
import category_theory.limits.preserves.shapes.zero

/-!
# Preservation of biproducts

We define the image of a (binary) bicone under a functor that preserves zero morphisms and define
classes `preserves_biproduct` and `preserves_binary_biproduct`. We then

* show that a functor that preserves biproducts of a two-element type preserves binary biproducts,
* give the canonical isomorphism between the image of a biproduct and the biproduct of the images,
* show that in a preadditive category, a functor preserves a biproduct if and only if it preserves
  the corresponding product if and only if it preserves the corresponding coproduct.

-/

universes w₁ w₂ v₁ v₂ u₁ u₂

noncomputable theory

open category_theory
open category_theory.limits

namespace category_theory

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

section has_zero_morphisms
variables [has_zero_morphisms C] [has_zero_morphisms D]

namespace functor

section map
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type w₁}

/-- The image of a bicone under a functor. -/
@[simps]
def map_bicone {f : J → C} (b : bicone f) : bicone (F.obj ∘ f) :=
{ X := F.obj b.X,
  π := λ j, F.map (b.π j),
  ι := λ j, F.map (b.ι j),
  ι_π := λ j j',
  begin
    rw ← F.map_comp,
    split_ifs,
    { subst h,
      simp only [bicone_ι_π_self, category_theory.functor.map_id, eq_to_hom_refl] },
    { rw [bicone_ι_π_ne _ h, F.map_zero] }
  end }

lemma map_bicone_whisker {K : Type w₂} {g : K ≃ J} {f : J → C} (c : bicone f) :
  F.map_bicone (c.whisker g) = (F.map_bicone c).whisker g := rfl

end bicone

/-- The image of a binary bicone under a functor. -/
@[simps]
def map_binary_bicone {X Y : C} (b : binary_bicone X Y) : binary_bicone (F.obj X) (F.obj Y) :=
{ X := F.obj b.X,
  fst := F.map b.fst,
  snd := F.map b.snd,
  inl := F.map b.inl,
  inr := F.map b.inr,
  inl_fst' := by rw [← F.map_comp, b.inl_fst, F.map_id],
  inl_snd' := by rw [← F.map_comp, b.inl_snd, F.map_zero],
  inr_fst' := by rw [← F.map_comp, b.inr_fst, F.map_zero],
  inr_snd' := by rw [← F.map_comp, b.inr_snd, F.map_id] }

end map

end functor

open category_theory.functor

namespace limits

section bicone
variables {J : Type w₁} {K : Type w₂}

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
class preserves_biproduct (f : J → C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : bicone f}, b.is_bilimit → (F.map_bicone b).is_bilimit)

/-- A functor `F` preserves biproducts of `f` if `F` maps every bilimit bicone over `f` to a
    bilimit bicone over `F.obj ∘ f`. -/
def is_bilimit_of_preserves {f : J → C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_biproduct f F] {b : bicone f} (hb : b.is_bilimit) : (F.map_bicone b).is_bilimit :=
preserves_biproduct.preserves hb

variables (J)

/-- A functor `F` preserves biproducts of shape `J` if it preserves biproducts of `f` for every
    `f : J → C`. -/
class preserves_biproducts_of_shape (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {f : J → C}, preserves_biproduct f F)

attribute [instance, priority 100] preserves_biproducts_of_shape.preserves

end bicone

/-- A functor `F` preserves finite biproducts if it preserves biproducts of shape `J` whenever
    `J` is a fintype. -/
class preserves_finite_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type} [fintype J], preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_finite_biproducts.preserves

/-- A functor `F` preserves biproducts if it preserves biproducts of any shape `J` of size `w`.
    The usual notion of preservation of biproducts is recovered by choosing `w` to be the universe
    of the morphisms of `C`. -/
class preserves_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {J : Type w₁}, preserves_biproducts_of_shape J F)

attribute [instance, priority 100] preserves_biproducts.preserves

/-- Preserving biproducts at a bigger universe level implies preserving biproducts at a
smaller universe level. -/
def preserves_biproducts_shrink (F : C ⥤ D) [preserves_zero_morphisms F]
  [hp : preserves_biproducts.{max w₁ w₂} F] : preserves_biproducts.{w₁} F :=
⟨λ J, ⟨λ f, ⟨λ b ib, ((F.map_bicone b).whisker_is_bilimit_iff _).to_fun
  (is_bilimit_of_preserves F ((b.whisker_is_bilimit_iff equiv.ulift.{w₂}).inv_fun ib))⟩⟩⟩

@[priority 100]
instance preserves_finite_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts.{w₁} F] : preserves_finite_biproducts F :=
{ preserves := λ J _, by letI := preserves_biproducts_shrink.{0} F; apply_instance }

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
class preserves_binary_biproduct (X Y : C) (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {b : binary_bicone X Y}, b.is_bilimit → (F.map_binary_bicone b).is_bilimit)

/-- A functor `F` preserves binary biproducts of `X` and `Y` if `F` maps every bilimit bicone over
    `X` and `Y` to a bilimit bicone over `F.obj X` and `F.obj Y`. -/
def is_binary_bilimit_of_preserves {X Y : C} (F : C ⥤ D) [preserves_zero_morphisms F]
  [preserves_binary_biproduct X Y F] {b : binary_bicone X Y} (hb : b.is_bilimit) :
  (F.map_binary_bicone b).is_bilimit :=
preserves_binary_biproduct.preserves hb

/-- A functor `F` preserves binary biproducts if it preserves the binary biproduct of `X` and `Y`
    for all `X` and `Y`. -/
class preserves_binary_biproducts (F : C ⥤ D) [preserves_zero_morphisms F] :=
(preserves : Π {X Y : C}, preserves_binary_biproduct X Y F . tactic.apply_instance)

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_biproduct (F : C ⥤ D) [preserves_zero_morphisms F]
  (X Y : C) [preserves_biproduct (pair_function X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb,
  { is_limit := is_limit.of_iso_limit
      ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_limit)) $
      cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy, }),
    is_colimit := is_colimit.of_iso_colimit
      ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _ ) _).symm
        ((is_bilimit_of_preserves F (b.to_bicone_is_bilimit.symm hb)).is_colimit)) $
      cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy, }) } }

/-- A functor that preserves biproducts of a pair preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_biproducts (F : C ⥤ D)
  [preserves_zero_morphisms F] [preserves_biproducts_of_shape walking_pair F] :
  preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_biproduct F X Y }

attribute [instance, priority 100] preserves_binary_biproducts.preserves

end limits

open category_theory.limits

namespace functor

section bicone
variables {J : Type w₁} (F : C ⥤ D) [preserves_zero_morphisms F] (f : J → C)
  [has_biproduct f] [preserves_biproduct f F]

instance has_biproduct_of_preserves : has_biproduct (F.obj ∘ f) :=
has_biproduct.mk
{ bicone := F.map_bicone (biproduct.bicone f),
  is_bilimit := preserves_biproduct.preserves (biproduct.is_bilimit _) }

/-- If `F` preserves a biproduct, we get a definitionally nice isomorphism
    `F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f)`. -/
@[simp]
def map_biproduct : F.obj (⨁ f) ≅ ⨁ (F.obj ∘ f) :=
biproduct.unique_up_to_iso _ (preserves_biproduct.preserves (biproduct.is_bilimit _))

lemma map_biproduct_hom : (map_biproduct F f).hom = biproduct.lift (λ j, F.map (biproduct.π f j)) :=
rfl

lemma map_biproduct_inv : (map_biproduct F f).inv = biproduct.desc (λ j, F.map (biproduct.ι f j)) :=
rfl

end bicone

variables (F : C ⥤ D) [preserves_zero_morphisms F] (X Y : C) [has_binary_biproduct X Y]
  [preserves_binary_biproduct X Y F]

instance has_binary_biproduct_of_preserves : has_binary_biproduct (F.obj X) (F.obj Y) :=
has_binary_biproduct.mk
{ bicone := F.map_binary_bicone (binary_biproduct.bicone X Y),
  is_bilimit := preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _) }

/-- If `F` preserves a binary biproduct, we get a definitionally nice isomorphism
    `F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y`. -/
@[simp]
def map_biprod : F.obj (X ⊞ Y) ≅ F.obj X ⊞ F.obj Y :=
biprod.unique_up_to_iso _ _
  (preserves_binary_biproduct.preserves (binary_biproduct.is_bilimit _ _))

lemma map_biprod_hom : (map_biprod F X Y).hom = biprod.lift (F.map biprod.fst) (F.map biprod.snd) :=
rfl

lemma map_biprod_inv : (map_biprod F X Y).inv = biprod.desc (F.map biprod.inl) (F.map biprod.inr) :=
rfl

end functor

namespace limits
variables (F : C ⥤ D) [preserves_zero_morphisms F]

section bicone
variables {J : Type w₁} (f : J → C) [has_biproduct f] [preserves_biproduct f F]
  {W : C}

lemma biproduct.map_lift_map_biprod (g : Π j, W ⟶ f j) :
  F.map (biproduct.lift g) ≫ (F.map_biproduct f).hom = biproduct.lift (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_inv_map_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).inv ≫ F.map (biproduct.desc g) = biproduct.desc (λ j, F.map (g j)) :=
by { ext, simp [← F.map_comp] }

lemma biproduct.map_biproduct_hom_desc (g : Π j, f j ⟶ W) :
  (F.map_biproduct f).hom ≫ biproduct.desc (λ j, F.map (g j)) = F.map (biproduct.desc g) :=
by rw [← biproduct.map_biproduct_inv_map_desc, iso.hom_inv_id_assoc]

end bicone

section binary_bicone
variables (X Y : C) [has_binary_biproduct X Y] [preserves_binary_biproduct X Y F] {W : C}

lemma biprod.map_lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  F.map (biprod.lift f g) ≫ (F.map_biprod X Y).hom = biprod.lift (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.lift_map_biprod (f : W ⟶ X) (g : W ⟶ Y) :
  biprod.lift (F.map f) (F.map g) ≫ (F.map_biprod X Y).inv = F.map (biprod.lift f g) :=
by rw [← biprod.map_lift_map_biprod, category.assoc, iso.hom_inv_id, category.comp_id]

lemma biprod.map_biprod_inv_map_desc (f : X ⟶ W) (g : Y ⟶ W) :
  (F.map_biprod X Y).inv ≫ F.map (biprod.desc f g) = biprod.desc (F.map f) (F.map g) :=
by ext; simp [← F.map_comp]

lemma biprod.map_biprod_hom_desc (f : X ⟶ W) (g : Y ⟶ W) :
 (F.map_biprod X Y).hom ≫ biprod.desc (F.map f) (F.map g) = F.map (biprod.desc f g) :=
by rw [← biprod.map_biprod_inv_map_desc, iso.hom_inv_id_assoc]

end binary_bicone

end limits

end has_zero_morphisms

open category_theory.functor

section preadditive
variables [preadditive C] [preadditive D] (F : C ⥤ D) [preserves_zero_morphisms F]

namespace limits

section fintype
variables {J : Type} [fintype J]

local attribute [tidy] tactic.discrete_cases

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_product_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_limit (discrete.functor f) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
  ((is_limit.postcompose_inv_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
    (is_bilimit_of_preserves F (bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
  cones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_product_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite products. -/
def preserves_products_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_limits_of_shape (discrete J) F :=
{ preserves_limit := λ f, preserves_limit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_product {f : J → C} [preserves_limit (discrete.functor f) F] :
  preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
      cones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite products
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_products_of_shape
  [preserves_limits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproduct_of_preserves_biproduct {f : J → C} [preserves_biproduct f F] :
  preserves_colimit (discrete.functor f) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (discrete.comp_nat_iso_discrete _ _) _).symm
      (is_bilimit_of_preserves F
        (bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
    cocones.ext (iso.refl _) (by tidy) }

section
local attribute [instance] preserves_coproduct_of_preserves_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) finite biproducts
    preserves finite coproducts. -/
def preserves_coproducts_of_shape_of_preserves_biproducts_of_shape
  [preserves_biproducts_of_shape J F] : preserves_colimits_of_shape (discrete J) F :=
{ preserves_colimit := λ f, preserves_colimit_of_iso_diagram _ discrete.nat_iso_functor.symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproduct_of_preserves_coproduct {f : J → C}
  [preserves_colimit (discrete.functor f) F] : preserves_biproduct f F :=
{ preserves := λ b hb, is_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (discrete.comp_nat_iso_discrete _ _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
      cocones.ext (iso.refl _) (by tidy) }

/-- A functor between preadditive categories that preserves (zero morphisms and) finite coproducts
    preserves finite biproducts. -/
def preserves_biproducts_of_shape_of_preserves_coproducts_of_shape
  [preserves_colimits_of_shape (discrete J) F] : preserves_biproducts_of_shape J F :=
{ preserves := λ f, preserves_biproduct_of_preserves_coproduct F }

end fintype

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_product_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_limit (pair X Y) F :=
{ preserves := λ c hc, is_limit.of_iso_limit
    ((is_limit.postcompose_inv_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_limit_cone_of_is_limit hc)).is_limit) $
    cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

section
local attribute [instance] preserves_binary_product_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary products. -/
def preserves_binary_products_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_limits_of_shape (discrete walking_pair) F :=
{ preserves_limit := λ K, preserves_limit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_product {X Y : C}
  [preserves_limit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_limit _ $
    is_limit.of_iso_limit ((is_limit.postcompose_hom_equiv (by exact diagram_iso_pair _)
      (F.map_cone b.to_cone)).symm (is_limit_of_preserves F hb.is_limit)) $
        cones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary products
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_products
  [preserves_limits_of_shape (discrete walking_pair) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_product F }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproduct_of_preserves_binary_biproduct {X Y : C}
  [preserves_binary_biproduct X Y F] : preserves_colimit (pair X Y) F :=
{ preserves := λ c hc, is_colimit.of_iso_colimit
    ((is_colimit.precompose_hom_equiv (by exact diagram_iso_pair _) _).symm
      (is_binary_bilimit_of_preserves F
        (binary_bicone_is_bilimit_of_colimit_cocone_of_is_colimit hc)).is_colimit) $
      cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

section
local attribute [instance] preserves_binary_coproduct_of_preserves_binary_biproduct

/-- A functor between preadditive categories that preserves (zero morphisms and) binary biproducts
    preserves binary coproducts. -/
def preserves_binary_coproducts_of_preserves_binary_biproducts
  [preserves_binary_biproducts F] : preserves_colimits_of_shape (discrete walking_pair) F :=
{ preserves_colimit := λ K, preserves_colimit_of_iso_diagram _ (diagram_iso_pair _).symm }

end

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproduct_of_preserves_binary_coproduct {X Y : C}
  [preserves_colimit (pair X Y) F] : preserves_binary_biproduct X Y F :=
{ preserves := λ b hb, is_binary_bilimit_of_is_colimit _ $
    is_colimit.of_iso_colimit ((is_colimit.precompose_inv_equiv (by exact diagram_iso_pair _)
      (F.map_cocone b.to_cocone)).symm (is_colimit_of_preserves F hb.is_colimit)) $
        cocones.ext (iso.refl _) (λ j, by { rcases j with ⟨⟨⟩⟩, tidy }) }

/-- A functor between preadditive categories that preserves (zero morphisms and) binary coproducts
    preserves binary biproducts. -/
def preserves_binary_biproducts_of_preserves_binary_coproducts
  [preserves_colimits_of_shape (discrete walking_pair) F] : preserves_binary_biproducts F :=
{ preserves := λ X Y, preserves_binary_biproduct_of_preserves_binary_coproduct F }

end limits

end preadditive

end category_theory


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

universes u_1 u_2 u_3

namespace Mathlib

/-!
# modular equivalence for submodule
-/

/-- A predicate saying two elements of a module are equivalent modulo a submodule. -/
def smodeq {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    (U : submodule R M) (x : M) (y : M) :=
  submodule.quotient.mk x = submodule.quotient.mk y

protected theorem smodeq.def {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} :
    smodeq U x y ↔ submodule.quotient.mk x = submodule.quotient.mk y :=
  iff.rfl

namespace smodeq

@[simp] theorem top {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M] {x : M}
    {y : M} : smodeq ⊤ x y :=
  iff.mpr (submodule.quotient.eq ⊤) submodule.mem_top

@[simp] theorem bot {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M] {x : M}
    {y : M} : smodeq ⊥ x y ↔ x = y :=
  sorry

theorem mono {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U₁ : submodule R M} {U₂ : submodule R M} {x : M} {y : M} (HU : U₁ ≤ U₂) (hxy : smodeq U₁ x y) :
    smodeq U₂ x y :=
  iff.mpr (submodule.quotient.eq U₂) (HU (iff.mp (submodule.quotient.eq U₁) hxy))

theorem refl {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} : smodeq U x x :=
  Eq.refl (submodule.quotient.mk x)

theorem symm {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} (hxy : smodeq U x y) : smodeq U y x :=
  Eq.symm hxy

theorem trans {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} {z : M} (hxy : smodeq U x y) (hyz : smodeq U y z) :
    smodeq U x z :=
  Eq.trans hxy hyz

theorem add {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x₁ : M} {x₂ : M} {y₁ : M} {y₂ : M} (hxy₁ : smodeq U x₁ y₁)
    (hxy₂ : smodeq U x₂ y₂) : smodeq U (x₁ + x₂) (y₁ + y₂) :=
  sorry

theorem smul {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} (hxy : smodeq U x y) (c : R) : smodeq U (c • x) (c • y) :=
  sorry

theorem zero {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} : smodeq U x 0 ↔ x ∈ U :=
  sorry

theorem map {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M]
    {U : submodule R M} {x : M} {y : M} {N : Type u_3} [add_comm_group N] [module R N]
    (hxy : smodeq U x y) (f : linear_map R M N) :
    smodeq (submodule.map f U) (coe_fn f x) (coe_fn f y) :=
  iff.mpr (submodule.quotient.eq (submodule.map f U))
    (Eq.subst (linear_map.map_sub f x y) submodule.mem_map_of_mem
      (iff.mp (submodule.quotient.eq U) hxy))

theorem comap {R : Type u_1} [ring R] {M : Type u_2} [add_comm_group M] [module R M] {x : M} {y : M}
    {N : Type u_3} [add_comm_group N] [module R N] (V : submodule R N) {f : linear_map R M N}
    (hxy : smodeq V (coe_fn f x) (coe_fn f y)) : smodeq (submodule.comap f V) x y :=
  iff.mpr (submodule.quotient.eq (submodule.comap f V))
    ((fun (this : coe_fn f (x - y) ∈ V) => this)
      (Eq.symm (linear_map.map_sub f x y) ▸ iff.mp (submodule.quotient.eq V) hxy))

end Mathlib


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

Evaluate expressions in the language of (semi-)rings.
Based on http://www.cs.ru.nl/~freek/courses/tt-2014/read/10.1.1.61.3041.pdf .
-/
import algebra.group_power tactic.norm_num
import tactic.converter.interactive

namespace tactic
namespace ring

def horner {α} [comm_semiring α] (a x : α) (n : ℕ) (b : α) := a * x ^ n + b

meta structure cache :=
(α : expr)
(univ : level)
(comm_semiring_inst : expr)

meta def mk_cache (e : expr) : tactic cache :=
do α ← infer_type e,
   c ← mk_app ``comm_semiring [α] >>= mk_instance,
   u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   return ⟨α, u, c⟩

meta def cache.cs_app (c : cache) (n : name) : list expr → expr :=
(@expr.const tt n [c.univ] c.α c.comm_semiring_inst).mk_app

meta def cache.mk_app (c : cache) (n inst : name) (l : list expr) : tactic expr :=
do m ← mk_instance ((expr.const inst [c.univ] : expr) c.α),
   return $ (@expr.const tt n [c.univ] c.α m).mk_app l

meta inductive horner_expr : Type
| const (e : expr) : horner_expr
| xadd (e : expr) (a : horner_expr) (x : expr) (n : expr × ℕ) (b : horner_expr) : horner_expr

meta def horner_expr.e : horner_expr → expr
| (horner_expr.const e) := e
| (horner_expr.xadd e _ _ _ _) := e

meta instance : has_coe horner_expr expr := ⟨horner_expr.e⟩

meta def horner_expr.xadd' (c : cache) (a : horner_expr) (x : expr) (n : expr × ℕ) (b : horner_expr): horner_expr :=
horner_expr.xadd (c.cs_app ``horner [a, x, n.1, b]) a x n b

open horner_expr

meta def horner_expr.to_string : horner_expr → string
| (const e) := to_string e
| (xadd e a x (_, n) b) :=
    "(" ++ a.to_string ++ ") * (" ++ to_string x ++ ")^"
        ++ to_string n ++ " + " ++ b.to_string

meta def horner_expr.pp : horner_expr → tactic format
| (const e) := pp e
| (xadd e a x (_, n) b) := do
  pa ← a.pp, pb ← b.pp, px ← pp x,
  return $ "(" ++ pa ++ ") * (" ++ px ++ ")^" ++ to_string n ++ " + " ++ pb

meta instance : has_to_tactic_format horner_expr := ⟨horner_expr.pp⟩

meta def horner_expr.refl_conv (e : horner_expr) : tactic (horner_expr × expr) :=
do p ← mk_eq_refl e, return (e, p)

theorem zero_horner {α} [comm_semiring α] (x n b) :
  @horner α _ 0 x n b = b :=
by simp [horner]

theorem horner_horner {α} [comm_semiring α] (a₁ x n₁ n₂ b n')
  (h : n₁ + n₂ = n') :
  @horner α _ (horner a₁ x n₁ 0) x n₂ b = horner a₁ x n' b :=
by simp [h.symm, horner, pow_add, mul_assoc]

meta def eval_horner (c : cache) : horner_expr → expr → expr × ℕ → horner_expr → tactic (horner_expr × expr)
| ha@(const a) x n b :=
  if a.to_nat = some 0 then
    return (b, c.cs_app ``zero_horner [x, n.1, b])
  else (xadd' c ha x n b).refl_conv
| ha@(xadd a a₁ x₁ n₁ b₁) x n b :=
  if x₁ = x ∧ b₁.e.to_nat = some 0 then do
    (n', h) ← mk_app ``has_add.add [n₁.1, n.1] >>= norm_num,
    return (xadd' c a₁ x (n', n₁.2 + n.2) b,
      c.cs_app ``horner_horner [a₁, x, n₁.1, n.1, b, n', h])
  else (xadd' c ha x n b).refl_conv

theorem const_add_horner {α} [comm_semiring α] (k a x n b b') (h : k + b = b') :
  k + @horner α _ a x n b = horner a x n b' :=
by simp [h.symm, horner]

theorem horner_add_const {α} [comm_semiring α] (a x n b k b') (h : b + k = b') :
  @horner α _ a x n b + k = horner a x n b' :=
by simp [h.symm, horner]

theorem horner_add_horner_lt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₁ + k = n₂) (h₂ : (a₁ + horner a₂ x k 0 : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₁ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]

theorem horner_add_horner_gt {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ b₂ k a' b')
  (h₁ : n₂ + k = n₁) (h₂ : (horner a₁ x k 0 + a₂ : α) = a') (h₃ : b₁ + b₂ = b') :
  @horner α _ a₁ x n₁ b₁ + horner a₂ x n₂ b₂ = horner a' x n₂ b' :=
by simp [h₂.symm, h₃.symm, h₁.symm, horner, pow_add, mul_add, mul_comm, mul_left_comm]

theorem horner_add_horner_eq {α} [comm_semiring α] (a₁ x n b₁ a₂ b₂ a' b' t)
  (h₁ : a₁ + a₂ = a') (h₂ : b₁ + b₂ = b') (h₃ : horner a' x n b' = t) :
  @horner α _ a₁ x n b₁ + horner a₂ x n b₂ = t :=
by simp [h₃.symm, h₂.symm, h₁.symm, horner, add_mul, mul_comm]

meta def eval_add (c : cache) : horner_expr → horner_expr → tactic (horner_expr × expr)
| (const e₁) (const e₂) := do
  (e, p) ← mk_app ``has_add.add [e₁, e₂] >>= norm_num,
  return (const e, p)
| he₁@(const e₁) he₂@(xadd e₂ a x n b) :=
  if e₁.to_nat = some 0 then  do
    p ← mk_app ``zero_add [e₂],
    return (he₂, p)
  else do
    (b', h) ← eval_add he₁ b,
    return (xadd' c a x n b',
      c.cs_app ``const_add_horner [e₁, a, x, n.1, b, b', h])
| he₁@(xadd e₁ a x n b) he₂@(const e₂) :=
  if e₂.to_nat = some 0 then do
    p ← mk_app ``add_zero [e₁],
    return (he₁, p)
  else do
    (b', h) ← eval_add b he₂,
    return (xadd' c a x n b',
      c.cs_app ``horner_add_const [a, x, n.1, b, e₂, b', h])
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) :=
  if expr.lex_lt x₁ x₂ then do
    (b', h) ← eval_add b₁ he₂,
    return (xadd' c a₁ x₁ n₁ b',
      c.cs_app ``horner_add_const [a₁, x₁, n₁.1, b₁, e₂, b', h])
  else if x₁ ≠ x₂ then do
    (b', h) ← eval_add he₁ b₂,
    return (xadd' c a₂ x₂ n₂ b',
      c.cs_app ``const_add_horner [e₁, a₂, x₂, n₂.1, b₂, b', h])
  else if n₁.2 < n₂.2 then do
    let k := n₂.2 - n₁.2,
    ek ← expr.of_nat (expr.const `nat []) k,
    (_, h₁) ← mk_app ``has_add.add [n₁.1, ek] >>= norm_num,
    α0 ← expr.of_nat c.α 0,
    (a', h₂) ← eval_add a₁ (xadd' c a₂ x₁ (ek, k) (const α0)),
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_add_horner_lt [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else if n₁ ≠ n₂ then do
    let k := n₁.2 - n₂.2,
    ek ← expr.of_nat (expr.const `nat []) k,
    (_, h₁) ← mk_app ``has_add.add [n₂.1, ek] >>= norm_num,
    α0 ← expr.of_nat c.α 0,
    (a', h₂) ← eval_add (xadd' c a₁ x₁ (ek, k) (const α0)) a₂,
    (b', h₃) ← eval_add b₁ b₂,
    return (xadd' c a' x₁ n₂ b',
      c.cs_app ``horner_add_horner_gt [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, ek, a', b', h₁, h₂, h₃])
  else do
    (a', h₁) ← eval_add a₁ a₂,
    (b', h₂) ← eval_add b₁ b₂,
    (t, h₃) ← eval_horner c a' x₁ n₁ b',
    return (t, c.cs_app ``horner_add_horner_eq
      [a₁, x₁, n₁.1, b₁, a₂, b₂, a', b', t, h₁, h₂, h₃])

theorem horner_neg {α} [comm_ring α] (a x n b a' b')
  (h₁ : -a = a') (h₂ : -b = b') :
  -@horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner]

meta def eval_neg (c : cache) : horner_expr → tactic (horner_expr × expr)
| (const e) := do
  (e', p) ← mk_app ``has_neg.neg [e] >>= norm_num,
  return (const e', p)
| (xadd e a x n b) := do
  (a', h₁) ← eval_neg a,
  (b', h₂) ← eval_neg b,
  p ← c.mk_app ``horner_neg ``comm_ring [a, x, n.1, b, a', b', h₁, h₂],
  return (xadd' c a' x n b', p)

theorem horner_const_mul {α} [comm_semiring α] (c a x n b a' b')
  (h₁ : c * a = a') (h₂ : c * b = b') :
  c * @horner α _ a x n b = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, mul_add, mul_assoc]

theorem horner_mul_const {α} [comm_semiring α] (a x n b c a' b')
  (h₁ : a * c = a') (h₂ : b * c = b') :
  @horner α _ a x n b * c = horner a' x n b' :=
by simp [h₂.symm, h₁.symm, horner, add_mul, mul_right_comm]

meta def eval_const_mul (c : cache) (k : expr) :
  horner_expr → tactic (horner_expr × expr)
| (const e) := do
  (e', p) ← mk_app ``has_mul.mul [k, e] >>= norm_num,
  return (const e', p)
| (xadd e a x n b) := do
  (a', h₁) ← eval_const_mul a,
  (b', h₂) ← eval_const_mul b,
  return (xadd' c a' x n b',
    c.cs_app ``horner_const_mul [k, a, x, n.1, b, a', b', h₁, h₂])

theorem horner_mul_horner_zero {α} [comm_semiring α] (a₁ x n₁ b₁ a₂ n₂ aa t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ 0 = t :=
by rw [← h₂, ← h₁];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

theorem horner_mul_horner {α} [comm_semiring α]
  (a₁ x n₁ b₁ a₂ n₂ b₂ aa haa ab bb t)
  (h₁ : @horner α _ a₁ x n₁ b₁ * a₂ = aa)
  (h₂ : horner aa x n₂ 0 = haa)
  (h₃ : a₁ * b₂ = ab) (h₄ : b₁ * b₂ = bb)
  (H : haa + horner ab x n₁ bb = t) :
  horner a₁ x n₁ b₁ * horner a₂ x n₂ b₂ = t :=
by rw [← H, ← h₂, ← h₁, ← h₃, ← h₄];
   simp [horner, mul_add, mul_comm, mul_left_comm, mul_assoc]

meta def eval_mul (c : cache) : horner_expr → horner_expr → tactic (horner_expr × expr)
| (const e₁) (const e₂) := do
  (e', p) ← mk_app ``has_mul.mul [e₁, e₂] >>= norm_num,
  return (const e', p)
| (const e₁) e₂ :=
  match e₁.to_nat with
  | (some 0) := do
    α0 ← expr.of_nat c.α 0,
    p ← mk_app ``zero_mul [e₂],
    return (const α0, p)
  | (some 1) := do
    p ← mk_app ``one_mul [e₂],
    return (e₂, p)
  | _ := eval_const_mul c e₁ e₂
  end
| e₁ he₂@(const e₂) := do
  p₁ ← mk_app ``mul_comm [e₁, e₂],
  (e', p₂) ← eval_mul he₂ e₁,
  p ← mk_eq_trans p₁ p₂, return (e', p)
| he₁@(xadd e₁ a₁ x₁ n₁ b₁) he₂@(xadd e₂ a₂ x₂ n₂ b₂) :=
  if expr.lex_lt x₁ x₂ then do
    (a', h₁) ← eval_mul a₁ he₂,
    (b', h₂) ← eval_mul b₁ he₂,
    return (xadd' c a' x₁ n₁ b',
      c.cs_app ``horner_mul_const [a₁, x₁, n₁.1, b₁, e₂, a', b', h₁, h₂])
  else if x₁ ≠ x₂ then do
    (a', h₁) ← eval_mul he₁ a₂,
    (b', h₂) ← eval_mul he₁ b₂,
    return (xadd' c a' x₂ n₂ b',
      c.cs_app ``horner_const_mul [e₁, a₂, x₂, n₂.1, b₂, a', b', h₁, h₂])
  else do
    (aa, h₁) ← eval_mul he₁ a₂,
    α0 ← expr.of_nat c.α 0,
    (haa, h₂) ← eval_horner c aa x₁ n₂ (const α0),
    if b₂.e.to_nat = some 0 then
      return (haa, c.cs_app ``horner_mul_horner_zero
        [a₁, x₁, n₁.1, b₁, a₂, n₂.1, aa, haa, h₁, h₂])
    else do
      (ab, h₃) ← eval_mul a₁ b₂,
      (bb, h₄) ← eval_mul b₁ b₂,
      (t, H) ← eval_add c haa (xadd' c ab x₁ n₁ bb),
      return (t, c.cs_app ``horner_mul_horner
        [a₁, x₁, n₁.1, b₁, a₂, n₂.1, b₂, aa, haa, ab, bb, t, h₁, h₂, h₃, h₄, H])

theorem horner_pow {α} [comm_semiring α] (a x n m n' a')
  (h₁ : n * m = n') (h₂ : a ^ m = a') :
  @horner α _ a x n 0 ^ m = horner a' x n' 0 :=
by simp [h₁.symm, h₂.symm, horner, mul_pow, pow_mul]

meta def eval_pow (c : cache) : horner_expr → expr × ℕ → tactic (horner_expr × expr)
| e (_, 0) := do
  α1 ← expr.of_nat c.α 1,
  p ← mk_app ``pow_zero [e],
  return (const α1, p)
| e (_, 1) := do
  p ← mk_app ``pow_one [e],
  return (e, p)
| (const e) (e₂, m) := do
  (e', p) ← mk_app ``monoid.pow [e, e₂] >>= norm_num.derive,
  return (const e', p)
| he@(xadd e a x n b) m :=
  let N : expr := expr.const `nat [] in
  match b.e.to_nat with
  | some 0 := do
    (n', h₁) ← mk_app ``has_mul.mul [n.1, m.1] >>= norm_num,
    (a', h₂) ← eval_pow a m,
    α0 ← expr.of_nat c.α 0,
    return (xadd' c a' x (n', n.2 * m.2) (const α0),
      c.cs_app ``horner_pow [a, x, n.1, m.1, n', a', h₁, h₂])
  | _ := do
    e₂ ← expr.of_nat N (m.2-1),
    l ← mk_app ``monoid.pow [e, e₂],
    (tl, hl) ← eval_pow he (e₂, m.2-1),
    (t, p₂) ← eval_mul c tl he,
    hr ← mk_eq_refl e,
    p₂ ← c.mk_app ``norm_num.subst_into_prod ``has_mul [l, e, tl, e, t, hl, hr, p₂],
    p₁ ← mk_app ``pow_succ' [e, e₂],
    p ← mk_eq_trans p₁ p₂,
    return (t, p)
  end

theorem horner_atom {α} [comm_semiring α] (x : α) : x = horner 1 x 1 0 :=
by simp [horner]

meta def eval_atom (c : cache) (e : expr) : tactic (horner_expr × expr) :=
do α0 ← expr.of_nat c.α 0,
   α1 ← expr.of_nat c.α 1,
   n1 ← expr.of_nat (expr.const `nat []) 1,
   return (xadd' c (const α1) e (n1, 1) (const α0), c.cs_app ``horner_atom [e])

lemma subst_into_pow {α} [monoid α] (l r tl tr t)
  (prl : (l : α) = tl) (prr : (r : ℕ) = tr) (prt : tl ^ tr = t) : l ^ r = t :=
by simp [prl, prr, prt]

lemma unfold_sub {α} [add_group α] (a b c : α)
  (h : a + -b = c) : a - b = c := h

lemma unfold_div {α} [division_ring α] (a b c : α)
  (h : a * b⁻¹ = c) : a / b = c := h

meta def eval (c : cache) : expr → tactic (horner_expr × expr)
| `(%%e₁ + %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_add c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_sum ``has_add [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| `(%%e₁ - %%e₂) := do
  e₂' ← mk_app ``has_neg.neg [e₂],
  e ← mk_app ``has_add.add [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_sub ``add_group [e₁, e₂, e', p],
  return (e', p')
| `(- %%e) := do
  (e₁, p₁) ← eval e,
  (e₂, p₂) ← eval_neg c e₁,
  p ← c.mk_app ``norm_num.subst_into_neg ``has_neg [e, e₁, e₂, p₁, p₂],
  return (e₂, p)
| `(%%e₁ * %%e₂) := do
  (e₁', p₁) ← eval e₁,
  (e₂', p₂) ← eval e₂,
  (e', p') ← eval_mul c e₁' e₂',
  p ← c.mk_app ``norm_num.subst_into_prod ``has_mul [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
  return (e', p)
| e@`(has_inv.inv %%_) := (do
    (e', p) ← norm_num.derive e,
    e'.to_rat,
    return (const e', p)) <|> eval_atom c e
| `(%%e₁ / %%e₂) := do
  e₂' ← mk_app ``has_inv.inv [e₂],
  e ← mk_app ``has_mul.mul [e₁, e₂'],
  (e', p) ← eval e,
  p' ← c.mk_app ``unfold_div ``division_ring [e₁, e₂, e', p],
  return (e', p')
| e@`(@has_pow.pow _ _ %%P %%e₁ %%e₂) := do
  (e₂', p₂) ← eval e₂,
  match e₂'.e.to_nat, P with
  | some k, `(monoid.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow c e₁' (e₂, k),
    p ← c.mk_app ``subst_into_pow ``monoid [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    return (e', p)
  | some k, `(nat.has_pow) := do
    (e₁', p₁) ← eval e₁,
    (e', p') ← eval_pow c e₁' (e₂, k),
    p₃ ← c.mk_app ``subst_into_pow ``monoid [e₁, e₂, e₁', e₂', e', p₁, p₂, p'],
    p₄ ← mk_app ``nat.pow_eq_pow [e₁, e₂] >>= mk_eq_symm,
    p ← mk_eq_trans p₄ p₃,
    return (e', p)
  | _, _ := eval_atom c e
  end
| e := match e.to_nat with
  | some n := (const e).refl_conv
  | none := eval_atom c e
  end

meta def eval' (c : cache) (e : expr) : tactic (expr × expr) :=
do (e', p) ← eval c e, return (e', p)

theorem horner_def' {α} [comm_semiring α] (a x n b) : @horner α _ a x n b = x ^ n * a + b :=
by simp [horner, mul_comm]

theorem mul_assoc_rev {α} [semigroup α] (a b c : α) : a * (b * c) = a * b * c :=
by simp [mul_assoc]

theorem pow_add_rev {α} [monoid α] (a b : α) (m n : ℕ) : a ^ m * a ^ n = a ^ (m + n) :=
by simp [pow_add]

theorem pow_add_rev_right {α} [monoid α] (a b : α) (m n : ℕ) : b * a ^ m * a ^ n = b * a ^ (m + n) :=
by simp [pow_add, mul_assoc]

theorem add_neg_eq_sub {α} [add_group α] (a b : α) : a + -b = a - b := rfl

@[derive has_reflect]
inductive normalize_mode | raw | SOP | horner

meta def normalize (mode := normalize_mode.horner) (e : expr) : tactic (expr × expr) := do
pow_lemma ← simp_lemmas.mk.add_simp ``pow_one,
let lemmas := match mode with
| normalize_mode.SOP :=
  [``horner_def', ``add_zero, ``mul_one, ``mul_add, ``mul_sub,
   ``mul_assoc_rev, ``pow_add_rev, ``pow_add_rev_right,
   ``mul_neg_eq_neg_mul_symm, ``add_neg_eq_sub]
| normalize_mode.horner :=
  [``horner.equations._eqn_1, ``add_zero, ``one_mul, ``pow_one,
   ``neg_mul_eq_neg_mul_symm, ``add_neg_eq_sub]
| _ := []
end,
lemmas ← lemmas.mfoldl simp_lemmas.add_simp simp_lemmas.mk,
(_, e', pr) ← ext_simplify_core () {}
  simp_lemmas.mk (λ _, failed) (λ _ _ _ _ e, do
    c ← mk_cache e,
    (new_e, pr) ← match mode with
    | normalize_mode.raw := eval' c
    | normalize_mode.horner := trans_conv (eval' c) (simplify lemmas [])
    | normalize_mode.SOP :=
      trans_conv (eval' c) $
      trans_conv (simplify lemmas []) $
      simp_bottom_up' (λ e, norm_num e <|> pow_lemma.rewrite e)
    end e,
    guard (¬ new_e =ₐ e),
    return ((), new_e, some pr, ff))
   (λ _ _ _ _ _, failed) `eq e,
return (e', pr)

end ring

namespace interactive
open interactive interactive.types lean.parser
open tactic.ring

local postfix `?`:9001 := optional

/-- Tactic for solving equations in the language of rings.
  This version of `ring` fails if the target is not an equality
  that is provable by the axioms of commutative (semi)rings. -/
meta def ring1 : tactic unit :=
do `(%%e₁ = %%e₂) ← target,
  c ← mk_cache e₁,
  (e₁', p₁) ← eval c e₁,
  (e₂', p₂) ← eval c e₂,
  is_def_eq e₁' e₂',
  p ← mk_eq_symm p₂ >>= mk_eq_trans p₁,
  tactic.exact p

meta def ring.mode : lean.parser ring.normalize_mode :=
with_desc "(SOP|raw|horner)?" $
do mode ← ident?, match mode with
| none         := return ring.normalize_mode.horner
| some `horner := return ring.normalize_mode.horner
| some `SOP    := return ring.normalize_mode.SOP
| some `raw    := return ring.normalize_mode.raw
| _            := failed
end

/-- Tactic for solving equations in the language of rings.
  Attempts to prove the goal outright if there is no `at`
  specifier and the target is an equality, but if this
  fails it falls back to rewriting all ring expressions
  into a normal form. When writing a normal form,
  `ring SOP` will use sum-of-products form instead of horner form. -/
meta def ring (SOP : parse ring.mode) (loc : parse location) : tactic unit :=
match loc with
| interactive.loc.ns [none] := ring1
| _ := failed
end <|>
do ns ← loc.get_locals,
   tt ← tactic.replace_at (normalize SOP) ns loc.include_goal
      | fail "ring failed to simplify",
   when loc.include_goal $ try tactic.reflexivity

end interactive
end tactic

namespace conv.interactive
open conv interactive
open tactic tactic.interactive (ring.mode ring1)
open tactic.ring (normalize)

meta def ring (SOP : parse ring.mode) : conv unit :=
discharge_eq_lhs ring1
<|> replace_lhs (normalize SOP)
<|> fail "ring failed to simplify"

end conv.interactive


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Robert Y. Lewis

Generalizes the Cauchy completion of (ℚ, abs) to the completion of a
commutative ring with absolute value.
-/
import data.real.cau_seq

namespace cau_seq.completion
open cau_seq

section
parameters {α : Type*} [linear_ordered_field α]
parameters {β : Type*} [comm_ring β] {abv : β → α} [is_absolute_value abv]

def Cauchy := @quotient (cau_seq _ abv) cau_seq.equiv

def mk : cau_seq _ abv → Cauchy := quotient.mk

@[simp] theorem mk_eq_mk (f) : @eq Cauchy ⟦f⟧ (mk f) := rfl

theorem mk_eq {f g} : mk f = mk g ↔ f ≈ g := quotient.eq

def of_rat (x : β) : Cauchy := mk (const abv x)

instance : has_zero Cauchy := ⟨of_rat 0⟩
instance : has_one Cauchy := ⟨of_rat 1⟩
instance : inhabited Cauchy := ⟨0⟩

theorem of_rat_zero : of_rat 0 = 0 := rfl
theorem of_rat_one : of_rat 1 = 1 := rfl

@[simp] theorem mk_eq_zero {f} : mk f = 0 ↔ lim_zero f :=
by have : mk f = 0 ↔ lim_zero (f - 0) := quotient.eq;
   rwa sub_zero at this

instance : has_add Cauchy :=
⟨λ x y, quotient.lift_on₂ x y (λ f g, mk (f + g)) $
  λ f₁ g₁ f₂ g₂ hf hg, quotient.sound $
  by simpa [(≈), setoid.r, sub_eq_add_neg, add_comm, add_left_comm, add_assoc]
    using add_lim_zero hf hg⟩

@[simp] theorem mk_add (f g : cau_seq β abv) : mk f + mk g = mk (f + g) := rfl

instance : has_neg Cauchy :=
⟨λ x, quotient.lift_on x (λ f, mk (-f)) $
  λ f₁ f₂ hf, quotient.sound $
  by simpa [(≈), setoid.r] using neg_lim_zero hf⟩

@[simp] theorem mk_neg (f : cau_seq β abv) : -mk f = mk (-f) := rfl

instance : has_mul Cauchy :=
⟨λ x y, quotient.lift_on₂ x y (λ f g, mk (f * g)) $
  λ f₁ g₁ f₂ g₂ hf hg, quotient.sound $
  by simpa [(≈), setoid.r, mul_add, mul_comm, add_assoc, sub_eq_add_neg] using
    add_lim_zero (mul_lim_zero_right g₁ hf) (mul_lim_zero_right f₂ hg)⟩

@[simp] theorem mk_mul (f g : cau_seq β abv) : mk f * mk g = mk (f * g) := rfl

instance : has_sub Cauchy :=
⟨λ x y, quotient.lift_on₂ x y (λ f g, mk (f - g)) $
  λ f₁ g₁ f₂ g₂ hf hg, quotient.sound $ show ((f₁ - g₁) - (f₂ - g₂)).lim_zero,
    by simpa [sub_eq_add_neg, add_assoc, add_comm, add_left_comm] using sub_lim_zero hf hg⟩

@[simp] theorem mk_sub (f g : cau_seq β abv) : mk f - mk g = mk (f - g) := rfl

theorem of_rat_add (x y : β) : of_rat (x + y) = of_rat x + of_rat y :=
congr_arg mk (const_add _ _)

theorem of_rat_neg (x : β) : of_rat (-x) = -of_rat x :=
congr_arg mk (const_neg _)

theorem of_rat_mul (x y : β) : of_rat (x * y) = of_rat x * of_rat y :=
congr_arg mk (const_mul _ _)

private lemma zero_def : 0 = mk 0 := rfl

private lemma one_def : 1 = mk 1 := rfl

instance : comm_ring Cauchy :=
by refine { neg := has_neg.neg, sub := has_sub.sub, sub_eq_add_neg := _,
    add := (+), zero := (0 : Cauchy), mul := (*), one := 1, nsmul := nsmul_rec, npow := npow_rec,
    gsmul := gsmul_rec, .. }; try { intros; refl };
{ repeat {refine λ a, quotient.induction_on a (λ _, _)},
  simp [zero_def, one_def, mul_left_comm, mul_comm, mul_add, add_comm, add_left_comm,
          sub_eq_add_neg] }

theorem of_rat_sub (x y : β) : of_rat (x - y) = of_rat x - of_rat y :=
congr_arg mk (const_sub _ _)

end

open_locale classical
section

parameters {α : Type*} [linear_ordered_field α]
parameters {β : Type*} [field β] {abv : β → α} [is_absolute_value abv]
local notation `Cauchy` := @Cauchy _ _ _ _ abv _

noncomputable instance : has_inv Cauchy :=
⟨λ x, quotient.lift_on x
  (λ f, mk $ if h : lim_zero f then 0 else inv f h) $
λ f g fg, begin
  have := lim_zero_congr fg,
  by_cases hf : lim_zero f,
  { simp [hf, this.1 hf, setoid.refl] },
  { have hg := mt this.2 hf, simp [hf, hg],
    have If : mk (inv f hf) * mk f = 1 := mk_eq.2 (inv_mul_cancel hf),
    have Ig : mk (inv g hg) * mk g = 1 := mk_eq.2 (inv_mul_cancel hg),
    rw [mk_eq.2 fg, ← Ig] at If,
    rw mul_comm at Ig,
    rw [← mul_one (mk (inv f hf)), ← Ig, ← mul_assoc, If,
        mul_assoc, Ig, mul_one] }
end⟩

@[simp] theorem inv_zero : (0 : Cauchy)⁻¹ = 0 :=
congr_arg mk $ by rw dif_pos; [refl, exact zero_lim_zero]

@[simp] theorem inv_mk {f} (hf) : (@mk α _ β _ abv _ f)⁻¹ = mk (inv f hf) :=
congr_arg mk $ by rw dif_neg

lemma cau_seq_zero_ne_one : ¬ (0 : cau_seq _ abv) ≈ 1 := λ h,
have lim_zero (1 - 0), from setoid.symm h,
have lim_zero 1, by simpa,
one_ne_zero $ const_lim_zero.1 this

lemma zero_ne_one : (0 : Cauchy) ≠ 1 :=
λ h, cau_seq_zero_ne_one $ mk_eq.1 h

protected theorem inv_mul_cancel {x : Cauchy} : x ≠ 0 → x⁻¹ * x = 1 :=
quotient.induction_on x $ λ f hf, begin
  simp at hf, simp [hf],
  exact quotient.sound (cau_seq.inv_mul_cancel hf)
end

noncomputable def field : field Cauchy :=
{ inv              := has_inv.inv,
  mul_inv_cancel   := λ x x0, by rw [mul_comm, cau_seq.completion.inv_mul_cancel x0],
  exists_pair_ne   := ⟨0, 1, zero_ne_one⟩,
  inv_zero         := inv_zero,
  .. Cauchy.comm_ring }

local attribute [instance] field

theorem of_rat_inv (x : β) : of_rat (x⁻¹) = ((of_rat x)⁻¹ : Cauchy) :=
congr_arg mk $ by split_ifs with h; [simp [const_lim_zero.1 h], refl]

theorem of_rat_div (x y : β) : of_rat (x / y) = (of_rat x / of_rat y : Cauchy) :=
by simp only [div_eq_inv_mul, of_rat_inv, of_rat_mul]

end
end cau_seq.completion

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

variables (β : Type*) [ring β] (abv : β → α) [is_absolute_value abv]

class is_complete :=
(is_complete : ∀ s : cau_seq β abv, ∃ b : β, s ≈ const abv b)
end

section

variables {β : Type*} [ring β] {abv : β → α} [is_absolute_value abv]
variable [is_complete β abv]

lemma complete : ∀ s : cau_seq β abv, ∃ b : β, s ≈ const abv b :=
is_complete.is_complete

noncomputable def lim (s : cau_seq β abv) := classical.some (complete s)

lemma equiv_lim (s : cau_seq β abv) : s ≈ const abv (lim s) :=
classical.some_spec (complete s)

lemma eq_lim_of_const_equiv {f : cau_seq β abv} {x : β} (h : cau_seq.const abv x ≈ f) : x = lim f :=
const_equiv.mp $ setoid.trans h $ equiv_lim f

lemma lim_eq_of_equiv_const {f : cau_seq β abv} {x : β} (h : f ≈ cau_seq.const abv x) : lim f = x :=
(eq_lim_of_const_equiv $ setoid.symm h).symm

lemma lim_eq_lim_of_equiv {f g : cau_seq β abv} (h : f ≈ g) : lim f = lim g :=
lim_eq_of_equiv_const $ setoid.trans h $ equiv_lim g

@[simp] lemma lim_const (x : β) : lim (const abv x) = x :=
lim_eq_of_equiv_const $ setoid.refl _

lemma lim_add (f g : cau_seq β abv) : lim f + lim g = lim (f + g) :=
eq_lim_of_const_equiv $ show lim_zero (const abv (lim f + lim g) - (f + g)),
  by rw [const_add, add_sub_comm];
  exact add_lim_zero (setoid.symm (equiv_lim f)) (setoid.symm (equiv_lim g))

lemma lim_mul_lim (f g : cau_seq β abv) : lim f * lim g = lim (f * g) :=
eq_lim_of_const_equiv $ show lim_zero (const abv (lim f * lim g) - f * g),
  from have h : const abv (lim f * lim g) - f * g = (const abv (lim f) - f) * g
      + const abv (lim f) * (const abv (lim g) - g) :=
    by simp [const_mul (lim f), mul_add, add_mul, sub_eq_add_neg, add_comm, add_left_comm],
  by rw h; exact add_lim_zero (mul_lim_zero_left _ (setoid.symm (equiv_lim _)))
    (mul_lim_zero_right _ (setoid.symm (equiv_lim _)))

lemma lim_mul (f : cau_seq β abv) (x : β) : lim f * x = lim (f * const abv x) :=
by rw [← lim_mul_lim, lim_const]

lemma lim_neg (f : cau_seq β abv) : lim (-f) = -lim f :=
lim_eq_of_equiv_const (show lim_zero (-f - const abv (-lim f)),
  by rw [const_neg, sub_neg_eq_add, add_comm, ← sub_eq_add_neg];
  exact setoid.symm (equiv_lim f))

lemma lim_eq_zero_iff (f : cau_seq β abv) : lim f = 0 ↔ lim_zero f :=
⟨assume h,
  by have hf := equiv_lim f;
  rw h at hf;
  exact (lim_zero_congr hf).mpr (const_lim_zero.mpr rfl),
assume h,
  have h₁ : f = (f - const abv 0) := ext (λ n, by simp [sub_apply, const_apply]),
  by rw h₁ at h; exact lim_eq_of_equiv_const h ⟩

end

section
variables {β : Type*} [field β] {abv : β → α} [is_absolute_value abv] [is_complete β abv]

lemma lim_inv {f : cau_seq β abv} (hf : ¬ lim_zero f) : lim (inv f hf) = (lim f)⁻¹ :=
have hl : lim f ≠ 0 := by rwa ← lim_eq_zero_iff at hf,
lim_eq_of_equiv_const $ show lim_zero (inv f hf - const abv (lim f)⁻¹),
  from have h₁ : ∀ (g f : cau_seq β abv) (hf : ¬ lim_zero f), lim_zero (g - f * inv f hf * g) :=
    λ g f hf, by rw [← one_mul g, ← mul_assoc, ← sub_mul, mul_one, mul_comm, mul_comm f];
    exact mul_lim_zero_right _ (setoid.symm (cau_seq.inv_mul_cancel _)),
  have h₂ : lim_zero ((inv f hf - const abv (lim f)⁻¹) - (const abv (lim f) - f) *
      (inv f hf * const abv (lim f)⁻¹)) :=
    by rw [sub_mul, ← sub_add, sub_sub, sub_add_eq_sub_sub, sub_right_comm, sub_add];
    exact show lim_zero (inv f hf - const abv (lim f) * (inv f hf * const abv (lim f)⁻¹)
      - (const abv (lim f)⁻¹ - f * (inv f hf * const abv (lim f)⁻¹))),
    from sub_lim_zero
      (by rw [← mul_assoc, mul_right_comm, const_inv hl]; exact h₁ _ _ _)
      (by rw [← mul_assoc]; exact h₁ _ _ _),
  (lim_zero_congr h₂).mpr $ mul_lim_zero_left _ (setoid.symm (equiv_lim f))

end

section
variables [is_complete α abs]

lemma lim_le {f : cau_seq α abs} {x : α}
  (h : f ≤ cau_seq.const abs x) : lim f ≤ x :=
cau_seq.const_le.1 $ cau_seq.le_of_eq_of_le (setoid.symm (equiv_lim f)) h

lemma le_lim {f : cau_seq α abs} {x : α}
  (h : cau_seq.const abs x ≤ f) : x ≤ lim f :=
cau_seq.const_le.1 $ cau_seq.le_of_le_of_eq h (equiv_lim f)

lemma lt_lim {f : cau_seq α abs} {x : α}
  (h : cau_seq.const abs x < f) : x < lim f :=
cau_seq.const_lt.1 $ cau_seq.lt_of_lt_of_eq h (equiv_lim f)

lemma lim_lt {f : cau_seq α abs} {x : α}
  (h : f < cau_seq.const abs x) : lim f < x :=
cau_seq.const_lt.1 $ cau_seq.lt_of_eq_of_lt (setoid.symm (equiv_lim f)) h

end
end cau_seq


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group.pi
import data.fintype.basic

/-!
# Matrices

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.
-/
universes u u' v w z

/-- `dmatrix m n` is the type of dependently typed matrices
whose rows are indexed by the fintype `m` and
whose columns are indexed by the fintype `n`. -/
@[nolint unused_arguments]
def dmatrix (m : Type u) (n : Type u') [fintype m] [fintype n] (α : m → n → Type v) :
  Type (max u u' v) :=
Π i j, α i j

variables {l m n o : Type*} [fintype l] [fintype m] [fintype n] [fintype o]
variables {α : m → n → Type v}

namespace dmatrix

section ext
variables {M N : dmatrix m n α}

theorem ext_iff : (∀ i j, M i j = N i j) ↔ M = N :=
⟨λ h, funext $ λ i, funext $ h i, λ h, by simp [h]⟩

@[ext] theorem ext : (∀ i j, M i j = N i j) → M = N :=
ext_iff.mp

end ext

/-- `M.map f` is the dmatrix obtained by applying `f` to each entry of the matrix `M`. -/
def map (M : dmatrix m n α) {β : m → n → Type w} (f : Π ⦃i j⦄, α i j → β i j) :
  dmatrix m n β := λ i j, f (M i j)

@[simp]
lemma map_apply {M : dmatrix m n α} {β : m → n → Type w} {f : Π ⦃i j⦄, α i j → β i j}
  {i : m} {j : n} : M.map f i j = f (M i j) :=
rfl

@[simp]
lemma map_map {M : dmatrix m n α} {β : m → n → Type w} {γ : m → n → Type z}
  {f : Π ⦃i j⦄, α i j → β i j} {g : Π ⦃i j⦄, β i j → γ i j} :
  (M.map f).map g = M.map (λ i j x, g (f x)) :=
by { ext, simp, }

/-- The transpose of a dmatrix. -/
def transpose (M : dmatrix m n α) : dmatrix n m (λ j i, α i j)
| x y := M y x

localized "postfix (name := dmatrix.transpose) `ᵀ`:1500 := dmatrix.transpose" in dmatrix

/-- `dmatrix.col u` is the column matrix whose entries are given by `u`. -/
def col {α : m → Type v} (w : Π i, α i) : dmatrix m unit (λ i j, α i)
| x y := w x

/-- `dmatrix.row u` is the row matrix whose entries are given by `u`. -/
def row {α : n → Type v} (v : Π j, α j) : dmatrix unit n (λ i j, α j)
| x y := v y

instance [∀ i j, inhabited (α i j)] : inhabited (dmatrix m n α) := pi.inhabited _
instance [∀ i j, has_add (α i j)] : has_add (dmatrix m n α) := pi.has_add
instance [∀ i j, add_semigroup (α i j)] : add_semigroup (dmatrix m n α) := pi.add_semigroup
instance [∀ i j, add_comm_semigroup (α i j)] : add_comm_semigroup (dmatrix m n α) :=
pi.add_comm_semigroup
instance [∀ i j, has_zero (α i j)] : has_zero (dmatrix m n α) := pi.has_zero
instance [∀ i j, add_monoid (α i j)] : add_monoid (dmatrix m n α) := pi.add_monoid
instance [∀ i j, add_comm_monoid (α i j)] : add_comm_monoid (dmatrix m n α) := pi.add_comm_monoid
instance [∀ i j, has_neg (α i j)] : has_neg (dmatrix m n α) := pi.has_neg
instance [∀ i j, has_sub (α i j)] : has_sub (dmatrix m n α) := pi.has_sub
instance [∀ i j, add_group (α i j)] : add_group (dmatrix m n α) := pi.add_group
instance [∀ i j, add_comm_group (α i j)] : add_comm_group (dmatrix m n α) := pi.add_comm_group
instance [∀ i j, unique (α i j)] : unique (dmatrix m n α) := pi.unique
instance [∀ i j, subsingleton (α i j)] : subsingleton (dmatrix m n α) := pi.subsingleton

@[simp] theorem zero_apply [∀ i j, has_zero (α i j)] (i j) : (0 : dmatrix m n α) i j = 0 := rfl
@[simp] theorem neg_apply [∀ i j, has_neg (α i j)] (M : dmatrix m n α) (i j) :
  (- M) i j = - M i j :=
rfl
@[simp] theorem add_apply [∀ i j, has_add (α i j)] (M N : dmatrix m n α) (i j) :
  (M + N) i j = M i j + N i j :=
rfl
@[simp] theorem sub_apply [∀ i j, has_sub (α i j)] (M N : dmatrix m n α) (i j) :
  (M - N) i j = M i j - N i j :=
rfl

@[simp] lemma map_zero [∀ i j, has_zero (α i j)] {β : m → n → Type w} [∀ i j, has_zero (β i j)]
  {f : Π ⦃i j⦄, α i j → β i j} (h : ∀ i j, f (0 : α i j) = 0) :
  (0 : dmatrix m n α).map f = 0 :=
by { ext, simp [h], }

lemma map_add [∀ i j, add_monoid (α i j)] {β : m → n → Type w} [∀ i j, add_monoid (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) (M N : dmatrix m n α) :
  (M + N).map (λ i j, @f i j) = M.map (λ i j, @f i j) + N.map (λ i j, @f i j) :=
by { ext, simp, }

lemma map_sub [∀ i j, add_group (α i j)] {β : m → n → Type w} [∀ i j, add_group (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) (M N : dmatrix m n α) :
  (M - N).map (λ i j, @f i j) = M.map (λ i j, @f i j) - N.map (λ i j, @f i j) :=
by { ext, simp }

instance subsingleton_of_empty_left [is_empty m] : subsingleton (dmatrix m n α) :=
⟨λ M N, by { ext, exact is_empty_elim i }⟩

instance subsingleton_of_empty_right [is_empty n] : subsingleton (dmatrix m n α) :=
⟨λ M N, by { ext, exact is_empty_elim j }⟩

end dmatrix

/-- The `add_monoid_hom` between spaces of dependently typed matrices
induced by an `add_monoid_hom` between their coefficients. -/
def add_monoid_hom.map_dmatrix
  [∀ i j, add_monoid (α i j)] {β : m → n → Type w} [∀ i j, add_monoid (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) :
  dmatrix m n α →+ dmatrix m n β :=
{ to_fun := λ M, M.map (λ i j, @f i j),
  map_zero' := by simp,
  map_add' := dmatrix.map_add f, }

@[simp] lemma add_monoid_hom.map_dmatrix_apply
  [∀ i j, add_monoid (α i j)] {β : m → n → Type w} [∀ i j, add_monoid (β i j)]
  (f : Π ⦃i j⦄, α i j →+ β i j) (M : dmatrix m n α) :
  add_monoid_hom.map_dmatrix f M = M.map (λ i j, @f i j) :=
rfl


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.banach
import Mathlib.analysis.normed_space.finite_dimension
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Complemented subspaces of normed vector spaces

A submodule `p` of a topological module `E` over `R` is called *complemented* if there exists
a continuous linear projection `f : E →ₗ[R] p`, `∀ x : p, f x = x`. We prove that for
a closed subspace of a normed space this condition is equivalent to existence of a closed
subspace `q` such that `p ⊓ q = ⊥`, `p ⊔ q = ⊤`. We also prove that a subspace of finite codimension
is always a complemented subspace.

## Tags

complemented subspace, normed vector space
-/

namespace continuous_linear_map

theorem ker_closed_complemented_of_finite_dimensional_range {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] [complete_space 𝕜] (f : continuous_linear_map 𝕜 E F)
    [finite_dimensional 𝕜 ↥(range f)] : submodule.closed_complemented (ker f) :=
  sorry

/-- If `f : E →L[R] F` and `g : E →L[R] G` are two surjective linear maps and
their kernels are complement of each other, then `x ↦ (f x, g x)` defines
a linear equivalence `E ≃L[R] F × G`. -/
def equiv_prod_of_surjective_of_is_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] {F : Type u_3} [normed_group F] [normed_space 𝕜 F]
    {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space E] [complete_space (F × G)]
    (f : continuous_linear_map 𝕜 E F) (g : continuous_linear_map 𝕜 E G) (hf : range f = ⊤)
    (hg : range g = ⊤) (hfg : is_compl (ker f) (ker g)) : continuous_linear_equiv 𝕜 E (F × G) :=
  linear_equiv.to_continuous_linear_equiv_of_continuous
    (linear_map.equiv_prod_of_surjective_of_is_compl (↑f) (↑g) hf hg hfg) sorry

@[simp] theorem coe_equiv_prod_of_surjective_of_is_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3} [normed_group F]
    [normed_space 𝕜 F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G] [complete_space E]
    [complete_space (F × G)] {f : continuous_linear_map 𝕜 E F} {g : continuous_linear_map 𝕜 E G}
    (hf : range f = ⊤) (hg : range g = ⊤) (hfg : is_compl (ker f) (ker g)) :
    ↑(equiv_prod_of_surjective_of_is_compl f g hf hg hfg) = ↑(continuous_linear_map.prod f g) :=
  rfl

@[simp] theorem equiv_prod_of_surjective_of_is_compl_to_linear_equiv {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space E] [complete_space (F × G)] {f : continuous_linear_map 𝕜 E F}
    {g : continuous_linear_map 𝕜 E G} (hf : range f = ⊤) (hg : range g = ⊤)
    (hfg : is_compl (ker f) (ker g)) :
    continuous_linear_equiv.to_linear_equiv (equiv_prod_of_surjective_of_is_compl f g hf hg hfg) =
        linear_map.equiv_prod_of_surjective_of_is_compl (↑f) (↑g) hf hg hfg :=
  rfl

@[simp] theorem equiv_prod_of_surjective_of_is_compl_apply {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E] {F : Type u_3}
    [normed_group F] [normed_space 𝕜 F] {G : Type u_4} [normed_group G] [normed_space 𝕜 G]
    [complete_space E] [complete_space (F × G)] {f : continuous_linear_map 𝕜 E F}
    {g : continuous_linear_map 𝕜 E G} (hf : range f = ⊤) (hg : range g = ⊤)
    (hfg : is_compl (ker f) (ker g)) (x : E) :
    coe_fn (equiv_prod_of_surjective_of_is_compl f g hf hg hfg) x = (coe_fn f x, coe_fn g x) :=
  rfl

end continuous_linear_map

namespace subspace

/-- If `q` is a closed complement of a closed subspace `p`, then `p × q` is continuously
isomorphic to `E`. -/
def prod_equiv_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] (p : subspace 𝕜 E) (q : subspace 𝕜 E)
    (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    continuous_linear_equiv 𝕜 (↥p × ↥q) E :=
  linear_equiv.to_continuous_linear_equiv_of_continuous (submodule.prod_equiv_of_is_compl p q h)
    sorry

/-- Projection to a closed submodule along a closed complement. -/
def linear_proj_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜] {E : Type u_2}
    [normed_group E] [normed_space 𝕜 E] [complete_space E] (p : subspace 𝕜 E) (q : subspace 𝕜 E)
    (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) : continuous_linear_map 𝕜 E ↥p :=
  continuous_linear_map.comp (continuous_linear_map.fst 𝕜 ↥p ↥q)
    ↑(continuous_linear_equiv.symm (prod_equiv_of_closed_compl p q h hp hq))

@[simp] theorem coe_prod_equiv_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E}
    {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    ⇑(prod_equiv_of_closed_compl p q h hp hq) = ⇑(submodule.prod_equiv_of_is_compl p q h) :=
  rfl

@[simp] theorem coe_prod_equiv_of_closed_compl_symm {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E}
    {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    ⇑(continuous_linear_equiv.symm (prod_equiv_of_closed_compl p q h hp hq)) =
        ⇑(linear_equiv.symm (submodule.prod_equiv_of_is_compl p q h)) :=
  rfl

@[simp] theorem coe_continuous_linear_proj_of_closed_compl {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {p : subspace 𝕜 E} {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p)
    (hq : is_closed ↑q) :
    ↑(linear_proj_of_closed_compl p q h hp hq) = submodule.linear_proj_of_is_compl p q h :=
  rfl

@[simp] theorem coe_continuous_linear_proj_of_closed_compl' {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {p : subspace 𝕜 E} {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p)
    (hq : is_closed ↑q) :
    ⇑(linear_proj_of_closed_compl p q h hp hq) = ⇑(submodule.linear_proj_of_is_compl p q h) :=
  rfl

theorem closed_complemented_of_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E}
    {q : subspace 𝕜 E} (h : is_compl p q) (hp : is_closed ↑p) (hq : is_closed ↑q) :
    submodule.closed_complemented p :=
  Exists.intro (linear_proj_of_closed_compl p q h hp hq)
    (submodule.linear_proj_of_is_compl_apply_left h)

theorem closed_complemented_iff_has_closed_compl {𝕜 : Type u_1} [nondiscrete_normed_field 𝕜]
    {E : Type u_2} [normed_group E] [normed_space 𝕜 E] [complete_space E] {p : subspace 𝕜 E} :
    submodule.closed_complemented p ↔
        is_closed ↑p ∧ ∃ (q : subspace 𝕜 E), ∃ (hq : is_closed ↑q), is_compl p q :=
  sorry

theorem closed_complemented_of_quotient_finite_dimensional {𝕜 : Type u_1}
    [nondiscrete_normed_field 𝕜] {E : Type u_2} [normed_group E] [normed_space 𝕜 E]
    [complete_space E] {p : subspace 𝕜 E} [complete_space 𝕜]
    [finite_dimensional 𝕜 (submodule.quotient p)] (hp : is_closed ↑p) :
    submodule.closed_complemented p :=
  sorry

end Mathlib


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

universes v u l

namespace Mathlib

/-!
# Kernel pairs

This file defines what it means for a parallel pair of morphisms `a b : R ⟶ X` to be the kernel pair
for a morphism `f`.
Some properties of kernel pairs are given, namely allowing one to transfer between
the kernel pair of `f₁ ≫ f₂` to the kernel pair of `f₁`.
It is also proved that if `f` is a coequalizer of some pair, and `a`,`b` is a kernel pair for `f` then
it is a coequalizer of `a`,`b`.

## Implementation

The definition is essentially just a wrapper for `is_limit (pullback_cone.mk _ _ _)`, but the
constructions given here are useful, yet awkward to present in that language, so a basic API
is developed here.

## TODO

- Internal equivalence relations (or congruences) and the fact that every kernel pair induces one,
  and the converse in an effective regular category (WIP by b-mehta).

-/

namespace category_theory

/--
`is_kernel_pair f a b` expresses that `(a, b)` is a kernel pair for `f`, i.e. `a ≫ f = b ≫ f`
and the square
  R → X
  ↓   ↓
  X → Y
is a pullback square.
This is essentially just a convenience wrapper over `is_limit (pullback_cone.mk _ _ _)`.
-/
structure is_kernel_pair {C : Type u} [category C] {R : C} {X : C} {Y : C} (f : X ⟶ Y) (a : R ⟶ X)
    (b : R ⟶ X)
    where
  comm : a ≫ f = b ≫ f
  is_limit : limits.is_limit (limits.pullback_cone.mk a b comm)

theorem is_kernel_pair.comm_assoc {C : Type u} [category C] {R : C} {X : C} {Y : C} {f : X ⟶ Y}
    {a : R ⟶ X} {b : R ⟶ X} (c : is_kernel_pair f a b) {X' : C} (f' : Y ⟶ X') :
    a ≫ f ≫ f' = b ≫ f ≫ f' :=
  sorry

namespace is_kernel_pair

/-- The data expressing that `(a, b)` is a kernel pair is subsingleton. -/
protected instance subsingleton {C : Type u} [category C] {R : C} {X : C} {Y : C} (f : X ⟶ Y)
    (a : R ⟶ X) (b : R ⟶ X) : subsingleton (is_kernel_pair f a b) :=
  subsingleton.intro
    fun (P Q : is_kernel_pair f a b) =>
      cases_on P
        fun (P_comm : a ≫ f = b ≫ f)
          (P_is_limit : limits.is_limit (limits.pullback_cone.mk a b P_comm)) =>
          cases_on Q
            fun (Q_comm : a ≫ f = b ≫ f)
              (Q_is_limit : limits.is_limit (limits.pullback_cone.mk a b Q_comm)) =>
              (fun {f : X ⟶ Y} {a b : R ⟶ X} (comm comm_1 : a ≫ f = b ≫ f)
                  (is_limit : limits.is_limit (limits.pullback_cone.mk a b comm))
                  (is_limit_1 : limits.is_limit (limits.pullback_cone.mk a b comm_1)) =>
                  Eq.trans
                    ((fun {f : X ⟶ Y} {a b : R ⟶ X} (comm : a ≫ f = b ≫ f)
                        (is_limit : limits.is_limit (limits.pullback_cone.mk a b comm)) =>
                        Eq.refl (mk comm is_limit))
                      comm is_limit)
                    (congr (Eq.refl (mk comm)) (subsingleton.elim is_limit is_limit_1)))
                P_comm Q_comm P_is_limit Q_is_limit

/-- If `f` is a monomorphism, then `(𝟙 _, 𝟙 _)`  is a kernel pair for `f`. -/
def id_of_mono {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    is_kernel_pair f 𝟙 𝟙 :=
  mk sorry
    (limits.pullback_cone.is_limit_aux' (limits.pullback_cone.mk 𝟙 𝟙 sorry)
      fun (s : limits.pullback_cone f f) =>
        { val := limits.pullback_cone.snd s, property := sorry })

protected instance inhabited {C : Type u} [category C] {X : C} {Y : C} (f : X ⟶ Y) [mono f] :
    Inhabited (is_kernel_pair f 𝟙 𝟙) :=
  { default := id_of_mono f }

/--
Given a pair of morphisms `p`, `q` to `X` which factor through `f`, they factor through any kernel
pair of `f`.
-/
def lift' {C : Type u} [category C] {R : C} {X : C} {Y : C} {f : X ⟶ Y} {a : R ⟶ X} {b : R ⟶ X}
    {S : C} (k : is_kernel_pair f a b) (p : S ⟶ X) (q : S ⟶ X) (w : p ≫ f = q ≫ f) :
    Subtype fun (t : S ⟶ R) => t ≫ a = p ∧ t ≫ b = q :=
  limits.pullback_cone.is_limit.lift' (is_limit k) p q w

/--
If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `a ≫ f₁ = b ≫ f₁`, then `(a,b)` is a kernel pair for
just `f₁`.
That is, to show that `(a,b)` is a kernel pair for `f₁` it suffices to only show the square
commutes, rather than to additionally show it's a pullback.
-/
def cancel_right {C : Type u} [category C] {R : C} {X : C} {Y : C} {Z : C} {a : R ⟶ X} {b : R ⟶ X}
    {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} (comm : a ≫ f₁ = b ≫ f₁) (big_k : is_kernel_pair (f₁ ≫ f₂) a b) :
    is_kernel_pair f₁ a b :=
  mk comm
    (limits.pullback_cone.is_limit_aux' (limits.pullback_cone.mk a b comm)
      fun (s : limits.pullback_cone f₁ f₁) =>
        let s' : limits.pullback_cone (f₁ ≫ f₂) (f₁ ≫ f₂) :=
          limits.pullback_cone.mk (limits.pullback_cone.fst s) (limits.pullback_cone.snd s)
            (limits.pullback_cone.condition_assoc s f₂);
        { val := limits.is_limit.lift (is_limit big_k) s', property := sorry })

/--
If `(a,b)` is a kernel pair for `f₁ ≫ f₂` and `f₂` is mono, then `(a,b)` is a kernel pair for
just `f₁`.
The converse of `comp_of_mono`.
-/
def cancel_right_of_mono {C : Type u} [category C] {R : C} {X : C} {Y : C} {Z : C} {a : R ⟶ X}
    {b : R ⟶ X} {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [mono f₂] (big_k : is_kernel_pair (f₁ ≫ f₂) a b) :
    is_kernel_pair f₁ a b :=
  cancel_right sorry big_k

/--
If `(a,b)` is a kernel pair for `f₁` and `f₂` is mono, then `(a,b)` is a kernel pair for `f₁ ≫ f₂`.
The converse of `cancel_right_of_mono`.
-/
def comp_of_mono {C : Type u} [category C] {R : C} {X : C} {Y : C} {Z : C} {a : R ⟶ X} {b : R ⟶ X}
    {f₁ : X ⟶ Y} {f₂ : Y ⟶ Z} [mono f₂] (small_k : is_kernel_pair f₁ a b) :
    is_kernel_pair (f₁ ≫ f₂) a b :=
  mk sorry
    (limits.pullback_cone.is_limit_aux' (limits.pullback_cone.mk a b sorry)
      fun (s : limits.pullback_cone (f₁ ≫ f₂) (f₁ ≫ f₂)) =>
        { val :=
            subtype.val
              (limits.pullback_cone.is_limit.lift' (is_limit small_k) (limits.pullback_cone.fst s)
                (limits.pullback_cone.snd s) sorry),
          property := sorry })

/--
If `(a,b)` is the kernel pair of `f`, and `f` is a coequalizer morphism for some parallel pair, then
`f` is a coequalizer morphism of `a` and `b`.
-/
def to_coequalizer {C : Type u} [category C] {R : C} {X : C} {Y : C} {f : X ⟶ Y} {a : R ⟶ X}
    {b : R ⟶ X} (k : is_kernel_pair f a b) [r : regular_epi f] :
    limits.is_colimit (limits.cofork.of_π f (comm k)) :=
  limits.cofork.is_colimit.mk (limits.cofork.of_π f (comm k))
    (fun (s : limits.cofork a b) =>
      subtype.val (limits.cofork.is_colimit.desc' regular_epi.is_colimit (limits.cofork.π s) sorry))
    sorry sorry

end Mathlib


import data.qpf.univariate.basic
import control.bifunctor

universes u
variables {F : Type u → Type u} [functor F]

namespace qpf

section box
variables (F)

/-- apply a functor to a set of values. taken from
 [Basil Fürer, Andreas Lochbihler, Joshua Schneider, Dmitriy Traytel *Quotients of Bounded Natural Functors*][fuerer-lochbihler-schneider-traytel2020]
henceforth referred to as the QBNF paper
 -/
def box {α} (A : set α) : set (F α) :=
{ x | ∀ β (f g : α → β), (∀ a ∈ A, f a = g a) → f <$> x = g <$> x }

variables {F}

/--
Alternate notion of support set based on `box`.
Taken from the QBNF paper
-/
def supp' {α} (x : F α) : set α :=
⋂ A ∈ { A : set α | x ∈ box F A}, A

/--
Alternate notion of predicate lifting based on `box`.
Taken from the QBNF paper
-/
def liftp' {α} (x : F α) (p : α → Prop) : Prop :=
∀ a ∈ supp' x, p a

end box

end qpf

namespace ex

/-- polynomial functor isomorph to `α × _` for some `α` -/
def prod.pfunctor (α : Type) : pfunctor :=
⟨ α, λ _, unit ⟩

instance {α} : qpf (prod α) :=
{ P := prod.pfunctor α,
  abs := λ β ⟨a,f⟩, (a, f ()),
  repr := λ β ⟨x,y⟩, ⟨x, λ _, y⟩,
  abs_repr := λ β ⟨x,y⟩, rfl,
  abs_map := λ β γ f ⟨a,g⟩, rfl }

/-- example relation for products -/
def foo.R (α : Type) (x y : bool × α) : Prop :=
x.1 = y.1 ∧ (x.1 → x.2 = y.2)

lemma equivalence_foo.R (α) : equivalence (foo.R α) :=
begin
  refine ⟨_,_,_⟩,
  { intro, exact ⟨rfl,λ _, rfl⟩ },
  { intros x y h, refine ⟨h.1.symm, λ _, (h.2 _).symm⟩,
    rwa h.1 },
  { rintros x y z ⟨ha,ha'⟩ ⟨hb,hb'⟩,
    refine ⟨ha.trans hb, λ hh, _⟩,
    refine (ha' hh).trans (hb' _),
    rwa ← ha }
end

/-- example of a qpf -/
def foo (α : Type) :=
quot $ foo.R α

instance {α} [inhabited α] : inhabited (foo α) := ⟨ quot.mk _ (default _) ⟩

/-- functor operation of `foo` -/
def foo.map {α β} (f : α → β) (x : foo α) : foo β :=
quot.lift_on x (λ x : bool × α, quot.mk (foo.R β) $ f <$> x)
  (λ ⟨a₀,a₁⟩ ⟨b₀,b₁⟩ h, quot.sound ⟨h.1,λ h', show f a₁ = f b₁, from congr_arg f (h.2 h')⟩)

instance : functor foo :=
{ map := @foo.map }

@[simp]
lemma foo.map_mk {α β : Type} (f : α → β) (x : bool × α) :
  (f <$> quot.mk _ x : foo β) = quot.mk _ (f <$> x) :=
by simp [(<$>),foo.map]

noncomputable instance qpf.foo : qpf foo :=
@qpf.quotient_qpf (prod bool) _ ex.prod.qpf foo _ (λ α, quot.mk _) (λ α, quot.out)
  (by simp)
  (by intros; simp)

/-- constructor for `foo` -/
def foo.mk {α} (b : bool) (x : α) : foo α := quot.mk _ (b, x)

@[simp]
lemma foo.map_mk' {α β : Type} (f : α → β) (b : bool) (x : α) :
  f <$> foo.mk b x = foo.mk b (f x) :=
by simp only [foo.mk, foo.map_mk]; refl

@[simp]
lemma foo.map_tt {α : Type} (x y : α) :
  foo.mk tt x = foo.mk tt y ↔ x = y :=
by simp [foo.mk]; split; intro h; [replace h := quot.exact _ h, rw h];
   rw relation.eqv_gen_iff_of_equivalence at h;
   [exact h.2 rfl, apply equivalence_foo.R]

/-- consequence of original definition of `supp`. If there exists more than
one value of type `α`, then the support of `foo.mk ff x` is empty -/
lemma supp_mk_ff₀ {α} (x y : α) (h : ¬ x = y) : functor.supp (foo.mk ff x) = {} :=
begin
  dsimp [functor.supp], ext z, simp, -- split; intro h,
  classical, by_cases x = z,
  { use (λ a, ¬ z = a), subst z,
    dsimp [functor.liftp],
    simp, refine ⟨foo.mk ff ⟨y,h⟩,_⟩,
    simp, apply quot.sound, simp [foo.R] },
  { use (λ a, x = a),
    dsimp [functor.liftp],
    simp [h], use foo.mk ff ⟨x,rfl⟩,
    simp }
end

/-- consequence of original definition of `supp`. If there exists only
one value of type `α`, then the support of `foo.mk ff x` contains that value -/
lemma supp_mk_ff₁ {α} (x : α) (h : ∀ z, x = z) : functor.supp (foo.mk ff x) = {x} :=
begin
  dsimp [functor.supp], ext y, simp, split; intro h',
  { apply @h' (= x), dsimp [functor.liftp],
    use foo.mk ff ⟨x,rfl⟩, refl },
  { introv hp, simp [functor.liftp] at hp,
    rcases hp with ⟨⟨z,z',hz⟩,hp⟩,
    simp at hp, convert hz,
    rw [h'], apply h },
end

/--
Such a QPF is not uniform
-/
lemma foo_not_uniform : ¬ @qpf.is_uniform foo _ qpf.foo :=
begin
  simp only [qpf.is_uniform, foo, qpf.foo, set.image_univ, not_forall, not_imp],
  existsi [bool,ff,ff,λ a : unit, tt,λ a : unit, ff], split,
  { apply quot.sound, simp [foo.R, qpf.abs, prod.qpf._match_1] },
  { simp! only [set.range, set.ext_iff],
    simp only [not_exists, false_iff, bool.forall_bool, eq_self_iff_true, exists_false, not_true,
      and_self, set.mem_set_of_eq, iff_false],
    exact λ h, h () }
end

/-- intuitive consequence of original definition of `supp`. -/
lemma supp_mk_tt {α} (x : α) : functor.supp (foo.mk tt x) = {x} :=
begin
  dsimp [functor.supp], ext y, simp, split; intro h',
  { apply @h' (= x), dsimp [functor.liftp],
    use foo.mk tt ⟨x,rfl⟩, refl },
  { introv hp, simp [functor.liftp] at hp,
    rcases hp with ⟨⟨z,z',hz⟩,hp⟩,
    simp at hp, replace hp := quot.exact _ hp,
    rw relation.eqv_gen_iff_of_equivalence (equivalence_foo.R _) at hp,
    rcases hp with ⟨⟨⟩,hp⟩, subst y,
    replace hp := hp rfl, cases hp,
    exact hz }
end

/-- simple consequence of the definition of `supp` from the QBNF paper -/
lemma supp_mk_ff' {α} (x : α) : qpf.supp' (foo.mk ff x) = {} :=
begin
  dsimp [qpf.supp'], ext, simp, dsimp [qpf.box],
  use ∅, simp [foo.mk], intros, apply quot.sound,
  dsimp [foo.R], split, refl, rintro ⟨ ⟩
end

/-- simple consequence of the definition of `supp` from the QBNF paper -/
lemma supp_mk_tt' {α} (x : α) : qpf.supp' (foo.mk tt x) = {x} :=
begin
  dsimp [qpf.supp'], ext, simp, dsimp [qpf.box], split; intro h,
  { specialize h {x} _,
    { clear h, introv hfg, simp, rw hfg, simp },
    { simp at h, assumption }, },
  { introv hfg, subst x_1, classical,
    let f : α → α ⊕ bool := λ x, if x ∈ i then sum.inl x else sum.inr tt,
    let g : α → α ⊕ bool := λ x, if x ∈ i then sum.inl x else sum.inr ff,
    specialize hfg _ f g _,
    { intros, simp [*,f,g,if_pos] },
    { simp [f,g] at hfg, split_ifs at hfg,
      assumption, cases hfg } }
end
end ex


open set function

theorem least_seq_at_n {S : set (ℕ → ℕ)} (H : S ≠ ∅) (n : ℕ) :
∃ f : ℕ → ℕ, f ∈ S ∧ ∀ g : ℕ → ℕ, g ∈ S → f n ≤ g n :=
sorry