/-
Copyright (c) 2021 Thomas Browning. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Thomas Browning
-/
import analysis.calculus.local_extr
import data.nat.prime_norm_num
import field_theory.abel_ruffini
import ring_theory.eisenstein_criterion

/-!
# Construction of an algebraic number that is not solvable by radicals.

The main ingredients are:
 * `solvable_by_rad.is_solvable'` in `field_theory/abel_ruffini` :
  an irreducible polynomial with an `is_solvable_by_rad` root has solvable Galois group
 * `gal_action_hom_bijective_of_prime_degree'` in `field_theory/polynomial_galois_group` :
  an irreducible polynomial of prime degree with 1-3 non-real roots has full Galois group
 * `equiv.perm.not_solvable` in `group_theory/solvable` : the symmetric group is not solvable

Then all that remains is the construction of a specific polynomial satisfying the conditions of
`gal_action_hom_bijective_of_prime_degree'`, which is done in this file.

-/

namespace abel_ruffini

open function polynomial polynomial.gal ideal
open_locale polynomial

local attribute [instance] splits_ℚ_ℂ

variables (R : Type*) [comm_ring R] (a b : ℕ)

/-- A quintic polynomial that we will show is irreducible -/
noncomputable def Φ : R[X] := X ^ 5 - C ↑a * X + C ↑b

variables {R}

@[simp] lemma map_Phi {S : Type*} [comm_ring S] (f : R →+* S) : (Φ R a b).map f = Φ S a b :=
by simp [Φ]

@[simp] lemma coeff_zero_Phi : (Φ R a b).coeff 0 = ↑b :=
by simp [Φ, coeff_X_pow]

@[simp] lemma coeff_five_Phi : (Φ R a b).coeff 5 = 1 :=
by simp [Φ, coeff_X, coeff_C, -C_eq_nat_cast, -map_nat_cast]

variables [nontrivial R]

lemma degree_Phi : (Φ R a b).degree = ↑5 :=
begin
  suffices : degree (X ^ 5 - C ↑a * X) = ↑5,
  { rwa [Φ, degree_add_eq_left_of_degree_lt],
    convert degree_C_le.trans_lt (with_bot.coe_lt_coe.mpr (nat.zero_lt_bit1 2)) },
  rw degree_sub_eq_left_of_degree_lt; rw degree_X_pow,
  exact (degree_C_mul_X_le _).trans_lt (with_bot.coe_lt_coe.mpr (nat.one_lt_bit1 two_ne_zero)),
end

lemma nat_degree_Phi : (Φ R a b).nat_degree = 5 :=
nat_degree_eq_of_degree_eq_some (degree_Phi a b)

lemma leading_coeff_Phi : (Φ R a b).leading_coeff = 1 :=
by rw [polynomial.leading_coeff, nat_degree_Phi, coeff_five_Phi]

lemma monic_Phi : (Φ R a b).monic :=
leading_coeff_Phi a b

lemma irreducible_Phi (p : ℕ) (hp : p.prime) (hpa : p ∣ a) (hpb : p ∣ b) (hp2b : ¬ p ^ 2 ∣ b) :
  irreducible (Φ ℚ a b) :=
