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

Archimedean groups and fields.
-/
import algebra.group_power data.rat

local infix ` • ` := add_monoid.smul

variables {α : Type*}

class floor_ring (α) extends linear_ordered_ring α :=
(floor : α → ℤ)
(le_floor : ∀ (z : ℤ) (x : α), z ≤ floor x ↔ (z : α) ≤ x)

instance : floor_ring ℤ :=
{ floor := id, le_floor := by simp,
  ..linear_ordered_comm_ring.to_linear_ordered_ring ℤ }

instance : floor_ring ℚ :=
{ floor := rat.floor, le_floor := @rat.le_floor,
  ..linear_ordered_comm_ring.to_linear_ordered_ring ℚ }

section
variable [floor_ring α]

def floor : α → ℤ := floor_ring.floor

notation `⌊` x `⌋` := floor x

theorem le_floor : ∀ {z : ℤ} {x : α}, z ≤ ⌊x⌋ ↔ (z : α) ≤ x :=
floor_ring.le_floor

theorem floor_lt {x : α} {z : ℤ} : ⌊x⌋ < z ↔ x < z :=
le_iff_le_iff_lt_iff_lt.1 le_floor

theorem floor_le (x : α) : (⌊x⌋ : α) ≤ x :=
le_floor.1 (le_refl _)

theorem floor_nonneg {x : α} : 0 ≤ ⌊x⌋ ↔ 0 ≤ x :=
by simpa using @le_floor _ _ 0 x

theorem lt_succ_floor (x : α) : x < ⌊x⌋.succ :=
floor_lt.1 $ int.lt_succ_self _

theorem lt_floor_add_one (x : α) : x < ⌊x⌋ + 1 :=
by simpa [int.succ] using lt_succ_floor x

theorem sub_one_lt_floor (x : α) : x - 1 < ⌊x⌋ :=
sub_lt_iff_lt_add.2 (lt_floor_add_one x)

@[simp] theorem floor_coe (z : ℤ) : ⌊(z:α)⌋ = z :=
eq_of_forall_le_iff $ λ a, by rw [le_floor, int.cast_le]

@[simp] theorem floor_zero : ⌊(0:α)⌋ = 0 := floor_coe 0

@[simp] theorem floor_one : ⌊(1:α)⌋ = 1 :=
by rw [← int.cast_one, floor_coe]

theorem floor_mono {a b : α} (h : a ≤ b) : ⌊a⌋ ≤ ⌊b⌋ :=
le_floor.2 (le_trans (floor_le _) h)

@[simp] theorem floor_add_int (x : α) (z : ℤ) : ⌊x + z⌋ = ⌊x⌋ + z :=
eq_of_forall_le_iff $ λ a, by rw [le_floor,
  ← sub_le_iff_le_add, ← sub_le_iff_le_add, le_floor, int.cast_sub]

theorem floor_sub_int (x : α) (z : ℤ) : ⌊x - z⌋ = ⌊x⌋ - z :=
eq.trans (by rw [int.cast_neg]; refl) (floor_add_int _ _)

/-- `ceil x` is the smallest integer `z` such that `x ≤ z` -/
def ceil (x : α) : ℤ := -⌊-x⌋

notation `⌈` x `⌉` := ceil x

theorem ceil_le {z : ℤ} {x : α} : ⌈x⌉ ≤ z ↔ x ≤ z :=
by rw [ceil, neg_le, le_floor, int.cast_neg, neg_le_neg_iff]

theorem lt_ceil {x : α} {z : ℤ} : z < ⌈x⌉ ↔ (z:α) < x :=
le_iff_le_iff_lt_iff_lt.1 ceil_le

theorem le_ceil (x : α) : x ≤ ⌈x⌉ :=
ceil_le.1 (le_refl _)

@[simp] theorem ceil_coe (z : ℤ) : ⌈(z:α)⌉ = z :=
by rw [ceil, ← int.cast_neg, floor_coe, neg_neg]

theorem ceil_mono {a b : α} (h : a ≤ b) : ⌈a⌉ ≤ ⌈b⌉ :=
ceil_le.2 (le_trans h (le_ceil _))

