/-
Copyright (c) 2021 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin
-/
import algebra.module.basic
import tactic.abel

/-!
# Symmetrized algebra

A commutative multiplication on a real or complex space can be constructed from any multiplication
by "symmetrization" i.e
$$
a \circ b = \frac{1}{2}(ab + ba)
$$

We provide the symmetrized version of a type `α` as `sym_alg α`, with notation `αˢʸᵐ`.

## Implementation notes

The approach taken here is inspired by algebra.opposites. We use Oxford Spellings
(IETF en-GB-oxendict).

## References

* [Hanche-Olsen and Størmer, Jordan Operator Algebras][hancheolsenstormer1984]
-/

open function

/--
The symmetrized algebra has the same underlying space as the original algebra.
-/
def sym_alg (α : Type*) : Type* := α

postfix `ˢʸᵐ`:std.prec.max_plus := sym_alg

namespace sym_alg

variables {α : Type*}

/-- The element of `sym_alg α` that represents `a : α`. -/
@[pattern,pp_nodot]
def sym : α → αˢʸᵐ := id

/-- The element of `α` represented by `x : αˢʸᵐ`. -/
@[pp_nodot]
def unsym : αˢʸᵐ → α := id

@[simp] lemma unsym_sym (a : α) : unsym (sym a) = a := rfl
@[simp] lemma sym_unsym (a : α) : sym (unsym a) = a := rfl

@[simp] lemma sym_comp_unsym : (sym : α → αˢʸᵐ) ∘ unsym = id := rfl
@[simp] lemma unsym_comp_sym : (unsym : αˢʸᵐ → α) ∘ sym = id := rfl

/-- The canonical bijection between `α` and `αˢʸᵐ`. -/
@[simps apply symm_apply { fully_applied := ff }]
def sym_equiv : α ≃ αˢʸᵐ := ⟨sym, unsym, unsym_sym, sym_unsym⟩

lemma sym_bijective : bijective (sym : α → αˢʸᵐ) := sym_equiv.bijective
lemma unsym_bijective : bijective (unsym : αˢʸᵐ → α) := sym_equiv.symm.bijective
lemma sym_injective : injective (sym : α → αˢʸᵐ) := sym_bijective.injective
lemma sym_surjective : surjective (sym : α → αˢʸᵐ) := sym_bijective.surjective
lemma unsym_injective : injective (unsym : αˢʸᵐ → α) := unsym_bijective.injective
lemma unsym_surjective : surjective (unsym : αˢʸᵐ → α) := unsym_bijective.surjective

@[simp] lemma sym_inj {a b : α} : sym a = sym b ↔ a = b := sym_injective.eq_iff
@[simp] lemma unsym_inj {a b : αˢʸᵐ} : unsym a = unsym b ↔ a = b := unsym_injective.eq_iff

instance [nontrivial α] : nontrivial αˢʸᵐ := sym_injective.nontrivial
instance [inhabited α] : inhabited αˢʸᵐ := ⟨sym default⟩
instance [subsingleton α] : subsingleton αˢʸᵐ := unsym_injective.subsingleton
instance [unique α] : unique αˢʸᵐ := unique.mk' _
instance [is_empty α] : is_empty αˢʸᵐ := function.is_empty unsym

@[to_additive]
instance [has_one α] : has_one αˢʸᵐ := { one := sym 1 }

instance [has_add α] : has_add αˢʸᵐ :=
{ add := λ a b, sym (unsym a + unsym b) }

instance [has_sub α] : has_sub αˢʸᵐ := { sub := λ a b, sym (unsym a - unsym b) }

instance [has_neg α] : has_neg αˢʸᵐ :=
{ neg := λ a, sym (-unsym a) }

/- Introduce the symmetrized multiplication-/
instance [has_add α] [has_mul α] [has_one α] [invertible (2 : α)] : has_mul (αˢʸᵐ) :=
{ mul := λ a b, sym (⅟2 * (unsym a * unsym b + unsym b * unsym a)) }

@[to_additive] instance [has_inv α] : has_inv αˢʸᵐ :=
{ inv := λ a, sym $ (unsym a)⁻¹ }

instance (R : Type*) [has_smul R α] : has_smul R αˢʸᵐ :=
{ smul := λ r a, sym (r • unsym a) }

@[simp, to_additive] lemma sym_one [has_one α] : sym (1 : α) = 1 := rfl
@[simp, to_additive] lemma unsym_one [has_one α] : unsym (1 : αˢʸᵐ) = 1 := rfl

@[simp] lemma sym_add [has_add α] (a b : α) : sym (a + b) = sym a + sym b := rfl
@[simp] lemma unsym_add [has_add α] (a b : αˢʸᵐ) : unsym (a + b) = unsym a + unsym b := rfl

@[simp] lemma sym_sub [has_sub α] (a b : α) : sym (a - b) = sym a - sym b := rfl
@[simp] lemma unsym_sub [has_sub α] (a b : αˢʸᵐ) : unsym (a - b) = unsym a - unsym b := rfl

@[simp] lemma sym_neg [has_neg α] (a : α) : sym (-a) = -sym a := rfl
@[simp] lemma unsym_neg [has_neg α] (a : αˢʸᵐ) : unsym (-a) = -unsym a := rfl

lemma mul_def [has_add α] [has_mul α] [has_one α] [invertible (2 : α)] (a b : αˢʸᵐ) :
  a * b = sym (⅟2*(unsym a * unsym b + unsym b * unsym a)) := by refl

lemma unsym_mul [has_mul α] [has_add α] [has_one α] [invertible (2 : α)] (a b : αˢʸᵐ) :
  unsym (a * b) = ⅟2*(unsym a * unsym b + unsym b * unsym a) := by refl

lemma sym_mul_sym [has_mul α] [has_add α] [has_one α] [invertible (2 : α)] (a b : α) :
  sym a * sym b = sym (⅟2*(a * b + b * a)) :=
rfl

@[simp, to_additive] lemma sym_inv [has_inv α] (a : α) : sym (a⁻¹) = (sym a)⁻¹ := rfl
@[simp, to_additive] lemma unsym_inv [has_inv α] (a : αˢʸᵐ) : unsym (a⁻¹) = (unsym a)⁻¹ := rfl

@[simp] lemma sym_smul {R : Type*} [has_smul R α] (c : R) (a : α) : sym (c • a) = c • sym a := rfl
@[simp] lemma unsym_smul {R : Type*} [has_smul R α] (c : R) (a : αˢʸᵐ) :
  unsym (c • a) = c • unsym a := rfl

@[simp, to_additive] lemma unsym_eq_one_iff [has_one α] (a : αˢʸᵐ) : a.unsym = 1 ↔ a = 1 :=
unsym_injective.eq_iff' rfl

@[simp, to_additive] lemma sym_eq_one_iff [has_one α] (a : α) : sym a = 1 ↔ a = 1 :=
sym_injective.eq_iff' rfl

@[to_additive] lemma unsym_ne_one_iff [has_one α] (a : αˢʸᵐ) : a.unsym ≠ (1 : α) ↔ a ≠ (1 : αˢʸᵐ) :=
not_congr $ unsym_eq_one_iff a

@[to_additive] lemma sym_ne_one_iff [has_one α] (a : α) : sym a ≠ (1 : αˢʸᵐ) ↔ a ≠ (1 : α) :=
not_congr $ sym_eq_one_iff a

instance [add_comm_semigroup α] : add_comm_semigroup (αˢʸᵐ) :=
unsym_injective.add_comm_semigroup _ unsym_add

instance [add_monoid α] : add_monoid (αˢʸᵐ) :=
unsym_injective.add_monoid _ unsym_zero unsym_add (λ _ _, rfl)

instance [add_group α] : add_group (αˢʸᵐ) :=
unsym_injective.add_group _ unsym_zero
  unsym_add unsym_neg unsym_sub (λ _ _, rfl) (λ _ _, rfl)

instance [add_comm_monoid α] : add_comm_monoid (αˢʸᵐ) :=
{ ..sym_alg.add_comm_semigroup, ..sym_alg.add_monoid }

instance [add_comm_group α] : add_comm_group (αˢʸᵐ) :=
{ ..sym_alg.add_comm_monoid, ..sym_alg.add_group }

instance {R : Type*} [semiring R] [add_comm_monoid α] [module R α] : module R αˢʸᵐ :=
function.injective.module R ⟨unsym, unsym_zero, unsym_add⟩ unsym_injective unsym_smul

instance [has_mul α] [has_add α] [has_one α] [invertible (2 : α)] (a : α) [invertible a] :
  invertible (sym a) :=
{ inv_of := sym (⅟a),
  inv_of_mul_self := begin
    rw [sym_mul_sym, mul_inv_of_self, inv_of_mul_self, ←bit0, inv_of_mul_self, sym_one],
  end,
  mul_inv_of_self := begin
    rw [sym_mul_sym, mul_inv_of_self, inv_of_mul_self, ←bit0, inv_of_mul_self, sym_one],
  end }

@[simp] lemma inv_of_sym [has_mul α] [has_add α] [has_one α] [invertible (2 : α)] (a : α)
  [invertible a] : ⅟(sym a) = sym (⅟a) := rfl

instance [semiring α] [invertible (2 : α)] : non_assoc_semiring (αˢʸᵐ) :=
{ one := 1,
  mul := (*),
  zero := (0),
  zero_mul := λ _, by rw [mul_def, unsym_zero, zero_mul, mul_zero, add_zero, mul_zero, sym_zero],
  mul_zero := λ _, by rw [mul_def, unsym_zero, zero_mul, mul_zero, add_zero, mul_zero, sym_zero],
  mul_one := λ _, by rw [mul_def, unsym_one, mul_one, one_mul, ←two_mul, inv_of_mul_self_assoc,
                         sym_unsym],
  one_mul := λ _, by rw [mul_def, unsym_one, mul_one, one_mul, ←two_mul, inv_of_mul_self_assoc,
                         sym_unsym],
  left_distrib := λ a b c, match a, b, c with
    | sym a, sym b, sym c := begin
      rw [sym_mul_sym, sym_mul_sym, ←sym_add, sym_mul_sym, ←sym_add, mul_add a, add_mul _ _ a,
        add_add_add_comm, mul_add],
    end
  end,
  right_distrib := λ a b c, match a, b, c with
    | sym a, sym b, sym c := begin
      rw [sym_mul_sym, sym_mul_sym, ←sym_add, sym_mul_sym, ←sym_add, mul_add c, add_mul _ _ c,
        add_add_add_comm, mul_add],
    end
  end,
  ..sym_alg.add_comm_monoid, }

/-- The symmetrization of a real (unital, associative) algebra is a non-associative ring. -/
instance [ring α] [invertible (2 : α)] : non_assoc_ring (αˢʸᵐ) :=
{ ..sym_alg.non_assoc_semiring,
  ..sym_alg.add_comm_group, }

/-! The squaring operation coincides for both multiplications -/

lemma unsym_mul_self [semiring α] [invertible (2 : α)] (a : αˢʸᵐ) :
  unsym (a*a) = unsym a * unsym a :=
by rw [mul_def, unsym_sym, ←two_mul, inv_of_mul_self_assoc]