begin
  rw [←map_Phi a b (int.cast_ring_hom ℚ), ←is_primitive.int.irreducible_iff_irreducible_map_cast],
  apply irreducible_of_eisenstein_criterion,
  { rwa [span_singleton_prime (int.coe_nat_ne_zero.mpr hp.ne_zero), int.prime_iff_nat_abs_prime] },
  { rw [leading_coeff_Phi, mem_span_singleton],
    exact_mod_cast mt nat.dvd_one.mp (hp.ne_one) },
  { intros n hn,
    rw mem_span_singleton,
    rw [degree_Phi, with_bot.coe_lt_coe] at hn,
    interval_cases n with hn;
    simp only [Φ, coeff_X_pow, coeff_C, int.coe_nat_dvd.mpr, hpb, if_true, coeff_C_mul, if_false,
      nat.zero_ne_bit1, eq_self_iff_true, coeff_X_zero, hpa, coeff_add, zero_add, mul_zero,
      coeff_sub, sub_self, nat.one_ne_zero, add_zero, coeff_X_one, mul_one,
      zero_sub, dvd_neg, nat.one_eq_bit1, bit0_eq_zero, neg_zero, nat.bit0_ne_bit1,
      dvd_mul_of_dvd_left, nat.bit1_eq_bit1, nat.one_ne_bit0, nat.bit1_ne_zero], },
  { simp only [degree_Phi, ←with_bot.coe_zero, with_bot.coe_lt_coe, nat.succ_pos'] },
  { rw [coeff_zero_Phi, span_singleton_pow, mem_span_singleton],
    exact mt int.coe_nat_dvd.mp hp2b },
  all_goals { exact monic.is_primitive (monic_Phi a b) },
end

lemma real_roots_Phi_le : fintype.card ((Φ ℚ a b).root_set ℝ) ≤ 3 :=
begin
  rw [←map_Phi a b (algebra_map ℤ ℚ), Φ, ←one_mul (X ^ 5), ←C_1],
  refine (card_root_set_le_derivative _).trans
    (nat.succ_le_succ ((card_root_set_le_derivative _).trans (nat.succ_le_succ _))),
  suffices : ((C ((algebra_map ℤ ℚ) 20) * X ^ 3).root_set ℝ).subsingleton,
  { norm_num [fintype.card_le_one_iff_subsingleton, ← mul_assoc, *] at * },
  rw root_set_C_mul_X_pow; norm_num,
end

lemma real_roots_Phi_ge_aux (hab : b < a) :
  ∃ x y : ℝ, x ≠ y ∧ aeval x (Φ ℚ a b) = 0 ∧ aeval y (Φ ℚ a b) = 0 :=
begin
  let f := λ x : ℝ, aeval x (Φ ℚ a b),
  have hf : f = λ x, x ^ 5 - a * x + b := by simp [f, Φ],
  have hc : ∀ s : set ℝ, continuous_on f s := λ s, (Φ ℚ a b).continuous_on_aeval,
  have ha : (1 : ℝ) ≤ a := nat.one_le_cast.mpr (nat.one_le_of_lt hab),
  have hle : (0 : ℝ) ≤ 1 := zero_le_one,
  have hf0 : 0 ≤ f 0 := by norm_num [hf],
  by_cases hb : (1 : ℝ) - a + b < 0,
  { have hf1 : f 1 < 0 := by norm_num [hf, hb],
    have hfa : 0 ≤ f a,
    { simp_rw [hf, ←sq],
      refine add_nonneg (sub_nonneg.mpr (pow_le_pow ha _)) _; norm_num },
    obtain ⟨x, ⟨-, hx1⟩, hx2⟩ := intermediate_value_Ico' hle (hc _) (set.mem_Ioc.mpr ⟨hf1, hf0⟩),
    obtain ⟨y, ⟨hy1, -⟩, hy2⟩ := intermediate_value_Ioc ha (hc _) (set.mem_Ioc.mpr ⟨hf1, hfa⟩),
    exact ⟨x, y, (hx1.trans hy1).ne, hx2, hy2⟩ },
  { replace hb : (b : ℝ) = a - 1 := by linarith [show (b : ℝ) + 1 ≤ a, by exact_mod_cast hab],
    have hf1 : f 1 = 0 := by norm_num [hf, hb],
    have hfa := calc f (-a) = a ^ 2 - a ^ 5 + b       : by norm_num [hf, ← sq]
                        ... ≤ a ^ 2 - a ^ 3 + (a - 1) : by refine add_le_add (sub_le_sub_left
                                                            (pow_le_pow ha _) _) _; linarith
                        ... = -(a - 1) ^ 2 * (a + 1)  : by ring
                        ... ≤ 0                       : by nlinarith,
    have ha' := neg_nonpos.mpr (hle.trans ha),
    obtain ⟨x, ⟨-, hx1⟩, hx2⟩ := intermediate_value_Icc ha' (hc _) (set.mem_Icc.mpr ⟨hfa, hf0⟩),
    exact ⟨x, 1, (hx1.trans_lt zero_lt_one).ne, hx2, hf1⟩ },
end

lemma real_roots_Phi_ge (hab : b < a) : 2 ≤ fintype.card ((Φ ℚ a b).root_set ℝ) :=
begin
  have q_ne_zero : Φ ℚ a b ≠ 0 := (monic_Phi a b).ne_zero,
  obtain ⟨x, y, hxy, hx, hy⟩ := real_roots_Phi_ge_aux a b hab,
  have key : ↑({x, y} : finset ℝ) ⊆ (Φ ℚ a b).root_set ℝ,
  { simp [set.insert_subset, mem_root_set_of_ne q_ne_zero, hx, hy] },
  convert fintype.card_le_of_embedding (set.embedding_of_subset _ _ key),
  simp only [finset.coe_sort_coe, fintype.card_coe, finset.card_singleton,
             finset.card_insert_of_not_mem (mt finset.mem_singleton.mp hxy)]
end

lemma complex_roots_Phi (h : (Φ ℚ a b).separable) : fintype.card ((Φ ℚ a b).root_set ℂ) = 5 :=
(card_root_set_eq_nat_degree h (is_alg_closed.splits_codomain _)).trans (nat_degree_Phi a b)

lemma gal_Phi (hab : b < a) (h_irred : irreducible (Φ ℚ a b)) :
  bijective (gal_action_hom (Φ ℚ a b) ℂ) :=
begin
  apply gal_action_hom_bijective_of_prime_degree' h_irred,
  { norm_num [nat_degree_Phi] },
  { rw [complex_roots_Phi a b h_irred.separable, nat.succ_le_succ_iff],
    exact (real_roots_Phi_le a b).trans (nat.le_succ 3) },
  { simp_rw [complex_roots_Phi a b h_irred.separable, nat.succ_le_succ_iff],
    exact real_roots_Phi_ge a b hab },
end

theorem not_solvable_by_rad (p : ℕ) (x : ℂ) (hx : aeval x (Φ ℚ a b) = 0) (hab : b < a)
  (hp : p.prime) (hpa : p ∣ a) (hpb : p ∣ b) (hp2b : ¬ p ^ 2 ∣ b) :
  ¬ is_solvable_by_rad ℚ x :=
begin
  have h_irred := irreducible_Phi a b p hp hpa hpb hp2b,
  apply mt (solvable_by_rad.is_solvable' h_irred hx),
  introI h,
  refine equiv.perm.not_solvable _ (le_of_eq _)
    (solvable_of_surjective (gal_Phi a b hab h_irred).2),
  rw_mod_cast [cardinal.mk_fintype, complex_roots_Phi a b h_irred.separable],
end

theorem not_solvable_by_rad' (x : ℂ) (hx : aeval x (Φ ℚ 4 2) = 0) :
  ¬ is_solvable_by_rad ℚ x :=
by apply not_solvable_by_rad 4 2 2 x hx; norm_num

/-- **Abel-Ruffini Theorem** -/
theorem exists_not_solvable_by_rad : ∃ x : ℂ, is_algebraic ℚ x ∧ ¬ is_solvable_by_rad ℚ x :=
begin
  obtain ⟨x, hx⟩ := exists_root_of_splits (algebra_map ℚ ℂ)
    (is_alg_closed.splits_codomain (Φ ℚ 4 2))
    (ne_of_eq_of_ne (degree_Phi 4 2) (mt with_bot.coe_eq_coe.mp (nat.bit1_ne_zero 2))),
  exact ⟨x, ⟨Φ ℚ 4 2, (monic_Phi 4 2).ne_zero, hx⟩, not_solvable_by_rad' x hx⟩,
end

end abel_ruffini


import data.real.basic
import data.vector
open real

variable X : Type -- hide

/-
# Work in progress.

-/

-- begin hide

--#check finset
--#check finset.card_range
--#check list
--Do we want a list? A vector?
--either way, not sure how to go about this yet
--def partition (a b : ℝ) (A: set.Icc a b) (n : ℕ) := list ℝ

-- end hide

/- Lemma
If $A$ and $B$ are sets of any type $X$, then
$$ A \subseteq A\cup B.$$
-/
theorem subset_union_left (A B : set X) : A ⊆ A ∪ B :=
begin
    --change ∀ (x : α), x ∈ A → x ∈ A ∪ B,  --they may want to do this
    intros x hx,
    left, exact hx, done
end


/-
Copyright (c) 2019 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Casper Putz, Anne Baanen
-/
import linear_algebra.matrix.reindex
import linear_algebra.matrix.to_lin

/-!
# Bases and matrices

This file defines the map `basis.to_matrix` that sends a family of vectors to
the matrix of their coordinates with respect to some basis.

## Main definitions

 * `basis.to_matrix e v` is the matrix whose `i, j`th entry is `e.repr (v j) i`
 * `basis.to_matrix_equiv` is `basis.to_matrix` bundled as a linear equiv

## Main results

 * `linear_map.to_matrix_id_eq_basis_to_matrix`: `linear_map.to_matrix b c id`
   is equal to `basis.to_matrix b c`
 * `basis.to_matrix_mul_to_matrix`: multiplying `basis.to_matrix` with another
   `basis.to_matrix` gives a `basis.to_matrix`

## Tags

matrix, basis
-/

noncomputable theory

open linear_map matrix set submodule
open_locale big_operators
open_locale matrix

section basis_to_matrix

variables {ι ι' κ κ' : Type*}
variables {R M : Type*} [comm_ring R] [add_comm_group M] [module R M]

open function matrix

/-- From a basis `e : ι → M` and a family of vectors `v : ι' → M`, make the matrix whose columns
are the vectors `v i` written in the basis `e`. -/
def basis.to_matrix (e : basis ι R M) (v : ι' → M) : matrix ι ι' R :=
λ i j, e.repr (v j) i

variables (e : basis ι R M) (v : ι' → M) (i : ι) (j : ι')

namespace basis

lemma to_matrix_apply : e.to_matrix v i j = e.repr (v j) i :=
rfl

lemma to_matrix_transpose_apply : (e.to_matrix v)ᵀ j = e.repr (v j) :=
funext $ (λ _, rfl)

lemma to_matrix_eq_to_matrix_constr [fintype ι] [decidable_eq ι] (v : ι → M) :
  e.to_matrix v = linear_map.to_matrix e e (e.constr ℕ v) :=
by { ext, rw [basis.to_matrix_apply, linear_map.to_matrix_apply, basis.constr_basis] }

-- TODO (maybe) Adjust the definition of `basis.to_matrix` to eliminate the transpose.
lemma coe_pi_basis_fun.to_matrix_eq_transpose [fintype ι] :
  ((pi.basis_fun R ι).to_matrix : matrix ι ι R → matrix ι ι R) = matrix.transpose :=
by { ext M i j, refl, }

@[simp] lemma to_matrix_self [decidable_eq ι] : e.to_matrix e = 1 :=
begin
  rw basis.to_matrix,
  ext i j,
  simp [basis.equiv_fun, matrix.one_apply, finsupp.single, eq_comm]
end

lemma to_matrix_update [decidable_eq ι'] (x : M) :
  e.to_matrix (function.update v j x) = matrix.update_column (e.to_matrix v) j (e.repr x) :=
begin
  ext i' k,
  rw [basis.to_matrix, matrix.update_column_apply, e.to_matrix_apply],
  split_ifs,
  { rw [h, update_same j x v] },
  { rw update_noteq h },
end

@[simp] lemma sum_to_matrix_smul_self [fintype ι] : ∑ (i : ι), e.to_matrix v i j • e i = v j :=
by simp_rw [e.to_matrix_apply, e.sum_repr]

@[simp] lemma to_lin_to_matrix [fintype ι] [fintype ι'] [decidable_eq ι'] (v : basis ι' R M) :
  matrix.to_lin v e (e.to_matrix v) = id :=
v.ext (λ i, by rw [to_lin_self, id_apply, e.sum_to_matrix_smul_self])

/-- From a basis `e : ι → M`, build a linear equivalence between families of vectors `v : ι → M`,
and matrices, making the matrix whose columns are the vectors `v i` written in the basis `e`. -/
def to_matrix_equiv [fintype ι] (e : basis ι R M) : (ι → M) ≃ₗ[R] matrix ι ι R :=
{ to_fun := e.to_matrix,
  map_add' := λ v w, begin
    ext i j,
    change _ = _ + _,
    rw [e.to_matrix_apply, pi.add_apply, linear_equiv.map_add],
    refl
  end,
  map_smul' := begin
    intros c v,
    ext i j,
    rw [e.to_matrix_apply, pi.smul_apply, linear_equiv.map_smul],
    refl
  end,
  inv_fun := λ m j, ∑ i, (m i j) • e i,
  left_inv := begin
    intro v,
    ext j,
    exact e.sum_to_matrix_smul_self v j
  end,
  right_inv := begin
    intros m,
    ext k l,
    simp only [e.to_matrix_apply, ← e.equiv_fun_apply, ← e.equiv_fun_symm_apply,
               linear_equiv.apply_symm_apply],
  end }

end basis

section mul_linear_map_to_matrix

variables {N : Type*} [add_comm_group N] [module R N]
variables (b : basis ι R M) (b' : basis ι' R M) (c : basis κ R N) (c' : basis κ' R N)
variables (f : M →ₗ[R] N)

open linear_map

section fintype

variables [fintype ι'] [fintype κ] [fintype κ']

@[simp] lemma basis_to_matrix_mul_linear_map_to_matrix [decidable_eq ι'] :
  c.to_matrix c' ⬝ linear_map.to_matrix b' c' f = linear_map.to_matrix b' c f :=
(matrix.to_lin b' c).injective
  (by haveI := classical.dec_eq κ';
      rw [to_lin_to_matrix, to_lin_mul b' c' c, to_lin_to_matrix, c.to_lin_to_matrix, id_comp])

variable [fintype ι]

@[simp] lemma linear_map_to_matrix_mul_basis_to_matrix [decidable_eq ι] [decidable_eq ι'] :
  linear_map.to_matrix b' c' f ⬝ b'.to_matrix b = linear_map.to_matrix b c' f :=
(matrix.to_lin b c').injective
  (by rw [to_lin_to_matrix, to_lin_mul b b' c', to_lin_to_matrix, b'.to_lin_to_matrix, comp_id])

lemma basis_to_matrix_mul_linear_map_to_matrix_mul_basis_to_matrix
  [decidable_eq ι] [decidable_eq ι'] :
  c.to_matrix c' ⬝ linear_map.to_matrix b' c' f ⬝ b'.to_matrix b = linear_map.to_matrix b c f :=
by rw [basis_to_matrix_mul_linear_map_to_matrix, linear_map_to_matrix_mul_basis_to_matrix]

/-- A generalization of `linear_map.to_matrix_id`. -/
@[simp] lemma linear_map.to_matrix_id_eq_basis_to_matrix [decidable_eq ι] :
  linear_map.to_matrix b b' id = b'.to_matrix b :=
by { haveI := classical.dec_eq ι',
      rw [←@basis_to_matrix_mul_linear_map_to_matrix _ _ ι, to_matrix_id, matrix.mul_one] }

/-- See also `basis.to_matrix_reindex` which gives the `simp` normal form of this result. -/
lemma basis.to_matrix_reindex' [decidable_eq ι] [decidable_eq ι']
  (b : basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
  (b.reindex e).to_matrix v = matrix.reindex_alg_equiv _ e (b.to_matrix (v ∘ e)) :=
by { ext, simp only [basis.to_matrix_apply, basis.reindex_repr, matrix.reindex_alg_equiv_apply,
        matrix.reindex_apply, matrix.minor_apply, function.comp_app, e.apply_symm_apply] }

end fintype

/-- A generalization of `basis.to_matrix_self`, in the opposite direction. -/
@[simp] lemma basis.to_matrix_mul_to_matrix {ι'' : Type*} [fintype ι'] (b'' : ι'' → M) :
  b.to_matrix b' ⬝ b'.to_matrix b'' = b.to_matrix b'' :=
begin
  have  := classical.dec_eq ι,
  have  := classical.dec_eq ι',
  haveI := classical.dec_eq ι'',
  ext i j,
  simp only [matrix.mul_apply, basis.to_matrix_apply, basis.sum_repr_mul_repr],
end

/-- `b.to_matrix b'` and `b'.to_matrix b` are inverses. -/
lemma basis.to_matrix_mul_to_matrix_flip [decidable_eq ι] [fintype ι'] :
  b.to_matrix b' ⬝ b'.to_matrix b = 1 :=
by rw [basis.to_matrix_mul_to_matrix, basis.to_matrix_self]

@[simp]
lemma basis.to_matrix_reindex
  (b : basis ι R M) (v : ι' → M) (e : ι ≃ ι') :
  (b.reindex e).to_matrix v = (b.to_matrix v).minor e.symm id :=
by { ext, simp only [basis.to_matrix_apply, basis.reindex_repr, matrix.minor_apply, id.def] }

@[simp]
lemma basis.to_matrix_map (b : basis ι R M) (f : M ≃ₗ[R] N) (v : ι → N) :
  (b.map f).to_matrix v = b.to_matrix (f.symm ∘ v) :=
by { ext, simp only [basis.to_matrix_apply, basis.map, linear_equiv.trans_apply] }

end mul_linear_map_to_matrix

end basis_to_matrix


/-
Copyright (c) 2019 Kenny Lau, Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Chris Hughes

! This file was ported from Lean 3 source module algebra.direct_limit
! leanprover-community/mathlib commit e7f0ddbf65bd7181a85edb74b64bdc35ba4bdc74
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Finset.Order
import Mathbin.Algebra.DirectSum.Module
import Mathbin.RingTheory.FreeCommRing
import Mathbin.RingTheory.Ideal.QuotientOperations

/-!
# Direct limit of modules, abelian groups, rings, and fields.

See Atiyah-Macdonald PP.32-33, Matsumura PP.269-270

Generalizes the notion of "union", or "gluing", of incomparable modules over the same ring,
or incomparable abelian groups, or rings, or fields.

It is constructed as a quotient of the free module (for the module case) or quotient of
the free commutative ring (for the ring case) instead of a quotient of the disjoint union
so as to make the operations (addition etc.) "computable".

## Main definitions

* `directed_system f`
* `module.direct_limit G f`
* `add_comm_group.direct_limit G f`
* `ring.direct_limit G f`

-/

universe u v w u₁

open Submodule

variable {R : Type u} [Ring R]

variable {ι : Type v}

variable [dec_ι : DecidableEq ι] [Preorder ι]

variable (G : ι → Type w)

/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`map_self] [] -/
/- ./././Mathport/Syntax/Translate/Command.lean:388:30: infer kinds are unsupported in Lean 4: #[`map_map] [] -/
/-- A directed system is a functor from a category (directed poset) to another category. -/
class DirectedSystem (f : ∀ i j, i ≤ j → G i → G j) : Prop where
  map_self : ∀ i x h, f i i h x = x
  map_map : ∀ {i j k} (hij hjk x), f j k hjk (f i j hij x) = f i k (le_trans hij hjk) x
#align directed_system DirectedSystem

namespace Module

variable [∀ i, AddCommGroup (G i)] [∀ i, Module R (G i)]

variable {G} (f : ∀ i j, i ≤ j → G i →ₗ[R] G j)

/-- A copy of `directed_system.map_self` specialized to linear maps, as otherwise the
`λ i j h, f i j h` can confuse the simplifier. -/
theorem DirectedSystem.map_self [DirectedSystem G fun i j h => f i j h] (i x h) : f i i h x = x :=
  DirectedSystem.map_self (fun i j h => f i j h) i x h
#align module.directed_system.map_self Module.DirectedSystem.map_self

/-- A copy of `directed_system.map_map` specialized to linear maps, as otherwise the
`λ i j h, f i j h` can confuse the simplifier. -/
theorem DirectedSystem.map_map [DirectedSystem G fun i j h => f i j h] {i j k} (hij hjk x) :
    f j k hjk (f i j hij x) = f i k (le_trans hij hjk) x :=
  DirectedSystem.map_map (fun i j h => f i j h) hij hjk x
#align module.directed_system.map_map Module.DirectedSystem.map_map

variable (G)

include dec_ι

/-- The direct limit of a directed system is the modules glued together along the maps. -/
def DirectLimit : Type max v w :=
  DirectSum ι G ⧸
    (span R <|
      { a |
        ∃ (i j : _)(H : i ≤ j)(x : _),
          DirectSum.lof R ι G i x - DirectSum.lof R ι G j (f i j H x) = a })
#align module.direct_limit Module.DirectLimit

namespace DirectLimit

instance : AddCommGroup (DirectLimit G f) :=
  Quotient.addCommGroup _

instance : Module R (DirectLimit G f) :=
  Quotient.module _

instance : Inhabited (DirectLimit G f) :=
  ⟨0⟩

variable (R ι)

/-- The canonical map from a component to the direct limit. -/
def of (i) : G i →ₗ[R] DirectLimit G f :=
  (mkQ _).comp <| DirectSum.lof R ι G i
#align module.direct_limit.of Module.DirectLimit.of

variable {R ι G f}

@[simp]
theorem of_f {i j hij x} : of R ι G f j (f i j hij x) = of R ι G f i x :=
  Eq.symm <| (Submodule.Quotient.eq _).2 <| subset_span ⟨i, j, hij, x, rfl⟩
#align module.direct_limit.of_f Module.DirectLimit.of_f

/-- Every element of the direct limit corresponds to some element in
some component of the directed system. -/
theorem exists_of [Nonempty ι] [IsDirected ι (· ≤ ·)] (z : DirectLimit G f) :
    ∃ i x, of R ι G f i x = z :=
  Nonempty.elim (by infer_instance) fun ind : ι =>
    Quotient.inductionOn' z fun z =>
      DirectSum.induction_on z ⟨ind, 0, LinearMap.map_zero _⟩ (fun i x => ⟨i, x, rfl⟩)
        fun p q ⟨i, x, ihx⟩ ⟨j, y, ihy⟩ =>
        let ⟨k, hik, hjk⟩ := exists_ge_ge i j
        ⟨k, f i k hik x + f j k hjk y, by rw [LinearMap.map_add, of_f, of_f, ihx, ihy] <;> rfl⟩
#align module.direct_limit.exists_of Module.DirectLimit.exists_of

@[elab_as_elim]
protected theorem induction_on [Nonempty ι] [IsDirected ι (· ≤ ·)] {C : DirectLimit G f → Prop}
    (z : DirectLimit G f) (ih : ∀ i x, C (of R ι G f i x)) : C z :=
  let ⟨i, x, h⟩ := exists_of z
  h ▸ ih i x
#align module.direct_limit.induction_on Module.DirectLimit.induction_on

variable {P : Type u₁} [AddCommGroup P] [Module R P] (g : ∀ i, G i →ₗ[R] P)

variable (Hg : ∀ i j hij x, g j (f i j hij x) = g i x)

include Hg

variable (R ι G f)

/-- The universal property of the direct limit: maps from the components to another module
that respect the directed system structure (i.e. make some diagram commute) give rise
to a unique map out of the direct limit. -/
def lift : DirectLimit G f →ₗ[R] P :=
  liftQ _ (DirectSum.toModule R ι P g)
    (span_le.2 fun a ⟨i, j, hij, x, hx⟩ => by
      rw [← hx, SetLike.mem_coe, LinearMap.sub_mem_ker_iff, DirectSum.toModule_lof,
        DirectSum.toModule_lof, Hg])
#align module.direct_limit.lift Module.DirectLimit.lift

variable {R ι G f}

omit Hg

theorem lift_of {i} (x) : lift R ι G f g Hg (of R ι G f i x) = g i x :=
  DirectSum.toModule_lof R _ _
#align module.direct_limit.lift_of Module.DirectLimit.lift_of

theorem lift_unique [Nonempty ι] [IsDirected ι (· ≤ ·)] (F : DirectLimit G f →ₗ[R] P) (x) :
    F x =
      lift R ι G f (fun i => F.comp <| of R ι G f i)
        (fun i j hij x => by rw [LinearMap.comp_apply, of_f] <;> rfl) x :=
  DirectLimit.induction_on x fun i x => by rw [lift_of] <;> rfl
#align module.direct_limit.lift_unique Module.DirectLimit.lift_unique

section Totalize

open Classical

variable (G f)

omit dec_ι

/-- `totalize G f i j` is a linear map from `G i` to `G j`, for *every* `i` and `j`.
If `i ≤ j`, then it is the map `f i j` that comes with the directed system `G`,
and otherwise it is the zero map. -/
noncomputable def totalize (i j) : G i →ₗ[R] G j :=
  if h : i ≤ j then f i j h else 0
#align module.direct_limit.totalize Module.DirectLimit.totalize

variable {G f}

theorem totalize_of_le {i j} (h : i ≤ j) : totalize G f i j = f i j h :=
  dif_pos h
#align module.direct_limit.totalize_of_le Module.DirectLimit.totalize_of_le

theorem totalize_of_not_le {i j} (h : ¬i ≤ j) : totalize G f i j = 0 :=
  dif_neg h
#align module.direct_limit.totalize_of_not_le Module.DirectLimit.totalize_of_not_le

end Totalize

variable [DirectedSystem G fun i j h => f i j h]

open Classical

theorem toModule_totalize_of_le {x : DirectSum ι G} {i j : ι} (hij : i ≤ j)
    (hx : ∀ k ∈ x.support, k ≤ i) :
    DirectSum.toModule R ι (G j) (fun k => totalize G f k j) x =
      f i j hij (DirectSum.toModule R ι (G i) (fun k => totalize G f k i) x) :=
  by
  rw [← @Dfinsupp.sum_single ι G _ _ _ x]
  unfold Dfinsupp.sum
  simp only [LinearMap.map_sum]
  refine' Finset.sum_congr rfl fun k hk => _
  rw [DirectSum.single_eq_lof R k (x k), DirectSum.toModule_lof, DirectSum.toModule_lof,
    totalize_of_le (hx k hk), totalize_of_le (le_trans (hx k hk) hij), DirectedSystem.map_map]
#align module.direct_limit.to_module_totalize_of_le Module.DirectLimit.toModule_totalize_of_le

theorem of.zero_exact_aux [Nonempty ι] [IsDirected ι (· ≤ ·)] {x : DirectSum ι G}
    (H : Submodule.Quotient.mk x = (0 : DirectLimit G f)) :
    ∃ j,
      (∀ k ∈ x.support, k ≤ j) ∧
        DirectSum.toModule R ι (G j) (fun i => totalize G f i j) x = (0 : G j) :=
  Nonempty.elim (by infer_instance) fun ind : ι =>
    span_induction ((Quotient.mk_eq_zero _).1 H)
      (fun x ⟨i, j, hij, y, hxy⟩ =>
        let ⟨k, hik, hjk⟩ := exists_ge_ge i j
        ⟨k, by
          clear_
          subst hxy
          constructor
          · intro i0 hi0
            rw [Dfinsupp.mem_support_iff, DirectSum.sub_apply, ← DirectSum.single_eq_lof, ←
              DirectSum.single_eq_lof, Dfinsupp.single_apply, Dfinsupp.single_apply] at hi0
            split_ifs  at hi0 with hi hj hj
            · rwa [hi] at hik
            · rwa [hi] at hik
            · rwa [hj] at hjk
            exfalso
            apply hi0
            rw [sub_zero]
          simp [LinearMap.map_sub, totalize_of_le, hik, hjk, DirectedSystem.map_map,
            DirectSum.apply_eq_component, DirectSum.component.of]⟩)
      ⟨ind, fun _ h => (Finset.not_mem_empty _ h).elim, LinearMap.map_zero _⟩
      (fun x y ⟨i, hi, hxi⟩ ⟨j, hj, hyj⟩ =>
        let ⟨k, hik, hjk⟩ := exists_ge_ge i j
        ⟨k, fun l hl =>
          (Finset.mem_union.1 (Dfinsupp.support_add hl)).elim (fun hl => le_trans (hi _ hl) hik)
            fun hl => le_trans (hj _ hl) hjk,
          by
          simp [LinearMap.map_add, hxi, hyj, to_module_totalize_of_le hik hi,
            to_module_totalize_of_le hjk hj]⟩)
      fun a x ⟨i, hi, hxi⟩ =>
      ⟨i, fun k hk => hi k (DirectSum.support_smul _ _ hk), by simp [LinearMap.map_smul, hxi]⟩
#align module.direct_limit.of.zero_exact_aux Module.DirectLimit.of.zero_exact_aux

/-- A component that corresponds to zero in the direct limit is already zero in some
bigger module in the directed system. -/
theorem of.zero_exact [IsDirected ι (· ≤ ·)] {i x} (H : of R ι G f i x = 0) :
    ∃ j hij, f i j hij x = (0 : G j) :=
  haveI : Nonempty ι := ⟨i⟩
  let ⟨j, hj, hxj⟩ := of.zero_exact_aux H
  if hx0 : x = 0 then ⟨i, le_rfl, by simp [hx0]⟩
  else
    have hij : i ≤ j := hj _ <| by simp [DirectSum.apply_eq_component, hx0]
    ⟨j, hij, by simpa [totalize_of_le hij] using hxj⟩
#align module.direct_limit.of.zero_exact Module.DirectLimit.of.zero_exact

end DirectLimit

end Module

namespace AddCommGroup

variable [∀ i, AddCommGroup (G i)]

include dec_ι

/-- The direct limit of a directed system is the abelian groups glued together along the maps. -/
def DirectLimit (f : ∀ i j, i ≤ j → G i →+ G j) : Type _ :=
  @Module.DirectLimit ℤ _ ι _ _ G _ _ fun i j hij => (f i j hij).toIntLinearMap
#align add_comm_group.direct_limit AddCommGroup.DirectLimit

namespace DirectLimit

variable (f : ∀ i j, i ≤ j → G i →+ G j)

omit dec_ι

protected theorem directedSystem [h : DirectedSystem G fun i j h => f i j h] :
    DirectedSystem G fun i j hij => (f i j hij).toIntLinearMap :=
  h
#align add_comm_group.direct_limit.directed_system AddCommGroup.DirectLimit.directedSystem

include dec_ι

attribute [local instance] direct_limit.directed_system

instance : AddCommGroup (DirectLimit G f) :=
  Module.DirectLimit.addCommGroup G fun i j hij => (f i j hij).toIntLinearMap

instance : Inhabited (DirectLimit G f) :=
  ⟨0⟩

/-- The canonical map from a component to the direct limit. -/
def of (i) : G i →ₗ[ℤ] DirectLimit G f :=
  Module.DirectLimit.of ℤ ι G (fun i j hij => (f i j hij).toIntLinearMap) i
#align add_comm_group.direct_limit.of AddCommGroup.DirectLimit.of

variable {G f}

@[simp]
theorem of_f {i j} (hij) (x) : of G f j (f i j hij x) = of G f i x :=
  Module.DirectLimit.of_f
#align add_comm_group.direct_limit.of_f AddCommGroup.DirectLimit.of_f

@[elab_as_elim]
protected theorem induction_on [Nonempty ι] [IsDirected ι (· ≤ ·)] {C : DirectLimit G f → Prop}
    (z : DirectLimit G f) (ih : ∀ i x, C (of G f i x)) : C z :=
  Module.DirectLimit.induction_on z ih
#align add_comm_group.direct_limit.induction_on AddCommGroup.DirectLimit.induction_on

/-- A component that corresponds to zero in the direct limit is already zero in some
bigger module in the directed system. -/
theorem of.zero_exact [IsDirected ι (· ≤ ·)] [DirectedSystem G fun i j h => f i j h] (i x)
    (h : of G f i x = 0) : ∃ j hij, f i j hij x = 0 :=
  Module.DirectLimit.of.zero_exact h
#align add_comm_group.direct_limit.of.zero_exact AddCommGroup.DirectLimit.of.zero_exact

variable (P : Type u₁) [AddCommGroup P]

variable (g : ∀ i, G i →+ P)

variable (Hg : ∀ i j hij x, g j (f i j hij x) = g i x)

variable (G f)

/-- The universal property of the direct limit: maps from the components to another abelian group
that respect the directed system structure (i.e. make some diagram commute) give rise
to a unique map out of the direct limit. -/
def lift : DirectLimit G f →ₗ[ℤ] P :=
  Module.DirectLimit.lift ℤ ι G (fun i j hij => (f i j hij).toIntLinearMap)
    (fun i => (g i).toIntLinearMap) Hg
#align add_comm_group.direct_limit.lift AddCommGroup.DirectLimit.lift

variable {G f}

@[simp]
theorem lift_of (i x) : lift G f P g Hg (of G f i x) = g i x :=
  Module.DirectLimit.lift_of _ _ _
#align add_comm_group.direct_limit.lift_of AddCommGroup.DirectLimit.lift_of

theorem lift_unique [Nonempty ι] [IsDirected ι (· ≤ ·)] (F : DirectLimit G f →+ P) (x) :
    F x = lift G f P (fun i => F.comp (of G f i).toAddMonoidHom) (fun i j hij x => by simp) x :=
  DirectLimit.induction_on x fun i x => by simp
#align add_comm_group.direct_limit.lift_unique AddCommGroup.DirectLimit.lift_unique

end DirectLimit

end AddCommGroup

namespace Ring

variable [∀ i, CommRing (G i)]

section

variable (f : ∀ i j, i ≤ j → G i → G j)

open FreeCommRing

/-- The direct limit of a directed system is the rings glued together along the maps. -/
def DirectLimit : Type max v w :=
  FreeCommRing (Σi, G i) ⧸
    Ideal.span
      { a |
        (∃ i j H x, of (⟨j, f i j H x⟩ : Σi, G i) - of ⟨i, x⟩ = a) ∨
          (∃ i, of (⟨i, 1⟩ : Σi, G i) - 1 = a) ∨
            (∃ i x y, of (⟨i, x + y⟩ : Σi, G i) - (of ⟨i, x⟩ + of ⟨i, y⟩) = a) ∨
              ∃ i x y, of (⟨i, x * y⟩ : Σi, G i) - of ⟨i, x⟩ * of ⟨i, y⟩ = a }
#align ring.direct_limit Ring.DirectLimit

namespace DirectLimit

instance : CommRing (DirectLimit G f) :=
  Ideal.Quotient.commRing _

instance : Ring (DirectLimit G f) :=
  CommRing.toRing _

instance : Inhabited (DirectLimit G f) :=
  ⟨0⟩

/-- The canonical map from a component to the direct limit. -/
def of (i) : G i →+* DirectLimit G f :=
  RingHom.mk'
    { toFun := fun x => Ideal.Quotient.mk _ (of (⟨i, x⟩ : Σi, G i))
      map_one' := Ideal.Quotient.eq.2 <| subset_span <| Or.inr <| Or.inl ⟨i, rfl⟩
      map_mul' := fun x y =>
        Ideal.Quotient.eq.2 <| subset_span <| Or.inr <| Or.inr <| Or.inr ⟨i, x, y, rfl⟩ }
    fun x y => Ideal.Quotient.eq.2 <| subset_span <| Or.inr <| Or.inr <| Or.inl ⟨i, x, y, rfl⟩
#align ring.direct_limit.of Ring.DirectLimit.of

variable {G f}

@[simp]
theorem of_f {i j} (hij) (x) : of G f j (f i j hij x) = of G f i x :=
  Ideal.Quotient.eq.2 <| subset_span <| Or.inl ⟨i, j, hij, x, rfl⟩
#align ring.direct_limit.of_f Ring.DirectLimit.of_f

/-- Every element of the direct limit corresponds to some element in
some component of the directed system. -/
theorem exists_of [Nonempty ι] [IsDirected ι (· ≤ ·)] (z : DirectLimit G f) :
    ∃ i x, of G f i x = z :=
  Nonempty.elim (by infer_instance) fun ind : ι =>
    Quotient.inductionOn' z fun x =>
      FreeAbelianGroup.induction_on x ⟨ind, 0, (of _ _ ind).map_zero⟩
        (fun s =>
          Multiset.induction_on s ⟨ind, 1, (of _ _ ind).map_one⟩ fun a s ih =>
            let ⟨i, x⟩ := a
            let ⟨j, y, hs⟩ := ih
            let ⟨k, hik, hjk⟩ := exists_ge_ge i j
            ⟨k, f i k hik x * f j k hjk y, by rw [(of _ _ _).map_mul, of_f, of_f, hs] <;> rfl⟩)
        (fun s ⟨i, x, ih⟩ => ⟨i, -x, by rw [(of _ _ _).map_neg, ih] <;> rfl⟩)
        fun p q ⟨i, x, ihx⟩ ⟨j, y, ihy⟩ =>
        let ⟨k, hik, hjk⟩ := exists_ge_ge i j
        ⟨k, f i k hik x + f j k hjk y, by rw [(of _ _ _).map_add, of_f, of_f, ihx, ihy] <;> rfl⟩
#align ring.direct_limit.exists_of Ring.DirectLimit.exists_of

section

open Classical

open Polynomial

variable {f' : ∀ i j, i ≤ j → G i →+* G j}

theorem Polynomial.exists_of [Nonempty ι] [IsDirected ι (· ≤ ·)]
    (q : Polynomial (DirectLimit G fun i j h => f' i j h)) :
    ∃ i p, Polynomial.map (of G (fun i j h => f' i j h) i) p = q :=
  Polynomial.induction_on q
    (fun z =>
      let ⟨i, x, h⟩ := exists_of z
      ⟨i, C x, by rw [map_C, h]⟩)
    (fun q₁ q₂ ⟨i₁, p₁, ih₁⟩ ⟨i₂, p₂, ih₂⟩ =>
      let ⟨i, h1, h2⟩ := exists_ge_ge i₁ i₂
      ⟨i, p₁.map (f' i₁ i h1) + p₂.map (f' i₂ i h2),
        by
        rw [Polynomial.map_add, map_map, map_map, ← ih₁, ← ih₂]
        congr 2 <;> ext x <;> simp_rw [RingHom.comp_apply, of_f]⟩)
    fun n z ih =>
    let ⟨i, x, h⟩ := exists_of z
    ⟨i, C x * X ^ (n + 1), by rw [Polynomial.map_mul, map_C, h, Polynomial.map_pow, map_X]⟩
#align ring.direct_limit.polynomial.exists_of Ring.DirectLimit.Polynomial.exists_of

end

@[elab_as_elim]
theorem induction_on [Nonempty ι] [IsDirected ι (· ≤ ·)] {C : DirectLimit G f → Prop}
    (z : DirectLimit G f) (ih : ∀ i x, C (of G f i x)) : C z :=
  let ⟨i, x, hx⟩ := exists_of z
  hx ▸ ih i x
#align ring.direct_limit.induction_on Ring.DirectLimit.induction_on

section OfZeroExact

open Classical

variable (f' : ∀ i j, i ≤ j → G i →+* G j)

variable [DirectedSystem G fun i j h => f' i j h]

variable (G f)

theorem of.zero_exact_aux2 {x : FreeCommRing (Σi, G i)} {s t} (hxs : IsSupported x s) {j k}
    (hj : ∀ z : Σi, G i, z ∈ s → z.1 ≤ j) (hk : ∀ z : Σi, G i, z ∈ t → z.1 ≤ k) (hjk : j ≤ k)
    (hst : s ⊆ t) :
    f' j k hjk (lift (fun ix : s => f' ix.1.1 j (hj ix ix.2) ix.1.2) (restriction s x)) =
      lift (fun ix : t => f' ix.1.1 k (hk ix ix.2) ix.1.2) (restriction t x) :=
  by
  refine' Subring.InClosure.recOn hxs _ _ _ _
  ·
    rw [(restriction _).map_one, (FreeCommRing.lift _).map_one, (f' j k hjk).map_one,
      (restriction _).map_one, (FreeCommRing.lift _).map_one]
  ·
    rw [(restriction _).map_neg, (restriction _).map_one, (FreeCommRing.lift _).map_neg,
      (FreeCommRing.lift _).map_one, (f' j k hjk).map_neg, (f' j k hjk).map_one,
      (restriction _).map_neg, (restriction _).map_one, (FreeCommRing.lift _).map_neg,
      (FreeCommRing.lift _).map_one]
  · rintro _ ⟨p, hps, rfl⟩ n ih
    rw [(restriction _).map_mul, (FreeCommRing.lift _).map_mul, (f' j k hjk).map_mul, ih,
      (restriction _).map_mul, (FreeCommRing.lift _).map_mul, restriction_of, dif_pos hps, lift_of,
      restriction_of, dif_pos (hst hps), lift_of]
    dsimp only
    have := DirectedSystem.map_map fun i j h => f' i j h
    dsimp only at this
    rw [this]
    rfl
  · rintro x y ihx ihy
    rw [(restriction _).map_add, (FreeCommRing.lift _).map_add, (f' j k hjk).map_add, ihx, ihy,
      (restriction _).map_add, (FreeCommRing.lift _).map_add]
#align ring.direct_limit.of.zero_exact_aux2 Ring.DirectLimit.of.zero_exact_aux2

variable {G f f'}

theorem of.zero_exact_aux [Nonempty ι] [IsDirected ι (· ≤ ·)] {x : FreeCommRing (Σi, G i)}
    (H : Ideal.Quotient.mk _ x = (0 : DirectLimit G fun i j h => f' i j h)) :
    ∃ j s,
      ∃ H : ∀ k : Σi, G i, k ∈ s → k.1 ≤ j,
        IsSupported x s ∧
          lift (fun ix : s => f' ix.1.1 j (H ix ix.2) ix.1.2) (restriction s x) = (0 : G j) :=
  by
  refine' span_induction (Ideal.Quotient.eq_zero_iff_mem.1 H) _ _ _ _
  · rintro x (⟨i, j, hij, x, rfl⟩ | ⟨i, rfl⟩ | ⟨i, x, y, rfl⟩ | ⟨i, x, y, rfl⟩)
    · refine'
        ⟨j, {⟨i, x⟩, ⟨j, f' i j hij x⟩}, _,
          is_supported_sub (is_supported_of.2 <| Or.inr rfl) (is_supported_of.2 <| Or.inl rfl), _⟩
      · rintro k (rfl | ⟨rfl | _⟩)
        exact hij
        rfl
      · rw [(restriction _).map_sub, (FreeCommRing.lift _).map_sub, restriction_of, dif_pos,
          restriction_of, dif_pos, lift_of, lift_of]
        dsimp only
        have := DirectedSystem.map_map fun i j h => f' i j h
        dsimp only at this
        rw [this]
        exact sub_self _
        exacts[Or.inr rfl, Or.inl rfl]
    · refine' ⟨i, {⟨i, 1⟩}, _, is_supported_sub (is_supported_of.2 rfl) is_supported_one, _⟩
      · rintro k (rfl | h)
        rfl
      · rw [(restriction _).map_sub, (FreeCommRing.lift _).map_sub, restriction_of, dif_pos,
          (restriction _).map_one, lift_of, (FreeCommRing.lift _).map_one]
        dsimp only
        rw [(f' i i _).map_one, sub_self]
        · exact Set.mem_singleton _
    · refine'
        ⟨i, {⟨i, x + y⟩, ⟨i, x⟩, ⟨i, y⟩}, _,
          is_supported_sub (is_supported_of.2 <| Or.inl rfl)
            (is_supported_add (is_supported_of.2 <| Or.inr <| Or.inl rfl)
              (is_supported_of.2 <| Or.inr <| Or.inr rfl)),
          _⟩
      · rintro k (rfl | ⟨rfl | ⟨rfl | hk⟩⟩) <;> rfl
      · rw [(restriction _).map_sub, (restriction _).map_add, restriction_of, restriction_of,
          restriction_of, dif_pos, dif_pos, dif_pos, (FreeCommRing.lift _).map_sub,
          (FreeCommRing.lift _).map_add, lift_of, lift_of, lift_of]
        dsimp only
        rw [(f' i i _).map_add]
        exact sub_self _
        exacts[Or.inl rfl, Or.inr (Or.inr rfl), Or.inr (Or.inl rfl)]
    · refine'
        ⟨i, {⟨i, x * y⟩, ⟨i, x⟩, ⟨i, y⟩}, _,
          is_supported_sub (is_supported_of.2 <| Or.inl rfl)
            (is_supported_mul (is_supported_of.2 <| Or.inr <| Or.inl rfl)
              (is_supported_of.2 <| Or.inr <| Or.inr rfl)),
          _⟩
      · rintro k (rfl | ⟨rfl | ⟨rfl | hk⟩⟩) <;> rfl
      · rw [(restriction _).map_sub, (restriction _).map_mul, restriction_of, restriction_of,
          restriction_of, dif_pos, dif_pos, dif_pos, (FreeCommRing.lift _).map_sub,
          (FreeCommRing.lift _).map_mul, lift_of, lift_of, lift_of]
        dsimp only
        rw [(f' i i _).map_mul]
        exacts[sub_self _, Or.inl rfl, Or.inr (Or.inr rfl), Or.inr (Or.inl rfl)]
  · refine' Nonempty.elim (by infer_instance) fun ind : ι => _
    refine' ⟨ind, ∅, fun _ => False.elim, is_supported_zero, _⟩
    rw [(restriction _).map_zero, (FreeCommRing.lift _).map_zero]
  · rintro x y ⟨i, s, hi, hxs, ihs⟩ ⟨j, t, hj, hyt, iht⟩
    obtain ⟨k, hik, hjk⟩ := exists_ge_ge i j
    have : ∀ z : Σi, G i, z ∈ s ∪ t → z.1 ≤ k :=
      by
      rintro z (hz | hz)
      exact le_trans (hi z hz) hik
      exact le_trans (hj z hz) hjk
    refine'
      ⟨k, s ∪ t, this,
        is_supported_add (is_supported_upwards hxs <| Set.subset_union_left s t)
          (is_supported_upwards hyt <| Set.subset_union_right s t),
        _⟩
    ·
      rw [(restriction _).map_add, (FreeCommRing.lift _).map_add, ←
        of.zero_exact_aux2 G f' hxs hi this hik (Set.subset_union_left s t), ←
        of.zero_exact_aux2 G f' hyt hj this hjk (Set.subset_union_right s t), ihs,
        (f' i k hik).map_zero, iht, (f' j k hjk).map_zero, zero_add]
  · rintro x y ⟨j, t, hj, hyt, iht⟩
    rw [smul_eq_mul]
    rcases exists_finset_support x with ⟨s, hxs⟩
    rcases(s.image Sigma.fst).exists_le with ⟨i, hi⟩
    obtain ⟨k, hik, hjk⟩ := exists_ge_ge i j
    have : ∀ z : Σi, G i, z ∈ ↑s ∪ t → z.1 ≤ k :=
      by
      rintro z (hz | hz)
      exacts[(hi z.1 <| Finset.mem_image.2 ⟨z, hz, rfl⟩).trans hik, (hj z hz).trans hjk]
    refine'
      ⟨k, ↑s ∪ t, this,
        is_supported_mul (is_supported_upwards hxs <| Set.subset_union_left (↑s) t)
          (is_supported_upwards hyt <| Set.subset_union_right (↑s) t),
        _⟩
    rw [(restriction _).map_mul, (FreeCommRing.lift _).map_mul, ←
      of.zero_exact_aux2 G f' hyt hj this hjk (Set.subset_union_right (↑s) t), iht,
      (f' j k hjk).map_zero, MulZeroClass.mul_zero]
#align ring.direct_limit.of.zero_exact_aux Ring.DirectLimit.of.zero_exact_aux

/-- A component that corresponds to zero in the direct limit is already zero in some
bigger module in the directed system. -/
theorem of.zero_exact [IsDirected ι (· ≤ ·)] {i x} (hix : of G (fun i j h => f' i j h) i x = 0) :
    ∃ (j : _)(hij : i ≤ j), f' i j hij x = 0 :=
  haveI : Nonempty ι := ⟨i⟩
  let ⟨j, s, H, hxs, hx⟩ := of.zero_exact_aux hix
  have hixs : (⟨i, x⟩ : Σi, G i) ∈ s := is_supported_of.1 hxs
  ⟨j, H ⟨i, x⟩ hixs, by rw [restriction_of, dif_pos hixs, lift_of] at hx <;> exact hx⟩
#align ring.direct_limit.of.zero_exact Ring.DirectLimit.of.zero_exact

end OfZeroExact

variable (f' : ∀ i j, i ≤ j → G i →+* G j)

/-- If the maps in the directed system are injective, then the canonical maps
from the components to the direct limits are injective. -/
theorem of_injective [IsDirected ι (· ≤ ·)] [DirectedSystem G fun i j h => f' i j h]
    (hf : ∀ i j hij, Function.Injective (f' i j hij)) (i) :
    Function.Injective (of G (fun i j h => f' i j h) i) :=
  by
  suffices ∀ x, of G (fun i j h => f' i j h) i x = 0 → x = 0
    by
    intro x y hxy
    rw [← sub_eq_zero]
    apply this
    rw [(of G _ i).map_sub, hxy, sub_self]
  intro x hx
  rcases of.zero_exact hx with ⟨j, hij, hfx⟩
  apply hf i j hij
  rw [hfx, (f' i j hij).map_zero]
#align ring.direct_limit.of_injective Ring.DirectLimit.of_injective

variable (P : Type u₁) [CommRing P]

variable (g : ∀ i, G i →+* P)

variable (Hg : ∀ i j hij x, g j (f i j hij x) = g i x)

include Hg

open FreeCommRing

variable (G f)

/-- The universal property of the direct limit: maps from the components to another ring
that respect the directed system structure (i.e. make some diagram commute) give rise
to a unique map out of the direct limit.
-/
def lift : DirectLimit G f →+* P :=
  Ideal.Quotient.lift _ (FreeCommRing.lift fun x : Σi, G i => g x.1 x.2)
    (by
      suffices Ideal.span _ ≤ Ideal.comap (FreeCommRing.lift fun x : Σi : ι, G i => g x.fst x.snd) ⊥
        by
        intro x hx
        exact (mem_bot P).1 (this hx)
      rw [Ideal.span_le]
      intro x hx
      rw [SetLike.mem_coe, Ideal.mem_comap, mem_bot]
      rcases hx with (⟨i, j, hij, x, rfl⟩ | ⟨i, rfl⟩ | ⟨i, x, y, rfl⟩ | ⟨i, x, y, rfl⟩) <;>
        simp only [RingHom.map_sub, lift_of, Hg, RingHom.map_one, RingHom.map_add, RingHom.map_mul,
          (g i).map_one, (g i).map_add, (g i).map_mul, sub_self])
#align ring.direct_limit.lift Ring.DirectLimit.lift

variable {G f}

omit Hg

@[simp]
theorem lift_of (i x) : lift G f P g Hg (of G f i x) = g i x :=
  FreeCommRing.lift_of _ _
#align ring.direct_limit.lift_of Ring.DirectLimit.lift_of

theorem lift_unique [Nonempty ι] [IsDirected ι (· ≤ ·)] (F : DirectLimit G f →+* P) (x) :
    F x = lift G f P (fun i => F.comp <| of G f i) (fun i j hij x => by simp) x :=
  DirectLimit.induction_on x fun i x => by simp
#align ring.direct_limit.lift_unique Ring.DirectLimit.lift_unique

end DirectLimit

end

end Ring

namespace Field

variable [Nonempty ι] [IsDirected ι (· ≤ ·)] [∀ i, Field (G i)]

variable (f : ∀ i j, i ≤ j → G i → G j)

variable (f' : ∀ i j, i ≤ j → G i →+* G j)

namespace DirectLimit

instance nontrivial [DirectedSystem G fun i j h => f' i j h] :
    Nontrivial (Ring.DirectLimit G fun i j h => f' i j h) :=
  ⟨⟨0, 1,
      Nonempty.elim (by infer_instance) fun i : ι =>
        by
        change (0 : Ring.DirectLimit G fun i j h => f' i j h) ≠ 1
        rw [← (Ring.DirectLimit.of _ _ _).map_one]
        intro H; rcases Ring.DirectLimit.of.zero_exact H.symm with ⟨j, hij, hf⟩
        rw [(f' i j hij).map_one] at hf
        exact one_ne_zero hf⟩⟩
#align field.direct_limit.nontrivial Field.DirectLimit.nontrivial

theorem exists_inv {p : Ring.DirectLimit G f} : p ≠ 0 → ∃ y, p * y = 1 :=
  Ring.DirectLimit.induction_on p fun i x H =>
    ⟨Ring.DirectLimit.of G f i x⁻¹, by
      erw [← (Ring.DirectLimit.of _ _ _).map_mul,
        mul_inv_cancel fun h : x = 0 => H <| by rw [h, (Ring.DirectLimit.of _ _ _).map_zero],
        (Ring.DirectLimit.of _ _ _).map_one]⟩
#align field.direct_limit.exists_inv Field.DirectLimit.exists_inv

section

open Classical

/-- Noncomputable multiplicative inverse in a direct limit of fields. -/
noncomputable def inv (p : Ring.DirectLimit G f) : Ring.DirectLimit G f :=
  if H : p = 0 then 0 else Classical.choose (DirectLimit.exists_inv G f H)
#align field.direct_limit.inv Field.DirectLimit.inv

protected theorem mul_inv_cancel {p : Ring.DirectLimit G f} (hp : p ≠ 0) : p * inv G f p = 1 := by
  rw [inv, dif_neg hp, Classical.choose_spec (direct_limit.exists_inv G f hp)]
#align field.direct_limit.mul_inv_cancel Field.DirectLimit.mul_inv_cancel

protected theorem inv_mul_cancel {p : Ring.DirectLimit G f} (hp : p ≠ 0) : inv G f p * p = 1 := by
  rw [_root_.mul_comm, direct_limit.mul_inv_cancel G f hp]
#align field.direct_limit.inv_mul_cancel Field.DirectLimit.inv_mul_cancel

/-- Noncomputable field structure on the direct limit of fields.
See note [reducible non-instances]. -/
@[reducible]
protected noncomputable def field [DirectedSystem G fun i j h => f' i j h] :
    Field (Ring.DirectLimit G fun i j h => f' i j h) :=
  { Ring.DirectLimit.commRing G fun i j h => f' i j h,
    DirectLimit.nontrivial G fun i j h =>
      f' i j h with
    inv := inv G fun i j h => f' i j h
    mul_inv_cancel := fun p => DirectLimit.mul_inv_cancel G fun i j h => f' i j h
    inv_zero := dif_pos rfl }
#align field.direct_limit.field Field.DirectLimit.field

end

end DirectLimit

end Field


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Yury Kudryashov
-/
import analysis.convex.normed
import analysis.convex.strict
import analysis.normed.order.basic
import analysis.normed_space.add_torsor
import analysis.normed_space.pointwise
import analysis.normed_space.affine_isometry

/-!
# Strictly convex spaces

This file defines strictly convex spaces. A normed space is strictly convex if all closed balls are
strictly convex. This does **not** mean that the norm is strictly convex (in fact, it never is).

## Main definitions

`strict_convex_space`: a typeclass saying that a given normed space over a normed linear ordered
field (e.g., `ℝ` or `ℚ`) is strictly convex. The definition requires strict convexity of a closed
ball of positive radius with center at the origin; strict convexity of any other closed ball follows
from this assumption.

## Main results

In a strictly convex space, we prove

- `strict_convex_closed_ball`: a closed ball is strictly convex.
- `combo_mem_ball_of_ne`, `open_segment_subset_ball_of_ne`, `norm_combo_lt_of_ne`:
  a nontrivial convex combination of two points in a closed ball belong to the corresponding open
  ball;
- `norm_add_lt_of_not_same_ray`, `same_ray_iff_norm_add`, `dist_add_dist_eq_iff`:
  the triangle inequality `dist x y + dist y z ≤ dist x z` is a strict inequality unless `y` belongs
  to the segment `[x -[ℝ] z]`.
- `isometry.affine_isometry_of_strict_convex_space`: an isometry of `normed_add_torsor`s for real
  normed spaces, strictly convex in the case of the codomain, is an affine isometry.

We also provide several lemmas that can be used as alternative constructors for `strict_convex ℝ E`:

- `strict_convex_space.of_strict_convex_closed_unit_ball`: if `closed_ball (0 : E) 1` is strictly
  convex, then `E` is a strictly convex space;

- `strict_convex_space.of_norm_add`: if `‖x + y‖ = ‖x‖ + ‖y‖` implies `same_ray ℝ x y` for all
  nonzero `x y : E`, then `E` is a strictly convex space.

## Implementation notes

While the definition is formulated for any normed linear ordered field, most of the lemmas are
formulated only for the case `𝕜 = ℝ`.

## Tags

convex, strictly convex
-/

open set metric
open_locale convex pointwise

/-- A *strictly convex space* is a normed space where the closed balls are strictly convex. We only
require balls of positive radius with center at the origin to be strictly convex in the definition,
then prove that any closed ball is strictly convex in `strict_convex_closed_ball` below.

See also `strict_convex_space.of_strict_convex_closed_unit_ball`. -/
class strict_convex_space (𝕜 E : Type*) [normed_linear_ordered_field 𝕜] [normed_add_comm_group E]
  [normed_space 𝕜 E] : Prop :=
(strict_convex_closed_ball : ∀ r : ℝ, 0 < r → strict_convex 𝕜 (closed_ball (0 : E) r))

variables (𝕜 : Type*) {E : Type*} [normed_linear_ordered_field 𝕜]
  [normed_add_comm_group E] [normed_space 𝕜 E]

/-- A closed ball in a strictly convex space is strictly convex. -/
lemma strict_convex_closed_ball [strict_convex_space 𝕜 E] (x : E) (r : ℝ) :
  strict_convex 𝕜 (closed_ball x r) :=
begin
  cases le_or_lt r 0 with hr hr,
  { exact (subsingleton_closed_ball x hr).strict_convex },
  rw ← vadd_closed_ball_zero,
  exact (strict_convex_space.strict_convex_closed_ball r hr).vadd _,
end

variables [normed_space ℝ E]

/-- A real normed vector space is strictly convex provided that the unit ball is strictly convex. -/
lemma strict_convex_space.of_strict_convex_closed_unit_ball
  [linear_map.compatible_smul E E 𝕜 ℝ] (h : strict_convex 𝕜 (closed_ball (0 : E) 1)) :
  strict_convex_space 𝕜 E :=
⟨λ r hr, by simpa only [smul_closed_unit_ball_of_nonneg hr.le] using h.smul r⟩

/-- Strict convexity is equivalent to `‖a • x + b • y‖ < 1` for all `x` and `y` of norm at most `1`
and all strictly positive `a` and `b` such that `a + b = 1`. This lemma shows that it suffices to
check this for points of norm one and some `a`, `b` such that `a + b = 1`. -/
lemma strict_convex_space.of_norm_combo_lt_one
  (h : ∀ x y : E, ‖x‖ = 1 → ‖y‖ = 1 → x ≠ y → ∃ a b : ℝ, a + b = 1 ∧ ‖a • x + b • y‖ < 1) :
  strict_convex_space ℝ E :=
begin
  refine strict_convex_space.of_strict_convex_closed_unit_ball ℝ
    ((convex_closed_ball _ _).strict_convex' $ λ x hx y hy hne, _),
  rw [interior_closed_ball (0 : E) one_ne_zero, closed_ball_diff_ball, mem_sphere_zero_iff_norm]
    at hx hy,
  rcases h x y hx hy hne with ⟨a, b, hab, hlt⟩,
  use b,
  rwa [affine_map.line_map_apply_module, interior_closed_ball (0 : E) one_ne_zero,
    mem_ball_zero_iff, sub_eq_iff_eq_add.2 hab.symm]
end

lemma strict_convex_space.of_norm_combo_ne_one
  (h : ∀ x y : E, ‖x‖ = 1 → ‖y‖ = 1 → x ≠ y →
    ∃ a b : ℝ, 0 ≤ a ∧ 0 ≤ b ∧ a + b = 1 ∧ ‖a • x + b • y‖ ≠ 1) :
  strict_convex_space ℝ E :=
begin
  refine strict_convex_space.of_strict_convex_closed_unit_ball ℝ
    ((convex_closed_ball _ _).strict_convex _),
  simp only [interior_closed_ball _ one_ne_zero, closed_ball_diff_ball, set.pairwise,
    frontier_closed_ball _ one_ne_zero, mem_sphere_zero_iff_norm],
  intros x hx y hy hne,
  rcases h x y hx hy hne with ⟨a, b, ha, hb, hab, hne'⟩,
  exact ⟨_, ⟨a, b, ha, hb, hab, rfl⟩, mt mem_sphere_zero_iff_norm.1 hne'⟩
end

lemma strict_convex_space.of_norm_add_ne_two
  (h : ∀ ⦃x y : E⦄, ‖x‖ = 1 → ‖y‖ = 1 → x ≠ y → ‖x + y‖ ≠ 2) :
  strict_convex_space ℝ E :=
begin
  refine strict_convex_space.of_norm_combo_ne_one
    (λ x y hx hy hne, ⟨1/2, 1/2, one_half_pos.le, one_half_pos.le, add_halves _, _⟩),
  rw [← smul_add, norm_smul, real.norm_of_nonneg one_half_pos.le, one_div,
    ← div_eq_inv_mul, ne.def, div_eq_one_iff_eq (two_ne_zero' ℝ)],
  exact h hx hy hne,
end

lemma strict_convex_space.of_pairwise_sphere_norm_ne_two
  (h : (sphere (0 : E) 1).pairwise $ λ x y, ‖x + y‖ ≠ 2) :
  strict_convex_space ℝ E :=
strict_convex_space.of_norm_add_ne_two $ λ x y hx hy,
  h (mem_sphere_zero_iff_norm.2 hx) (mem_sphere_zero_iff_norm.2 hy)

/-- If `‖x + y‖ = ‖x‖ + ‖y‖` implies that `x y : E` are in the same ray, then `E` is a strictly
convex space. See also a more -/
lemma strict_convex_space.of_norm_add
  (h : ∀ x y : E, ‖x‖ = 1 → ‖y‖ = 1 → ‖x + y‖ = 2 → same_ray ℝ x y) :
  strict_convex_space ℝ E :=
begin
  refine strict_convex_space.of_pairwise_sphere_norm_ne_two (λ x hx y hy, mt $ λ h₂, _),
  rw mem_sphere_zero_iff_norm at hx hy,
  exact (same_ray_iff_of_norm_eq (hx.trans hy.symm)).1 (h x y hx hy h₂)
end

variables [strict_convex_space ℝ E] {x y z : E} {a b r : ℝ}

/-- If `x ≠ y` belong to the same closed ball, then a convex combination of `x` and `y` with
positive coefficients belongs to the corresponding open ball. -/
lemma combo_mem_ball_of_ne (hx : x ∈ closed_ball z r) (hy : y ∈ closed_ball z r) (hne : x ≠ y)
  (ha : 0 < a) (hb : 0 < b) (hab : a + b = 1) : a • x + b • y ∈ ball z r :=
begin
  rcases eq_or_ne r 0 with rfl|hr,
  { rw [closed_ball_zero, mem_singleton_iff] at hx hy,
    exact (hne (hx.trans hy.symm)).elim },
  { simp only [← interior_closed_ball _ hr] at hx hy ⊢,
    exact strict_convex_closed_ball ℝ z r hx hy hne ha hb hab }
end

/-- If `x ≠ y` belong to the same closed ball, then the open segment with endpoints `x` and `y` is
included in the corresponding open ball. -/
lemma open_segment_subset_ball_of_ne (hx : x ∈ closed_ball z r) (hy : y ∈ closed_ball z r)
  (hne : x ≠ y) : open_segment ℝ x y ⊆ ball z r :=
(open_segment_subset_iff _).2 $ λ a b, combo_mem_ball_of_ne hx hy hne

/-- If `x` and `y` are two distinct vectors of norm at most `r`, then a convex combination of `x`
and `y` with positive coefficients has norm strictly less than `r`. -/
lemma norm_combo_lt_of_ne (hx : ‖x‖ ≤ r) (hy : ‖y‖ ≤ r) (hne : x ≠ y) (ha : 0 < a) (hb : 0 < b)
  (hab : a + b = 1) : ‖a • x + b • y‖ < r :=
begin
  simp only [← mem_ball_zero_iff, ← mem_closed_ball_zero_iff] at hx hy ⊢,
  exact combo_mem_ball_of_ne hx hy hne ha hb hab
end

/-- In a strictly convex space, if `x` and `y` are not in the same ray, then `‖x + y‖ < ‖x‖ +
‖y‖`. -/
lemma norm_add_lt_of_not_same_ray (h : ¬same_ray ℝ x y) : ‖x + y‖ < ‖x‖ + ‖y‖ :=
begin
  simp only [same_ray_iff_inv_norm_smul_eq, not_or_distrib, ← ne.def] at h,
  rcases h with ⟨hx, hy, hne⟩,
  rw ← norm_pos_iff at hx hy,
  have hxy : 0 < ‖x‖ + ‖y‖ := add_pos hx hy,
  have := combo_mem_ball_of_ne (inv_norm_smul_mem_closed_unit_ball x)
    (inv_norm_smul_mem_closed_unit_ball y) hne (div_pos hx hxy) (div_pos hy hxy)
    (by rw [← add_div, div_self hxy.ne']),
  rwa [mem_ball_zero_iff, div_eq_inv_mul, div_eq_inv_mul, mul_smul, mul_smul,
    smul_inv_smul₀ hx.ne', smul_inv_smul₀ hy.ne', ← smul_add, norm_smul,
    real.norm_of_nonneg (inv_pos.2 hxy).le, ← div_eq_inv_mul, div_lt_one hxy] at this
end

lemma lt_norm_sub_of_not_same_ray (h : ¬same_ray ℝ x y) : ‖x‖ - ‖y‖ < ‖x - y‖ :=
begin
  nth_rewrite 0 ←sub_add_cancel x y at ⊢ h,
  exact sub_lt_iff_lt_add.2 (norm_add_lt_of_not_same_ray $ λ H', h $ H'.add_left same_ray.rfl),
end

lemma abs_lt_norm_sub_of_not_same_ray (h : ¬same_ray ℝ x y) : |‖x‖ - ‖y‖| < ‖x - y‖ :=
begin
  refine abs_sub_lt_iff.2 ⟨lt_norm_sub_of_not_same_ray h, _⟩,
  rw norm_sub_rev,
  exact lt_norm_sub_of_not_same_ray (mt same_ray.symm h),
end

/-- In a strictly convex space, two vectors `x`, `y` are in the same ray if and only if the triangle
inequality for `x` and `y` becomes an equality. -/
lemma same_ray_iff_norm_add : same_ray ℝ x y ↔ ‖x + y‖ = ‖x‖ + ‖y‖ :=
⟨same_ray.norm_add, λ h, not_not.1 $ λ h', (norm_add_lt_of_not_same_ray h').ne h⟩

/-- If `x` and `y` are two vectors in a strictly convex space have the same norm and the norm of
their sum is equal to the sum of their norms, then they are equal. -/
lemma eq_of_norm_eq_of_norm_add_eq (h₁ : ‖x‖ = ‖y‖) (h₂ : ‖x + y‖ = ‖x‖ + ‖y‖) : x = y :=
(same_ray_iff_norm_add.mpr h₂).eq_of_norm_eq h₁

/-- In a strictly convex space, two vectors `x`, `y` are not in the same ray if and only if the
triangle inequality for `x` and `y` is strict. -/
lemma not_same_ray_iff_norm_add_lt : ¬ same_ray ℝ x y ↔ ‖x + y‖ < ‖x‖ + ‖y‖ :=
same_ray_iff_norm_add.not.trans (norm_add_le _ _).lt_iff_ne.symm

lemma same_ray_iff_norm_sub : same_ray ℝ x y ↔ ‖x - y‖ = |‖x‖ - ‖y‖| :=
⟨same_ray.norm_sub, λ h, not_not.1 $ λ h', (abs_lt_norm_sub_of_not_same_ray h').ne' h⟩

lemma not_same_ray_iff_abs_lt_norm_sub : ¬ same_ray ℝ x y ↔ |‖x‖ - ‖y‖| < ‖x - y‖ :=
same_ray_iff_norm_sub.not.trans $ ne_comm.trans (abs_norm_sub_norm_le _ _).lt_iff_ne.symm

/-- In a strictly convex space, the triangle inequality turns into an equality if and only if the
middle point belongs to the segment joining two other points. -/
lemma dist_add_dist_eq_iff : dist x y + dist y z = dist x z ↔ y ∈ [x -[ℝ] z] :=
by simp only [mem_segment_iff_same_ray, same_ray_iff_norm_add, dist_eq_norm',
  sub_add_sub_cancel', eq_comm]

lemma norm_midpoint_lt_iff (h : ‖x‖ = ‖y‖) : ‖(1/2 : ℝ) • (x + y)‖ < ‖x‖ ↔ x ≠ y :=
by rw [norm_smul, real.norm_of_nonneg (one_div_nonneg.2 zero_le_two), ←inv_eq_one_div,
    ←div_eq_inv_mul, div_lt_iff (zero_lt_two' ℝ), mul_two, ←not_same_ray_iff_of_norm_eq h,
    not_same_ray_iff_norm_add_lt, h]

variables {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
variables {PF : Type*} {PE : Type*} [metric_space PF] [metric_space PE]
variables [normed_add_torsor F PF] [normed_add_torsor E PE]

include E

lemma eq_line_map_of_dist_eq_mul_of_dist_eq_mul {x y z : PE} (hxy : dist x y = r * dist x z)
  (hyz : dist y z = (1 - r) * dist x z) :
  y = affine_map.line_map x z r :=
begin
  have : y -ᵥ x ∈ [(0 : E) -[ℝ] z -ᵥ x],
  { rw [← dist_add_dist_eq_iff, dist_zero_left, dist_vsub_cancel_right, ← dist_eq_norm_vsub',
      ← dist_eq_norm_vsub', hxy, hyz, ← add_mul, add_sub_cancel'_right, one_mul] },
  rcases eq_or_ne x z with rfl|hne,
  { obtain rfl : y = x, by simpa,
    simp },
  { rw [← dist_ne_zero] at hne,
    rcases this with ⟨a, b, ha, hb, hab, H⟩,
    rw [smul_zero, zero_add] at H,
    have H' := congr_arg norm H,
    rw [norm_smul, real.norm_of_nonneg hb, ← dist_eq_norm_vsub', ← dist_eq_norm_vsub', hxy,
      mul_left_inj' hne] at H',
    rw [affine_map.line_map_apply, ← H', H, vsub_vadd] },
end

lemma eq_midpoint_of_dist_eq_half {x y z : PE} (hx : dist x y = dist x z / 2)
  (hy : dist y z = dist x z / 2) : y = midpoint ℝ x z :=
begin
  apply eq_line_map_of_dist_eq_mul_of_dist_eq_mul,
  { rwa [inv_of_eq_inv, ← div_eq_inv_mul] },
  { rwa [inv_of_eq_inv, ← one_div, sub_half, one_div, ← div_eq_inv_mul] }
end

namespace isometry

include F

/-- An isometry of `normed_add_torsor`s for real normed spaces, strictly convex in the case of
the codomain, is an affine isometry.  Unlike Mazur-Ulam, this does not require the isometry to
be surjective.  -/
noncomputable def affine_isometry_of_strict_convex_space {f : PF → PE} (hi : isometry f) :
  PF →ᵃⁱ[ℝ] PE :=
{ norm_map := λ x, by simp [affine_map.of_map_midpoint, ←dist_eq_norm_vsub E, hi.dist_eq],
  ..affine_map.of_map_midpoint f (λ x y, begin
    apply eq_midpoint_of_dist_eq_half,
    { rw [hi.dist_eq, hi.dist_eq, dist_left_midpoint, real.norm_of_nonneg zero_le_two,
        div_eq_inv_mul] },
    { rw [hi.dist_eq, hi.dist_eq, dist_midpoint_right, real.norm_of_nonneg zero_le_two,
        div_eq_inv_mul] },
  end) hi.continuous }

@[simp] lemma coe_affine_isometry_of_strict_convex_space {f : PF → PE} (hi : isometry f) :
  ⇑(hi.affine_isometry_of_strict_convex_space) = f :=
rfl

@[simp] lemma affine_isometry_of_strict_convex_space_apply {f : PF → PE} (hi : isometry f)
  (p : PF) :
  hi.affine_isometry_of_strict_convex_space p = f p :=
rfl

end isometry


import Fine.PropositionalLanguage

inductive BTheorem : Form → Type
  | taut {p} : BTheorem (p ⊃ p)
  | andE₁ {p q} : BTheorem (p & q ⊃ p)
  | andE₂ {p q} : BTheorem (p & q ⊃ q)
  | andI {p q r} : BTheorem ((p ⊃ q) & (p ⊃ r) ⊃ (p ⊃ q & r))
  | orI₁ {p q} : BTheorem (p ⊃ p ¦ q)
  | orI₂ {p q} : BTheorem (q ⊃ p ¦ q)
  | orE {p q r} : BTheorem ((p ⊃ r) & (q ⊃ r) ⊃ (p ¦ q ⊃ r))
  | dne {p} : BTheorem (~~p ⊃ p)
  | dist {p q r} : BTheorem (p & (q ¦ r) ⊃ (p & q) ¦ (p & r))
  | mp {p q} (h₁ : BTheorem p) (h₂ : BTheorem (p ⊃ q)) : BTheorem q
  | adj {p q} (h₁ : BTheorem p) (h₂ : BTheorem q) : BTheorem (p & q)
  | cp {p q} (h₁ : BTheorem (p ⊃ ~q)) : BTheorem (q ⊃ ~p)
  | hs {p q r s} (h₁ : BTheorem (p ⊃ q)) (h₂ : BTheorem (r ⊃ s)) : BTheorem ((q ⊃ r) ⊃ (p ⊃ s))

inductive BProof : Ctx → Form → Type
  | ax {Γ} {p} (h: p ∈ Γ) : BProof Γ p
  | mp {Γ} {p} {q} (h₁ : BProof Γ p) (h₂ : BTheorem (p ⊃ q)) : BProof Γ q
  | adj {Γ} {p} {q} (h₁ : BProof Γ p) (h₂ : BProof Γ q) : BProof Γ (p & q)

abbrev BProvable (Γ : Ctx) (f : Form) : Prop:= Nonempty (BProof Γ f)

abbrev BTheory (f : Form) : Prop := Nonempty (BTheorem f)

infix:128 "⊢" => BProvable

section

open BTheorem

variable {p q r s : Form}

def BTheorem.transitivity (h₁ : BTheorem (p ⊃ q)) (h₂ : BTheorem (q ⊃ r)) : BTheorem (p ⊃ r) :=
  mp taut (hs h₁ h₂)

def BTheorem.transitivityLeft (h : BTheorem (p ⊃ q)) : BTheorem ((q ⊃ r) ⊃ (p ⊃ r)) :=
  hs h taut

def BTheorem.transitivityRight (h : BTheorem (p ⊃ q)) : BTheorem ((r ⊃ p) ⊃ (r ⊃ q)) :=
  hs taut h

def BTheorem.commAnd : BTheorem (q & p ⊃ p & q) :=
  BTheorem.mp (BTheorem.adj BTheorem.andE₂ BTheorem.andE₁) BTheorem.andI

def BTheorem.distRight : BTheorem ((q ¦ r) & p ⊃ (q & p) ¦ (r & p)) :=
  have l₁ : BTheorem ((q ¦ r) & p ⊃ (p & q) ¦ (p & r)) := BTheorem.transitivity BTheorem.commAnd BTheorem.dist
  have l₂ : BTheorem ((p & q) ¦ (p & r) ⊃ (q & p) ¦ (r & p)) := BTheorem.mp
     (BTheorem.adj (BTheorem.transitivity BTheorem.commAnd BTheorem.orI₁) (BTheorem.transitivity BTheorem.commAnd BTheorem.orI₂))
     BTheorem.orE
  BTheorem.transitivity l₁ l₂

def BTheorem.demorgansLaw1 : BTheorem ((p & q) ⊃ ~(~p ¦ ~q)) :=
  have l₁ : ∀{r : Form}, BTheorem (r ⊃ ~~r) := cp taut
  have l₂ : BTheorem (~p ⊃ ~(p & q)) := cp $ mp taut (hs andE₁ l₁)
  have l₃ : BTheorem (~q ⊃ ~(p & q)) := cp $ mp taut (hs andE₂ l₁)
  cp $ mp (adj l₂ l₃) orE

def BTheorem.demorgansLaw2 : BTheorem (~(~p ¦ ~q) ⊃ (p & q)) :=
  have l₁ : BTheorem (~p ⊃ ~~(~p ¦ ~q)) := transitivity orI₁ (cp taut)
  have l₂ : BTheorem (~(~p ¦ ~q) ⊃ p ) := transitivity (cp l₁) dne
  have l₃ : BTheorem (~q ⊃ ~~(~p ¦ ~q)) := transitivity orI₂ (cp taut)
  have l₄ : BTheorem (~(~p ¦ ~q) ⊃ q ) := transitivity (cp l₃) dne
  mp (adj l₂ l₄) andI

def BTheorem.demorgansLaw3 : BTheorem (~(p & q) ⊃ (~p ¦ ~q)) :=
  have l₁ : BTheorem (~(~p ¦ ~q) ⊃ ~~(p & q)):= transitivity demorgansLaw2 (cp taut)
  transitivity (cp l₁) dne

def BTheorem.demorgansLaw4 : BTheorem ((~p & ~q) ⊃ ~(p ¦ q)) :=
  have l₁ : BTheorem (p ⊃ ~(~p & ~q)) := cp andE₁
  have l₂ : BTheorem (q ⊃ ~(~p & ~q)) := cp andE₂
  cp (mp (adj l₁ l₂) orE)

def BTheorem.fromProof { p q : Form } : BProof {p} q → BTheorem (p ⊃ q)
  | BProof.ax h => by rw [h]; exact taut
  | BProof.adj h₁ h₂ => mp (adj (fromProof h₁) (fromProof h₂)) andI
  | BProof.mp h₁ h₂ => transitivity (fromProof h₁) h₂

def BTheorem.toProof { p q : Form } (h₁ : BTheorem (p ⊃ q)) : BProof {p} q :=
  BProof.mp (BProof.ax rfl) h₁

example : BTheorem ((p ⊃ q) ⊃ (p ⊃ (q ¦ r))) :=
  hs taut orI₁

example : BTheorem ((p ⊃ q) ⊃ (p & r ⊃ q)) :=
  hs andE₁ taut

def BProof.monotone { f : Form } { Γ : Ctx } { Δ : Ctx } (mono: Γ ⊆ Δ ) : BProof Γ f → BProof Δ f
  | ax h₁ => ax (mono h₁)
  | mp prf₁ thm₂ => mp (monotone mono prf₁) thm₂
  | adj prf₁ prf₂ => adj (monotone mono prf₁) (monotone mono prf₂)

def BProof.adjoinPremises { p q r : Form } : BProof {p,q} r → BProof {p & q} r
  | ax h => if c₁ : r = p then by
              rw [c₁]
              exact mp (ax rfl : BProof {p&q} (p&q)) andE₁
            else if c₂ : r = q then by
              rw [c₂]
              exact mp (ax rfl : BProof {p&q} (p&q)) andE₂
            else False.elim (Or.elim h c₁ c₂)
  | mp h₁ h₂ => mp (adjoinPremises h₁) h₂
  | adj h₁ h₂ => adj (adjoinPremises h₁) (adjoinPremises h₂)

def BProof.proveList { l : List Form } { f : Form } { Γ : Ctx } : { g | g ∈ f :: l } ⊆ Γ → BProof Γ (Form.conjoinList f l) := by
  intros h₁
  induction l
  case nil =>
    exact BProof.ax (h₁ $ List.mem_singleton.mpr rfl)
  case cons head tail ih =>
    have l₂ : { g | g ∈ f :: tail } ⊆ Γ := by
      intros g h₂
      cases h₂
      case head => exact h₁ $ List.mem_cons.mpr $ Or.inl rfl
      case tail h₃ => exact h₁ $ List.mem_cons.mpr $ Or.inr $ List.mem_cons.mpr $ Or.inr h₃
    have prf₁ := ih l₂
    have prf₂ := BProof.ax $ h₁ $ List.mem_cons.mpr $ Or.inr $ List.mem_cons.mpr $ Or.inl rfl
    cases tail
    case nil => exact BProof.adj prf₁ prf₂
    case cons head' tail' =>
      have prf₃ := BProof.mp prf₁ BTheorem.andE₁
      have prf₄ := BProof.mp prf₁ BTheorem.andE₂
      exact BProof.adj prf₃ $ BProof.adj prf₂ prf₄

def BProof.proveFromList { l : List Form } { f : Form } : g ∈ f :: l → BProof {Form.conjoinList f l} g := by
  intros h₁
  induction l
  case nil =>
    have l₁ : g = f := by
      cases List.mem_cons.mp h₁
      . assumption
      . contradiction
    rw [l₁]
    have l₂ : f ∈ ({f} : Ctx) := rfl
    exact BProof.ax l₂
  case cons head tail ih =>
      cases decEq g head
      case isFalse h₂ =>
        have l₁ : g ∈ f :: tail := by
          cases List.mem_cons.mp h₁
          case inl h₃ => exact List.mem_cons.mpr $ Or.inl h₃
          case inr h₃ =>
            cases List.mem_cons.mp h₃
            case inl => contradiction
            case inr h₄ => exact List.mem_cons.mpr $ Or.inr h₄
        have prf₁ := ih l₁
        cases tail
        case nil =>
          have prf₂ : BProof {Form.conjoinList f [head]} f := BProof.mp (BProof.ax rfl) BTheorem.andE₁
          exact BProof.mp prf₂ (BTheorem.fromProof prf₁)
        case cons head' tail' =>
          have prf₂ : BProof {Form.conjoinList f (head :: head' :: tail')} (Form.conjoinList f (head' :: tail')) := by
            exact BProof.adj (BProof.mp (BProof.ax rfl) BTheorem.andE₁) (BProof.mp (BProof.mp (BProof.ax rfl) BTheorem.andE₂) BTheorem.andE₂)
          exact BProof.mp prf₂ (BTheorem.fromProof prf₁)
      case isTrue h₂ =>
        rw [h₂]
        cases tail
        case nil => exact BProof.mp (BProof.ax rfl) BTheorem.andE₂
        case cons head' tail' => exact BProof.mp (BProof.mp (BProof.ax rfl) BTheorem.andE₂) BTheorem.andE₁

theorem BProof.compactness { Γ : Ctx } { f : Form } : BProof Γ f → Σs : Finset Form, Σ'_ : ↑s ⊆ Γ,  BProof ↑s f := by
  intros prf₁; induction prf₁
  case ax g h₁ =>
    let Gsing : Finset Form := {g}
    have l₁ : g ∈ {g} := Finset.mem_singleton.mpr rfl
    have l₂ : Gsing = ({g} : Ctx) := Finset.coe_singleton g
    have l₃ : ↑Gsing ⊆ Γ := by
      intros g' h₂
      rw [l₂] at h₂
      rw [h₂]
      assumption
    have prf₂ : BProof ↑{g} g := by
      rw [←l₂]
      apply ax l₁
    rw [←l₂] at prf₂
    exact ⟨Gsing, l₃, prf₂⟩
  case mp P Q _ h₂ ih =>
    have ⟨fin, h₁, prf⟩ := ih
    exact ⟨fin, h₁, mp prf h₂⟩
  case adj P Q _ _ ih₁ ih₂ =>
    have ⟨fin₁, h₁, prf₁⟩ := ih₁
    have ⟨fin₂, h₂, prf₂⟩ := ih₂
    have prf₃ : BProof (↑fin₁ ∪ ↑fin₂) P := BProof.monotone (Set.subset_union_left ↑fin₁ ↑fin₂) prf₁
    have prf₄ : BProof (↑fin₁ ∪ ↑fin₂) Q := BProof.monotone (Set.subset_union_right ↑fin₁ ↑fin₂) prf₂
    have prf₅ := adj prf₃ prf₄
    have l₁ : ↑(fin₁ ∪ fin₂) ⊆ Γ := by
      intros f h₃
      rw [Finset.coe_union] at h₃
      cases h₃
      case inl h₄ => exact h₁ h₄
      case inr h₄ => exact h₂ h₄
    rw [←Finset.coe_union] at prf₅
    exact ⟨↑(fin₁ ∪ fin₂), l₁, prf₅⟩

theorem BProof.listCompression { l : List Form } { f : Form } {g : Form} : BProof {h : Form | h = f ∨ h ∈ l } g → BProof {Form.conjoinList f l} g  := by
  intros prf₁; induction prf₁
  case ax p h₁ => exact BProof.proveFromList $ List.mem_cons.mpr h₁
  case mp p q _ prf₂ ih => exact BProof.mp ih prf₂
  case adj p q _ _ prf₁ prf₂  => exact BProof.adj prf₁ prf₂

theorem BProof.sentenceCompactness { Γ : Ctx } { f g : Form } : BProof (insert f Γ) g → Σl : List Form, Σ'_ : {x | x ∈ l} ⊆ Γ,  BProof {Form.conjoinList f l} g := by
  intros h₁
  have ⟨s₁,h₂,prf₁⟩ := BProof.compactness h₁
  let lst₁ := (Finset.erase s₁ f).toList
  have l₁ : ↑s₁ ⊆ {h : Form | h = f ∨ h ∈ lst₁} := by
    intros k h₂
    cases decEq f k
    case isTrue h₃ => rw [h₃]; exact Or.inl rfl
    case isFalse h₃ =>
      have l₂ : k ∈ lst₁ := by
        apply Finset.mem_toList.mpr
        exact Finset.mem_erase.mpr ⟨h₃ ∘ Eq.symm, h₂⟩
      exact Or.inr l₂
  have prf₂ := BProof.listCompression $  BProof.monotone l₁ prf₁
  refine ⟨lst₁,?_,prf₂⟩
  intros k h₃
  have : k ∈ Finset.erase s₁ f := Finset.mem_toList.mp h₃
  have ⟨l₅,l₆⟩: k ≠ f ∧ k ∈ s₁ := Finset.mem_erase.mp this
  have : k ∈ insert f Γ := h₂ $ Finset.mem_coe.mpr l₆
  exact Set.mem_of_mem_insert_of_ne this l₅

end


lemma iff_trans (P Q R : Prop) : (P ↔ Q) → (Q ↔ R) → (P ↔ R) :=
begin
intros hpq hqr,
split,
intro p,
apply hqr.1,
apply hpq.1,
exact p,
intro r,
apply hpq.2,
apply hqr.2,
exact r,
end