@[simp] theorem ceil_add_int (x : α) (z : ℤ) : ⌈x + z⌉ = ⌈x⌉ + z :=
by rw [ceil, neg_add', floor_sub_int, neg_sub, sub_eq_neg_add]; refl

theorem ceil_sub_int (x : α) (z : ℤ) : ⌈x - z⌉ = ⌈x⌉ - z :=
eq.trans (by rw [int.cast_neg]; refl) (ceil_add_int _ _)

theorem ceil_lt_add_one (x : α) : (⌈x⌉ : α) < x + 1 :=
by rw [← lt_ceil, ← int.cast_one, ceil_add_int]; apply lt_add_one

lemma ceil_pos {a : α} : 0 < ⌈a⌉ ↔ 0 < a :=
⟨ λ h, have ⌊-a⌋ < 0, from neg_of_neg_pos h,
  pos_of_neg_neg $ lt_of_not_ge $ (not_iff_not_of_iff floor_nonneg).1 $ not_le_of_gt this,
 λ h, have -a < 0, from neg_neg_of_pos h,
  neg_pos_of_neg $ lt_of_not_ge $ (not_iff_not_of_iff floor_nonneg).2 $ not_le_of_gt this ⟩

lemma ceil_nonneg {q : ℚ} (hq : q ≥ 0) : ⌈q⌉ ≥ 0 :=
if h : q > 0 then le_of_lt $ ceil_pos.2 h
else
  have h' : q = 0, from le_antisymm (le_of_not_lt h) hq,
  by simp [h']

end

class archimedean (α) [ordered_comm_monoid α] : Prop :=
(arch : ∀ (x : α) {y}, 0 < y → ∃ n : ℕ, x ≤ n • y)

theorem exists_nat_gt [linear_ordered_semiring α] [archimedean α]
  (x : α) : ∃ n : ℕ, x < n :=
let ⟨n, h⟩ := archimedean.arch x zero_lt_one in
⟨n+1, lt_of_le_of_lt (by simpa using h)
  (nat.cast_lt.2 (nat.lt_succ_self _))⟩

section linear_ordered_ring
variables [linear_ordered_ring α] [archimedean α]

lemma pow_unbounded_of_gt_one (x : α) {y : α}
    (hy1 : 1 < y) : ∃ n : ℕ, x < y ^ n :=
have hy0 : 0 <  y - 1 := sub_pos_of_lt hy1,
let ⟨n, h⟩ := archimedean.arch x hy0 in
⟨n, calc x ≤ n • (y - 1)     : h
       ... < 1 + n • (y - 1) : by rw add_comm; exact lt_add_one _
       ... ≤ y ^ n           : pow_ge_one_add_sub_mul (le_of_lt hy1) _⟩

theorem exists_int_gt (x : α) : ∃ n : ℤ, x < n :=
let ⟨n, h⟩ := exists_nat_gt x in ⟨n, by simp [h]⟩

theorem exists_int_lt (x : α) : ∃ n : ℤ, (n : α) < x :=
let ⟨n, h⟩ := exists_int_gt (-x) in ⟨-n, by simp [neg_lt.1 h]⟩

theorem exists_floor (x : α) :
  ∃ (fl : ℤ), ∀ (z : ℤ), z ≤ fl ↔ (z : α) ≤ x :=
begin
  haveI := classical.prop_decidable,
  have : ∃ (ub : ℤ), (ub:α) ≤ x ∧ ∀ (z : ℤ), (z:α) ≤ x → z ≤ ub :=
  int.exists_greatest_of_bdd
    (let ⟨n, hn⟩ := exists_int_gt x in ⟨n, λ z h',
      int.cast_le.1 $ le_trans h' $ le_of_lt hn⟩)
    (let ⟨n, hn⟩ := exists_int_lt x in ⟨n, le_of_lt hn⟩),
  refine this.imp (λ fl h z, _),
  cases h with h₁ h₂,
  exact ⟨λ h, le_trans (int.cast_le.2 h) h₁, h₂ z⟩,
end

end linear_ordered_ring

instance : archimedean ℕ :=
⟨λ n m m0, ⟨n, by simpa using nat.mul_le_mul_left n m0⟩⟩

instance : archimedean ℤ :=
⟨λ n m m0, ⟨n.to_nat, begin
  simp [add_monoid.smul_eq_mul],
  refine le_trans (int.le_to_nat _) _,
  simpa using mul_le_mul_of_nonneg_left
    (int.add_one_le_iff.2 m0) (int.coe_zero_le n.to_nat),
end⟩⟩

noncomputable def archimedean.floor_ring (α)
  [linear_ordered_ring α] [archimedean α] : floor_ring α :=
{ floor := λ x, classical.some (exists_floor x),
  le_floor := λ z x, classical.some_spec (exists_floor x) z }

section linear_ordered_field
variables [linear_ordered_field α]

theorem archimedean_iff_nat_lt :
  archimedean α ↔ ∀ x : α, ∃ n : ℕ, x < n :=
⟨@exists_nat_gt α _, λ H, ⟨λ x y y0,
  (H (x / y)).imp $ λ n h, le_of_lt $
  by rwa [div_lt_iff y0, ← add_monoid.smul_eq_mul] at h⟩⟩

theorem archimedean_iff_nat_le :
  archimedean α ↔ ∀ x : α, ∃ n : ℕ, x ≤ n :=
archimedean_iff_nat_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (nat.cast_lt.2 (lt_add_one _))⟩⟩

theorem exists_rat_gt [archimedean α] (x : α) : ∃ q : ℚ, x < q :=
let ⟨n, h⟩ := exists_nat_gt x in ⟨n, by simp [h]⟩

theorem archimedean_iff_rat_lt :
  archimedean α ↔ ∀ x : α, ∃ q : ℚ, x < q :=
⟨@exists_rat_gt α _,
  λ H, archimedean_iff_nat_lt.2 $ λ x,
  let ⟨q, h⟩ := H x in
  ⟨rat.nat_ceil q, lt_of_lt_of_le h $
    by simpa using (@rat.cast_le α _ _ _).2 (rat.le_nat_ceil _)⟩⟩

theorem archimedean_iff_rat_le :
  archimedean α ↔ ∀ x : α, ∃ q : ℚ, x ≤ q :=
archimedean_iff_rat_lt.trans
⟨λ H x, (H x).imp $ λ _, le_of_lt,
 λ H x, let ⟨n, h⟩ := H x in ⟨n+1,
   lt_of_le_of_lt h (rat.cast_lt.2 (lt_add_one _))⟩⟩

variable [archimedean α]

theorem exists_rat_lt (x : α) : ∃ q : ℚ, (q : α) < x :=
let ⟨n, h⟩ := exists_int_lt x in ⟨n, by simp [h]⟩

theorem exists_pos_rat_lt {x : α} (x0 : 0 < x) : ∃ q : ℚ, 0 < q ∧ (q : α) < x :=
let ⟨n, h⟩ := exists_nat_gt x⁻¹ in begin
  have n0 := nat.cast_pos.1 (lt_trans (inv_pos x0) h),
  refine ⟨n⁻¹, inv_pos (nat.cast_pos.2 n0), _⟩,
  simpa [rat.cast_inv_of_ne_zero, ne_of_gt n0] using
    (inv_lt x0 (nat.cast_pos.2 n0)).1 h
end

theorem exists_rat_btwn {x y : α} (h : x < y) : ∃ q : ℚ, x < q ∧ (q:α) < y :=
begin
  cases exists_nat_gt (y - x)⁻¹ with n nh,
  cases exists_floor (x * n) with z zh,
  refine ⟨(z + 1 : ℤ) / n, _⟩,
  have n0 := nat.cast_pos.1 (lt_trans (inv_pos (sub_pos.2 h)) nh),
  simp [rat.cast_div_of_ne_zero, -int.cast_add, ne_of_gt n0],
  have n0' := (@nat.cast_pos α _ _).2 n0,
  refine ⟨(lt_div_iff n0').2 $
    (le_iff_le_iff_lt_iff_lt.1 (zh _)).1 (lt_add_one _), _⟩,
  simp [div_lt_iff n0', -add_comm],
  refine lt_of_le_of_lt (add_le_add_right ((zh _).1 (le_refl _)) _) _,
  rwa [← lt_sub_iff_add_lt', ← sub_mul,
       ← div_lt_iff' (sub_pos.2 h), one_div_eq_inv]
end

include α
@[simp] theorem rat.cast_floor (x : ℚ) :
  by haveI := archimedean.floor_ring α; exact ⌊(x:α)⌋ = ⌊x⌋ :=
begin
  haveI := archimedean.floor_ring α,
  apply le_antisymm,
  { rw [le_floor, ← @rat.cast_le α, rat.cast_coe_int],
    apply floor_le },
  { rw [le_floor, ← rat.cast_coe_int, rat.cast_le],
    apply floor_le }
end

end linear_ordered_field

section
variables [discrete_linear_ordered_field α] [archimedean α]

theorem exists_rat_near (x : α) {ε : α} (ε0 : ε > 0) :
  ∃ q : ℚ, abs (x - q) < ε :=
let ⟨q, h₁, h₂⟩ := exists_rat_btwn $
  lt_trans ((sub_lt_self_iff x).2 ε0) ((lt_add_iff_pos_left x).2 ε0) in
⟨q, abs_sub_lt_iff.2 ⟨sub_lt.1 h₁, sub_lt_iff_lt_add.2 h₂⟩⟩

end

instance : archimedean ℚ :=
archimedean_iff_rat_le.2 $ λ q, ⟨q, by simp⟩


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johan Commelin
-/
import algebra.category.Module.monoidal
import category_theory.monoidal.functorial
import category_theory.monoidal.types
import linear_algebra.direct_sum.finsupp
import category_theory.linear.linear_functor

/-!
The functor of forming finitely supported functions on a type with values in a `[ring R]`
is the left adjoint of
the forgetful functor from `R`-modules to types.
-/

noncomputable theory

open category_theory

namespace Module

universe u

open_locale classical

variables (R : Type u)

section
variables [ring R]

/--
The free functor `Type u ⥤ Module R` sending a type `X` to the
free `R`-module with generators `x : X`, implemented as the type `X →₀ R`.
-/
@[simps]
def free : Type u ⥤ Module R :=
{ obj := λ X, Module.of R (X →₀ R),
  map := λ X Y f, finsupp.lmap_domain _ _ f,
  map_id' := by { intros, exact finsupp.lmap_domain_id _ _ },
  map_comp' := by { intros, exact finsupp.lmap_domain_comp _ _ _ _, } }

/--
The free-forgetful adjunction for R-modules.
-/
def adj : free R ⊣ forget (Module.{u} R) :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X M, (finsupp.lift M R X).to_equiv.symm,
  hom_equiv_naturality_left_symm' := λ _ _ M f g,
  finsupp.lhom_ext' (λ x, linear_map.ext_ring
    (finsupp.sum_map_domain_index_add_monoid_hom (λ y, ((smul_add_hom R M).flip) (g y))).symm) }

instance : is_right_adjoint (forget (Module.{u} R)) := ⟨_, adj R⟩

end

namespace free
variables [comm_ring R]
local attribute [ext] tensor_product.ext

/-- (Implementation detail) The unitor for `free R`. -/
def ε : 𝟙_ (Module.{u} R) ⟶ (free R).obj (𝟙_ (Type u)) :=
finsupp.lsingle punit.star

/-- (Implementation detail) The tensorator for `free R`. -/
def μ (α β : Type u) : (free R).obj α ⊗ (free R).obj β ⟶ (free R).obj (α ⊗ β) :=
(finsupp_tensor_finsupp' R α β).to_linear_map

lemma left_unitality (X : Type u) :
  (λ_ ((free R).obj X)).hom =
  (ε R ⊗ 𝟙 ((free R).obj X)) ≫ μ R (𝟙_ (Type u)) X ≫ map (free R).obj (λ_ X).hom :=
begin
  intros,
  ext,
  dsimp [ε, μ],
  simp_rw [finsupp_tensor_finsupp'_single_tmul_single,
    Module.monoidal_category.left_unitor_hom_apply, finsupp.smul_single', mul_one,
    finsupp.map_domain_single, category_theory.left_unitor_hom_apply],
end

lemma right_unitality (X : Type u) :
  (ρ_ ((free R).obj X)).hom =
  (𝟙 ((free R).obj X) ⊗ ε R) ≫ μ R X (𝟙_ (Type u)) ≫ map (free R).obj (ρ_ X).hom :=
begin
  intros,
  ext,
  dsimp [ε, μ],
  simp_rw [finsupp_tensor_finsupp'_single_tmul_single,
    Module.monoidal_category.right_unitor_hom_apply, finsupp.smul_single', mul_one,
    finsupp.map_domain_single, category_theory.right_unitor_hom_apply],
end

lemma associativity (X Y Z : Type u) :
  (μ R X Y ⊗ 𝟙 ((free R).obj Z)) ≫ μ R (X ⊗ Y) Z ≫ map (free R).obj (α_ X Y Z).hom =
  (α_ ((free R).obj X) ((free R).obj Y) ((free R).obj Z)).hom ≫
    (𝟙 ((free R).obj X) ⊗ μ R Y Z) ≫ μ R X (Y ⊗ Z) :=
begin
  intros,
  ext,
  dsimp [μ],
  simp_rw [finsupp_tensor_finsupp'_single_tmul_single, finsupp.map_domain_single, mul_one,
    category_theory.associator_hom_apply],
end

/-- The free R-module functor is lax monoidal. -/
-- In fact, it's strong monoidal, but we don't yet have a typeclass for that.
instance : lax_monoidal.{u} (free R).obj :=
{ -- Send `R` to `punit →₀ R`
  ε := ε R,
  -- Send `(α →₀ R) ⊗ (β →₀ R)` to `α × β →₀ R`
  μ := μ R,
  μ_natural' := λ X Y X' Y' f g, μ_natural R f g,
  left_unitality' := left_unitality R,
  right_unitality' := right_unitality R,
  associativity' := associativity R, }

end free

end Module

namespace category_theory

universes v u

/--
`Free R C` is a type synonym for `C`, which, given `[comm_ring R]` and `[category C]`,
we will equip with a category structure where the morphisms are formal `R`-linear combinations
of the morphisms in `C`.
-/
@[nolint unused_arguments has_inhabited_instance]
def Free (R : Type*) (C : Type u) := C

/--
Consider an object of `C` as an object of the `R`-linear completion.
-/
def Free.of (R : Type*) {C : Type u} (X : C) : Free R C := X

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

open finsupp

-- Conceptually, it would be nice to construct this via "transport of enrichment",
-- using the fact that `Module.free R : Type ⥤ Module R` and `Module.forget` are both lax monoidal.
-- This still seems difficult, so we just do it by hand.
instance category_Free : category (Free R C) :=
{ hom := λ (X Y : C), (X ⟶ Y) →₀ R,
  id := λ (X : C), finsupp.single (𝟙 X) 1,
  comp := λ (X Y Z : C) f g, f.sum (λ f' s, g.sum (λ g' t, finsupp.single (f' ≫ g') (s * t))),
  assoc' := λ W X Y Z f g h,
  begin
    dsimp,
    -- This imitates the proof of associativity for `monoid_algebra`.
    simp only [sum_sum_index, sum_single_index,
      single_zero, single_add, eq_self_iff_true, forall_true_iff, forall_3_true_iff,
      add_mul, mul_add, category.assoc, mul_assoc, zero_mul, mul_zero, sum_zero, sum_add],
  end }.

namespace Free

section
local attribute [simp] category_theory.category_Free

@[simp]
lemma single_comp_single {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (r s : R) :
  (single f r ≫ single g s : (Free.of R X) ⟶ (Free.of R Z)) = single (f ≫ g) (r * s) :=
by { dsimp, simp, }

instance : preadditive (Free R C) :=
{ hom_group := λ X Y, finsupp.add_comm_group,
  add_comp' := λ X Y Z f f' g, begin
    dsimp,
    rw [finsupp.sum_add_index];
    { simp [add_mul], }
  end,
  comp_add' := λ X Y Z f g g', begin
    dsimp,
    rw ← finsupp.sum_add,
    congr, ext r h,
    rw [finsupp.sum_add_index];
    { simp [mul_add], },
  end, }

instance : linear R (Free R C) :=
{ hom_module := λ X Y, finsupp.module (X ⟶ Y) R,
  smul_comp' := λ X Y Z r f g, begin
    dsimp,
    rw [finsupp.sum_smul_index];
    simp [finsupp.smul_sum, mul_assoc],
  end,
  comp_smul' := λ X Y Z f r g, begin
    dsimp,
    simp_rw [finsupp.smul_sum],
    congr, ext h s,
    rw [finsupp.sum_smul_index];
    simp [finsupp.smul_sum, mul_left_comm],
  end, }

end

/--
A category embeds into its `R`-linear completion.
-/
@[simps]
def embedding : C ⥤ Free R C :=
{ obj := λ X, X,
  map := λ X Y f, finsupp.single f 1,
  map_id' := λ X, rfl,
  map_comp' := λ X Y Z f g, by simp, }

variables (R) {C} {D : Type u} [category.{v} D] [preadditive D] [linear R D]

open preadditive linear

/--
A functor to a preadditive category lifts to a functor from its `R`-linear completion.
-/
@[simps]
def lift (F : C ⥤ D) : Free R C ⥤ D :=
{ obj := λ X, F.obj X,
  map := λ X Y f, f.sum (λ f' r, r • (F.map f')),
  map_id' := by { dsimp [category_theory.category_Free], simp },
  map_comp' := λ X Y Z f g, begin
    apply finsupp.induction_linear f,
    { simp, },
    { intros f₁ f₂ w₁ w₂,
      rw add_comp,
      rw [finsupp.sum_add_index, finsupp.sum_add_index],
      { simp [w₁, w₂, add_comp], },
      { simp, },
      { intros, simp only [add_smul], },
      { simp, },
      { intros, simp only [add_smul], }, },
    { intros f' r,
      apply finsupp.induction_linear g,
      { simp, },
      { intros f₁ f₂ w₁ w₂,
        rw comp_add,
        rw [finsupp.sum_add_index, finsupp.sum_add_index],
        { simp [w₁, w₂, add_comp], },
        { simp, },
        { intros, simp only [add_smul], },
        { simp, },
        { intros, simp only [add_smul], }, },
      { intros g' s,
        erw single_comp_single,
        simp [mul_comm r s, mul_smul], } }
  end, }

@[simp]
lemma lift_map_single (F : C ⥤ D) {X Y : C} (f : X ⟶ Y) (r : R) :
  (lift R F).map (single f r) = r • F.map f :=
by simp

instance lift_additive (F : C ⥤ D) : (lift R F).additive :=
{ map_add' := λ X Y f g, begin
    dsimp,
    rw finsupp.sum_add_index; simp [add_smul]
  end, }

instance lift_linear (F : C ⥤ D) : (lift R F).linear R :=
{ map_smul' := λ X Y f r, begin
    dsimp,
    rw finsupp.sum_smul_index;
    simp [finsupp.smul_sum, mul_smul],
  end, }

/--
The embedding into the `R`-linear completion, followed by the lift,
is isomorphic to the original functor.
-/
def embedding_lift_iso (F : C ⥤ D) : embedding R C ⋙ lift R F ≅ F :=
nat_iso.of_components
  (λ X, iso.refl _)
  (by tidy)

/--
Two `R`-linear functors out of the `R`-linear completion are isomorphic iff their
compositions with the embedding functor are isomorphic.
-/
@[ext]
def ext {F G : Free R C ⥤ D} [F.additive] [F.linear R] [G.additive] [G.linear R]
  (α : embedding R C ⋙ F ≅ embedding R C ⋙ G) : F ≅ G :=
nat_iso.of_components
  (λ X, α.app X)
  begin
    intros X Y f,
    apply finsupp.induction_linear f,
    { simp, },
    { intros f₁ f₂ w₁ w₂,
      simp only [F.map_add, G.map_add, add_comp, comp_add, w₁, w₂], },
    { intros f' r,
      rw [iso.app_hom, iso.app_hom, ←smul_single_one, F.map_smul, G.map_smul, smul_comp, comp_smul],
      change r • (embedding R C ⋙ F).map f' ≫ _ = r • _ ≫ (embedding R C ⋙ G).map f',
      rw α.hom.naturality f',
      apply_instance, -- Why are these not picked up automatically when we rewrite?
      apply_instance, }
  end

/--
`Free.lift` is unique amongst `R`-linear functors `Free R C ⥤ D`
which compose with `embedding ℤ C` to give the original functor.
-/
def lift_unique (F : C ⥤ D) (L : Free R C ⥤ D) [L.additive] [L.linear R]
  (α : embedding R C ⋙ L ≅ F) :
  L ≅ lift R F :=
ext R (α.trans (embedding_lift_iso R F).symm)

end Free

end category_theory


/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov

! This file was ported from Lean 3 source module category_theory.category.Groupoid
! leanprover-community/mathlib commit c9c9fa15fec7ca18e9ec97306fb8764bfe988a7e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.SingleObj
import Mathbin.CategoryTheory.Limits.Shapes.Products
import Mathbin.CategoryTheory.Pi.Basic
import Mathbin.CategoryTheory.Limits.IsLimit

/-!
# Category of groupoids

This file contains the definition of the category `Groupoid` of all groupoids.
In this category objects are groupoids and morphisms are functors
between these groupoids.

We also provide two “forgetting” functors: `objects : Groupoid ⥤ Type`
and `forget_to_Cat : Groupoid ⥤ Cat`.

## Implementation notes

Though `Groupoid` is not a concrete category, we use `bundled` to define
its carrier type.
-/

universe v u

namespace CategoryTheory

-- intended to be used with explicit universe parameters
/-- Category of groupoids -/
@[nolint check_univs]
def GroupoidCat :=
  Bundled Groupoid.{v, u}
#align category_theory.Groupoid CategoryTheory.GroupoidCat

namespace Groupoid

instance : Inhabited GroupoidCat :=
  ⟨Bundled.of (SingleObj PUnit)⟩

instance str (C : GroupoidCat.{v, u}) : Groupoid.{v, u} C.α :=
  C.str
#align category_theory.Groupoid.str CategoryTheory.GroupoidCat.str

instance : CoeSort GroupoidCat (Type _) :=
  Bundled.hasCoeToSort

/-- Construct a bundled `Groupoid` from the underlying type and the typeclass. -/
def of (C : Type u) [Groupoid.{v} C] : GroupoidCat.{v, u} :=
  Bundled.of C
#align category_theory.Groupoid.of CategoryTheory.GroupoidCat.of

@[simp]
theorem coe_of (C : Type u) [Groupoid C] : (of C : Type u) = C :=
  rfl
#align category_theory.Groupoid.coe_of CategoryTheory.GroupoidCat.coe_of

/-- Category structure on `Groupoid` -/
instance category : LargeCategory.{max v u} GroupoidCat.{v, u}
    where
  Hom C D := C ⥤ D
  id C := 𝟭 C
  comp C D E F G := F ⋙ G
  id_comp' C D F := by cases F <;> rfl
  comp_id' C D F := by cases F <;> rfl
  assoc' := by intros <;> rfl
#align category_theory.Groupoid.category CategoryTheory.GroupoidCat.category

/-- Functor that gets the set of objects of a groupoid. It is not
called `forget`, because it is not a faithful functor. -/
def objects : GroupoidCat.{v, u} ⥤ Type u
    where
  obj := Bundled.α
  map C D F := F.obj
#align category_theory.Groupoid.objects CategoryTheory.GroupoidCat.objects

/-- Forgetting functor to `Cat` -/
def forgetToCat : GroupoidCat.{v, u} ⥤ Cat.{v, u}
    where
  obj C := Cat.of C
  map C D := id
#align category_theory.Groupoid.forget_to_Cat CategoryTheory.GroupoidCat.forgetToCat

instance forgetToCatFull : Full forgetToCat where preimage C D := id
#align category_theory.Groupoid.forget_to_Cat_full CategoryTheory.GroupoidCat.forgetToCatFull

instance forgetToCat_faithful : Faithful forgetToCat where
#align category_theory.Groupoid.forget_to_Cat_faithful CategoryTheory.GroupoidCat.forgetToCat_faithful

/-- Convert arrows in the category of groupoids to functors,
which sometimes helps in applying simp lemmas -/
theorem hom_to_functor {C D E : GroupoidCat.{v, u}} (f : C ⟶ D) (g : D ⟶ E) : f ≫ g = f ⋙ g :=
  rfl
#align category_theory.Groupoid.hom_to_functor CategoryTheory.GroupoidCat.hom_to_functor

/-- Converts identity in the category of groupoids to the functor identity -/
theorem id_to_functor {C : GroupoidCat.{v, u}} : 𝟭 C = 𝟙 C :=
  rfl
#align category_theory.Groupoid.id_to_functor CategoryTheory.GroupoidCat.id_to_functor

section Products

attribute [local tidy] tactic.discrete_cases

/-- Construct the product over an indexed family of groupoids, as a fan. -/
def piLimitFan ⦃J : Type u⦄ (F : J → GroupoidCat.{u, u}) : Limits.Fan F :=
  Limits.Fan.mk (@of (∀ j : J, F j) _) fun j => CategoryTheory.Pi.eval _ j
#align category_theory.Groupoid.pi_limit_fan CategoryTheory.GroupoidCat.piLimitFan

/-- The product fan over an indexed family of groupoids, is a limit cone. -/
def piLimitFanIsLimit ⦃J : Type u⦄ (F : J → GroupoidCat.{u, u}) : Limits.IsLimit (piLimitFan F) :=
  Limits.mkFanLimit (piLimitFan F) (fun s => Functor.pi' fun j => s.proj j)
    (by
      intros
      dsimp only [pi_limit_fan]
      simp [hom_to_functor])
    (by
      intro s m w
      apply functor.pi_ext
      intro j; specialize w j
      simpa)
#align category_theory.Groupoid.pi_limit_fan_is_limit CategoryTheory.GroupoidCat.piLimitFanIsLimit

instance has_pi : Limits.HasProducts GroupoidCat.{u, u} :=
  Limits.hasProducts_of_limit_fans piLimitFan piLimitFanIsLimit
#align category_theory.Groupoid.has_pi CategoryTheory.GroupoidCat.has_pi

/-- The product of a family of groupoids is isomorphic
to the product object in the category of Groupoids -/
noncomputable def piIsoPi (J : Type u) (f : J → GroupoidCat.{u, u}) : @of (∀ j, f j) _ ≅ ∏ f :=
  Limits.IsLimit.conePointUniqueUpToIso (piLimitFanIsLimit f)
    (Limits.limit.isLimit (Discrete.functor f))
#align category_theory.Groupoid.pi_iso_pi CategoryTheory.GroupoidCat.piIsoPi

@[simp]
theorem piIsoPi_hom_π (J : Type u) (f : J → GroupoidCat.{u, u}) (j : J) :
    (piIsoPi J f).Hom ≫ Limits.Pi.π f j = CategoryTheory.Pi.eval _ j :=
  by
  simp [pi_iso_pi]
  rfl
#align category_theory.Groupoid.pi_iso_pi_hom_π CategoryTheory.GroupoidCat.piIsoPi_hom_π

end Products

end Groupoid

end CategoryTheory


/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel, Mario Carneiro, Yury Kudryashov, Heather Macbeth
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.normed_space.basic
import Mathlib.PostPort

universes u v w u_1

namespace Mathlib

/-!
# Bounded continuous functions

The type of bounded continuous functions taking values in a metric space, with
the uniform distance.

-/

/-- The type of bounded continuous functions from a topological space to a metric space -/
def bounded_continuous_function (α : Type u) (β : Type v) [topological_space α] [metric_space β] :=
  Subtype fun (f : α → β) => continuous f ∧ ∃ (C : ℝ), ∀ (x y : α), dist (f x) (f y) ≤ C

namespace bounded_continuous_function

protected instance has_coe_to_fun {α : Type u} {β : Type v} [topological_space α] [metric_space β] :
    has_coe_to_fun (bounded_continuous_function α β) :=
  has_coe_to_fun.mk (fun (x : bounded_continuous_function α β) => α → β) subtype.val

theorem bounded_range {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} : metric.bounded (set.range ⇑f) :=
  iff.mpr metric.bounded_range_iff (and.right (subtype.property f))

/-- If a function is continuous on a compact space, it is automatically bounded,
and therefore gives rise to an element of the type of bounded continuous functions -/
def mk_of_compact {α : Type u} {β : Type v} [topological_space α] [metric_space β] [compact_space α]
    (f : α → β) (hf : continuous f) : bounded_continuous_function α β :=
  { val := f, property := sorry }

/-- If a function is bounded on a discrete space, it is automatically continuous,
and therefore gives rise to an element of the type of bounded continuous functions -/
def mk_of_discrete {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    [discrete_topology α] (f : α → β) (hf : ∃ (C : ℝ), ∀ (x y : α), dist (f x) (f y) ≤ C) :
    bounded_continuous_function α β :=
  { val := f, property := sorry }

/-- The uniform distance between two bounded continuous functions -/
protected instance has_dist {α : Type u} {β : Type v} [topological_space α] [metric_space β] :
    has_dist (bounded_continuous_function α β) :=
  has_dist.mk
    fun (f g : bounded_continuous_function α β) =>
      Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C)

theorem dist_eq {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} :
    dist f g = Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C) :=
  rfl

theorem dist_set_exists {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} :
    ∃ (C : ℝ), 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C :=
  sorry

/-- The pointwise distance is controlled by the distance between functions, by definition. -/
theorem dist_coe_le_dist {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} (x : α) :
    dist (coe_fn f x) (coe_fn g x) ≤ dist f g :=
  le_cInf dist_set_exists
    fun (b : ℝ)
      (hb : b ∈ set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C) =>
      and.right hb x

theorem ext {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β}
    (H : ∀ (x : α), coe_fn f x = coe_fn g x) : f = g :=
  subtype.eq (funext H)

theorem ext_iff {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} :
    f = g ↔ ∀ (x : α), coe_fn f x = coe_fn g x :=
  { mp := fun (h : f = g) (x : α) => h ▸ rfl, mpr := ext }

/- This lemma will be needed in the proof of the metric space instance, but it will become
useless afterwards as it will be superceded by the general result that the distance is nonnegative
is metric spaces. -/

/-- The distance between two functions is controlled by the supremum of the pointwise distances -/
theorem dist_le {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} {C : ℝ}
    (C0 : 0 ≤ C) : dist f g ≤ C ↔ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C :=
  sorry

/-- On an empty space, bounded continuous functions are at distance 0 -/
theorem dist_zero_of_empty {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} {g : bounded_continuous_function α β} (e : ¬Nonempty α) :
    dist f g = 0 :=
  le_antisymm (iff.mpr (dist_le (le_refl 0)) fun (x : α) => not.elim e (Nonempty.intro x))
    dist_nonneg'

/-- The type of bounded continuous functions, with the uniform distance, is a metric space. -/
protected instance metric_space {α : Type u} {β : Type v} [topological_space α] [metric_space β] :
    metric_space (bounded_continuous_function α β) :=
  metric_space.mk sorry sorry sorry sorry
    (fun (x y : bounded_continuous_function α β) =>
      ennreal.of_real
        ((fun (f g : bounded_continuous_function α β) =>
            Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C))
          x y))
    (uniform_space_of_dist
      (fun (f g : bounded_continuous_function α β) =>
        Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), dist (coe_fn f x) (coe_fn g x) ≤ C))
      sorry sorry sorry)

/-- Constant as a continuous bounded function. -/
def const (α : Type u) {β : Type v} [topological_space α] [metric_space β] (b : β) :
    bounded_continuous_function α β :=
  { val := fun (x : α) => b, property := sorry }

@[simp] theorem coe_const {α : Type u} {β : Type v} [topological_space α] [metric_space β] (b : β) :
    ⇑(const α b) = function.const α b :=
  rfl

theorem const_apply {α : Type u} {β : Type v} [topological_space α] [metric_space β] (a : α)
    (b : β) : coe_fn (const α b) a = b :=
  rfl

/-- If the target space is inhabited, so is the space of bounded continuous functions -/
protected instance inhabited {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    [Inhabited β] : Inhabited (bounded_continuous_function α β) :=
  { default := const α Inhabited.default }

/-- The evaluation map is continuous, as a joint function of `u` and `x` -/
theorem continuous_eval {α : Type u} {β : Type v} [topological_space α] [metric_space β] :
    continuous fun (p : bounded_continuous_function α β × α) => coe_fn (prod.fst p) (prod.snd p) :=
  sorry

/- use the continuity of `f` to find a neighborhood of `x` where it varies at most by ε/2 -/

/-- In particular, when `x` is fixed, `f → f x` is continuous -/
theorem continuous_evalx {α : Type u} {β : Type v} [topological_space α] [metric_space β] {x : α} :
    continuous fun (f : bounded_continuous_function α β) => coe_fn f x :=
  continuous.comp continuous_eval (continuous.prod_mk continuous_id continuous_const)

/-- When `f` is fixed, `x → f x` is also continuous, by definition -/
theorem continuous_evalf {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    {f : bounded_continuous_function α β} : continuous ⇑f :=
  and.left (subtype.property f)

/-- Bounded continuous functions taking values in a complete space form a complete space. -/
protected instance complete_space {α : Type u} {β : Type v} [topological_space α] [metric_space β]
    [complete_space β] : complete_space (bounded_continuous_function α β) :=
  sorry

/-- Composition (in the target) of a bounded continuous function with a Lipschitz map again
gives a bounded continuous function -/
def comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α] [metric_space β]
    [metric_space γ] (G : β → γ) {C : nnreal} (H : lipschitz_with C G)
    (f : bounded_continuous_function α β) : bounded_continuous_function α γ :=
  { val := fun (x : α) => G (coe_fn f x), property := sorry }

/-- The composition operator (in the target) with a Lipschitz map is Lipschitz -/
theorem lipschitz_comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α] [metric_space β]
    [metric_space γ] {G : β → γ} {C : nnreal} (H : lipschitz_with C G) :
    lipschitz_with C (comp G H) :=
  sorry

/-- The composition operator (in the target) with a Lipschitz map is uniformly continuous -/
theorem uniform_continuous_comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α]
    [metric_space β] [metric_space γ] {G : β → γ} {C : nnreal} (H : lipschitz_with C G) :
    uniform_continuous (comp G H) :=
  lipschitz_with.uniform_continuous (lipschitz_comp H)

/-- The composition operator (in the target) with a Lipschitz map is continuous -/
theorem continuous_comp {α : Type u} {β : Type v} {γ : Type w} [topological_space α]
    [metric_space β] [metric_space γ] {G : β → γ} {C : nnreal} (H : lipschitz_with C G) :
    continuous (comp G H) :=
  lipschitz_with.continuous (lipschitz_comp H)

/-- Restriction (in the target) of a bounded continuous function taking values in a subset -/
def cod_restrict {α : Type u} {β : Type v} [topological_space α] [metric_space β] (s : set β)
    (f : bounded_continuous_function α β) (H : ∀ (x : α), coe_fn f x ∈ s) :
    bounded_continuous_function α ↥s :=
  { val := set.cod_restrict (⇑f) s H, property := sorry }

/- Arzela-Ascoli theorem asserts that, on a compact space, a set of functions sharing
a common modulus of continuity and taking values in a compact set forms a compact
subset for the topology of uniform convergence. In this section, we prove this theorem
and several useful variations around it. -/

/-- First version, with pointwise equicontinuity and range in a compact space -/
theorem arzela_ascoli₁ {α : Type u} {β : Type v} [topological_space α] [compact_space α]
    [metric_space β] [compact_space β] (A : set (bounded_continuous_function α β))
    (closed : is_closed A)
    (H :
      ∀ (x : α) (ε : ℝ) (H : ε > 0),
        ∃ (U : set α),
          ∃ (H : U ∈ nhds x),
            ∀ (y z : α),
              y ∈ U →
                z ∈ U →
                  ∀ (f : bounded_continuous_function α β),
                    f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε) :
    is_compact A :=
  sorry

/-- Second version, with pointwise equicontinuity and range in a compact subset -/
theorem arzela_ascoli₂ {α : Type u} {β : Type v} [topological_space α] [compact_space α]
    [metric_space β] (s : set β) (hs : is_compact s) (A : set (bounded_continuous_function α β))
    (closed : is_closed A)
    (in_s : ∀ (f : bounded_continuous_function α β) (x : α), f ∈ A → coe_fn f x ∈ s)
    (H :
      ∀ (x : α) (ε : ℝ) (H : ε > 0),
        ∃ (U : set α),
          ∃ (H : U ∈ nhds x),
            ∀ (y z : α),
              y ∈ U →
                z ∈ U →
                  ∀ (f : bounded_continuous_function α β),
                    f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε) :
    is_compact A :=
  sorry

/- This version is deduced from the previous one by restricting to the compact type in the target,
using compactness there and then lifting everything to the original space. -/

/-- Third (main) version, with pointwise equicontinuity and range in a compact subset, but
without closedness. The closure is then compact -/
theorem arzela_ascoli {α : Type u} {β : Type v} [topological_space α] [compact_space α]
    [metric_space β] (s : set β) (hs : is_compact s) (A : set (bounded_continuous_function α β))
    (in_s : ∀ (f : bounded_continuous_function α β) (x : α), f ∈ A → coe_fn f x ∈ s)
    (H :
      ∀ (x : α) (ε : ℝ) (H : ε > 0),
        ∃ (U : set α),
          ∃ (H : U ∈ nhds x),
            ∀ (y z : α),
              y ∈ U →
                z ∈ U →
                  ∀ (f : bounded_continuous_function α β),
                    f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε) :
    is_compact (closure A) :=
  sorry

/- This version is deduced from the previous one by checking that the closure of A, in
addition to being closed, still satisfies the properties of compact range and equicontinuity -/

/- To apply the previous theorems, one needs to check the equicontinuity. An important
instance is when the source space is a metric space, and there is a fixed modulus of continuity
for all the functions in the set A -/

theorem equicontinuous_of_continuity_modulus {β : Type v} [metric_space β] {α : Type u}
    [metric_space α] (b : ℝ → ℝ) (b_lim : filter.tendsto b (nhds 0) (nhds 0))
    (A : set (bounded_continuous_function α β))
    (H :
      ∀ (x y : α) (f : bounded_continuous_function α β),
        f ∈ A → dist (coe_fn f x) (coe_fn f y) ≤ b (dist x y))
    (x : α) (ε : ℝ) (ε0 : 0 < ε) :
    ∃ (U : set α),
        ∃ (H : U ∈ nhds x),
          ∀ (y z : α),
            y ∈ U →
              z ∈ U →
                ∀ (f : bounded_continuous_function α β),
                  f ∈ A → dist (coe_fn f y) (coe_fn f z) < ε :=
  sorry

/- In this section, if β is a normed group, then we show that the space of bounded
continuous functions from α to β inherits a normed group structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance has_zero {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    HasZero (bounded_continuous_function α β) :=
  { zero := const α 0 }

@[simp] theorem coe_zero {α : Type u} {β : Type v} [topological_space α] [normed_group β] {x : α} :
    coe_fn 0 x = 0 :=
  rfl

protected instance has_norm {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    has_norm (bounded_continuous_function α β) :=
  has_norm.mk fun (u : bounded_continuous_function α β) => dist u 0

theorem norm_def {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) : norm f = dist f 0 :=
  rfl

/-- The norm of a bounded continuous function is the supremum of `∥f x∥`.
We use `Inf` to ensure that the definition works if `α` has no elements. -/
theorem norm_eq {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) :
    norm f = Inf (set_of fun (C : ℝ) => 0 ≤ C ∧ ∀ (x : α), norm (coe_fn f x) ≤ C) :=
  sorry

theorem norm_coe_le_norm {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (x : α) : norm (coe_fn f x) ≤ norm f :=
  sorry

theorem dist_le_two_norm' {β : Type v} {γ : Type w} [normed_group β] {f : γ → β} {C : ℝ}
    (hC : ∀ (x : γ), norm (f x) ≤ C) (x : γ) (y : γ) : dist (f x) (f y) ≤ bit0 1 * C :=
  trans_rel_left LessEq (le_trans (dist_le_norm_add_norm (f x) (f y)) (add_le_add (hC x) (hC y)))
    (Eq.symm (two_mul C))

/-- Distance between the images of any two points is at most twice the norm of the function. -/
theorem dist_le_two_norm {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (x : α) (y : α) :
    dist (coe_fn f x) (coe_fn f y) ≤ bit0 1 * norm f :=
  dist_le_two_norm' (norm_coe_le_norm f) x y

/-- The norm of a function is controlled by the supremum of the pointwise norms -/
theorem norm_le {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    {f : bounded_continuous_function α β} {C : ℝ} (C0 : 0 ≤ C) :
    norm f ≤ C ↔ ∀ (x : α), norm (coe_fn f x) ≤ C :=
  sorry

/-- Norm of `const α b` is less than or equal to `∥b∥`. If `α` is nonempty,
then it is equal to `∥b∥`. -/
theorem norm_const_le {α : Type u} {β : Type v} [topological_space α] [normed_group β] (b : β) :
    norm (const α b) ≤ norm b :=
  iff.mpr (norm_le (norm_nonneg b)) fun (x : α) => le_refl (norm (coe_fn (const α b) x))

@[simp] theorem norm_const_eq {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    [h : Nonempty α] (b : β) : norm (const α b) = norm b :=
  le_antisymm (norm_const_le b) (nonempty.elim h fun (x : α) => norm_coe_le_norm (const α b) x)

/-- Constructing a bounded continuous function from a uniformly bounded continuous
function taking values in a normed group. -/
def of_normed_group {α : Type u} {β : Type v} [topological_space α] [normed_group β] (f : α → β)
    (Hf : continuous f) (C : ℝ) (H : ∀ (x : α), norm (f x) ≤ C) : bounded_continuous_function α β :=
  { val := fun (n : α) => f n, property := sorry }

theorem norm_of_normed_group_le {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    {f : α → β} (hfc : continuous f) {C : ℝ} (hC : 0 ≤ C) (hfC : ∀ (x : α), norm (f x) ≤ C) :
    norm (of_normed_group f hfc C hfC) ≤ C :=
  iff.mpr (norm_le hC) hfC

/-- Constructing a bounded continuous function from a uniformly bounded
function on a discrete space, taking values in a normed group -/
def of_normed_group_discrete {α : Type u} {β : Type v} [topological_space α] [discrete_topology α]
    [normed_group β] (f : α → β) (C : ℝ) (H : ∀ (x : α), norm (f x) ≤ C) :
    bounded_continuous_function α β :=
  of_normed_group f sorry C H

/-- The pointwise sum of two bounded continuous functions is again bounded continuous. -/
protected instance has_add {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    Add (bounded_continuous_function α β) :=
  { add :=
      fun (f g : bounded_continuous_function α β) =>
        of_normed_group (⇑f + ⇑g) sorry (norm f + norm g) sorry }

/-- The pointwise opposite of a bounded continuous function is again bounded continuous. -/
protected instance has_neg {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    Neg (bounded_continuous_function α β) :=
  { neg := fun (f : bounded_continuous_function α β) => of_normed_group (-⇑f) sorry (norm f) sorry }

/-- The pointwise difference of two bounded continuous functions is again bounded continuous. -/
protected instance has_sub {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    Sub (bounded_continuous_function α β) :=
  { sub :=
      fun (f g : bounded_continuous_function α β) =>
        of_normed_group (⇑f - ⇑g) sorry (norm f + norm g) sorry }

@[simp] theorem coe_add {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) :
    ⇑(f + g) = fun (x : α) => coe_fn f x + coe_fn g x :=
  rfl

theorem add_apply {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) {x : α} :
    coe_fn (f + g) x = coe_fn f x + coe_fn g x :=
  rfl

@[simp] theorem coe_neg {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) : ⇑(-f) = fun (x : α) => -coe_fn f x :=
  rfl

theorem neg_apply {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) {x : α} : coe_fn (-f) x = -coe_fn f x :=
  rfl

theorem forall_coe_zero_iff_zero {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) : (∀ (x : α), coe_fn f x = 0) ↔ f = 0 :=
  iff.symm ext_iff

protected instance add_comm_group {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    add_comm_group (bounded_continuous_function α β) :=
  add_comm_group.mk Add.add sorry 0 sorry sorry Neg.neg Sub.sub sorry sorry

@[simp] theorem coe_sub {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) :
    ⇑(f - g) = fun (x : α) => coe_fn f x - coe_fn g x :=
  rfl

theorem sub_apply {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) {x : α} :
    coe_fn (f - g) x = coe_fn f x - coe_fn g x :=
  rfl

protected instance normed_group {α : Type u} {β : Type v} [topological_space α] [normed_group β] :
    normed_group (bounded_continuous_function α β) :=
  normed_group.mk sorry

theorem abs_diff_coe_le_dist {α : Type u} {β : Type v} [topological_space α] [normed_group β]
    (f : bounded_continuous_function α β) (g : bounded_continuous_function α β) {x : α} :
    norm (coe_fn f x - coe_fn g x) ≤ dist f g :=
  eq.mpr (id (Eq._oldrec (Eq.refl (norm (coe_fn f x - coe_fn g x) ≤ dist f g)) (dist_eq_norm f g)))
    (norm_coe_le_norm (f - g) x)

theorem coe_le_coe_add_dist {α : Type u} [topological_space α] {x : α}
    {f : bounded_continuous_function α ℝ} {g : bounded_continuous_function α ℝ} :
    coe_fn f x ≤ coe_fn g x + dist f g :=
  iff.mp sub_le_iff_le_add' (and.right (iff.mp abs_le (dist_coe_le_dist x)))

/-!
### Normed space structure

In this section, if `β` is a normed space, then we show that the space of bounded
continuous functions from `α` to `β` inherits a normed space structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance has_scalar {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_group β] [normed_space 𝕜 β] :
    has_scalar 𝕜 (bounded_continuous_function α β) :=
  has_scalar.mk
    fun (c : 𝕜) (f : bounded_continuous_function α β) =>
      of_normed_group (c • ⇑f) sorry (norm c * norm f) sorry

@[simp] theorem coe_smul {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_group β] [normed_space 𝕜 β] (c : 𝕜)
    (f : bounded_continuous_function α β) : ⇑(c • f) = fun (x : α) => c • coe_fn f x :=
  rfl

theorem smul_apply {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α]
    [normed_group β] [normed_space 𝕜 β] (c : 𝕜) (f : bounded_continuous_function α β) (x : α) :
    coe_fn (c • f) x = c • coe_fn f x :=
  rfl

protected instance semimodule {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_group β] [normed_space 𝕜 β] :
    semimodule 𝕜 (bounded_continuous_function α β) :=
  semimodule.of_core (semimodule.core.mk (has_scalar.mk has_scalar.smul) sorry sorry sorry sorry)

protected instance normed_space {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_group β] [normed_space 𝕜 β] :
    normed_space 𝕜 (bounded_continuous_function α β) :=
  normed_space.mk sorry

/-!
### Normed ring structure

In this section, if `R` is a normed ring, then we show that the space of bounded
continuous functions from `α` to `R` inherits a normed ring structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance ring {α : Type u} [topological_space α] {R : Type u_1} [normed_ring R] :
    ring (bounded_continuous_function α R) :=
  ring.mk add_comm_group.add sorry add_comm_group.zero sorry sorry add_comm_group.neg
    add_comm_group.sub sorry sorry
    (fun (f g : bounded_continuous_function α R) =>
      of_normed_group (⇑f * ⇑g) sorry (norm f * norm g) sorry)
    sorry (const α 1) sorry sorry sorry sorry

protected instance normed_ring {α : Type u} [topological_space α] {R : Type u_1} [normed_ring R] :
    normed_ring (bounded_continuous_function α R) :=
  normed_ring.mk sorry sorry

/-!
### Normed commutative ring structure

In this section, if `R` is a normed commutative ring, then we show that the space of bounded
continuous functions from `α` to `R` inherits a normed commutative ring structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

protected instance comm_ring {α : Type u} [topological_space α] {R : Type u_1}
    [normed_comm_ring R] : comm_ring (bounded_continuous_function α R) :=
  comm_ring.mk ring.add sorry ring.zero sorry sorry ring.neg ring.sub sorry sorry ring.mul sorry
    ring.one sorry sorry sorry sorry sorry

protected instance normed_comm_ring {α : Type u} [topological_space α] {R : Type u_1}
    [normed_comm_ring R] : normed_comm_ring (bounded_continuous_function α R) :=
  normed_comm_ring.mk sorry

/-!
### Normed algebra structure

In this section, if `γ` is a normed algebra, then we show that the space of bounded
continuous functions from `α` to `γ` inherits a normed algebra structure, by using
pointwise operations and checking that they are compatible with the uniform distance. -/

/-- `bounded_continuous_function.const` as a `ring_hom`. -/
def C {α : Type u} {γ : Type w} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α]
    [normed_ring γ] [normed_algebra 𝕜 γ] : 𝕜 →+* bounded_continuous_function α γ :=
  ring_hom.mk (fun (c : 𝕜) => const α (coe_fn (algebra_map 𝕜 γ) c)) sorry sorry sorry sorry

protected instance algebra {α : Type u} {γ : Type w} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_ring γ] [normed_algebra 𝕜 γ] :
    algebra 𝕜 (bounded_continuous_function α γ) :=
  algebra.mk C sorry sorry

protected instance normed_algebra {α : Type u} {γ : Type w} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_ring γ] [normed_algebra 𝕜 γ] [Nonempty α] :
    normed_algebra 𝕜 (bounded_continuous_function α γ) :=
  normed_algebra.mk sorry

/-!
### Structure as normed module over scalar functions

If `β` is a normed `𝕜`-space, then we show that the space of bounded continuous
functions from `α` to `β` is naturally a module over the algebra of bounded continuous
functions from `α` to `𝕜`. -/

protected instance has_scalar' {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_group β] [normed_space 𝕜 β] :
    has_scalar (bounded_continuous_function α 𝕜) (bounded_continuous_function α β) :=
  has_scalar.mk
    fun (f : bounded_continuous_function α 𝕜) (g : bounded_continuous_function α β) =>
      of_normed_group (fun (x : α) => coe_fn f x • coe_fn g x) sorry (norm f * norm g) sorry

protected instance module' {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜]
    [topological_space α] [normed_group β] [normed_space 𝕜 β] :
    module (bounded_continuous_function α 𝕜) (bounded_continuous_function α β) :=
  semimodule.of_core (semimodule.core.mk (has_scalar.mk has_scalar.smul) sorry sorry sorry sorry)

theorem norm_smul_le {α : Type u} {β : Type v} {𝕜 : Type u_1} [normed_field 𝕜] [topological_space α]
    [normed_group β] [normed_space 𝕜 β] (f : bounded_continuous_function α 𝕜)
    (g : bounded_continuous_function α β) : norm (f • g) ≤ norm f * norm g :=
  norm_of_normed_group_le (has_scalar'._proof_1 f g) (mul_nonneg (norm_nonneg f) (norm_nonneg g))
    (has_scalar'._proof_2 f g)

end Mathlib


import data.matrix.pequiv data.rat.basic

variables {m n : ℕ}

/-- The type of ordered partitions of `m + n` elements into a
  `m` row variables and `n` column variables  -/
structure partition (m n : ℕ) : Type :=
( rowp : fin m ≃. fin (m + n) )
( colp : fin n ≃. fin (m + n) )
( rowp_trans_rowp_symm : rowp.trans rowp.symm = pequiv.refl (fin m) )
( colp_trans_colp_symm : colp.trans colp.symm = pequiv.refl (fin n) )
( rowp_trans_colp_symm : rowp.trans colp.symm = ⊥ )

namespace partition
open pequiv function matrix finset fintype

local infix ` ⬝ `:70 := matrix.mul
local postfix `ᵀ` : 1500 := transpose

attribute [simp] rowp_trans_rowp_symm colp_trans_colp_symm rowp_trans_colp_symm

lemma fin.coe_eq_val (a : fin n) : (a : ℕ) = a.val := rfl

def default : partition m n :=
{ rowp :=
  { to_fun := some ∘ fin.cast_le (le_add_right (le_refl _)),
    inv_fun := λ j, if hm : j.1 < m then some ⟨j, hm⟩ else none,
    inv := begin
      rintros ⟨i, _⟩ ⟨j, _⟩, split_ifs;
      simp [fin.coe_eq_val, fin.cast_le, fin.cast_lt, eq_comm, -not_lt];
      intro; simp [*, -not_lt] at *,
    end },
  colp := { to_fun := λ i, some ⟨m + i, add_lt_add_of_le_of_lt (le_refl _) i.2⟩,
    inv_fun := λ j, if hm : m ≤ j.1
      then some ⟨j - m, (nat.sub_lt_left_iff_lt_add hm).2 j.2⟩ else none,
    inv := begin
      rintros ⟨i, _⟩ ⟨j, _⟩,
      simp [pequiv.trans, pequiv.symm, fin.cast_le, fin.cast_lt, fin.coe_eq_val, fin.ext_iff],
      split_ifs,
      { simp [fin.ext_iff, nat.sub_eq_iff_eq_add h, @eq_comm _ j] at * },
      { simp, intro, subst j, simp [nat.le_add_left, *] at * }
    end },
  rowp_trans_rowp_symm := trans_symm_eq_iff_forall_is_some.2 (λ _, rfl),
  colp_trans_colp_symm := trans_symm_eq_iff_forall_is_some.2 (λ _, rfl),
  rowp_trans_colp_symm := pequiv.ext begin
    rintro ⟨i, hi⟩,
    dsimp [pequiv.trans, pequiv.symm, fin.cast_le, fin.cast_lt],
    rw [dif_neg (not_le_of_gt hi)]
  end }

instance : inhabited (partition m n) := ⟨default⟩

lemma is_some_rowp (B : partition m n) : ∀ (i : fin m), (B.rowp i).is_some :=
by rw [← trans_symm_eq_iff_forall_is_some, rowp_trans_rowp_symm]

lemma is_some_colp (B : partition m n) : ∀ (k : fin n), (B.colp k).is_some :=
by rw [← trans_symm_eq_iff_forall_is_some, colp_trans_colp_symm]

lemma injective_rowp (B : partition m n) : injective B.rowp :=
injective_of_forall_is_some (is_some_rowp B)

lemma injective_colp (B : partition m n) : injective B.colp :=
injective_of_forall_is_some (is_some_colp B)

/-- given a row index, `rowg` returns the variable in that position -/
def rowg (B : partition m n) (r : fin m) : fin (m + n) :=
option.get (B.is_some_rowp r)

/-- given a column index, `colg` returns the variable in that position -/
def colg (B : partition m n) (s : fin n) : fin (m + n) :=
option.get (B.is_some_colp s)

lemma injective_rowg (B : partition m n) : injective B.rowg :=
λ x y h, by rw [rowg, rowg, ← option.some_inj, option.some_get, option.some_get] at h;
  exact injective_rowp B h

lemma injective_colg (B : partition m n) : injective B.colg :=
λ x y h, by rw [colg, colg, ← option.some_inj, option.some_get, option.some_get] at h;
  exact injective_colp B h

local infix ` ♣ `: 70 := pequiv.trans

def swap (B : partition m n) (r : fin m) (s : fin n) : partition m n :=
{ rowp := B.rowp.trans (equiv.swap (B.rowg r) (B.colg s)).to_pequiv,
  colp := B.colp.trans (equiv.swap (B.rowg r) (B.colg s)).to_pequiv,
  rowp_trans_rowp_symm := by rw [symm_trans_rev, ← trans_assoc, trans_assoc B.rowp,
      ← equiv.to_pequiv_symm,  ← equiv.to_pequiv_trans];
    simp,
  colp_trans_colp_symm := by rw [symm_trans_rev, ← trans_assoc, trans_assoc B.colp,
      ← equiv.to_pequiv_symm, ← equiv.to_pequiv_trans];
    simp,
  rowp_trans_colp_symm := by rw [symm_trans_rev, ← trans_assoc, trans_assoc B.rowp,
      ← equiv.to_pequiv_symm, ← equiv.to_pequiv_trans];
    simp }

lemma not_is_some_colp_of_is_some_rowp (B : partition m n) (j : fin (m + n)) :
  (B.rowp.symm j).is_some → (B.colp.symm j).is_some → false :=
begin
  rw [option.is_some_iff_exists, option.is_some_iff_exists],
  rintros ⟨i, hi⟩ ⟨k, hk⟩,
  have : B.rowp.trans B.colp.symm i = none,
  { rw [B.rowp_trans_colp_symm, pequiv.bot_apply] },
  rw [pequiv.trans_eq_none] at this,
  rw [pequiv.eq_some_iff] at hi,
  exact (this j k).resolve_left (not_not.2 hi) hk
end

@[simp] lemma rowg_mem (B : partition m n) (r : fin m) : (B.rowg r) ∈ B.rowp r :=
option.get_mem _

lemma rowp_eq_some_rowg (B : partition m n) (r : fin m) : B.rowp r = some (B.rowg r) :=
rowg_mem _ _

@[simp] lemma colg_mem (B : partition m n) (s : fin n) : (B.colg s) ∈ B.colp s :=
option.get_mem _

lemma colp_eq_some_colg (B : partition m n) (s : fin n) : B.colp s = some (B.colg s) :=
colg_mem _ _

@[simp] lemma rowp_rowg (B : partition m n) (r : fin m) : B.rowp.symm (B.rowg r) = some r :=
B.rowp.mem_iff_mem.2 (rowg_mem _ _)

@[simp] lemma colp_colg (B : partition m n) (s : fin n) : B.colp.symm (B.colg s) = some s :=
B.colp.mem_iff_mem.2 (colg_mem _ _)

lemma colp_ne_none_of_rowp_eq_none (B : partition m n) (v : fin (m + n))
  (hb : B.rowp.symm v = none) (hnb : B.colp.symm v = none) : false :=
have hs : card (univ.image B.rowg) = m,
  by rw [card_image_of_injective _ (B.injective_rowg), card_univ, card_fin],
have ht : card (univ.image B.colg) = n,
  by rw [card_image_of_injective _ (B.injective_colg), card_univ, card_fin],
have hst : disjoint (univ.image B.rowg) (univ.image B.colg),
  from finset.disjoint_left.2 begin
    simp only [mem_image, exists_imp_distrib, not_exists],
    assume v i _ hi j _ hj,
    subst hi,
    exact not_is_some_colp_of_is_some_rowp B (B.rowg i)
      (option.is_some_iff_exists.2 ⟨i, by simp⟩)
      (hj ▸ option.is_some_iff_exists.2 ⟨j, by simp⟩),
  end,
have (univ.image B.rowg) ∪ (univ.image B.colg) = univ,
  from eq_of_subset_of_card_le (λ _ _, mem_univ _)
    (by rw [card_disjoint_union hst, hs, ht, card_univ, card_fin]),
begin
  cases mem_union.1 (eq_univ_iff_forall.1 this v);
  rcases mem_image.1 h with ⟨_, _, h⟩; subst h; simp * at *
end

lemma is_some_rowp_iff (B : partition m n) (j : fin (m + n)) :
  (B.rowp.symm j).is_some ↔ ¬(B.colp.symm j).is_some :=
⟨not_is_some_colp_of_is_some_rowp B j,
  by erw [option.not_is_some_iff_eq_none, ← option.ne_none_iff_is_some, forall_swap];
    exact colp_ne_none_of_rowp_eq_none B j⟩

@[simp] lemma colp_rowg_eq_none (B : partition m n) (r : fin m) :
  B.colp.symm (B.rowg r) = none :=
option.not_is_some_iff_eq_none.1 ((B.is_some_rowp_iff _).1 (is_some_symm_get _ _))

@[simp] lemma rowp_colg_eq_none (B : partition m n) (s : fin n) :
  B.rowp.symm (B.colg s) = none :=
option.not_is_some_iff_eq_none.1 (mt (B.is_some_rowp_iff _).1 $ not_not.2 (is_some_symm_get _ _))

lemma eq_rowg_or_colg (B : partition m n) (i : fin (m + n)) :
  (∃ j, i = B.rowg j) ∨ (∃ j, i = B.colg j) :=
begin
  dsimp only [rowg, colg],
  by_cases h : ↥(B.rowp.symm i).is_some,
  { cases option.is_some_iff_exists.1 h with j hj,
    exact or.inl ⟨j, by rw [B.rowp.eq_some_iff] at hj;
      rw [← option.some_inj, ← hj, option.some_get]⟩ },
  { rw [(@not_iff_comm _ _ (classical.dec _) (classical.dec _)).1 (B.is_some_rowp_iff _).symm] at h,
    cases option.is_some_iff_exists.1 h with j hj,
    exact or.inr ⟨j, by rw [B.colp.eq_some_iff] at hj;
      rw [← option.some_inj, ← hj, option.some_get]⟩ }
end

lemma rowg_ne_colg (B : partition m n) (i : fin m) (j : fin n) : B.rowg i ≠ B.colg j :=
λ h, by simpa using congr_arg B.rowp.symm h

@[simp] lemma option.get_inj {α : Type*} : Π {a b : option α} {ha : a.is_some} {hb : b.is_some},
  option.get ha = option.get hb ↔ a = b
| (some a) (some b) _ _ := by rw [option.get_some, option.get_some, option.some_inj]

@[extensionality] lemma ext {B C : partition m n} (h : ∀ i, B.rowg i = C.rowg i)
  (h₂ : ∀ j, B.colg j = C.colg j) : B = C :=
begin
  cases B, cases C,
  simp [rowg, colg, function.funext_iff, pequiv.ext_iff] at *,
  tauto
end

@[simp] lemma single_rowg_mul_rowp (B : partition m n) (i : fin m) :
  ((single (0 : fin 1) (B.rowg i)).to_matrix : matrix _ _ ℚ) ⬝
    B.rowp.to_matrixᵀ = (single (0 : fin 1) i).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_mem _ (rowp_rowg _ _)]

@[simp] lemma single_rowg_mul_colp (B : partition m n) (i : fin m) :
  ((single (0 : fin 1) (B.rowg i)).to_matrix : matrix _ _ ℚ) ⬝
    B.colp.to_matrixᵀ = 0 :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_eq_none _ (colp_rowg_eq_none _ _),
  to_matrix_bot]; apply_instance

@[simp] lemma single_colg_mul_colp (B : partition m n) (k : fin n) :
  ((single (0 : fin 1) (B.colg k)).to_matrix : matrix _ _ ℚ) ⬝
    B.colp.to_matrixᵀ = (single (0 : fin 1) k).to_matrix :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_mem _ (colp_colg _ _)]

lemma single_colg_mul_rowp (B : partition m n) (k : fin n) :
  ((single (0 : fin 1) (B.colg k)).to_matrix : matrix _ _ ℚ) ⬝
    B.rowp.to_matrixᵀ = 0 :=
by rw [← to_matrix_symm, ← to_matrix_trans, single_trans_of_eq_none _ (rowp_colg_eq_none _ _),
  to_matrix_bot]; apply_instance

lemma colp_trans_rowp_symm (B : partition m n) : B.colp.trans B.rowp.symm = ⊥ :=
symm_injective $ by rw [symm_trans_rev, symm_symm, rowp_trans_colp_symm, symm_bot]

@[simp] lemma colp_mul_rowp_transpose (B : partition m n) :
  (B.colp.to_matrix : matrix _ _ ℚ) ⬝ B.rowp.to_matrixᵀ = 0 :=
by rw [← to_matrix_bot, ← B.colp_trans_rowp_symm, to_matrix_trans, to_matrix_symm]

@[simp] lemma rowp_mul_colp_transpose (B : partition m n) :
  (B.rowp.to_matrix : matrix _ _ ℚ) ⬝ B.colp.to_matrixᵀ = 0 :=
by rw [← to_matrix_bot, ← B.rowp_trans_colp_symm, to_matrix_trans, to_matrix_symm]

@[simp] lemma colp_mul_colp_transpose (B : partition m n) :
  (B.colp.to_matrix : matrix _ _ ℚ) ⬝ B.colp.to_matrixᵀ = 1 :=
by rw [← to_matrix_refl, ← B.colp_trans_colp_symm, to_matrix_trans, to_matrix_symm]

@[simp] lemma rowp_mul_rowp_transpose (B : partition m n) :
  (B.rowp.to_matrix : matrix _ _ ℚ) ⬝ B.rowp.to_matrixᵀ = 1 :=
by rw [← to_matrix_refl, ← B.rowp_trans_rowp_symm, to_matrix_trans, to_matrix_symm]

lemma transpose_mul_add_transpose_mul (B : partition m n) :
  (B.rowp.to_matrixᵀ ⬝ B.rowp.to_matrix : matrix _ _ ℚ) +
  B.colp.to_matrixᵀ ⬝ B.colp.to_matrix  = 1 :=
begin
  ext,
  repeat {rw [← to_matrix_symm, ← to_matrix_trans] },
  simp only [add_val, pequiv.symm_trans, pequiv.to_matrix, one_val,
    pequiv.mem_of_set_iff, set.mem_set_of_eq],
  have := is_some_rowp_iff B j,
  split_ifs; tauto
end

lemma swap_rowp_eq (B : partition m n) (r : fin m) (s : fin n) :
  (B.swap r s).rowp.to_matrix = (B.rowp.to_matrix : matrix _ _ ℚ)
  - (single r (B.rowg r)).to_matrix + (single r (B.colg s)).to_matrix :=
begin
  dsimp [swap],
  rw [to_matrix_trans, to_matrix_swap],
  simp only [matrix.mul_add, sub_eq_add_neg, matrix.mul_one, matrix.mul_neg,
    (to_matrix_trans _ _).symm, trans_single_of_mem _ (rowg_mem B r),
    trans_single_of_eq_none _ (rowp_colg_eq_none B s), to_matrix_bot, neg_zero, add_zero]
end

lemma swap_colp_eq (B : partition m n) (r : fin m) (s : fin n) :
  (B.swap r s).colp.to_matrix = (B.colp.to_matrix : matrix _ _ ℚ)
  - (single s (B.colg s)).to_matrix + (single s (B.rowg r)).to_matrix :=
begin
  dsimp [swap],
  rw [to_matrix_trans, to_matrix_swap],
  simp only [matrix.mul_add, sub_eq_add_neg, matrix.mul_one, matrix.mul_neg,
    (to_matrix_trans _ _).symm, trans_single_of_mem _ (colg_mem B s),
    trans_single_of_eq_none _ (colp_rowg_eq_none B r), to_matrix_bot, neg_zero, add_zero]
end

@[simp] lemma rowg_swap (B : partition m n) (r : fin m) (s : fin n) :
  (B.swap r s).rowg r = B.colg s :=
option.some_inj.1 begin
  dsimp [swap, rowg, colg, pequiv.trans],
  rw [option.some_get, option.some_get],
  conv in (B.rowp r) { rw rowp_eq_some_rowg },
  dsimp [equiv.to_pequiv, equiv.swap_apply_def, rowg],
  simp,
end

@[simp] lemma colg_swap (B : partition m n) (r : fin m) (s : fin n) :
  (B.swap r s).colg s = B.rowg r :=
option.some_inj.1 begin
  dsimp [swap, rowg, colg, pequiv.trans],
  rw [option.some_get, option.some_get],
  conv in (B.colp s) { rw colp_eq_some_colg },
  dsimp [equiv.to_pequiv, equiv.swap_apply_def, colg],
  rw [if_neg, if_pos rfl, option.some_get],
  exact (rowg_ne_colg _ _ _).symm
end

lemma rowg_swap_of_ne (B : partition m n) {i r : fin m} {s : fin n} (h : i ≠ r) :
  (B.swap r s).rowg i = B.rowg i :=
option.some_inj.1 begin
  dsimp [swap, rowg, colg, pequiv.trans],
  rw [option.some_get, option.bind_eq_some'],
  use [B.rowg i, rowp_eq_some_rowg _ _],
  dsimp [equiv.to_pequiv, equiv.swap_apply_def, option.get_some],
  rw [← colg, ← rowg, if_neg (rowg_ne_colg B i s), if_neg
    (mt B.injective_rowg.eq_iff.1 h), rowg]
end

lemma colg_swap_of_ne (B : partition m n) {r : fin m} {j s : fin n} (h : j ≠ s) :
  (B.swap r s).colg j = B.colg j :=
option.some_inj.1 begin
  dsimp [swap, rowg, colg, pequiv.trans],
  rw [option.some_get, option.bind_eq_some'],
  use [B.colg j, colp_eq_some_colg _ _],
  dsimp [equiv.to_pequiv, equiv.swap_apply_def, option.get_some],
  rw [← colg, ← rowg, if_neg (rowg_ne_colg B r j).symm, if_neg
    (mt B.injective_colg.eq_iff.1 h), colg]
end

lemma rowg_swap' (B : partition m n) (i r : fin m) (s : fin n) :
  (B.swap r s).rowg i = if i = r then B.colg s else B.rowg i :=
if hir : i = r then by simp [hir]
  else by rw [if_neg hir, rowg_swap_of_ne _ hir]

lemma colg_swap' (B : partition m n) (r : fin m) (j s : fin n) :
  (B.swap r s).colg j = if j = s then B.rowg r else B.colg j :=
if hjs : j = s then by simp [hjs]
  else by rw [if_neg hjs, colg_swap_of_ne _ hjs]

@[simp] lemma swap_swap (B : partition m n) (r : fin m) (s : fin n) :
  (B.swap r s).swap r s = B :=
by ext; intros; simp [rowg_swap', colg_swap']; split_ifs; cc

@[simp] lemma colp_trans_swap_rowp_symm (B : partition m n) (r : fin m) (s : fin n) :
  B.colp.trans (B.swap r s).rowp.symm = single s r :=
begin
  rw [swap, symm_trans_rev, ← equiv.to_pequiv_symm, ← equiv.perm.inv_def, equiv.swap_inv],
  ext i j,
  rw [mem_single_iff],
  dsimp [pequiv.trans, equiv.to_pequiv, equiv.swap_apply_def],
  simp only [coe, coe_mk_apply, option.mem_def, option.bind_eq_some'],
  rw [option.mem_def.1 (colg_mem B i)],
  simp [B.injective_colg.eq_iff, (B.rowg_ne_colg _ _).symm],
  split_ifs; simp [*, eq_comm]
end

@[simp] lemma colp_mul_swap_rowp_tranpose (B : partition m n) (r : fin m) (s : fin n) :
  (B.colp.to_matrix : matrix _ _ ℚ) ⬝ (B.swap r s).rowp.to_matrixᵀ = (single s r).to_matrix :=
by rw [← colp_trans_swap_rowp_symm, to_matrix_trans, to_matrix_symm]

lemma rowp_trans_swap_rowp_transpose (B : partition m n) (r : fin m) (s : fin n) :
  B.rowp.trans (B.swap r s).rowp.symm = of_set {i | i ≠ r} :=
begin
  rw [swap, symm_trans_rev, ← equiv.to_pequiv_symm, ← equiv.perm.inv_def, equiv.swap_inv],
  ext i j,
  dsimp [pequiv.trans, equiv.to_pequiv, equiv.swap_apply_def],
  simp only [coe, coe_mk_apply, option.mem_def, option.bind_eq_some'],
  rw [option.mem_def.1 (rowg_mem B i)],
  simp [B.injective_rowg.eq_iff, B.rowg_ne_colg],
  split_ifs,
  { simp * },
  { simp *; split; intros; simp * at * }
end

lemma swap_rowp_transpose_mul_single_of_ne (B : partition m n) {r : fin m}
  (s : fin n) {i : fin m} (hir : i ≠ r) :
  ((B.swap r s).rowp.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single i (0 : fin 1)).to_matrix =
  B.rowp.to_matrixᵀ ⬝ (single i 0).to_matrix :=
begin
  simp only [swap_rowp_eq, sub_eq_add_neg, matrix.mul_add, matrix.mul_neg, matrix.mul_one,
    matrix.add_mul, (to_matrix_trans _ _).symm, (to_matrix_symm _).symm, transpose_add,
    transpose_neg, matrix.neg_mul, symm_trans_rev, trans_assoc],
  rw [trans_single_of_mem _ (rowp_rowg _ _), trans_single_of_eq_none, trans_single_of_eq_none,
    to_matrix_bot, neg_zero, add_zero, add_zero];
  {dsimp [single]; simp [*, B.injective_rowg.eq_iff]} <|> apply_instance
end

@[simp] lemma swap_rowp_transpose_mul_single (B : partition m n) (r : fin m) (s : fin n) :
  ((B.swap r s).rowp.to_matrixᵀ : matrix _ _ ℚ) ⬝ (single r (0 : fin 1)).to_matrix =
  B.colp.to_matrixᵀ ⬝ (single s (0 : fin 1)).to_matrix :=
begin
  simp only [swap_rowp_eq, sub_eq_add_neg, matrix.mul_add, matrix.mul_neg, matrix.mul_one,
    matrix.add_mul, (to_matrix_trans _ _).symm, (to_matrix_symm _).symm, transpose_add,
    transpose_neg, matrix.neg_mul, symm_trans_rev, trans_assoc, symm_single],
  rw [trans_single_of_mem _ (rowp_rowg _ _), trans_single_of_mem _ (mem_single _ _),
    trans_single_of_mem _ (mem_single _ _), trans_single_of_mem _ (colp_colg _ _)],
  simp,
  all_goals {apply_instance}
end

def equiv_aux : partition m n ≃ Σ' (rowp : fin m ≃. fin (m + n))
  (colp : fin n ≃. fin (m + n))
  ( rowp_trans_rowp_symm : rowp.trans rowp.symm = pequiv.refl (fin m) )
( colp_trans_colp_symm : colp.trans colp.symm = pequiv.refl (fin n) ),
  rowp.trans colp.symm = ⊥ :=
{ to_fun := λ ⟨a, b, c, d, e⟩, ⟨a, b, c, d, e⟩,
  inv_fun := λ ⟨a, b, c, d, e⟩, ⟨a, b, c, d, e⟩,
  left_inv := λ ⟨_, _, _, _, _⟩, rfl,
  right_inv := λ ⟨_, _, _, _, _⟩, rfl }

end partition


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Mario Carneiro, Sean Leather
-/
import data.finset.card
import order.hom.basic

/-!
# Finite sets in `option α`

In this file we define

* `option.to_finset`: construct an empty or singleton `finset α` from an `option α`;
* `finset.insert_none`: given `s : finset α`, lift it to a finset on `option α` using `option.some`
  and then insert `option.none`;
* `finset.erase_none`: given `s : finset (option α)`, returns `t : finset α` such that
  `x ∈ t ↔ some x ∈ s`.

Then we prove some basic lemmas about these definitions.

## Tags

finset, option
-/

variables {α β : Type*}

open function

namespace option

/-- Construct an empty or singleton finset from an `option` -/
def to_finset (o : option α) : finset α := o.elim ∅ singleton

@[simp] theorem to_finset_none : none.to_finset = (∅ : finset α) := rfl

@[simp] theorem to_finset_some {a : α} : (some a).to_finset = {a} := rfl

@[simp] theorem mem_to_finset {a : α} {o : option α} : a ∈ o.to_finset ↔ a ∈ o :=
by cases o; simp [eq_comm]

theorem card_to_finset (o : option α) : o.to_finset.card = o.elim 0 1 :=
by cases o; refl

end option

namespace finset

/-- Given a finset on `α`, lift it to being a finset on `option α`
using `option.some` and then insert `option.none`. -/
def insert_none : finset α ↪o finset (option α) :=
order_embedding.of_map_le_iff (λ s, cons none (s.map embedding.some) $ by simp) $ λ s t,
  cons_subset_cons.trans map_subset_map

/-⟨none ::ₘ s.1.map some, multiset.nodup_cons.2
  ⟨by simp, multiset.nodup_map (λ a b, option.some.inj) s.2⟩⟩-/

@[simp] theorem mem_insert_none {s : finset α} : ∀ {o : option α},
  o ∈ s.insert_none ↔ ∀ a ∈ o, a ∈ s
| none     := iff_of_true (multiset.mem_cons_self _ _) (λ a h, by cases h)
| (some a) := multiset.mem_cons.trans $ by simp; refl

theorem some_mem_insert_none {s : finset α} {a : α} :
  some a ∈ s.insert_none ↔ a ∈ s := by simp

@[simp] theorem card_insert_none (s : finset α) : s.insert_none.card = s.card + 1 :=
by simp [insert_none]

/-- Given `s : finset (option α)`, `s.erase_none : finset α` is the set of `x : α` such that
`some x ∈ s`. -/
def erase_none : finset (option α) →o finset α :=
(finset.map_embedding (equiv.option_is_some_equiv α).to_embedding).to_order_hom.comp
  ⟨finset.subtype _, subtype_mono⟩

@[simp] lemma mem_erase_none {s : finset (option α)} {x : α} :
  x ∈ s.erase_none ↔ some x ∈ s :=
by simp [erase_none]

lemma erase_none_eq_bUnion [decidable_eq α] (s : finset (option α)) :
  s.erase_none = s.bUnion option.to_finset :=
by { ext, simp }

@[simp] lemma erase_none_map_some (s : finset α) : (s.map embedding.some).erase_none = s :=
by { ext, simp }

@[simp] lemma erase_none_image_some [decidable_eq (option α)] (s : finset α) :
  (s.image some).erase_none = s :=
by simpa only [map_eq_image] using erase_none_map_some s

@[simp] lemma coe_erase_none (s : finset (option α)) :
  (s.erase_none : set α) = some ⁻¹' s :=
set.ext $ λ x, mem_erase_none

@[simp] lemma erase_none_union [decidable_eq (option α)] [decidable_eq α]
  (s t : finset (option α)) :
  (s ∪ t).erase_none = s.erase_none ∪ t.erase_none :=
by { ext, simp }

@[simp] lemma erase_none_inter [decidable_eq (option α)] [decidable_eq α]
  (s t : finset (option α)) :
  (s ∩ t).erase_none = s.erase_none ∩ t.erase_none :=
by { ext, simp }

@[simp] lemma erase_none_empty : (∅ : finset (option α)).erase_none = ∅ := by { ext, simp }

@[simp] lemma erase_none_none : ({none} : finset (option α)).erase_none = ∅ := by { ext, simp }

@[simp] lemma image_some_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  s.erase_none.image some = s.erase none :=
by ext (_|x); simp

@[simp] lemma map_some_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  s.erase_none.map embedding.some = s.erase none :=
by rw [map_eq_image, embedding.some_apply, image_some_erase_none]

@[simp] lemma insert_none_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  insert_none (erase_none s) = insert none s :=
by ext (_|x); simp

@[simp] lemma erase_none_insert_none (s : finset α) : erase_none (insert_none s) = s :=
by { ext, simp }

end finset


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

import ring_theory.finite_type

/-!
# Polynomial module

In this file, we define the polynomial module for an `R`-module `M`, i.e. the `R[X]`-module `M[X]`.

This is defined as an type alias `polynomial_module R M := ℕ →₀ M`, since there might be different
module structures on `ℕ →₀ M` of interest. See the docstring of `polynomial_module` for details.

-/

universes u v

open polynomial
open_locale polynomial big_operators

variables (R M : Type*) [comm_ring R] [add_comm_group M] [module R M] (I : ideal R)

include R

/--
The `R[X]`-module `M[X]` for an `R`-module `M`.
This is isomorphic (as an `R`-module) to `M[X]` when `M` is a ring.

We require all the module instances `module S (polynomial_module R M)` to factor through `R` except
`module R[X] (polynomial_module R M)`.
In this constraint, we have the following instances for example :
- `R` acts on `polynomial_module R R[X]`
- `R[X]` acts on `polynomial_module R R[X]` as `R[Y]` acting on `R[X][Y]`
- `R` acts on `polynomial_module R[X] R[X]`
- `R[X]` acts on `polynomial_module R[X] R[X]` as `R[X]` acting on `R[X][Y]`
- `R[X][X]` acts on `polynomial_module R[X] R[X]` as `R[X][Y]` acting on itself

This is also the reason why `R` is included in the alias, or else there will be two different
instances of `module R[X] (polynomial_module R[X])`.

See https://leanprover.zulipchat.com/#narrow/stream/144837-PR-reviews/topic/.2315065.20polynomial.20modules
for the full discussion.
-/
@[derive add_comm_group, derive inhabited, nolint unused_arguments]
def polynomial_module := ℕ →₀ M

omit R

variables {M}
variables {S : Type*} [comm_semiring S] [algebra S R] [module S M] [is_scalar_tower S R M]

namespace polynomial_module

/-- This is required to have the `is_scalar_tower S R M` instance to avoid diamonds. -/
@[nolint unused_arguments]
noncomputable
instance : module S (polynomial_module R M) :=
finsupp.module ℕ M

instance : has_coe_to_fun (polynomial_module R M) (λ _, ℕ → M) :=
finsupp.has_coe_to_fun

/-- The monomial `m * x ^ i`. This is defeq to `finsupp.single_add_hom`, and is redefined here
so that it has the desired type signature.  -/
noncomputable
def single (i : ℕ) : M →+ polynomial_module R M :=
finsupp.single_add_hom i

lemma single_apply (i : ℕ) (m : M) (n : ℕ) : single R i m n = ite (i = n) m 0 :=
finsupp.single_apply

/-- `polynomial_module.single` as a linear map. -/
noncomputable
def lsingle (i : ℕ) : M →ₗ[R] polynomial_module R M :=
finsupp.lsingle i

lemma lsingle_apply (i : ℕ) (m : M) (n : ℕ) : lsingle R i m n = ite (i = n) m 0 :=
finsupp.single_apply

variable {R}

lemma induction_linear {P : polynomial_module R M → Prop} (f : polynomial_module R M)
  (h0 : P 0) (hadd : ∀ f g, P f → P g → P (f + g)) (hsingle : ∀ a b, P (single R a b)) : P f :=
finsupp.induction_linear f h0 hadd hsingle

@[semireducible] noncomputable
instance polynomial_module : module R[X] (polynomial_module R M) :=
module_polynomial_of_endo (finsupp.lmap_domain _ _ nat.succ)

instance (M : Type u) [add_comm_group M] [module R M] [module S M] [is_scalar_tower S R M] :
  is_scalar_tower S R (polynomial_module R M) :=
finsupp.is_scalar_tower _ _

instance is_scalar_tower' (M : Type u) [add_comm_group M] [module R M] [module S M]
  [is_scalar_tower S R M] :
  is_scalar_tower S R[X] (polynomial_module R M) :=
begin
  haveI : is_scalar_tower R R[X] (polynomial_module R M) :=
    module_polynomial_of_endo.is_scalar_tower _,
  constructor,
  intros x y z,
  rw [← @is_scalar_tower.algebra_map_smul S R, ← @is_scalar_tower.algebra_map_smul S R,
    smul_assoc],
end

@[simp]
lemma monomial_smul_single (i : ℕ) (r : R) (j : ℕ) (m : M) :
  monomial i r • single R j m = single R (i + j) (r • m) :=
begin
  simp only [linear_map.mul_apply, polynomial.aeval_monomial, linear_map.pow_apply,
    module.algebra_map_End_apply, module_polynomial_of_endo_smul_def],
  induction i generalizing r j m,
  { simp [single] },
  { rw [function.iterate_succ, function.comp_app, nat.succ_eq_add_one, add_assoc, ← i_ih],
    congr' 2,
    ext a,
    dsimp [single],
    rw [finsupp.map_domain_single, nat.succ_eq_one_add] }
end

@[simp]
lemma monomial_smul_apply (i : ℕ) (r : R) (g : polynomial_module R M) (n : ℕ) :
  (monomial i r • g) n = ite (i ≤ n) (r • g (n - i)) 0 :=
begin
  induction g using polynomial_module.induction_linear with p q hp hq,
  { simp only [smul_zero, finsupp.zero_apply, if_t_t] },
  { simp only [smul_add, finsupp.add_apply, hp, hq],
    split_ifs, exacts [rfl, zero_add 0] },
  { rw [monomial_smul_single, single_apply, single_apply, smul_ite, smul_zero, ← ite_and],
    congr,
    rw eq_iff_iff,
    split,
    { rintro rfl, simp },
    { rintro ⟨e, rfl⟩, rw [add_comm, tsub_add_cancel_of_le e] } }
end

@[simp]
lemma smul_single_apply (i : ℕ) (f : R[X]) (m : M) (n : ℕ) :
  (f • single R i m) n = ite (i ≤ n) (f.coeff (n - i) • m) 0 :=
begin
  induction f using polynomial.induction_on' with p q hp hq,
  { rw [add_smul, finsupp.add_apply, hp, hq, coeff_add, add_smul],
    split_ifs, exacts [rfl, zero_add 0] },
  { rw [monomial_smul_single, single_apply, coeff_monomial, ite_smul, zero_smul],
    by_cases h : i ≤ n,
    { simp_rw [eq_tsub_iff_add_eq_of_le h, if_pos h] },
    { rw [if_neg h, ite_eq_right_iff], intro e, exfalso, linarith } }
end

lemma smul_apply (f : R[X]) (g : polynomial_module R M) (n : ℕ) :
  (f • g) n = ∑ x in finset.nat.antidiagonal n, f.coeff x.1 • g x.2 :=
begin
  induction f using polynomial.induction_on' with p q hp hq,
  { rw [add_smul, finsupp.add_apply, hp, hq, ← finset.sum_add_distrib],
    congr',
    ext,
    rw [coeff_add, add_smul] },
  { rw [finset.nat.sum_antidiagonal_eq_sum_range_succ (λ i j, (monomial f_n f_a).coeff i • g j),
      monomial_smul_apply],
    dsimp [monomial],
    simp_rw [finsupp.single_smul, finsupp.single_apply],
    rw finset.sum_ite_eq,
    simp [nat.lt_succ_iff] }
end

/-- `polynomial_module R R` is isomorphic to `R[X]` as an `R[X]` module. -/
noncomputable
def equiv_polynomial_self : polynomial_module R R ≃ₗ[R[X]] R[X] :=
{ map_smul' := λ r x, begin
    induction r using polynomial.induction_on' with _ _ _ _ n p,
    { simp only [add_smul, map_add, ring_equiv.to_fun_eq_coe, *] at * },
    { ext i,
      dsimp,
      rw [monomial_smul_apply, ← polynomial.C_mul_X_pow_eq_monomial, mul_assoc,
        polynomial.coeff_C_mul, polynomial.coeff_X_pow_mul', mul_ite, mul_zero],
      simp }
  end,
  ..(polynomial.to_finsupp_iso R).symm  }

/-- `polynomial_module R S` is isomorphic to `S[X]` as an `R` module. -/
noncomputable
def equiv_polynomial {S : Type*} [comm_ring S] [algebra R S] :
  polynomial_module R S ≃ₗ[R] S[X] :=
{ map_smul' := λ r x, rfl, ..(polynomial.to_finsupp_iso S).symm  }

variables (R' : Type*) {M' : Type*} [comm_ring R'] [add_comm_group M'] [module R' M']
variables [algebra R R'] [module R M'] [is_scalar_tower R R' M']

/-- The image of a polynomial under a linear map. -/
noncomputable
def map (f : M →ₗ[R] M') : polynomial_module R M →ₗ[R] polynomial_module R' M' :=
finsupp.map_range.linear_map f

@[simp]
lemma map_single (f : M →ₗ[R] M') (i : ℕ) (m : M) :
  map R' f (single R i m) = single R' i (f m) :=
finsupp.map_range_single

lemma map_smul (f : M →ₗ[R] M') (p : R[X]) (q : polynomial_module R M) :
  map R' f (p • q) = p.map (algebra_map R R') • map R' f q :=
begin
  apply induction_linear q,
  { rw [smul_zero, map_zero, smul_zero] },
  { intros f g e₁ e₂, rw [smul_add, map_add, e₁, e₂, map_add, smul_add] },
  intros i m,
  apply polynomial.induction_on' p,
  { intros p q e₁ e₂, rw [add_smul, map_add, e₁, e₂, polynomial.map_add, add_smul] },
  { intros j s,
    rw [monomial_smul_single, map_single, polynomial.map_monomial, map_single,
      monomial_smul_single, f.map_smul, algebra_map_smul] }
end

/-- Evaulate a polynomial `p : polynomial_module R M` at `r : R`. -/
@[simps (lemmas_only)]
def eval (r : R) : polynomial_module R M →ₗ[R] M :=
{ to_fun := λ p, p.sum (λ i m, r ^ i • m),
  map_add' := λ x y, finsupp.sum_add_index' (λ _, smul_zero _) (λ _ _ _, smul_add _ _ _),
  map_smul' := λ s m, begin
    refine (finsupp.sum_smul_index' _).trans _,
    { exact λ i, smul_zero _ },
    { simp_rw [← smul_comm s, ← finsupp.smul_sum], refl }
  end }

@[simp]
lemma eval_single (r : R) (i : ℕ) (m : M) : eval r (single R i m) = r ^ i • m :=
finsupp.sum_single_index (smul_zero _)

@[simp]
lemma eval_lsingle (r : R) (i : ℕ) (m : M) : eval r (lsingle R i m) = r ^ i • m :=
eval_single r i m

lemma eval_smul (p : R[X]) (q : polynomial_module R M) (r : R) :
  eval r (p • q) = p.eval r • eval r q :=
begin
  apply induction_linear q,
  { rw [smul_zero, map_zero, smul_zero] },
  { intros f g e₁ e₂, rw [smul_add, map_add, e₁, e₂, map_add, smul_add] },
  intros i m,
  apply polynomial.induction_on' p,
  { intros p q e₁ e₂, rw [add_smul, map_add, polynomial.eval_add, e₁, e₂, add_smul] },
  { intros j s,
    rw [monomial_smul_single, eval_single, polynomial.eval_monomial, eval_single,
      smul_comm, ← smul_smul, pow_add, mul_smul] }
end

@[simp]
lemma eval_map (f : M →ₗ[R] M') (q : polynomial_module R M) (r : R) :
  eval (algebra_map R R' r) (map R' f q) = f (eval r q) :=
begin
  apply induction_linear q,
  { simp_rw map_zero },
  { intros f g e₁ e₂, simp_rw [map_add, e₁, e₂] },
  { intros i m,
    rw [map_single, eval_single, eval_single, f.map_smul, ← map_pow, algebra_map_smul] }
end

@[simp]
lemma eval_map' (f : M →ₗ[R] M) (q : polynomial_module R M) (r : R) :
  eval r (map R f q) = f (eval r q) :=
eval_map R f q r

/-- `comp p q` is the composition of `p : R[X]` and `q : M[X]` as `q(p(x))`.  -/
@[simps] noncomputable
def comp (p : R[X]) : polynomial_module R M →ₗ[R] polynomial_module R M :=
((eval p).restrict_scalars R).comp (map R[X] (lsingle R 0))

lemma comp_single (p : R[X]) (i : ℕ) (m : M) : comp p (single R i m) = p ^ i • single R 0 m :=
begin
  rw comp_apply,
  erw [map_single, eval_single],
  refl
end

lemma comp_eval (p : R[X]) (q : polynomial_module R M) (r : R) :
  eval r (comp p q) = eval (p.eval r) q :=
begin
  rw ← linear_map.comp_apply,
  apply induction_linear q,
  { rw [map_zero, map_zero] },
  { intros _ _ e₁ e₂, rw [map_add, map_add, e₁, e₂] },
  { intros i m,
    rw [linear_map.comp_apply, comp_single, eval_single, eval_smul, eval_single, pow_zero,
      one_smul, polynomial.eval_pow] }
end

lemma comp_smul (p p' : R[X]) (q : polynomial_module R M) :
  comp p (p' • q) = p'.comp p • comp p q :=
begin
  rw [comp_apply, map_smul, eval_smul, polynomial.comp, polynomial.eval_map, comp_apply],
  refl
end

end polynomial_module