lemma sym_mul_self [semiring α] [invertible (2 : α)] (a : α) : sym (a*a) = sym a * sym a :=
by rw [sym_mul_sym, ←two_mul, inv_of_mul_self_assoc]

lemma mul_comm [has_mul α] [add_comm_semigroup α] [has_one α] [invertible (2 : α)] (a b : αˢʸᵐ) :
  a * b = b * a :=
by rw [mul_def, mul_def, add_comm]

end sym_alg


/-
Copyright (c) 2022 Paul A. Reichert. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul A. Reichert
-/
import analysis.convex.basic
import analysis.normed_space.basic
import topology.metric_space.hausdorff_distance

/-!
# Convex bodies

This file contains the definition of the type `convex_body V`
consisting of
convex, compact, nonempty subsets of a real topological vector space `V`.

`convex_body V` is a module over the nonnegative reals (`nnreal`) and a pseudo-metric space.
If `V` is a normed space, `convex_body V` is a metric space.

## TODO

- define positive convex bodies, requiring the interior to be nonempty
- introduce support sets
- Characterise the interaction of the distance with algebraic operations, eg
  `dist (a • K) (a • L) = ‖a‖ * dist K L`, `dist (a +ᵥ K) (a +ᵥ L) = dist K L`

## Tags

convex, convex body
-/

open_locale pointwise
open_locale nnreal

variables {V : Type*}

/--
Let `V` be a real topological vector space. A subset of `V` is a convex body if and only if
it is convex, compact, and nonempty.
-/
structure convex_body (V : Type*) [topological_space V] [add_comm_monoid V] [has_smul ℝ V] :=
(carrier : set V)
(convex' : convex ℝ carrier)
(is_compact' : is_compact carrier)
(nonempty' : carrier.nonempty)

namespace convex_body
section TVS
variables [topological_space V] [add_comm_group V] [module ℝ V]

instance : set_like (convex_body V) V :=
{ coe := convex_body.carrier,
  coe_injective' := λ K L h, by { cases K, cases L, congr' } }

protected lemma convex (K : convex_body V) : convex ℝ (K : set V) := K.convex'
protected lemma is_compact (K : convex_body V) : is_compact (K : set V) := K.is_compact'
protected lemma nonempty (K : convex_body V) : (K : set V).nonempty := K.nonempty'

@[ext]
protected lemma ext {K L : convex_body V} (h : (K : set V) = L) : K = L := set_like.ext' h

@[simp]
lemma coe_mk (s : set V) (h₁ h₂ h₃) : (mk s h₁ h₂ h₃ : set V) = s := rfl

section has_continuous_add
variables [has_continuous_add V]

instance : add_monoid (convex_body V) :=
-- we cannot write K + L to avoid reducibility issues with the set.has_add instance
{ add := λ K L, ⟨set.image2 (+) K L,
                 K.convex.add L.convex,
                 K.is_compact.add L.is_compact,
                 K.nonempty.add L.nonempty⟩,
  add_assoc := λ K L M, by { ext, simp only [coe_mk, set.image2_add, add_assoc] },
  zero := ⟨0, convex_singleton 0, is_compact_singleton, set.singleton_nonempty 0⟩,
  zero_add := λ K, by { ext, simp only [coe_mk, set.image2_add, zero_add] },
  add_zero := λ K, by { ext, simp only [coe_mk, set.image2_add, add_zero] } }

@[simp]
lemma coe_add (K L : convex_body V) : (↑(K + L) : set V) = (K : set V) + L := rfl

@[simp]
lemma coe_zero : (↑(0 : convex_body V) : set V) = 0 := rfl

instance : inhabited (convex_body V) := ⟨0⟩

instance : add_comm_monoid (convex_body V) :=
{ add_comm := λ K L, by { ext, simp only [coe_add, add_comm] },
  .. convex_body.add_monoid }

end has_continuous_add

variables [has_continuous_smul ℝ V]

instance : has_smul ℝ (convex_body V) :=
{ smul := λ c K, ⟨c • (K : set V), K.convex.smul _, K.is_compact.smul _, K.nonempty.smul_set⟩ }

@[simp]
lemma coe_smul (c : ℝ) (K : convex_body V) : (↑(c • K) : set V) = c • (K : set V) := rfl

variables [has_continuous_add V]

instance : distrib_mul_action ℝ (convex_body V) :=
{ to_has_smul := convex_body.has_smul,
  one_smul := λ K, by { ext, simp only [coe_smul, one_smul] },
  mul_smul := λ c d K, by { ext, simp only [coe_smul, mul_smul] },
  smul_add := λ c K L, by { ext, simp only [coe_smul, coe_add, smul_add] },
  smul_zero := λ c, by { ext, simp only [coe_smul, coe_zero, smul_zero] } }

@[simp]
lemma coe_smul' (c : ℝ≥0) (K : convex_body V) : (↑(c • K) : set V) = c • (K : set V) := rfl

/--
The convex bodies in a fixed space $V$ form a module over the nonnegative reals.
-/
instance : module ℝ≥0 (convex_body V) :=
{ add_smul := λ c d K,
  begin
    ext1,
    simp only [coe_smul, coe_add],
    exact convex.add_smul K.convex (nnreal.coe_nonneg _) (nnreal.coe_nonneg _),
  end,
  zero_smul := λ K, by { ext1, exact set.zero_smul_set K.nonempty } }

end TVS

section seminormed_add_comm_group
variables [seminormed_add_comm_group V] [normed_space ℝ V] (K L : convex_body V)

protected lemma bounded : metric.bounded (K : set V) := K.is_compact.bounded

lemma Hausdorff_edist_ne_top {K L : convex_body V} : emetric.Hausdorff_edist (K : set V) L ≠ ⊤ :=
by apply_rules [metric.Hausdorff_edist_ne_top_of_nonempty_of_bounded, convex_body.nonempty,
  convex_body.bounded]

/-- Convex bodies in a fixed seminormed space $V$ form a pseudo-metric space under the Hausdorff
metric. -/
noncomputable instance : pseudo_metric_space (convex_body V) :=
{ dist := λ K L, metric.Hausdorff_dist (K : set V) L,
  dist_self := λ _, metric.Hausdorff_dist_self_zero,
  dist_comm := λ _ _, metric.Hausdorff_dist_comm,
  dist_triangle := λ K L M, metric.Hausdorff_dist_triangle Hausdorff_edist_ne_top }

@[simp, norm_cast]
lemma Hausdorff_dist_coe : metric.Hausdorff_dist (K : set V) L = dist K L := rfl

@[simp, norm_cast] lemma Hausdorff_edist_coe : emetric.Hausdorff_edist (K : set V) L = edist K L :=
by { rw edist_dist, exact (ennreal.of_real_to_real Hausdorff_edist_ne_top).symm }

end seminormed_add_comm_group

section normed_add_comm_group
variables [normed_add_comm_group V] [normed_space ℝ V]

/-- Convex bodies in a fixed normed space `V` form a metric space under the Hausdorff metric. -/
noncomputable instance : metric_space (convex_body V) :=
{ eq_of_dist_eq_zero := λ K L hd, convex_body.ext $
    (K.is_compact.is_closed.Hausdorff_dist_zero_iff_eq
      L.is_compact.is_closed Hausdorff_edist_ne_top).mp hd }

end normed_add_comm_group
end convex_body


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

! This file was ported from Lean 3 source module data.nat.factorization.prime_pow
! leanprover-community/mathlib commit 6ca1a09bc9aa75824bf97388c9e3b441fc4ccf3f
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.IsPrimePow
import Mathbin.Data.Nat.Factorization.Basic

/-!
# Prime powers and factorizations

This file deals with factorizations of prime powers.
-/

variable {R : Type _} [CommMonoidWithZero R] (n p : R) (k : ℕ)

#print IsPrimePow.minFac_pow_factorization_eq /-
theorem IsPrimePow.minFac_pow_factorization_eq {n : ℕ} (hn : IsPrimePow n) :
    n.minFac ^ n.factorization n.minFac = n :=
  by
  obtain ⟨p, k, hp, hk, rfl⟩ := hn
  rw [← Nat.prime_iff] at hp
  rw [hp.pow_min_fac hk.ne', hp.factorization_pow, Finsupp.single_eq_same]
#align is_prime_pow.min_fac_pow_factorization_eq IsPrimePow.minFac_pow_factorization_eq
-/

#print isPrimePow_of_minFac_pow_factorization_eq /-
theorem isPrimePow_of_minFac_pow_factorization_eq {n : ℕ}
    (h : n.minFac ^ n.factorization n.minFac = n) (hn : n ≠ 1) : IsPrimePow n :=
  by
  rcases eq_or_ne n 0 with (rfl | hn')
  · simpa using h
  refine' ⟨_, _, (Nat.minFac_prime hn).Prime, _, h⟩
  rw [pos_iff_ne_zero, ← Finsupp.mem_support_iff, Nat.factor_iff_mem_factorization,
    Nat.mem_factors_iff_dvd hn' (Nat.minFac_prime hn)]
  apply Nat.minFac_dvd
#align is_prime_pow_of_min_fac_pow_factorization_eq isPrimePow_of_minFac_pow_factorization_eq
-/

#print isPrimePow_iff_minFac_pow_factorization_eq /-
theorem isPrimePow_iff_minFac_pow_factorization_eq {n : ℕ} (hn : n ≠ 1) :
    IsPrimePow n ↔ n.minFac ^ n.factorization n.minFac = n :=
  ⟨fun h => h.minFac_pow_factorization_eq, fun h => isPrimePow_of_minFac_pow_factorization_eq h hn⟩
#align is_prime_pow_iff_min_fac_pow_factorization_eq isPrimePow_iff_minFac_pow_factorization_eq
-/

#print isPrimePow_iff_factorization_eq_single /-
theorem isPrimePow_iff_factorization_eq_single {n : ℕ} :
    IsPrimePow n ↔ ∃ p k : ℕ, 0 < k ∧ n.factorization = Finsupp.single p k :=
  by
  rw [isPrimePow_nat_iff]
  refine' exists₂_congr fun p k => _
  constructor
  · rintro ⟨hp, hk, hn⟩
    exact ⟨hk, by rw [← hn, Nat.Prime.factorization_pow hp]⟩
  · rintro ⟨hk, hn⟩
    have hn0 : n ≠ 0 := by
      rintro rfl
      simpa only [Finsupp.single_eq_zero, eq_comm, Nat.factorization_zero, hk.ne'] using hn
    rw [Nat.eq_pow_of_factorization_eq_single hn0 hn]
    exact
      ⟨Nat.prime_of_mem_factorization (by simp [hn, hk.ne'] : p ∈ n.factorization.support), hk, rfl⟩
#align is_prime_pow_iff_factorization_eq_single isPrimePow_iff_factorization_eq_single
-/

#print isPrimePow_iff_card_support_factorization_eq_one /-
theorem isPrimePow_iff_card_support_factorization_eq_one {n : ℕ} :
    IsPrimePow n ↔ n.factorization.support.card = 1 := by
  simp_rw [isPrimePow_iff_factorization_eq_single, Finsupp.card_support_eq_one', exists_prop,
    pos_iff_ne_zero]
#align is_prime_pow_iff_card_support_factorization_eq_one isPrimePow_iff_card_support_factorization_eq_one
-/

#print IsPrimePow.exists_ord_compl_eq_one /-
theorem IsPrimePow.exists_ord_compl_eq_one {n : ℕ} (h : IsPrimePow n) :
    ∃ p : ℕ, p.Prime ∧ ord_compl[p] n = 1 :=
  by
  rcases eq_or_ne n 0 with (rfl | hn0); · cases not_isPrimePow_zero h
  rcases is_prime_pow_iff_factorization_eq_single.mp h with ⟨p, k, hk0, h1⟩
  rcases em' p.prime with (pp | pp)
  · refine' absurd _ hk0.ne'
    simp [← Nat.factorization_eq_zero_of_non_prime n pp, h1]
  refine' ⟨p, pp, _⟩
  refine' Nat.eq_of_factorization_eq (Nat.ord_compl_pos p hn0).ne' (by simp) fun q => _
  rw [Nat.factorization_ord_compl n p, h1]
  simp
#align is_prime_pow.exists_ord_compl_eq_one IsPrimePow.exists_ord_compl_eq_one
-/

#print exists_ord_compl_eq_one_iff_isPrimePow /-
theorem exists_ord_compl_eq_one_iff_isPrimePow {n : ℕ} (hn : n ≠ 1) :
    IsPrimePow n ↔ ∃ p : ℕ, p.Prime ∧ ord_compl[p] n = 1 :=
  by
  refine' ⟨fun h => IsPrimePow.exists_ord_compl_eq_one h, fun h => _⟩
  rcases h with ⟨p, pp, h⟩
  rw [isPrimePow_nat_iff]
  rw [← Nat.eq_of_dvd_of_div_eq_one (Nat.ord_proj_dvd n p) h] at hn⊢
  refine' ⟨p, n.factorization p, pp, _, by simp⟩
  contrapose! hn
  simp [le_zero_iff.1 hn]
#align exists_ord_compl_eq_one_iff_is_prime_pow exists_ord_compl_eq_one_iff_isPrimePow
-/

#print isPrimePow_iff_unique_prime_dvd /-
/-- An equivalent definition for prime powers: `n` is a prime power iff there is a unique prime
dividing it. -/
theorem isPrimePow_iff_unique_prime_dvd {n : ℕ} : IsPrimePow n ↔ ∃! p : ℕ, p.Prime ∧ p ∣ n :=
  by
  rw [isPrimePow_nat_iff]
  constructor
  · rintro ⟨p, k, hp, hk, rfl⟩
    refine' ⟨p, ⟨hp, dvd_pow_self _ hk.ne'⟩, _⟩
    rintro q ⟨hq, hq'⟩
    exact (Nat.prime_dvd_prime_iff_eq hq hp).1 (hq.dvd_of_dvd_pow hq')
  rintro ⟨p, ⟨hp, hn⟩, hq⟩
  rcases eq_or_ne n 0 with (rfl | hn₀)
  · cases (hq 2 ⟨Nat.prime_two, dvd_zero 2⟩).trans (hq 3 ⟨Nat.prime_three, dvd_zero 3⟩).symm
  refine' ⟨p, n.factorization p, hp, hp.factorization_pos_of_dvd hn₀ hn, _⟩
  simp only [and_imp] at hq
  apply Nat.dvd_antisymm (Nat.ord_proj_dvd _ _)
  -- We need to show n ∣ p ^ n.factorization p
  apply Nat.dvd_of_factors_subperm hn₀
  rw [hp.factors_pow, List.subperm_ext_iff]
  intro q hq'
  rw [Nat.mem_factors hn₀] at hq'
  cases hq _ hq'.1 hq'.2
  simp
#align is_prime_pow_iff_unique_prime_dvd isPrimePow_iff_unique_prime_dvd
-/

#print isPrimePow_pow_iff /-
theorem isPrimePow_pow_iff {n k : ℕ} (hk : k ≠ 0) : IsPrimePow (n ^ k) ↔ IsPrimePow n :=
  by
  simp only [isPrimePow_iff_unique_prime_dvd]
  apply existsUnique_congr
  simp only [and_congr_right_iff]
  intro p hp
  exact ⟨hp.dvd_of_dvd_pow, fun t => t.trans (dvd_pow_self _ hk)⟩
#align is_prime_pow_pow_iff isPrimePow_pow_iff
-/

#print Nat.coprime.isPrimePow_dvd_mul /-
theorem Nat.coprime.isPrimePow_dvd_mul {n a b : ℕ} (hab : Nat.coprime a b) (hn : IsPrimePow n) :
    n ∣ a * b ↔ n ∣ a ∨ n ∣ b :=
  by
  rcases eq_or_ne a 0 with (rfl | ha)
  · simp only [Nat.coprime_zero_left] at hab
    simp [hab, Finset.filter_singleton, not_isPrimePow_one]
  rcases eq_or_ne b 0 with (rfl | hb)
  · simp only [Nat.coprime_zero_right] at hab
    simp [hab, Finset.filter_singleton, not_isPrimePow_one]
  refine'
    ⟨_, fun h =>
      Or.elim h (fun i => i.trans (dvd_mul_right _ _)) fun i => i.trans (dvd_mul_left _ _)⟩
  obtain ⟨p, k, hp, hk, rfl⟩ := (isPrimePow_nat_iff _).1 hn
  simp only [hp.pow_dvd_iff_le_factorization (mul_ne_zero ha hb), Nat.factorization_mul ha hb,
    hp.pow_dvd_iff_le_factorization ha, hp.pow_dvd_iff_le_factorization hb, Pi.add_apply,
    Finsupp.coe_add]
  have : a.factorization p = 0 ∨ b.factorization p = 0 :=
    by
    rw [← Finsupp.not_mem_support_iff, ← Finsupp.not_mem_support_iff, ← not_and_or, ←
      Finset.mem_inter]
    exact fun t => (Nat.factorization_disjoint_of_coprime hab).le_bot t
  cases this <;> simp [this, imp_or]
#align nat.coprime.is_prime_pow_dvd_mul Nat.coprime.isPrimePow_dvd_mul
-/

/- warning: nat.mul_divisors_filter_prime_pow -> Nat.mul_divisors_filter_prime_pow is a dubious translation:
lean 3 declaration is
  forall {a : Nat} {b : Nat}, (Nat.coprime a b) -> (Eq.{1} (Finset.{0} Nat) (Finset.filter.{0} Nat (IsPrimePow.{0} Nat (LinearOrderedCommMonoidWithZero.toCommMonoidWithZero.{0} Nat Nat.linearOrderedCommMonoidWithZero)) (fun (a : Nat) => IsPrimePow.decidable a) (Nat.divisors (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) a b))) (Finset.filter.{0} Nat (IsPrimePow.{0} Nat (LinearOrderedCommMonoidWithZero.toCommMonoidWithZero.{0} Nat Nat.linearOrderedCommMonoidWithZero)) (fun (a : Nat) => IsPrimePow.decidable a) (Union.union.{0} (Finset.{0} Nat) (Finset.hasUnion.{0} Nat (fun (a : Nat) (b : Nat) => Nat.decidableEq a b)) (Nat.divisors a) (Nat.divisors b))))
but is expected to have type
  forall {a : Nat} {b : Nat}, (Nat.coprime a b) -> (Eq.{1} (Finset.{0} Nat) (Finset.filter.{0} Nat (IsPrimePow.{0} Nat (LinearOrderedCommMonoidWithZero.toCommMonoidWithZero.{0} Nat Nat.linearOrderedCommMonoidWithZero)) (fun (a : Nat) => instDecidableIsPrimePowNatToCommMonoidWithZeroLinearOrderedCommMonoidWithZero a) (Nat.divisors (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) a b))) (Finset.filter.{0} Nat (IsPrimePow.{0} Nat (LinearOrderedCommMonoidWithZero.toCommMonoidWithZero.{0} Nat Nat.linearOrderedCommMonoidWithZero)) (fun (a : Nat) => instDecidableIsPrimePowNatToCommMonoidWithZeroLinearOrderedCommMonoidWithZero a) (Union.union.{0} (Finset.{0} Nat) (Finset.instUnionFinset.{0} Nat (fun (a : Nat) (b : Nat) => instDecidableEqNat a b)) (Nat.divisors a) (Nat.divisors b))))
Case conversion may be inaccurate. Consider using '#align nat.mul_divisors_filter_prime_pow Nat.mul_divisors_filter_prime_powₓ'. -/
theorem Nat.mul_divisors_filter_prime_pow {a b : ℕ} (hab : a.coprime b) :
    (a * b).divisors.filterₓ IsPrimePow = (a.divisors ∪ b.divisors).filterₓ IsPrimePow :=
  by
  rcases eq_or_ne a 0 with (rfl | ha)
  · simp only [Nat.coprime_zero_left] at hab
    simp [hab, Finset.filter_singleton, not_isPrimePow_one]
  rcases eq_or_ne b 0 with (rfl | hb)
  · simp only [Nat.coprime_zero_right] at hab
    simp [hab, Finset.filter_singleton, not_isPrimePow_one]
  ext n
  simp only [ha, hb, Finset.mem_union, Finset.mem_filter, Nat.mul_eq_zero, and_true_iff, Ne.def,
    and_congr_left_iff, not_false_iff, Nat.mem_divisors, or_self_iff]
  apply hab.is_prime_pow_dvd_mul
#align nat.mul_divisors_filter_prime_pow Nat.mul_divisors_filter_prime_pow


/-
Copyright (c) 2020 Jujian Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jujian Zhang
-/
import analysis.calculus.mean_value
import data.polynomial.denoms_clearable
import data.real.irrational
import ring_theory.algebraic
import topology.algebra.polynomial
/-!
# Liouville's theorem
This file contains a proof of Liouville's theorem stating that all Liouville numbers are
transcendental.

To obtain this result, there is first a proof that Liouville numbers are irrational and two
technical lemmas.  These lemmas exploit the fact that a polynomial with integer coefficients
takes integer values at integers.  When evaluating at a rational number, we can clear denominators
and obtain precise inequalities that ultimately allow us to prove transcendence of
Liouville numbers.
-/

/--
A Liouville number is a real number `x` such that for every natural number `n`, there exist
`a, b ∈ ℤ` with `1 < b` such that `0 < |x - a/b| < 1/bⁿ`.
In the implementation, the condition `x ≠ a/b` replaces the traditional equivalent `0 < |x - a/b|`.
-/
def liouville (x : ℝ) := ∀ n : ℕ, ∃ a b : ℤ, 1 < b ∧ x ≠ a / b ∧ abs (x - a / b) < 1 / b ^ n

namespace liouville

@[protected] lemma irrational {x : ℝ} (h : liouville x) : irrational x :=
begin
  -- By contradiction, `x = a / b`, with `a ∈ ℤ`, `0 < b ∈ ℕ` is a Liouville number,
  rintros ⟨⟨a, b, bN0, cop⟩, rfl⟩,
  -- clear up the mess of constructions of rationals
  change (liouville (a / b)) at h,
  -- Since `a / b` is a Liouville number, there are `p, q ∈ ℤ`, with `q1 : 1 < q`,
  -- `a0 : a / b ≠ p / q` and `a1 : abs (a / b - p / q) < 1 / q ^ (b + 1)`
  rcases h (b + 1) with ⟨p, q, q1, a0, a1⟩,
  -- A few useful inequalities
  have qR0 : (0 : ℝ) < q := int.cast_pos.mpr (zero_lt_one.trans q1),
  have b0 : (b : ℝ) ≠ 0 := ne_of_gt (nat.cast_pos.mpr bN0),
  have bq0 : (0 : ℝ) < b * q := mul_pos (nat.cast_pos.mpr bN0) qR0,
  -- At a1, clear denominators...
  replace a1 : abs (a * q - b * p) * q ^ (b + 1) < b * q, by
    rwa [div_sub_div _ _ b0 (ne_of_gt qR0), abs_div, div_lt_div_iff (abs_pos.mpr (ne_of_gt bq0))
      (pow_pos qR0 _), abs_of_pos bq0, one_mul,
      -- ... and revert to integers
       ← int.cast_pow, ← int.cast_mul, ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_mul,
       ← int.cast_sub, ← int.cast_abs, ← int.cast_mul, int.cast_lt] at a1,
  -- At a0, clear denominators...
  replace a0 : ¬a * q - ↑b * p = 0, by
    rwa [ne.def, div_eq_div_iff b0 (ne_of_gt qR0), mul_comm ↑p, ← sub_eq_zero,
      -- ... and revert to integers
      ← int.cast_coe_nat, ← int.cast_mul, ← int.cast_mul, ← int.cast_sub, int.cast_eq_zero] at a0,
  -- Actually, `q` is a natural number
  lift q to ℕ using (zero_lt_one.trans q1).le,
  -- Looks innocuous, but we now have an integer with non-zero absolute value: this is at
  -- least one away from zero.  The gain here is what gets the proof going.
  have ap : 0 < abs (a * ↑q - ↑b * p) := abs_pos.mpr a0,
  -- Actually, the absolute value of an integer is a natural number
  lift (abs (a * ↑q - ↑b * p)) to ℕ using (abs_nonneg (a * ↑q - ↑b * p)),
  -- At a1, revert to natural numbers
  rw [← int.coe_nat_mul, ← int.coe_nat_pow, ← int.coe_nat_mul, int.coe_nat_lt] at a1,
  -- Recall this is by contradiction: we obtained the inequality `b * q ≤ x * q ^ (b + 1)`, so
  -- we are done.
  exact not_le.mpr a1 (nat.mul_lt_mul_pow_succ (int.coe_nat_pos.mp ap) (int.coe_nat_lt.mp q1)).le,
end

open polynomial metric set real ring_hom

/-- Let `Z, N` be types, let `R` be a metric space, let `α : R` be a point and let
`j : Z → N → R` be a function.  We aim to estimate how close we can get to `α`, while staying
in the image of `j`.  The points `j z a` of `R` in the image of `j` come with a "cost" equal to
`d a`.  As we get closer to `α` while staying in the image of `j`, we are interested in bounding
the quantity `d a * dist α (j z a)` from below by a strictly positive amount `1 / A`: the intuition
is that approximating well `α` with the points in the image of `j` should come at a high cost.  The
hypotheses on the function `f : R → R` provide us with sufficient conditions to ensure our goal.
The first hypothesis is that `f` is Lipschitz at `α`: this yields a bound on the distance.
The second hypothesis is specific to the Liouville argument and provides the missing bound
involving the cost function `d`.

This lemma collects the properties used in the proof of `exists_pos_real_of_irrational_root`.
It is stated in more general form than needed: in the intended application, `Z = ℤ`, `N = ℕ`,
`R = ℝ`, `d a = (a + 1) ^ f.nat_degree`, `j z a  = z / (a + 1)`, `f ∈ ℤ[x]`, `α` is an irrational
root of `f`, `ε` is small, `M` is a bound on the Lipschitz constant of `f` near `α`, `n` is
the degree of the polynomial `f`.
-/
lemma exists_one_le_pow_mul_dist {Z N R : Type*} [metric_space R]
  {d : N → ℝ} {j : Z → N → R} {f : R → R} {α : R} {ε M : ℝ}
-- denominators are positive
  (d0 : ∀ (a : N), 1 ≤ d a)
  (e0 : 0 < ε)
-- function is Lipschitz at α
  (B : ∀ ⦃y : R⦄, y ∈ closed_ball α ε → dist (f α) (f y) ≤ (dist α y) * M)
-- clear denominators
  (L : ∀ ⦃z : Z⦄, ∀ ⦃a : N⦄, j z a ∈ closed_ball α ε → 1 ≤ (d a) * dist (f α) (f (j z a))) :
  ∃ A : ℝ, 0 < A ∧ ∀ (z : Z), ∀ (a : N), 1 ≤ (d a) * (dist α (j z a) * A) :=
begin
  -- A useful inequality to keep at hand
  have me0 : 0 < max (1 / ε) M := lt_max_iff.mpr (or.inl (one_div_pos.mpr e0)),
  -- The maximum between `1 / ε` and `M` works
  refine ⟨max (1 / ε) M, me0, λ z a, _⟩,
  -- First, let's deal with the easy case in which we are far away from `α`
  by_cases dm1 : 1 ≤ (dist α (j z a) * max (1 / ε) M),
  { exact one_le_mul_of_one_le_of_one_le (d0 a) dm1 },
  { -- `j z a = z / (a + 1)`: we prove that this ratio is close to `α`
    have : j z a ∈ closed_ball α ε,
    { refine mem_closed_ball'.mp (le_trans _ ((one_div_le me0 e0).mpr (le_max_left _ _))),
      exact ((le_div_iff me0).mpr (not_le.mp dm1).le) },
    -- use the "separation from `1`" (assumption `L`) for numerators,
    refine (L this).trans _,
    -- remove a common factor and use the Lipschitz assumption `B`
    refine mul_le_mul_of_nonneg_left ((B this).trans _) (zero_le_one.trans (d0 a)),
    exact mul_le_mul_of_nonneg_left (le_max_right _ M) dist_nonneg }
end

lemma exists_pos_real_of_irrational_root {α : ℝ} (ha : irrational α)
  {f : polynomial ℤ} (f0 : f ≠ 0) (fa : eval α (map (algebra_map ℤ ℝ) f) = 0):
  ∃ A : ℝ, 0 < A ∧
    ∀ (a : ℤ), ∀ (b : ℕ), (1 : ℝ) ≤ (b + 1) ^ f.nat_degree * (abs (α - (a / (b + 1))) * A) :=
begin
  -- `fR` is `f` viewed as a polynomial with `ℝ` coefficients.
  set fR : polynomial ℝ := map (algebra_map ℤ ℝ) f,
  -- `fR` is non-zero, since `f` is non-zero.
  obtain fR0 : fR ≠ 0 := λ fR0, (map_injective (algebra_map ℤ ℝ) (λ _ _ A, int.cast_inj.mp A)).ne
    f0 (fR0.trans (polynomial.map_zero _).symm),
  -- reformulating assumption `fa`: `α` is a root of `fR`.
  have ar : α ∈ (fR.roots.to_finset : set ℝ) :=
    finset.mem_coe.mpr (multiset.mem_to_finset.mpr ((mem_roots fR0).mpr (is_root.def.mpr fa))),
  -- Since the polynomial `fR` has finitely many roots, there is a closed interval centered at `α`
  -- such that `α` is the only root of `fR` in the interval.
  obtain ⟨ζ, z0, U⟩ : ∃ ζ > 0, closed_ball α ζ ∩ (fR.roots.to_finset) = {α} :=
    @exists_closed_ball_inter_eq_singleton_of_discrete _ _ _ discrete_of_t1_of_finite _ ar,
  -- Since `fR` is continuous, it is bounded on the interval above.
  obtain ⟨xm, -, hM⟩ : ∃ (xm : ℝ) (H : xm ∈ Icc (α - ζ) (α + ζ)), ∀ (y : ℝ),
    y ∈ Icc (α - ζ) (α + ζ) → abs (fR.derivative.eval y) ≤ abs (fR.derivative.eval xm) :=
    is_compact.exists_forall_ge compact_Icc
    ⟨α, (sub_lt_self α z0).le, (lt_add_of_pos_right α z0).le⟩
    (continuous_abs.comp fR.derivative.continuous_aeval).continuous_on,
  -- Use the key lemma `exists_one_le_pow_mul_dist`: we are left to show that ...
  refine @exists_one_le_pow_mul_dist ℤ ℕ ℝ _ _ _ (λ y, fR.eval y) α ζ
    (abs (fR.derivative.eval xm)) _ z0 (λ y hy, _) (λ z a hq, _),
  -- 1: the denominators are positive -- essentially by definition;
  { exact λ a, one_le_pow_of_one_le ((le_add_iff_nonneg_left 1).mpr a.cast_nonneg) _ },
  -- 2: the polynomial `fR` is Lipschitz at `α` -- as its derivative continuous;
  { rw mul_comm,
    rw closed_ball_Icc at hy,
    -- apply the Mean Value Theorem: the bound on the derivative comes from differentiability.
    refine convex.norm_image_sub_le_of_norm_deriv_le (λ _ _, fR.differentiable_at)
      (λ y h, by { rw fR.deriv, exact hM _ h }) (convex_Icc _ _) hy (mem_Icc_iff_abs_le.mp _),
    exact @mem_closed_ball_self ℝ _ α ζ (le_of_lt z0) },
  -- 3: the weird inequality of Liouville type with powers of the denominators.
  { show 1 ≤ (a + 1 : ℝ) ^ f.nat_degree * abs (eval α fR - eval (z / (a + 1)) fR),
    rw [fa, zero_sub, abs_neg],
    -- key observation: the right-hand side of the inequality is an *integer*.  Therefore,
    -- if its absolute value is not at least one, then it vanishes.  Proceed by contradiction
    refine one_le_pow_mul_abs_eval_div (int.coe_nat_succ_pos a) (λ hy, _),
    -- As the evaluation of the polynomial vanishes, we found a root of `fR` that is rational.
    -- We know that `α` is the only root of `fR` in our interval, and `α` is irrational:
    -- follow your nose.
    refine (irrational_iff_ne_rational α).mp ha z (a + 1) ((mem_singleton_iff.mp _).symm),
    refine U.subset _,
    refine ⟨hq, finset.mem_coe.mp (multiset.mem_to_finset.mpr _)⟩,
    exact (mem_roots fR0).mpr (is_root.def.mpr hy) }
end

theorem transcendental {x : ℝ} (lx : liouville x) :
  transcendental ℤ x :=
begin
  -- Proceed by contradiction: if `x` is algebraic, then `x` is the root (`ef0`) of a
  -- non-zero (`f0`) polynomial `f`
  rintros ⟨f : polynomial ℤ, f0, ef0⟩,
  -- Change `aeval x f = 0` to `eval (map _ f) = 0`, who knew.
  replace ef0 : (f.map (algebra_map ℤ ℝ)).eval x = 0, { rwa [aeval_def, ← eval_map] at ef0 },
  -- There is a "large" real number `A` such that `(b + 1) ^ (deg f) * |f (x - a / (b + 1))| * A`
  -- is at least one.  This is obtained from lemma `exists_pos_real_of_irrational_root`.
  obtain ⟨A, hA, h⟩ : ∃ (A : ℝ), 0 < A ∧
    ∀ (a : ℤ) (b : ℕ), (1 : ℝ) ≤ (b.succ) ^ f.nat_degree * (abs (x - a / (b.succ)) * A) :=
    exists_pos_real_of_irrational_root lx.irrational f0 ef0,
  -- Since the real numbers are Archimedean, a power of `2` exceeds `A`: `hn : A < 2 ^ r`.
  rcases pow_unbounded_of_one_lt A (lt_add_one 1) with ⟨r, hn⟩,
  -- Use the Liouville property, with exponent `r +  deg f`.
  obtain ⟨a, b, b1, -, a1⟩ : ∃ (a b : ℤ), 1 < b ∧ x ≠ a / b ∧
    abs (x - a / b) < 1 / b ^ (r + f.nat_degree) := lx (r + f.nat_degree),
  have b0 : (0 : ℝ) < b := zero_lt_one.trans (by { rw ← int.cast_one, exact int.cast_lt.mpr b1 }),
  -- Prove that `b ^ f.nat_degree * abs (x - a / b)` is strictly smaller than itself
  -- recall, this is a proof by contradiction!
  refine lt_irrefl ((b : ℝ) ^ f.nat_degree * abs (x - ↑a / ↑b)) _,
  -- clear denominators at `a1`
  rw [lt_div_iff' (pow_pos b0 _), pow_add, mul_assoc] at a1,
  -- split the inequality via `1 / A`.
  refine ((_  : (b : ℝ) ^ f.nat_degree * abs (x - a / b) < 1 / A).trans_le _),
  -- This branch of the proof uses the Liouville condition and the Archimedean property
  { refine (lt_div_iff' hA).mpr _,
    refine lt_of_le_of_lt _ a1,
    refine mul_le_mul_of_nonneg_right _ (mul_nonneg (pow_nonneg b0.le _) (abs_nonneg _)),
    refine hn.le.trans _,
    refine pow_le_pow_of_le_left zero_le_two _ _,
    exact int.cast_two.symm.le.trans (int.cast_le.mpr (int.add_one_le_iff.mpr b1)) },
  -- this branch of the proof exploits the "integrality" of evaluations of polynomials
  -- at ratios of integers.
  { lift b to ℕ using zero_le_one.trans b1.le,
    specialize h a b.pred,
    rwa [nat.succ_pred_eq_of_pos (zero_lt_one.trans _), ← mul_assoc, ← (div_le_iff hA)] at h,
    exact int.coe_nat_lt.mp b1 }
end

end liouville


import incidence_world.level03--hide
open IncidencePlane --hide

/-
# Incidence World

## Level 4: in search of the extreme cases.

In axiomatic geometry, when we are given a point, we can't determine where it is. Then, if we need to
generate more points to prove a lemma, it might be the case where one of these points drops exactly where
the given point was located. Analogously, it might be the case where two of the points generated make a line with
the given point, or perhaps they don't... Because of this reason, we should think about all the possible
distributions that are needed to satisfy a lemma. Let's learn how to come up with them by solving this level!

## Step 1: Thinking of a mathematical proof!

To begin with, read the lemma and do a drawing of the situation. To solve this level, we are given a point; call it P.
Now, try to think of an axiom to set up our proof. If you are not sure about which one to choose, let's step through them one by one.
It might be the case where some of them cannot be used, thus reducing the number of usable axioms and hence increasing the probability
of using the ideal one.

For example, let's say that we want to start our proof with the first axiom of incidence. In this case, we would generate two
points (A and B) to make a line that passes through them. In case we are lucky, these points won't be dropped exactly where the given point P is spotted.
Then, we would be done because the points A, B and P are not collinear. However, it might be also the case where these three points happened to pass through
the same line. Then, the points A, B and P would be collinear, and this is not what we want. For this reason, the first axiom of incidence is not a good candidate
to set up our proof.

Following the above train of thought, you wil get to the point where the third axiom of incidence is the correct one to choose. Still and all,
we have to think of all the possible distributions that could arise when having three non-collinear points (A, B and C) and the given point P.
It might be the case where the point P concurs with one of these three, or it might not... Consequently, we must proceed the proof by cases: one
where P = A (note that it would be the same if P = B or P = C, since P cannot be equal to two of these points at the same time), another one where P ≠ A.

If P = A, then we are done because the points B, C and P are not collinear. Read the lemma and see how this case satisfies it.

If P ≠ A, it might be the case where P is not incident with any of the lines that passes through A and B, or trough A and C, or through B and C.
However, it might be also the case where P is incident with the line through A and B, **or** with line through A and C, **or** with the line through B and C.
In all of these last three situations, three points would be collinear and only one point which is not P would be non-collinear with it.
Read the lemma and note that this is not what we want. For this reason, we have to come up with an **auxiliary point** (call it E).

## Step 2: Writing a mathematical proof in paper!

Now, read the mathematical proof in paper for this lemma and try to grasp every bit of it! You will see that we are using two Lean theorem statements!

**Claim:** Given a point P, there exist two points Q and R, such that the three points are not collinear.

**Proof:**

By the third axiom of incidence, let A, B and C be three non-collinear points that lie on the plane Ω.

Now, we proceed with the proof by cases.

**Case 1:** Let P = A. By the third axiom of incidence, we prove that the points P, B and C are not collinear.

**Case 2:** Let P ≠ A. By the first axiom of incidence, let ℓ be the line that is incident with the points A and P.
By the lemma `exists_not_point_in_line`, there exists a point that is not incident with the line ℓ. Let E be that point.
By the lemma `point_in_line_not_point`, since the point E is not incident with the line ℓ, then P ≠ E and A ≠ E. By the
third axiom of incidence, we prove that the points P, A and E are not collinear.

Hence, we have shown that, given a point P, there exist two points Q and R, such that the three points are not collinear.

## Step 3: Writing a mathematical proof in Lean!

To begin with, we generate three non-collinear points A, B and C in the plane Ω by using the following theorem statement:

`existence (Ω : Type) : ∃ P Q R : Ω, P ≠ Q ∧ P ≠ R ∧ Q ≠ R ∧ R ∉ (line_through P Q)`

To do so, delete the `sorry` and type `rcases existence Ω with ⟨A, B, C, ⟨hAB, hAC, hBC, h⟩⟩,` where Ω is the plane, A, B and C are the points that lie on
that plane and `hAB`, `hAC`, `hBC` and `h` are the hypotheses `A ≠ B`, `A ≠ C`, `B ≠ C` and `C ∉ (line_through A B)`, respectively.

Then, we proceed with the proof by cases. First, we type `by_cases h : P = A,`. This will break the proof into two cases. On the one hand, the one where the
point P is equal to A. On the other hand, the one where the point P is not equal to A. [**Recommendation:** Write curly braces to structure the proof. See level
9 of Tutorial World in case you don't remember how to do it.] Now, try to solve the first case by your own! Then, come back here to prove the second case together!

When it comes to the second case, you can add the hypothesis `H : ∃ (E : Ω), E ∉ line_through P A,` by using the `have` tactic. Then, `apply exists_point_not_in_line,`
will prove your hypothesis, so that you can use it to prove this second case. Right after, `cases H with E hE` will generate the point E. By typing `use A, use E,` we
tell the computer which points are non-collinear with P. Now, `split` the goal. Remember that `¬ P = A` is equivalent to `P ≠ A`. To finish with, you will have to prove
that P ≠ E and A ≠ E. Remember that the lemma `point_in_line_not_point` states that `(hPr : P ∈ r) (hQr : Q ∉ r) : P ≠ Q`. Because your first goal is to prove the conclusion of
the statement, that is, `⊢ P ≠ E`, then you have to provide Lean with the two previous hypotheses. To do so, type `exact point_in_line_not_point (line_through_left P A) hE,`.
Now, try to finish the remaining goals by your own. In case you get stuck, click right below for a hint.
-/

/- Hint : Click here for a hint, in case you get stuck.
You can close the first case just by using the `split`, `exact` and `rewrite` tactics. To finish the second case, you may have to change `line_through_left P A` into
`line_through_right P A` for the remaining goals. Try to understand why that happens. Still bewildered? Click on "View source" (located on the top right corner of the
game screen) to see the solution.
-/

variables {Ω : Type} [IncidencePlane Ω] --hide

/- Lemma :
Given a point P, there exist two points Q and R, such that the three points are not collinear.
-/
lemma point_existence_postulate (P : Ω) : ∃ (Q R : Ω), P ≠ Q ∧ P ≠ R ∧ Q ≠ R ∧
R ∉ (line_through P Q) :=
begin
  rcases ( existence Ω ) with ⟨ A, B, C, ⟨ h1, h2, h3, h4  ⟩ ⟩,
by_cases h : P = A,
 {
  use B,
  use C,
  split,
  rw h,
  exact h1,
  split,
  rw h,
  exact h2,
  split,
  exact h3,
  rw h,
  exact h4,
},
{
   have H : ∃ (E : Ω), E ∉ line_through P A,
   {
      apply exists_point_not_in_line,
   },
   cases H with E hE,
   use A,
   use E,
   split,
   exact h,
   split,
   exact point_in_line_not_point (line_through_left P A) hE,
   split,
   exact point_in_line_not_point (line_through_right P A) hE,
   exact hE,

},

end


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.products.basic
import Mathlib.PostPort

universes u₁ u₂ u₃ v₁ v₂ v₃

namespace Mathlib

/-#
The associator functor `((C × D) × E) ⥤ (C × (D × E))` and its inverse form an equivalence.
-/

namespace category_theory.prod

/--
The associator functor `(C × D) × E ⥤ C × (D × E)`.
-/
@[simp] theorem associator_map (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃)
    [category E] (_x : (C × D) × E) :
    ∀ (_x_1 : (C × D) × E) (f : _x ⟶ _x_1),
        functor.map (associator C D E) f =
          (prod.fst (prod.fst f), prod.snd (prod.fst f), prod.snd f) :=
  fun (_x_1 : (C × D) × E) (f : _x ⟶ _x_1) => Eq.refl (functor.map (associator C D E) f)

/--
The inverse associator functor `C × (D × E) ⥤ (C × D) × E `.
-/
@[simp] theorem inverse_associator_map (C : Type u₁) [category C] (D : Type u₂) [category D]
    (E : Type u₃) [category E] (_x : C × D × E) :
    ∀ (_x_1 : C × D × E) (f : _x ⟶ _x_1),
        functor.map (inverse_associator C D E) f =
          ((prod.fst f, prod.fst (prod.snd f)), prod.snd (prod.snd f)) :=
  fun (_x_1 : C × D × E) (f : _x ⟶ _x_1) => Eq.refl (functor.map (inverse_associator C D E) f)

/--
The equivalence of categories expressing associativity of products of categories.
-/
def associativity (C : Type u₁) [category C] (D : Type u₂) [category D] (E : Type u₃) [category E] :
    (C × D) × E ≌ C × D × E :=
  equivalence.mk (associator C D E) (inverse_associator C D E)
    (nat_iso.of_components (fun (X : (C × D) × E) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : C × D × E) => eq_to_iso sorry) sorry)

protected instance associator_is_equivalence (C : Type u₁) [category C] (D : Type u₂) [category D]
    (E : Type u₃) [category E] : is_equivalence (associator C D E) :=
  is_equivalence.of_equivalence (associativity C D E)

protected instance inverse_associator_is_equivalence (C : Type u₁) [category C] (D : Type u₂)
    [category D] (E : Type u₃) [category E] : is_equivalence (inverse_associator C D E) :=
  is_equivalence.of_equivalence_inverse (associativity C D E)

end Mathlib


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import data.real.irrational
import topology.metric_space.baire

/-!
# Topology of irrational numbers

In this file we prove the following theorems:

* `is_Gδ_irrational`, `dense_irrational`, `eventually_residual_irrational`: irrational numbers
  form a dense Gδ set;

* `irrational.eventually_forall_le_dist_cast_div`,
  `irrational.eventually_forall_le_dist_cast_div_of_denom_le`;
  `irrational.eventually_forall_le_dist_cast_rat_of_denom_le`: a sufficiently small neighborhood of
  an irrational number is disjoint with the set of rational numbers with bounded denominator.

We also provide `order_topology`, `no_min_order`, `no_max_order`, and `densely_ordered`
instances for `{x // irrational x}`.

## Tags

irrational, residual
-/

open set filter metric
open_locale filter topological_space

lemma is_Gδ_irrational : is_Gδ {x | irrational x} :=
(countable_range _).is_Gδ_compl

lemma dense_irrational : dense {x : ℝ | irrational x} :=
begin
  refine real.is_topological_basis_Ioo_rat.dense_iff.2 _,
  simp only [mem_Union, mem_singleton_iff],
  rintro _ ⟨a, b, hlt, rfl⟩ hne, rw inter_comm,
  exact exists_irrational_btwn (rat.cast_lt.2 hlt)
end

lemma eventually_residual_irrational : ∀ᶠ x in residual ℝ, irrational x :=
eventually_residual.2 ⟨_, is_Gδ_irrational, dense_irrational, λ _, id⟩

namespace irrational

variable {x : ℝ}

instance : order_topology {x // irrational x} :=
induced_order_topology _ (λ x y, iff.rfl) $ λ x y hlt,
  let ⟨a, ha, hxa, hay⟩ := exists_irrational_btwn hlt in ⟨⟨a, ha⟩, hxa, hay⟩

instance : no_max_order {x // irrational x} :=
⟨λ ⟨x, hx⟩, ⟨⟨x + (1 : ℕ), hx.add_nat 1⟩, by simp⟩⟩

instance : no_min_order {x // irrational x} :=
⟨λ ⟨x, hx⟩, ⟨⟨x - (1 : ℕ), hx.sub_nat 1⟩, by simp⟩⟩

instance : densely_ordered {x // irrational x} :=
⟨λ x y hlt, let ⟨z, hz, hxz, hzy⟩ := exists_irrational_btwn hlt in ⟨⟨z, hz⟩, hxz, hzy⟩⟩

lemma eventually_forall_le_dist_cast_div (hx : irrational x) (n : ℕ) :
  ∀ᶠ ε : ℝ in 𝓝 0, ∀ m : ℤ, ε ≤ dist x (m / n) :=
begin
  have A : is_closed (range (λ m, n⁻¹ * m : ℤ → ℝ)),
    from ((is_closed_map_smul₀ (n⁻¹ : ℝ)).comp
      int.closed_embedding_coe_real.is_closed_map).closed_range,
  have B : x ∉ range (λ m, n⁻¹ * m : ℤ → ℝ),
  { rintro ⟨m, rfl⟩, simpa using hx },
  rcases metric.mem_nhds_iff.1 (A.is_open_compl.mem_nhds B) with ⟨ε, ε0, hε⟩,
  refine (ge_mem_nhds ε0).mono (λ δ hδ m, not_lt.1 $ λ hlt, _),
  rw dist_comm at hlt,
  refine hε (ball_subset_ball hδ hlt) ⟨m, _⟩,
  simp [div_eq_inv_mul]
end

lemma eventually_forall_le_dist_cast_div_of_denom_le (hx : irrational x) (n : ℕ) :
  ∀ᶠ ε : ℝ in 𝓝 0, ∀ (k ≤ n) (m : ℤ), ε ≤ dist x (m / k) :=
(finite_le_nat n).eventually_all.2 $ λ k hk, hx.eventually_forall_le_dist_cast_div k

end irrational


/-
Copyright (c) 2022 Jireh Loreaux. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jireh Loreaux
-/
import group_theory.subsemigroup.basic

/-!
# Subsemigroups: membership criteria

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

In this file we prove various facts about membership in a subsemigroup.
The intent is to mimic `group_theory/submonoid/membership`, but currently this file is mostly a
stub and only provides rudimentary support.

* `mem_supr_of_directed`, `coe_supr_of_directed`, `mem_Sup_of_directed_on`,
  `coe_Sup_of_directed_on`: the supremum of a directed collection of subsemigroup is their union.

## TODO

* Define the `free_semigroup` generated by a set. This might require some rather substantial
  additions to low-level API. For example, developing the subtype of nonempty lists, then defining
  a product on nonempty lists, powers where the exponent is a positive natural, et cetera.
  Another option would be to define the `free_semigroup` as the subsemigroup (pushed to be a
  semigroup) of the `free_monoid` consisting of non-identity elements.

## Tags
subsemigroup
-/

variables {ι : Sort*} {M A B : Type*}

section non_assoc
variables [has_mul M]

open set

namespace subsemigroup

-- TODO: this section can be generalized to `[mul_mem_class B M] [complete_lattice B]`
-- such that `complete_lattice.le` coincides with `set_like.le`

@[to_additive]
lemma mem_supr_of_directed {S : ι → subsemigroup M} (hS : directed (≤) S) {x : M} :
  x ∈ (⨆ i, S i) ↔ ∃ i, x ∈ S i :=
begin
  refine ⟨_, λ ⟨i, hi⟩, (set_like.le_def.1 $ le_supr S i) hi⟩,
  suffices : x ∈ closure (⋃ i, (S i : set M)) → ∃ i, x ∈ S i,
    by simpa only [closure_Union, closure_eq (S _)] using this,
  refine (λ hx, closure_induction hx (λ y hy, mem_Union.mp hy) _),
  { rintros x y ⟨i, hi⟩ ⟨j, hj⟩,
    rcases hS i j with ⟨k, hki, hkj⟩,
    exact ⟨k, (S k).mul_mem (hki hi) (hkj hj)⟩ }
end

@[to_additive]
lemma coe_supr_of_directed {S : ι → subsemigroup M} (hS : directed (≤) S) :
  ((⨆ i, S i : subsemigroup M) : set M) = ⋃ i, ↑(S i) :=
set.ext $ λ x, by simp [mem_supr_of_directed hS]

@[to_additive]
lemma mem_Sup_of_directed_on {S : set (subsemigroup M)}
  (hS : directed_on (≤) S) {x : M} :
  x ∈ Sup S ↔ ∃ s ∈ S, x ∈ s :=
by simp only [Sup_eq_supr', mem_supr_of_directed hS.directed_coe, set_coe.exists, subtype.coe_mk]

@[to_additive]

@[to_additive]
lemma mem_sup_left {S T : subsemigroup M} : ∀ {x : M}, x ∈ S → x ∈ S ⊔ T :=
show S ≤ S ⊔ T, from le_sup_left

@[to_additive]
lemma mem_sup_right {S T : subsemigroup M} : ∀ {x : M}, x ∈ T → x ∈ S ⊔ T :=
show T ≤ S ⊔ T, from le_sup_right

@[to_additive]
lemma mul_mem_sup {S T : subsemigroup M} {x y : M} (hx : x ∈ S) (hy : y ∈ T) : x * y ∈ S ⊔ T :=
mul_mem (mem_sup_left hx) (mem_sup_right hy)

@[to_additive]
lemma mem_supr_of_mem {S : ι → subsemigroup M} (i : ι) :
  ∀ {x : M}, x ∈ S i → x ∈ supr S :=
show S i ≤ supr S, from le_supr _ _

@[to_additive]
lemma mem_Sup_of_mem {S : set (subsemigroup M)} {s : subsemigroup M}
  (hs : s ∈ S) : ∀ {x : M}, x ∈ s → x ∈ Sup S :=
show s ≤ Sup S, from le_Sup hs

/-- An induction principle for elements of `⨆ i, S i`.
If `C` holds all elements of `S i` for all `i`, and is preserved under multiplication,
then it holds for all elements of the supremum of `S`. -/
@[elab_as_eliminator, to_additive /-" An induction principle for elements of `⨆ i, S i`.
If `C` holds all elements of `S i` for all `i`, and is preserved under addition,
then it holds for all elements of the supremum of `S`. "-/]
lemma supr_induction (S : ι → subsemigroup M) {C : M → Prop} {x : M} (hx : x ∈ ⨆ i, S i)
  (hp : ∀ i (x ∈ S i), C x)
  (hmul : ∀ x y, C x → C y → C (x * y)) : C x :=
begin
  rw supr_eq_closure at hx,
  refine closure_induction hx (λ x hx, _) hmul,
  obtain ⟨i, hi⟩ := set.mem_Union.mp hx,
  exact hp _ _ hi,
end

/-- A dependent version of `subsemigroup.supr_induction`. -/
@[elab_as_eliminator, to_additive /-"A dependent version of `add_subsemigroup.supr_induction`. "-/]
lemma supr_induction' (S : ι → subsemigroup M) {C : Π x, (x ∈ ⨆ i, S i) → Prop}
  (hp : ∀ i (x ∈ S i), C x (mem_supr_of_mem i ‹_›))
  (hmul : ∀ x y hx hy, C x hx → C y hy → C (x * y) (mul_mem ‹_› ‹_›))
  {x : M} (hx : x ∈ ⨆ i, S i) : C x hx :=
begin
  refine exists.elim _ (λ (hx : x ∈ ⨆ i, S i) (hc : C x hx), hc),
  refine supr_induction S hx (λ i x hx, _) (λ x y, _),
  { exact ⟨_, hp _ _ hx⟩ },
  { rintro ⟨_, Cx⟩ ⟨_, Cy⟩,
    exact ⟨_, hmul _ _ _ _ Cx Cy⟩ },
end

end subsemigroup

end non_assoc


/-
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.tensor_product
import algebra.module.ulift

/-!
# The characteristice predicate of tensor product

## Main definitions

- `is_tensor_product`: A predicate on `f : M₁ →ₗ[R] M₂ →ₗ[R] M` expressing that `f` realizes `M` as
  the tensor product of `M₁ ⊗[R] M₂`. This is defined by requiring the lift `M₁ ⊗[R] M₂ → M` to be
  bijective.
- `is_base_change`: A predicate on an `R`-algebra `S` and a map `f : M →ₗ[R] N` with `N` being a
  `S`-module, expressing that `f` realizes `N` as the base change of `M` along `R → S`.
- `algebra.is_pushout`: A predicate on the following diagram of scalar towers
  ```
    R  →  S
    ↓     ↓
    R' →  S'
  ```
    asserting that is a pushout diagram (i.e. `S' = S ⊗[R] R'`)

## Main results
- `tensor_product.is_base_change`: `S ⊗[R] M` is the base change of `M` along `R → S`.

-/

universes u v₁ v₂ v₃ v₄

open_locale tensor_product

open tensor_product

section is_tensor_product

variables {R : Type*} [comm_ring R]
variables {M₁ M₂ M M' : Type*}
variables [add_comm_monoid M₁] [add_comm_monoid M₂] [add_comm_monoid M] [add_comm_monoid M']
variables [module R M₁] [module R M₂] [module R M] [module R M']
variable (f : M₁ →ₗ[R] M₂ →ₗ[R] M)
variables {N₁ N₂ N : Type*} [add_comm_monoid N₁] [add_comm_monoid N₂] [add_comm_monoid N]
variables [module R N₁] [module R N₂] [module R N]
variable {g : N₁ →ₗ[R] N₂ →ₗ[R] N}

/--
Given a bilinear map `f : M₁ →ₗ[R] M₂ →ₗ[R] M`, `is_tensor_product f` means that
`M` is the tensor product of `M₁` and `M₂` via `f`.
This is defined by requiring the lift `M₁ ⊗[R] M₂ → M` to be bijective.
-/
def is_tensor_product : Prop := function.bijective (tensor_product.lift f)

variables (R M N) {f}

lemma tensor_product.is_tensor_product : is_tensor_product (tensor_product.mk R M N) :=
begin
  delta is_tensor_product,
  convert_to function.bijective linear_map.id using 2,
  { apply tensor_product.ext', simp },
  { exact function.bijective_id }
end

variables {R M N}

/-- If `M` is the tensor product of `M₁` and `M₂`, it is linearly equivalent to `M₁ ⊗[R] M₂`. -/
@[simps apply] noncomputable
def is_tensor_product.equiv (h : is_tensor_product f) : M₁ ⊗[R] M₂ ≃ₗ[R] M :=
linear_equiv.of_bijective _ h

@[simp] lemma is_tensor_product.equiv_to_linear_map (h : is_tensor_product f) :
  h.equiv.to_linear_map = tensor_product.lift f := rfl

@[simp] lemma is_tensor_product.equiv_symm_apply (h : is_tensor_product f) (x₁ : M₁) (x₂ : M₂) :
  h.equiv.symm (f x₁ x₂) = x₁ ⊗ₜ x₂ :=
begin
  apply h.equiv.injective,
  refine (h.equiv.apply_symm_apply _).trans _,
  simp
end

/-- If `M` is the tensor product of `M₁` and `M₂`, we may lift a bilinear map `M₁ →ₗ[R] M₂ →ₗ[R] M'`
to a `M →ₗ[R] M'`. -/
noncomputable
def is_tensor_product.lift (h : is_tensor_product f) (f' : M₁ →ₗ[R] M₂ →ₗ[R] M') : M →ₗ[R] M' :=
(tensor_product.lift f').comp h.equiv.symm.to_linear_map

lemma is_tensor_product.lift_eq (h : is_tensor_product f) (f' : M₁ →ₗ[R] M₂ →ₗ[R] M')
  (x₁ : M₁) (x₂ : M₂) : h.lift f' (f x₁ x₂) = f' x₁ x₂ :=
begin
  delta is_tensor_product.lift,
  simp,
end

/-- The tensor product of a pair of linear maps between modules. -/
noncomputable
def is_tensor_product.map (hf : is_tensor_product f) (hg : is_tensor_product g)
  (i₁ : M₁ →ₗ[R] N₁) (i₂ : M₂ →ₗ[R] N₂) : M →ₗ[R] N :=
hg.equiv.to_linear_map.comp ((tensor_product.map i₁ i₂).comp hf.equiv.symm.to_linear_map)

lemma is_tensor_product.map_eq (hf : is_tensor_product f) (hg : is_tensor_product g)
  (i₁ : M₁ →ₗ[R] N₁) (i₂ : M₂ →ₗ[R] N₂) (x₁ : M₁) (x₂ : M₂) :
    hf.map hg i₁ i₂ (f x₁ x₂) = g (i₁ x₁) (i₂ x₂) :=
begin
  delta is_tensor_product.map,
  simp
end

lemma is_tensor_product.induction_on (h : is_tensor_product f) {C : M → Prop}
  (m : M) (h0 : C 0) (htmul : ∀ x y, C (f x y)) (hadd : ∀ x y, C x → C y → C (x + y)) : C m :=
begin
  rw ← h.equiv.right_inv m,
  generalize : h.equiv.inv_fun m = y,
  change C (tensor_product.lift f y),
  induction y using tensor_product.induction_on,
  { rwa map_zero },
  { rw tensor_product.lift.tmul, apply htmul },
  { rw map_add, apply hadd; assumption }
end

end is_tensor_product

section is_base_change

variables {R : Type*} {M : Type v₁} {N : Type v₂} (S : Type v₃)
variables [add_comm_monoid M] [add_comm_monoid N] [comm_ring R]
variables [comm_ring S] [algebra R S] [module R M] [module R N] [module S N] [is_scalar_tower R S N]
variables (f : M →ₗ[R] N)

include f

/-- Given an `R`-algebra `S` and an `R`-module `M`, an `S`-module `N` together with a map
`f : M →ₗ[R] N` is the base change of `M` to `S` if the map `S × M → N, (s, m) ↦ s • f m` is the
tensor product. -/
def is_base_change : Prop := is_tensor_product
(((algebra.of_id S $ module.End S (M →ₗ[R] N)).to_linear_map.flip f).restrict_scalars R)

variables {S f} (h : is_base_change S f)
variables {P Q : Type*} [add_comm_monoid P] [module R P]
variables [add_comm_monoid Q] [module S Q]

section

variables [module R Q] [is_scalar_tower R S Q]

/-- Suppose `f : M →ₗ[R] N` is the base change of `M` along `R → S`. Then any `R`-linear map from
`M` to an `S`-module factors thorugh `f`. -/
noncomputable
def is_base_change.lift (g : M →ₗ[R] Q) : N →ₗ[S] Q :=
{ map_smul' := λ r x, begin
    let F := ((algebra.of_id S $ module.End S (M →ₗ[R] Q))
      .to_linear_map.flip g).restrict_scalars R,
    have hF : ∀ (s : S) (m : M), h.lift F (s • f m) = s • g m := h.lift_eq F,
    change h.lift F (r • x) = r • h.lift F x,
    apply h.induction_on x,
    { rw [smul_zero, map_zero, smul_zero] },
    { intros s m,
      change h.lift F (r • s • f m) = r • h.lift F (s • f m),
      rw [← mul_smul, hF, hF, mul_smul] },
    { intros x₁ x₂ e₁ e₂, rw [map_add, smul_add, map_add, smul_add, e₁, e₂] }
  end,
  ..(h.lift (((algebra.of_id S $ module.End S (M →ₗ[R] Q))
    .to_linear_map.flip g).restrict_scalars R)) }

lemma is_base_change.lift_eq (g : M →ₗ[R] Q) (x : M) : h.lift g (f x) = g x :=
begin
  have hF : ∀ (s : S) (m : M), h.lift g (s • f m) = s • g m := h.lift_eq _,
  convert hF 1 x; rw one_smul,
end

lemma is_base_change.lift_comp (g : M →ₗ[R] Q) : ((h.lift g).restrict_scalars R).comp f = g :=
linear_map.ext (h.lift_eq g)

end
include h

@[elab_as_eliminator]
lemma is_base_change.induction_on (x : N) (P : N → Prop)
  (h₁ : P 0)
  (h₂ : ∀ m : M, P (f m))
  (h₃ : ∀ (s : S) n, P n → P (s • n))
  (h₄ : ∀ n₁ n₂, P n₁ → P n₂ → P (n₁ + n₂)) : P x :=
h.induction_on x h₁ (λ s y, h₃ _ _ (h₂ _)) h₄

lemma is_base_change.alg_hom_ext (g₁ g₂ : N →ₗ[S] Q) (e : ∀ x, g₁ (f x) = g₂ (f x)) :
  g₁ = g₂ :=
begin
  ext x,
  apply h.induction_on x,
  { rw [map_zero, map_zero] },
  { assumption },
  { intros s n e', rw [g₁.map_smul, g₂.map_smul, e'] },
  { intros x y e₁ e₂, rw [map_add, map_add, e₁, e₂] }
end

lemma is_base_change.alg_hom_ext' [module R Q] [is_scalar_tower R S Q] (g₁ g₂ : N →ₗ[S] Q)
  (e : (g₁.restrict_scalars R).comp f = (g₂.restrict_scalars R).comp f) :
  g₁ = g₂ :=
h.alg_hom_ext g₁ g₂ (linear_map.congr_fun e)

variables (R M N S)

omit h f

lemma tensor_product.is_base_change : is_base_change S (tensor_product.mk R S M 1) :=
begin
  delta is_base_change,
  convert tensor_product.is_tensor_product R S M using 1,
  ext s x,
  change s • 1 ⊗ₜ x = s ⊗ₜ x,
  rw tensor_product.smul_tmul',
  congr' 1,
  exact mul_one _,
end

variables {R M N S}

/-- The base change of `M` along `R → S` is linearly equivalent to `S ⊗[R] M`. -/
noncomputable
def is_base_change.equiv : S ⊗[R] M ≃ₗ[S] N :=
{ map_smul' := λ r x, begin
    change h.equiv (r • x) = r • h.equiv x,
    apply tensor_product.induction_on x,
    { rw [smul_zero, map_zero, smul_zero] },
    { intros x y, simp [smul_tmul', algebra.of_id_apply] },
    { intros x y hx hy, rw [map_add, smul_add, map_add, smul_add, hx, hy] },
  end,
  ..h.equiv }

lemma is_base_change.equiv_tmul (s : S) (m : M) : h.equiv (s ⊗ₜ m) = s • (f m) :=
tensor_product.lift.tmul s m

lemma is_base_change.equiv_symm_apply (m : M) : h.equiv.symm (f m) = 1 ⊗ₜ m :=
by rw [h.equiv.symm_apply_eq, h.equiv_tmul, one_smul]

variable (f)

lemma is_base_change.of_lift_unique
  (h : ∀ (Q : Type (max v₁ v₂ v₃)) [add_comm_monoid Q], by exactI ∀ [module R Q] [module S Q],
    by exactI ∀ [is_scalar_tower R S Q], by exactI ∀ (g : M →ₗ[R] Q),
      ∃! (g' : N →ₗ[S] Q), (g'.restrict_scalars R).comp f = g) : is_base_change S f :=
begin
  obtain ⟨g, hg, -⟩ := h (ulift.{v₂} $ S ⊗[R] M)
    (ulift.module_equiv.symm.to_linear_map.comp $ tensor_product.mk R S M 1),
  let f' : S ⊗[R] M →ₗ[R] N := _, change function.bijective f',
  let f'' : S ⊗[R] M →ₗ[S] N,
  { refine { to_fun := f', map_smul' := λ s x,
      tensor_product.induction_on x _ (λ s' y, smul_assoc s s' _) (λ x y hx hy, _), .. f' },
    { rw [map_zero, smul_zero, map_zero, smul_zero] },
    { rw [smul_add, map_add, map_add, smul_add, hx, hy] } },
  simp_rw [fun_like.ext_iff, linear_map.comp_apply, linear_map.restrict_scalars_apply] at hg,
  let fe : S ⊗[R] M ≃ₗ[S] N :=
    linear_equiv.of_linear f'' (ulift.module_equiv.to_linear_map.comp g) _ _,
  { exact fe.bijective },
  { rw ← (linear_map.cancel_left (ulift.module_equiv : ulift.{max v₁ v₃} N ≃ₗ[S] N).symm.injective),
    refine (h (ulift.{max v₁ v₃} N) $ ulift.module_equiv.symm.to_linear_map.comp f).unique _ rfl,
    { apply_instance },
    ext x,
    simp only [linear_map.comp_apply, linear_map.restrict_scalars_apply, hg],
    apply one_smul },
  { ext x, change (g $ (1 : S) • f x).down = _, rw [one_smul, hg], refl },
end

variable {f}

lemma is_base_change.iff_lift_unique :
  is_base_change S f ↔
    ∀ (Q : Type (max v₁ v₂ v₃)) [add_comm_monoid Q], by exactI ∀ [module R Q] [module S Q],
    by exactI ∀ [is_scalar_tower R S Q], by exactI ∀ (g : M →ₗ[R] Q),
      ∃! (g' : N →ₗ[S] Q), (g'.restrict_scalars R).comp f = g :=
⟨λ h, by { introsI,
  exact ⟨h.lift g, h.lift_comp g, λ g' e, h.alg_hom_ext' _ _ (e.trans (h.lift_comp g).symm)⟩ },
  is_base_change.of_lift_unique f⟩

lemma is_base_change.of_equiv (e : M ≃ₗ[R] N) : is_base_change R e.to_linear_map :=
begin
  apply is_base_change.of_lift_unique,
  introsI Q I₁ I₂ I₃ I₄ g,
  have : I₂ = I₃,
  { ext r q,
    rw [← one_smul R q, smul_smul, ← smul_assoc, smul_eq_mul, mul_one] },
  unfreezingI { cases this },
  refine ⟨g.comp e.symm.to_linear_map, by { ext, simp }, _⟩,
  rintros y (rfl : _ = _),
  ext,
  simp,
end

variables {T O : Type*} [comm_ring T] [algebra R T] [algebra S T] [is_scalar_tower R S T]
variables [add_comm_monoid O] [module R O] [module S O] [module T O] [is_scalar_tower S T O]
variables [is_scalar_tower R S O] [is_scalar_tower R T O]

lemma is_base_change.comp {f : M →ₗ[R] N} (hf : is_base_change S f) {g : N →ₗ[S] O}
  (hg : is_base_change T g) : is_base_change T ((g.restrict_scalars R).comp f) :=
begin
  apply is_base_change.of_lift_unique,
  introsI Q _ _ _ _ i,
  letI := module.comp_hom Q (algebra_map S T),
  haveI : is_scalar_tower S T Q := ⟨λ x y z, by { rw [algebra.smul_def, mul_smul], refl }⟩,
  haveI : is_scalar_tower R S Q,
  { refine ⟨λ x y z, _⟩,
    change (is_scalar_tower.to_alg_hom R S T) (x • y) • z = x • (algebra_map S T y • z),
    rw [alg_hom.map_smul, smul_assoc],
    refl },
  refine ⟨hg.lift (hf.lift i), by { ext, simp [is_base_change.lift_eq] }, _⟩,
  rintros g' (e : _ = _),
  refine hg.alg_hom_ext' _ _ (hf.alg_hom_ext' _ _ _),
  rw [is_base_change.lift_comp, is_base_change.lift_comp, ← e],
  ext,
  refl
end

variables {R' S' : Type*} [comm_ring R'] [comm_ring S']
variables [algebra R R'] [algebra S S'] [algebra R' S'] [algebra R S']
variables [is_scalar_tower R R' S'] [is_scalar_tower R S S']

open is_scalar_tower (to_alg_hom)

variables (R S R' S')

/--
A type-class stating that the following diagram of scalar towers
R  →  S
↓     ↓
R' →  S'
is a pushout diagram (i.e. `S' = S ⊗[R] R'`)
-/
@[mk_iff]
class algebra.is_pushout : Prop :=
(out : is_base_change S (to_alg_hom R R' S').to_linear_map)

variables {R S R' S'}

lemma algebra.is_pushout.symm
  (h : algebra.is_pushout R S R' S') :
  algebra.is_pushout R R' S S' :=
begin
  letI := (algebra.tensor_product.include_right : R' →ₐ[R] S ⊗ R').to_ring_hom.to_algebra,
  let e : R' ⊗[R] S ≃ₗ[R'] S',
  { refine { map_smul' := _, ..(tensor_product.comm R R' S).trans $ h.1.equiv.restrict_scalars R },
    intros r x,
    change
      h.1.equiv (tensor_product.comm R R' S (r • x)) = r • h.1.equiv (tensor_product.comm R R' S x),
    apply tensor_product.induction_on x,
    { simp only [smul_zero, map_zero] },
    { intros x y,
      simp [smul_tmul', algebra.smul_def, ring_hom.algebra_map_to_algebra, h.1.equiv_tmul],
      ring },
    { intros x y hx hy, simp only [map_add, smul_add, hx, hy] } },
  have : (to_alg_hom R S S').to_linear_map
    = (e.to_linear_map.restrict_scalars R).comp (tensor_product.mk R R' S 1),
  { ext, simp [e, h.1.equiv_tmul, algebra.smul_def] },
  constructor,
  rw this,
  exact (tensor_product.is_base_change R S R').comp (is_base_change.of_equiv e),
end

variables (R S R' S')

lemma algebra.is_pushout.comm :
  algebra.is_pushout R S R' S' ↔ algebra.is_pushout R R' S S' :=
⟨algebra.is_pushout.symm, algebra.is_pushout.symm⟩

variables {R S R'}

local attribute [instance] algebra.tensor_product.right_algebra

instance tensor_product.is_pushout {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
  [algebra R S] [algebra R T] :
  algebra.is_pushout R S T (tensor_product R S T) :=
⟨tensor_product.is_base_change R T S⟩

instance tensor_product.is_pushout' {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
  [algebra R S] [algebra R T] :
  algebra.is_pushout R T S (tensor_product R S T) :=
algebra.is_pushout.symm infer_instance

/--
If `S' = S ⊗[R] R'`, then any pair of `R`-algebra homomorphisms `f : S → A` and `g : R' → A`
such that `f x` and `g y` commutes for all `x, y` descends to a (unique) homomoprhism `S' → A`.
-/
@[simps apply (lemmas_only)] noncomputable
def algebra.pushout_desc [H : algebra.is_pushout R S R' S']
  {A : Type*} [semiring A] [algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A)
    (hf : ∀ x y, f x * g y = g y * f x) : S' →ₐ[R] A :=
begin
  letI := module.comp_hom A f.to_ring_hom,
  haveI : is_scalar_tower R S A :=
  { smul_assoc := λ r s a, show f (r • s) * a = r • (f s * a), by rw [f.map_smul, smul_mul_assoc] },
  haveI : is_scalar_tower S A A :=
  { smul_assoc := λ r a b, mul_assoc _ _ _ },
  have : ∀ x, H.out.lift g.to_linear_map (algebra_map R' S' x) = g x := H.out.lift_eq _,
  refine alg_hom.of_linear_map ((H.out.lift g.to_linear_map).restrict_scalars R) _ _,
  { dsimp only [linear_map.restrict_scalars_apply],
    rw [← (algebra_map R' S').map_one, this, g.map_one] },
  { intros x y,
    apply H.out.induction_on x,
    { rw [zero_mul, map_zero, zero_mul] },
    rotate,
    { intros s s' e, dsimp only [linear_map.restrict_scalars_apply] at e ⊢,
      rw [linear_map.map_smul, smul_mul_assoc, linear_map.map_smul, e, smul_mul_assoc] },
    { intros s s' e₁ e₂, dsimp only [linear_map.restrict_scalars_apply] at e₁ e₂ ⊢,
      rw [add_mul, map_add, map_add, add_mul, e₁, e₂] },
    intro x, dsimp, rw this, apply H.out.induction_on y,
    { rw [mul_zero, map_zero, mul_zero] },
    { intro y, dsimp, rw [← _root_.map_mul, this, this, _root_.map_mul] },
    { intros s s' e,
      rw [mul_comm, smul_mul_assoc, linear_map.map_smul, linear_map.map_smul, mul_comm, e],
      change f s * (g x * _) = g x * (f s * _),
      rw [← mul_assoc, ← mul_assoc, hf] },
    { intros s s' e₁ e₂, rw [mul_add, map_add, map_add, mul_add, e₁, e₂] }, }
end

@[simp]
lemma algebra.pushout_desc_left [H : algebra.is_pushout R S R' S']
  {A : Type*} [semiring A] [algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) (x : S) :
  algebra.pushout_desc S' f g H (algebra_map S S' x) = f x :=
begin
  rw [algebra.pushout_desc_apply, algebra.algebra_map_eq_smul_one, linear_map.map_smul,
    ← algebra.pushout_desc_apply S' f g H, _root_.map_one],
  exact mul_one (f x)
end

lemma algebra.lift_alg_hom_comp_left [H : algebra.is_pushout R S R' S']
  {A : Type*} [semiring A] [algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) :
  (algebra.pushout_desc S' f g H).comp (to_alg_hom R S S') = f :=
alg_hom.ext (λ x, (algebra.pushout_desc_left S' f g H x : _))

@[simp]
lemma algebra.pushout_desc_right [H : algebra.is_pushout R S R' S']
  {A : Type*} [semiring A] [algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) (x : R') :
  algebra.pushout_desc S' f g H (algebra_map R' S' x) = g x :=
begin
  apply_with @@is_base_change.lift_eq { instances := ff },
end

lemma algebra.lift_alg_hom_comp_right [H : algebra.is_pushout R S R' S']
  {A : Type*} [semiring A] [algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) :
  (algebra.pushout_desc S' f g H).comp (to_alg_hom R R' S') = g :=
alg_hom.ext (λ x, (algebra.pushout_desc_right S' f g H x : _))

@[ext]
lemma algebra.is_pushout.alg_hom_ext [H : algebra.is_pushout R S R' S']
  {A : Type*} [semiring A] [algebra R A] {f g : S' →ₐ[R] A}
  (h₁ : f.comp (to_alg_hom R R' S') = g.comp (to_alg_hom R R' S'))
  (h₂ : f.comp (to_alg_hom R S S') = g.comp (to_alg_hom R S S')) : f = g :=
begin
  ext x,
  apply H.1.induction_on x,
  { simp only [map_zero] },
  { exact alg_hom.congr_fun h₁ },
  { intros s s' e, rw [algebra.smul_def, f.map_mul, g.map_mul, e],
    congr' 1, exact (alg_hom.congr_fun h₂ s : _) },
  { intros s₁ s₂ e₁ e₂, rw [map_add, map_add, e₁, e₂] }
end

end is_base_change