/-
Copyright (c) 2021 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn, Joachim Breitner
-/
import algebra.free_monoid.basic
import group_theory.congruence
import group_theory.is_free_group
import data.list.chain
import set_theory.cardinal.ordinal
import data.set.pointwise.smul

/-!
# The free product of groups or monoids

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

Given an `ι`-indexed family `M` of monoids, we define their free product (categorical coproduct)
`free_product M`. When `ι` and all `M i` have decidable equality, the free product bijects with the
type `word M` of reduced words. This bijection is constructed by defining an action of
`free_product M` on `word M`.

When `M i` are all groups, `free_product M` is also a group (and the coproduct in the category of
groups).

## Main definitions

- `free_product M`: the free product, defined as a quotient of a free monoid.
- `free_product.of {i} : M i →* free_product M`.
- `free_product.lift : (Π {i}, M i →* N) ≃ (free_product M →* N)`: the universal property.
- `free_product.word M`: the type of reduced words.
- `free_product.word.equiv M : free_product M ≃ word M`.
- `free_product.neword M i j`: an inductive description of non-empty words with first letter from
  `M i` and last letter from `M j`, together with an API (`singleton`, `append`, `head`, `tail`,
  `to_word`, `prod`, `inv`). Used in the proof of the Ping-Pong-lemma.
- `free_product.lift_injective_of_ping_pong`: The Ping-Pong-lemma, proving injectivity of the
  `lift`. See the documentation of that theorem for more information.

## Remarks

There are many answers to the question "what is the free product of a family `M` of monoids?", and
they are all equivalent but not obviously equivalent. We provide two answers. The first, almost
tautological answer is given by `free_product M`, which is a quotient of the type of words in the
alphabet `Σ i, M i`. It's straightforward to define and easy to prove its universal property. But
this answer is not completely satisfactory, because it's difficult to tell when two elements
`x y : free_product M` are distinct since `free_product M` is defined as a quotient.

The second, maximally efficient answer is given by `word M`. An element of `word M` is a word in the
alphabet `Σ i, M i`, where the letter `⟨i, 1⟩` doesn't occur and no adjacent letters share an index
`i`. Since we only work with reduced words, there is no need for quotienting, and it is easy to tell
when two elements are distinct. However it's not obvious that this is even a monoid!

We prove that every element of `free_product M` can be represented by a unique reduced word, i.e.
`free_product M` and `word M` are equivalent types. This means that `word M` can be given a monoid
structure, and it lets us tell when two elements of `free_product M` are distinct.

There is also a completely tautological, maximally inefficient answer given by
`algebra.category.Mon.colimits`. Whereas `free_product M` at least ensures that (any instance of)
associativity holds by reflexivity, in this answer associativity holds because of quotienting. Yet
another answer, which is constructively more satisfying, could be obtained by showing that
`free_product.rel` is confluent.

## References

[van der Waerden, *Free products of groups*][MR25465]

-/

open set

variables {ι : Type*} (M : Π i : ι, Type*) [Π i, monoid (M i)]

/-- A relation on the free monoid on alphabet `Σ i, M i`, relating `⟨i, 1⟩` with `1` and
`⟨i, x⟩ * ⟨i, y⟩` with `⟨i, x * y⟩`. -/
inductive free_product.rel : free_monoid (Σ i, M i) → free_monoid (Σ i, M i) → Prop
| of_one (i : ι) : free_product.rel (free_monoid.of ⟨i, 1⟩) 1
| of_mul {i : ι} (x y : M i) : free_product.rel (free_monoid.of ⟨i, x⟩ * free_monoid.of ⟨i, y⟩)
  (free_monoid.of ⟨i, x * y⟩)

/-- The free product (categorical coproduct) of an indexed family of monoids. -/
@[derive [monoid, inhabited]]
def free_product : Type* := (con_gen (free_product.rel M)).quotient

namespace free_product

/-- The type of reduced words. A reduced word cannot contain a letter `1`, and no two adjacent
letters can come from the same summand. -/
@[ext] structure word :=
(to_list : list (Σ i, M i))
(ne_one : ∀ l ∈ to_list, sigma.snd l ≠ 1)
(chain_ne : to_list.chain' (λ l l', sigma.fst l ≠ sigma.fst l'))

variable {M}

/-- The inclusion of a summand into the free product. -/
def of {i : ι} : M i →* free_product M :=
{ to_fun   := λ x, con.mk' _ (free_monoid.of $ sigma.mk i x),
  map_one' := (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_one i)),
  map_mul' := λ x y, eq.symm $ (con.eq _).mpr (con_gen.rel.of _ _ (free_product.rel.of_mul x y)) }

lemma of_apply {i} (m : M i) : of m = con.mk' _ (free_monoid.of $ sigma.mk i m) := rfl

variables {N : Type*} [monoid N]

/-- See note [partially-applied ext lemmas]. -/
@[ext] lemma ext_hom (f g : free_product M →* N) (h : ∀ i, f.comp (of : M i →* _) = g.comp of) :
  f = g :=
(monoid_hom.cancel_right con.mk'_surjective).mp $ free_monoid.hom_eq $ λ ⟨i, x⟩,
  by rw [monoid_hom.comp_apply, monoid_hom.comp_apply, ←of_apply,
    ←monoid_hom.comp_apply, ←monoid_hom.comp_apply, h]

/-- A map out of the free product corresponds to a family of maps out of the summands. This is the
universal property of the free product, charaterizing it as a categorical coproduct. -/
@[simps symm_apply]
def lift : (Π i, M i →* N) ≃ (free_product M →* N) :=
{ to_fun := λ fi, con.lift _ (free_monoid.lift $ λ p : Σ i, M i, fi p.fst p.snd) $ con.con_gen_le
    begin
      simp_rw [con.rel_eq_coe, con.ker_rel],
      rintro _ _ (i | ⟨x, y⟩),
      { change free_monoid.lift _ (free_monoid.of _) = free_monoid.lift _ 1,
        simp only [monoid_hom.map_one, free_monoid.lift_eval_of], },
      { change free_monoid.lift _ (free_monoid.of _ * free_monoid.of _) =
          free_monoid.lift _ (free_monoid.of _),
        simp only [monoid_hom.map_mul, free_monoid.lift_eval_of], }
    end,
  inv_fun := λ f i, f.comp of,
  left_inv := by { intro fi, ext i x,
    rw [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], },
  right_inv := by { intro f, ext i x,
    simp only [monoid_hom.comp_apply, of_apply, con.lift_mk', free_monoid.lift_eval_of], } }

@[simp] lemma lift_of {N} [monoid N] (fi : Π i, M i →* N) {i} (m : M i) :
  lift fi (of m) = fi i m :=
by conv_rhs { rw [←lift.symm_apply_apply fi, lift_symm_apply, monoid_hom.comp_apply] }

@[elab_as_eliminator]
lemma induction_on {C : free_product M → Prop}
  (m : free_product M)
  (h_one : C 1)
  (h_of : ∀ (i) (m : M i), C (of m))
  (h_mul : ∀ (x y), C x → C y → C (x * y)) :
  C m :=
begin
  let S : submonoid (free_product M) := submonoid.mk (set_of C) h_mul h_one,
  convert subtype.prop (lift (λ i, of.cod_restrict S (h_of i)) m),
  change monoid_hom.id _ m = S.subtype.comp _ m,
  congr,
  ext,
  simp [monoid_hom.cod_restrict],
end

lemma of_left_inverse [decidable_eq ι] (i : ι) :
  function.left_inverse (lift $ pi.mul_single i (monoid_hom.id (M i))) of :=
λ x, by simp only [lift_of, pi.mul_single_eq_same, monoid_hom.id_apply]

lemma of_injective (i : ι) : function.injective ⇑(of : M i →* _) :=
by { classical, exact (of_left_inverse i).injective }

lemma lift_mrange_le {N} [monoid N] (f : Π i, M i →* N) {s : submonoid N}
  (h : ∀ i, (f i).mrange ≤ s) : (lift f).mrange ≤ s :=
begin
  rintros _ ⟨x, rfl⟩,
  induction x using free_product.induction_on with i x x y hx hy,
  { exact s.one_mem, },
  { simp only [lift_of, set_like.mem_coe], exact h i (set.mem_range_self x), },
  { simp only [map_mul, set_like.mem_coe], exact s.mul_mem hx hy, },
end

lemma mrange_eq_supr {N} [monoid N] (f : Π i, M i →* N) :
  (lift f).mrange = ⨆ i, (f i).mrange :=
begin
  apply le_antisymm (lift_mrange_le f (λ i, le_supr _ i)),
  apply supr_le _,
  rintros i _ ⟨x, rfl⟩,
  exact ⟨of x, by simp only [lift_of]⟩
end

section group

variables (G : ι → Type*) [Π i, group (G i)]

instance : has_inv (free_product G) :=
{ inv := mul_opposite.unop ∘
    lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) }

lemma inv_def (x : free_product G) : x⁻¹ = mul_opposite.unop
  (lift (λ i, (of : G i →* _).op.comp (mul_equiv.inv' (G i)).to_monoid_hom) x) := rfl

instance : group (free_product G) :=
{ mul_left_inv := begin
    intro m,
    rw inv_def,
    apply m.induction_on,
    { rw [monoid_hom.map_one, mul_opposite.unop_one, one_mul], },
    { intros i m, change of m⁻¹ * of m = 1, rw [←of.map_mul, mul_left_inv, of.map_one], },
    { intros x y hx hy,
      rw [monoid_hom.map_mul, mul_opposite.unop_mul, mul_assoc, ← mul_assoc _ x y, hx,
        one_mul, hy], },
  end,
  ..free_product.has_inv G,
  ..free_product.monoid G }

lemma lift_range_le {N} [group N] (f : Π i, G i →* N) {s : subgroup N}
  (h : ∀ i, (f i).range ≤ s) : (lift f).range ≤ s :=
begin
  rintros _ ⟨x, rfl⟩,
  induction x using free_product.induction_on with i x x y hx hy,
  { exact s.one_mem, },
  { simp only [lift_of, set_like.mem_coe], exact h i (set.mem_range_self x), },
  { simp only [map_mul, set_like.mem_coe], exact s.mul_mem hx hy, },
end

lemma range_eq_supr {N} [group N] (f : Π i, G i →* N) :
  (lift f).range = ⨆ i, (f i).range :=
begin
  apply le_antisymm (lift_range_le _ f (λ i, le_supr _ i)),
  apply supr_le _,
  rintros i _ ⟨x, rfl⟩,
  exact ⟨of x, by simp only [lift_of]⟩
end

end group

namespace word

/-- The empty reduced word. -/
def empty : word M := { to_list := [], ne_one := λ _, false.elim, chain_ne := list.chain'_nil }

instance : inhabited (word M) := ⟨empty⟩

/-- A reduced word determines an element of the free product, given by multiplication. -/
def prod (w : word M) : free_product M :=
list.prod (w.to_list.map $ λ l, of l.snd)

@[simp] lemma prod_empty : prod (empty : word M) = 1 := rfl

/-- `fst_idx w` is `some i` if the first letter of `w` is `⟨i, m⟩` with `m : M i`. If `w` is empty
then it's `none`. -/
def fst_idx (w : word M) : option ι := w.to_list.head'.map sigma.fst

lemma fst_idx_ne_iff {w : word M} {i} :
  fst_idx w ≠ some i ↔ ∀ l ∈ w.to_list.head', i ≠ sigma.fst l :=
not_iff_not.mp $ by simp [fst_idx]

variable (M)

/-- Given an index `i : ι`, `pair M i` is the type of pairs `(head, tail)` where `head : M i` and
`tail : word M`, subject to the constraint that first letter of `tail` can't be `⟨i, m⟩`.
By prepending `head` to `tail`, one obtains a new word. We'll show that any word can be uniquely
obtained in this way. -/
@[ext] structure pair (i : ι) :=
(head : M i)
(tail : word M)
(fst_idx_ne : fst_idx tail ≠ some i)

instance (i : ι) : inhabited (pair M i) := ⟨⟨1, empty, by tauto⟩⟩

variable {M}

variables [∀ i, decidable_eq (M i)]

/-- Given a pair `(head, tail)`, we can form a word by prepending `head` to `tail`, except if `head`
is `1 : M i` then we have to just return `word` since we need the result to be reduced. -/
def rcons {i} (p : pair M i) : word M :=
if h : p.head = 1 then p.tail
else { to_list  := ⟨i, p.head⟩ :: p.tail.to_list,
       ne_one   := by { rintros l (rfl | hl), exact h, exact p.tail.ne_one l hl },
       chain_ne := p.tail.chain_ne.cons' (fst_idx_ne_iff.mp p.fst_idx_ne) }

/-- Given a word of the form `⟨l :: ls, h1, h2⟩`, we can form a word of the form `⟨ls, _, _⟩`,
dropping the first letter. -/
private def mk_aux {l} (ls : list (Σ i, M i)) (h1 : ∀ l' ∈ l :: ls, sigma.snd l' ≠ 1)
  (h2 : (l :: ls).chain' _) : word M :=
⟨ls, λ l' hl, h1 _ (list.mem_cons_of_mem _ hl), h2.tail⟩

lemma cons_eq_rcons {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = rcons ⟨m, mk_aux ls h1 h2, fst_idx_ne_iff.mpr h2.rel_head'⟩ :=
by { rw [rcons, dif_neg], refl, exact h1 ⟨i, m⟩ (ls.mem_cons_self _) }

@[simp] lemma prod_rcons {i} (p : pair M i) :
  prod (rcons p) = of p.head * prod p.tail :=
if hm : p.head = 1 then by rw [rcons, dif_pos hm, hm, monoid_hom.map_one, one_mul]
else by rw [rcons, dif_neg hm, prod, list.map_cons, list.prod_cons, prod]

lemma rcons_inj {i} : function.injective (rcons : pair M i → word M) :=
begin
  rintros ⟨m, w, h⟩ ⟨m', w', h'⟩ he,
  by_cases hm : m = 1;
  by_cases hm' : m' = 1,
  { simp only [rcons, dif_pos hm, dif_pos hm'] at he, cc, },
  { exfalso, simp only [rcons, dif_pos hm, dif_neg hm'] at he, rw he at h, exact h rfl },
  { exfalso, simp only [rcons, dif_pos hm', dif_neg hm] at he, rw ←he at h', exact h' rfl, },
  { have : m = m' ∧ w.to_list = w'.to_list,
    { simpa only [rcons, dif_neg hm, dif_neg hm', true_and, eq_self_iff_true, subtype.mk_eq_mk,
      heq_iff_eq, ←subtype.ext_iff_val] using he },
    rcases this with ⟨rfl, h⟩,
    congr, exact word.ext _ _ h, }
end

variable [decidable_eq ι]

/-- Given `i : ι`, any reduced word can be decomposed into a pair `p` such that `w = rcons p`. -/
-- This definition is computable but not very nice to look at. Thankfully we don't have to inspect
-- it, since `rcons` is known to be injective.
private def equiv_pair_aux (i) : Π w : word M, { p : pair M i // rcons p = w }
| w@⟨[], _, _⟩             := ⟨⟨1, w, by rintro ⟨⟩⟩, dif_pos rfl⟩
| w@⟨⟨j, m⟩ :: ls, h1, h2⟩ := if ij : i = j then
  { val := { head := ij.symm.rec m,
             tail := mk_aux ls h1 h2,
             fst_idx_ne := by cases ij; exact fst_idx_ne_iff.mpr h2.rel_head' },
    property := by cases ij; exact cons_eq_rcons.symm }
else ⟨⟨1, w, (option.some_injective _).ne (ne.symm ij)⟩, dif_pos rfl⟩

/-- The equivalence between words and pairs. Given a word, it decomposes it as a pair by removing
the first letter if it comes from `M i`. Given a pair, it prepends the head to the tail. -/
def equiv_pair (i) : word M ≃ pair M i :=
{ to_fun := λ w, (equiv_pair_aux i w).val,
  inv_fun := rcons,
  left_inv := λ w, (equiv_pair_aux i w).property,
  right_inv := λ p, rcons_inj (equiv_pair_aux i _).property }

lemma equiv_pair_symm (i) (p : pair M i) : (equiv_pair i).symm p = rcons p := rfl

lemma equiv_pair_eq_of_fst_idx_ne {i} {w : word M} (h : fst_idx w ≠ some i) :
  equiv_pair i w = ⟨1, w, h⟩ :=
(equiv_pair i).apply_eq_iff_eq_symm_apply.mpr $ eq.symm (dif_pos rfl)

instance summand_action (i) : mul_action (M i) (word M) :=
{ smul     := λ m w, rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w },
  one_smul := λ w, by { simp_rw [one_mul], apply (equiv_pair i).symm_apply_eq.mpr, ext; refl },
  mul_smul := λ m m' w, by simp only [mul_assoc, ←equiv_pair_symm, equiv.apply_symm_apply], }

instance : mul_action (free_product M) (word M) :=
mul_action.of_End_hom (lift (λ i, mul_action.to_End_hom))

lemma of_smul_def (i) (w : word M) (m : M i) :
  of m • w = rcons { head := m * (equiv_pair i w).head, ..equiv_pair i w } := rfl

lemma cons_eq_smul {i} {m : M i} {ls h1 h2} :
  word.mk (⟨i, m⟩ :: ls) h1 h2 = of m • mk_aux ls h1 h2 :=
by rw [cons_eq_rcons, of_smul_def, equiv_pair_eq_of_fst_idx_ne _]; simp only [mul_one]

lemma smul_induction {C : word M → Prop}
  (h_empty : C empty)
  (h_smul : ∀ i (m : M i) w, C w → C (of m • w))
  (w : word M) : C w :=
begin
  cases w with ls h1 h2,
  induction ls with l ls ih,
  { exact h_empty },
  cases l with i m,
  rw cons_eq_smul,
  exact h_smul _ _ _ (ih _ _),
end

@[simp] lemma prod_smul (m) : ∀ w : word M, prod (m • w) = m * prod w :=
begin
  apply m.induction_on,
  { intro, rw [one_smul, one_mul] },
  { intros, rw [of_smul_def, prod_rcons, of.map_mul, mul_assoc, ←prod_rcons,
      ←equiv_pair_symm, equiv.symm_apply_apply] },
  { intros x y hx hy w, rw [mul_smul, hx, hy, mul_assoc] },
end

/-- Each element of the free product corresponds to a unique reduced word. -/
def equiv : free_product M ≃ word M :=
{ to_fun := λ m, m • empty,
  inv_fun := λ w, prod w,
  left_inv := λ m, by dsimp only; rw [prod_smul, prod_empty, mul_one],
  right_inv := begin
    apply smul_induction,
    { dsimp only, rw [prod_empty, one_smul], },
    { dsimp only, intros i m w ih, rw [prod_smul, mul_smul, ih], },
  end }

instance : decidable_eq (word M) := function.injective.decidable_eq word.ext
instance : decidable_eq (free_product M) := word.equiv.decidable_eq

end word

variable (M)

/-- A `neword M i j` is a representation of a non-empty reduced words where the first letter comes
from `M i` and the last letter comes from `M j`. It can be constructed from singletons and via
concatentation, and thus provides a useful induction principle. -/
@[nolint has_nonempty_instance]
inductive neword : ι → ι → Type (max u_1 u_2)
| singleton : ∀ {i} (x : M i) (hne1 : x ≠ 1), neword i i
| append : ∀ {i j k l} (w₁ : neword i j) (hne : j ≠ k) (w₂ : neword k l), neword i l
variable {M}

namespace neword

open word

/-- The list represented by a given `neword` -/
@[simp]
def to_list : Π {i j} (w : neword M i j), list (Σ i, M i)
| i _ (singleton x hne1) := [⟨i, x⟩]
| _ _ (append w₁ hne w₂) := w₁.to_list ++ w₂.to_list

/--  The first letter of a `neword` -/
@[simp]
def head : Π {i j} (w : neword M i j), M i
| i _ (singleton x hne1) := x
| _ _ (append w₁ hne w₂) := w₁.head

/--  The last letter of a `neword` -/
@[simp]
def last : Π {i j} (w : neword M i j), M j
| i _ (singleton x hne1) := x
| _ _ (append w₁ hne w₂) := w₂.last

@[simp]
lemma to_list_head' {i j} (w : neword M i j) :
  w.to_list.head' = option.some ⟨i, w.head⟩ :=
begin
  rw ← option.mem_def,
  induction w,
  { rw option.mem_def, reflexivity, },
  { exact list.head'_append w_ih_w₁, },
end

@[simp]
lemma to_list_last' {i j} (w : neword M i j) :
  w.to_list.last' = option.some ⟨j, w.last⟩ :=
begin
  rw ← option.mem_def,
  induction w,
  { rw option.mem_def, reflexivity, },
  { exact list.last'_append w_ih_w₂, },
end

/-- The `word M` represented by a `neword M i j` -/
def to_word {i j} (w : neword M i j) : word M :=
{ to_list := w.to_list,
  ne_one :=
  begin
    induction w,
    { rintros ⟨k,x⟩ ⟨rfl, rfl⟩,
      exact w_hne1,
      exfalso, apply H, },
    { intros l h,
      simp only [to_list, list.mem_append] at h,
      cases h,
      { exact w_ih_w₁ _ h, },
      { exact w_ih_w₂ _ h, }, },
  end,
  chain_ne := begin
    induction w,
    { exact list.chain'_singleton _, },
    { apply list.chain'.append w_ih_w₁ w_ih_w₂,
      intros x hx y hy,
      rw [w_w₁.to_list_last', option.mem_some_iff] at hx,
      rw [w_w₂.to_list_head', option.mem_some_iff] at hy,
      subst hx, subst hy,
      exact w_hne, },
  end, }

/-- Every nonempty `word M` can be constructed as a `neword M i j` -/
lemma of_word (w : word M) (h : w ≠ empty) :
  ∃ i j (w' : neword M i j), w'.to_word = w :=
begin
  rsuffices ⟨i, j, w, h⟩ : ∃ i j (w' : neword M i j), w'.to_word.to_list = w.to_list,
  { refine ⟨i, j, w, _⟩, ext, rw h, },
  cases w with l hnot1 hchain,
  induction l with x l hi,
  { contradiction, },
  { rw list.forall_mem_cons at hnot1,
    cases l with y l,
    { refine ⟨x.1, x.1, singleton x.2 hnot1.1, _ ⟩,
      simp [to_word], },
    { rw list.chain'_cons at hchain,
      specialize hi hnot1.2 hchain.2 (by rintros ⟨rfl⟩),
      obtain ⟨i, j, w', hw' : w'.to_list = y :: l⟩ := hi,
      obtain rfl : y = ⟨i, w'.head⟩, by simpa [hw'] using w'.to_list_head',
      refine ⟨x.1, j, append (singleton x.2 hnot1.1) hchain.1 w', _⟩,
      { simpa [to_word] using hw', } } }
end

/-- A non-empty reduced word determines an element of the free product, given by multiplication. -/
def prod {i j} (w : neword M i j) := w.to_word.prod

@[simp]
lemma singleton_head {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).head = x := rfl

@[simp]
lemma singleton_last {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).last = x := rfl

@[simp] lemma prod_singleton {i} (x : M i) (hne_one : x ≠ 1) :
  (singleton x hne_one).prod = of x :=
by simp [to_word, prod, word.prod]

@[simp]
lemma append_head {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).head = w₁.head := rfl

@[simp]
lemma append_last {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).last = w₂.last := rfl

@[simp]
lemma append_prod {i j k l} {w₁ : neword M i j} {hne : j ≠ k} {w₂ : neword M k l} :
  (append w₁ hne w₂).prod = w₁.prod * w₂.prod :=
by simp [to_word, prod, word.prod]

/-- One can replace the first letter in a non-empty reduced word by an element of the same
group -/
def replace_head : Π {i j : ι} (x : M i) (hnotone : x ≠ 1) (w : neword M i j), neword M i j
| _ _ x h (singleton _ _) := singleton x h
| _ _ x h (append w₁ hne w₂) := append (replace_head x h w₁) hne w₂

@[simp]
lemma replace_head_head {i j : ι} (x : M i) (hnotone : x ≠ 1) (w : neword M i j) :
  (replace_head x hnotone w).head = x :=
by { induction w, refl, exact w_ih_w₁ _ _, }

/-- One can multiply an element from the left to a non-empty reduced word if it does not cancel
with the first element in the word. -/
def mul_head {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
  neword M i j := replace_head (x * w.head) hnotone w

@[simp]
lemma mul_head_head {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
   (mul_head w x hnotone).head = x * w.head :=
by { induction w, refl, exact w_ih_w₁ _ _, }

@[simp]
lemma mul_head_prod {i j : ι} (w : neword M i j) (x : M i) (hnotone : x * w.head ≠ 1) :
  (mul_head w x hnotone).prod = of x * w.prod :=
begin
  unfold mul_head,
  induction w,
  { simp [mul_head, replace_head], },
  { specialize w_ih_w₁ _ hnotone, clear w_ih_w₂,
    simp [replace_head, ← mul_assoc] at *,
    congr' 1, }
end

section group

variables {G : ι → Type*} [Π i, group (G i)]

/-- The inverse of a non-empty reduced word -/
def inv : Π {i j} (w : neword G i j), neword G j i
| _ _ (singleton x h) := singleton x⁻¹ (mt inv_eq_one.mp h)
| _ _ (append w₁ h w₂) := append w₂.inv h.symm w₁.inv

@[simp]
lemma inv_prod {i j} (w : neword G i j) : w.inv.prod = w.prod⁻¹ :=
by induction w; simp [inv, *]

@[simp]
lemma inv_head {i j} (w : neword G i j) : w.inv.head = w.last⁻¹ :=
by induction w; simp [inv, *]

@[simp]
lemma inv_last {i j} (w : neword G i j) : w.inv.last = w.head⁻¹ :=
by induction w; simp [inv, *]

end group

end neword

section ping_pong_lemma

open_locale pointwise
open_locale cardinal

variables [hnontriv : nontrivial ι]
variables {G : Type*} [group G]
variables {H : ι → Type*} [∀ i, group (H i)]
variables (f : Π i, H i →* G)

-- We need many groups or one group with many elements
variables (hcard : 3 ≤ # ι ∨ ∃ i, 3 ≤ # (H i))

-- A group action on α, and the ping-pong sets
variables {α : Type*} [mul_action G α]
variables (X : ι → set α)
variables (hXnonempty : ∀ i, (X i).nonempty)
variables (hXdisj : pairwise (λ i j, disjoint (X i) (X j)))
variables (hpp : pairwise (λ i j, ∀ h : H i, h ≠ 1 → f i h • X j ⊆ X i))

include hpp

lemma lift_word_ping_pong {i j k} (w : neword H i j) (hk : j ≠ k) :
  lift f w.prod • X k ⊆ X i :=
begin
  rename [i → i', j → j', k → m, hk → hm],
  induction w with i x hne_one i j k l w₁ hne w₂  hIw₁ hIw₂ generalizing m; clear i' j',
  { simpa using hpp hm _ hne_one, },
  { calc lift f (neword.append w₁ hne w₂).prod • X m
        = lift f w₁.prod • lift f w₂.prod • X m : by simp [mul_action.mul_smul]
    ... ⊆ lift f w₁.prod • X k : set_smul_subset_set_smul_iff.mpr (hIw₂ hm)
    ... ⊆ X i : hIw₁ hne },
end

include X hXnonempty hXdisj

lemma lift_word_prod_nontrivial_of_other_i {i j k} (w : neword H i j)
  (hhead : k ≠ i) (hlast : k ≠ j) : lift f w.prod ≠ 1 :=
begin
  intro heq1,
  have : X k ⊆ X i,
    by simpa [heq1] using lift_word_ping_pong f X hpp w hlast.symm,
  obtain ⟨x, hx⟩ := hXnonempty k,
  exact (hXdisj hhead).le_bot ⟨hx, this hx⟩,
end

include hnontriv

lemma lift_word_prod_nontrivial_of_head_eq_last {i} (w : neword H i i) :
  lift f w.prod ≠ 1 :=
begin
  obtain ⟨k, hk⟩ := exists_ne i,
  exact lift_word_prod_nontrivial_of_other_i f X hXnonempty hXdisj hpp w hk hk,
end

lemma lift_word_prod_nontrivial_of_head_card {i j} (w : neword H i j)
  (hcard : 3 ≤ # (H i)) (hheadtail : i ≠ j) : lift f w.prod ≠ 1 :=
begin
  obtain ⟨h, hn1, hnh⟩ := cardinal.three_le hcard 1 (w.head⁻¹),
  have hnot1 : h * w.head ≠ 1, by { rw ← div_inv_eq_mul, exact div_ne_one_of_ne hnh },
  let w' : neword H i i := neword.append
    (neword.mul_head w h hnot1) hheadtail.symm
    (neword.singleton h⁻¹ (inv_ne_one.mpr hn1)),
  have hw' : lift f w'.prod ≠ 1 :=
    lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w',
  intros heq1, apply hw', simp [w', heq1]
end

include hcard
lemma lift_word_prod_nontrivial_of_not_empty {i j} (w : neword H i j) :
  lift f w.prod ≠ 1 :=
begin
  classical,
  cases hcard,
  { obtain ⟨i, h1, h2⟩ := cardinal.three_le hcard i j,
    exact lift_word_prod_nontrivial_of_other_i f X hXnonempty hXdisj hpp w h1 h2, },
  { cases hcard with k hcard,
    by_cases hh : i = k; by_cases hl : j = k,
    { subst hh, subst hl,
      exact lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w, },
    { subst hh,
      change j ≠ i at hl,
      exact lift_word_prod_nontrivial_of_head_card f X hXnonempty hXdisj hpp w hcard hl.symm, },
    { subst hl,
      change i ≠ j at hh,
      have : lift f w.inv.prod ≠ 1 :=
        lift_word_prod_nontrivial_of_head_card f X hXnonempty hXdisj hpp w.inv hcard hh.symm,
      intros heq, apply this, simpa using heq, },
    { change i ≠ k at hh,
      change j ≠ k at hl,
      obtain ⟨h, hn1, -⟩ := cardinal.three_le hcard 1 1,
      let w' : neword H k k := neword.append
        (neword.append (neword.singleton h hn1) hh.symm w)
        hl (neword.singleton h⁻¹ (inv_ne_one.mpr hn1)) ,
      have hw' : lift f w'.prod ≠ 1 :=
        lift_word_prod_nontrivial_of_head_eq_last f X hXnonempty hXdisj hpp w',
      intros heq1, apply hw', simp [w', heq1], }, }
end

lemma empty_of_word_prod_eq_one {w : word H} (h : lift f w.prod = 1) :
  w = word.empty :=
begin
  by_contradiction hnotempty,
  obtain ⟨i, j, w, rfl⟩ := neword.of_word w hnotempty,
  exact lift_word_prod_nontrivial_of_not_empty f hcard X hXnonempty hXdisj hpp w h,
end

/--
The Ping-Pong-Lemma.

Given a group action of `G` on `X` so that the `H i` acts in a specific way on disjoint subsets
`X i` we can prove that `lift f` is injective, and thus the image of `lift f` is isomorphic to the
free product of the `H i`.

Often the Ping-Pong-Lemma is stated with regard to subgroups `H i` that generate the whole group;
we generalize to arbitrary group homomorphisms `f i : H i →* G` and do not require the group to be
generated by the images.

Usually the Ping-Pong-Lemma requires that one group `H i` has at least three elements. This
condition is only needed if `# ι = 2`, and we accept `3 ≤ # ι` as an alternative.
-/
theorem lift_injective_of_ping_pong:
  function.injective (lift f) :=
begin
  classical,
  apply (injective_iff_map_eq_one (lift f)).mpr,
  rw (free_product.word.equiv : _ ≃ word H).forall_congr_left',
  { intros w Heq,
    dsimp [word.equiv] at *,
    { rw empty_of_word_prod_eq_one f hcard X hXnonempty hXdisj hpp Heq,
      reflexivity, }, },
end

end ping_pong_lemma

/-- The free product of free groups is itself a free group -/
@[simps]
instance {ι : Type*} (G : ι → Type*) [∀ i, group (G i)] [hG : ∀ i, is_free_group (G i)] :
  is_free_group (free_product G) :=
{ generators := Σ i, is_free_group.generators (G i),
  mul_equiv :=
  monoid_hom.to_mul_equiv
    (free_group.lift (λ (x : Σ i, is_free_group.generators (G i)),
      free_product.of (is_free_group.of x.2 : G x.1)))
    (free_product.lift (λ (i : ι),
      (is_free_group.lift (λ (x : is_free_group.generators (G i)),
        free_group.of (⟨i, x⟩ : Σ i, is_free_group.generators (G i)))
        : G i →* (free_group (Σ i, is_free_group.generators (G i))))))
    (by {ext, simp, })
   (by {ext, simp, }) }

/-- A free group is a free product of copies of the free_group over one generator. -/

-- NB: One might expect this theorem to be phrased with ℤ, but ℤ is an additive group,
-- and using `multiplicative ℤ` runs into diamond issues.
@[simps]
def _root_.free_group_equiv_free_product {ι : Type u_1} :
  free_group ι ≃* free_product (λ (_ : ι), free_group unit) :=
begin
  refine monoid_hom.to_mul_equiv _ _ _ _,
  exact free_group.lift (λ i, @free_product.of ι _ _ i (free_group.of unit.star)),
  exact free_product.lift (λ i, free_group.lift (λ pstar, free_group.of i)),
  { ext i, refl, },
  { ext i a, cases a, refl, },
end

section ping_pong_lemma

open_locale pointwise cardinal

variables [nontrivial ι]
variables {G : Type u_1} [group G] (a : ι → G)

-- A group action on α, and the ping-pong sets
variables {α : Type*} [mul_action G α]
variables (X Y : ι → set α)
variables (hXnonempty : ∀ i, (X i).nonempty)
variables (hXdisj : pairwise (λ i j, disjoint (X i) (X j)))
variables (hYdisj : pairwise (λ i j, disjoint (Y i) (Y j)))
variables (hXYdisj : ∀ i j, disjoint (X i) (Y j))
variables (hX : ∀ i, a i • (Y i)ᶜ ⊆ X i)
variables (hY : ∀ i, a⁻¹ i • (X i)ᶜ ⊆ Y i)

include hXnonempty hXdisj hYdisj hXYdisj hX hY

/--
The Ping-Pong-Lemma.

Given a group action of `G` on `X` so that the generators of the free groups act in specific
ways on disjoint subsets `X i` and `Y i` we can prove that `lift f` is injective, and thus the image
of `lift f` is isomorphic to the free group.

Often the Ping-Pong-Lemma is stated with regard to group elements that generate the whole group;
we generalize to arbitrary group homomorphisms from the free group to `G`  and do not require the
group to be generated by the elements.
-/
theorem _root_.free_group.injective_lift_of_ping_pong :
  function.injective (free_group.lift a) :=
begin
  -- Step one: express the free group lift via the free product lift
  have : free_group.lift a =
    (free_product.lift (λ i, free_group.lift (λ _, a i))).comp
    (((@free_group_equiv_free_product ι)).to_monoid_hom),
  { ext i, simp, },
  rw this, clear this,
  refine function.injective.comp _ (mul_equiv.injective _),

  -- Step two: Invoke the ping-pong lemma for free products
  show function.injective (lift (λ (i : ι), free_group.lift (λ _, a i))),

  -- Prepare to instantiate lift_injective_of_ping_pong
  let H : ι → Type _ := λ i, free_group unit,
  let f : Π i, H i →* G := λ i, free_group.lift (λ _, a i),
  let X' : ι → set α := λ i, X i ∪ Y i,

  apply lift_injective_of_ping_pong f _ X',

  show _ ∨ ∃ i, 3 ≤ # (H i),
  { inhabit ι,
    right, use arbitrary ι,
    simp only [H],
    rw [free_group.free_group_unit_equiv_int.cardinal_eq, cardinal.mk_denumerable],
    apply le_of_lt,
    simp },

  show ∀ i, (X' i).nonempty,
  { exact (λ i, set.nonempty.inl (hXnonempty i)), },

  show pairwise (λ i j, disjoint (X' i) (X' j)),
  { intros i j hij,
    simp only [X'],
    apply disjoint.union_left; apply disjoint.union_right,
    { exact hXdisj hij, },
    { exact hXYdisj i j, },
    { exact (hXYdisj j i).symm, },
    { exact hYdisj hij, }, },

  show pairwise (λ i j, ∀ h : H i, h ≠ 1 → f i h • X' j ⊆ X' i),
  { rintros i j hij,
    -- use free_group unit ≃ ℤ
    refine free_group.free_group_unit_equiv_int.forall_congr_left'.mpr _,
    intros n hne1,
    change free_group.lift (λ _, a i) (free_group.of () ^ n) • X' j ⊆ X' i,
    simp only [map_zpow, free_group.lift.of],
    change a i ^ n • X' j ⊆ X' i,
    have hnne0 : n ≠ 0, { rintro rfl, apply hne1, simpa, }, clear hne1,
    simp only [X'],

    -- Positive and negative powers separately
    cases (lt_or_gt_of_ne hnne0).swap with hlt hgt,
    { have h1n : 1 ≤ n := hlt,
      calc a i ^ n • X' j ⊆ a i ^ n • (Y i)ᶜ : smul_set_mono
            ((hXYdisj j i).union_left $ hYdisj hij.symm).subset_compl_right
      ... ⊆ X i :
      begin
        refine int.le_induction _ _ _ h1n,
        { rw zpow_one, exact hX i, },
        { intros n hle hi,
          calc (a i ^ (n + 1)) • (Y i)ᶜ
                = (a i ^ n * a i) • (Y i)ᶜ : by rw [zpow_add, zpow_one]
            ... = a i ^ n • (a i • (Y i)ᶜ) : mul_action.mul_smul _ _ _
            ... ⊆ a i ^ n • X i : smul_set_mono $ hX i
            ... ⊆ a i ^ n • (Y i)ᶜ : smul_set_mono (hXYdisj i i).subset_compl_right
            ... ⊆ X i : hi, },
      end
      ... ⊆ X' i : set.subset_union_left _ _, },
    { have h1n : n ≤ -1, { apply int.le_of_lt_add_one, simpa using hgt, },
      calc a i ^ n • X' j ⊆ a i ^ n • (X i)ᶜ : smul_set_mono
            ((hXdisj hij.symm).union_left (hXYdisj i j).symm).subset_compl_right
      ... ⊆ Y i :
      begin
        refine int.le_induction_down _ _ _ h1n,
        { rw [zpow_neg, zpow_one], exact hY i, },
        { intros n hle hi,
          calc (a i ^ (n - 1)) • (X i)ᶜ
                = (a i ^ n * (a i)⁻¹) • (X i)ᶜ : by rw [zpow_sub, zpow_one]
            ... = a i ^ n • ((a i)⁻¹ • (X i)ᶜ) : mul_action.mul_smul _ _ _
            ... ⊆ a i ^ n • Y i : smul_set_mono $ hY i
            ... ⊆ a i ^ n • (X i)ᶜ : smul_set_mono (hXYdisj i i).symm.subset_compl_right
            ... ⊆ Y i : hi, },
      end
      ... ⊆ X' i : set.subset_union_right _ _, }, },
end

end ping_pong_lemma

end free_product


/-
Copyright (c) 2022 Yaël Dillies, Sara Rousta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import order.upper_lower.basic
import order.hom.complete_lattice

/-!
# `upper_set.Ici` etc as `sup`/`Sup`/`inf`/`Inf`-homomorphisms

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

In this file we define `upper_set.Ici_sup_hom` etc. These functions are `upper_set.Ici` and
`lower_set.Iic` bundled as `sup_hom`s, `inf_hom`s, `Sup_hom`s, or `Inf_hom`s.
-/

variable {α : Type*}
open order_dual

namespace upper_set

section semilattice_sup

variable [semilattice_sup α]

/-- `upper_set.Ici` as a `sup_hom`. -/
def Ici_sup_hom : sup_hom α (upper_set α) := ⟨Ici, Ici_sup⟩

@[simp] lemma coe_Ici_sup_hom : (Ici_sup_hom : α → upper_set α) = Ici := rfl
@[simp] lemma Ici_sup_hom_apply (a : α) : Ici_sup_hom a = (Ici a) := rfl

end semilattice_sup

variable [complete_lattice α]

/-- `upper_set.Ici` as a `Sup_hom`. -/
def Ici_Sup_hom : Sup_hom α (upper_set α) := ⟨Ici, λ s, (Ici_Sup s).trans Sup_image.symm⟩

@[simp] lemma coe_Ici_Sup_hom : (Ici_Sup_hom : α → upper_set α) = Ici := rfl
@[simp] lemma Ici_Sup_hom_apply (a : α) : Ici_Sup_hom a = Ici a := rfl

end upper_set

namespace lower_set

section semilattice_inf

variable [semilattice_inf α]

/-- `lower_set.Iic` as an `inf_hom`. -/
def Iic_inf_hom : inf_hom α (lower_set α) := ⟨Iic, Iic_inf⟩

@[simp] lemma coe_Iic_inf_hom : (Iic_inf_hom : α → lower_set α) = Iic := rfl
@[simp] lemma Iic_inf_hom_apply (a : α) : Iic_inf_hom a = Iic a := rfl

end semilattice_inf

variable [complete_lattice α]

/-- `lower_set.Iic` as an `Inf_hom`. -/
def Iic_Inf_hom : Inf_hom α (lower_set α) := ⟨Iic, λ s, (Iic_Inf s).trans Inf_image.symm⟩

@[simp] lemma coe_Iic_Inf_hom : (Iic_Inf_hom : α → lower_set α) = Iic := rfl
@[simp] lemma Iic_Inf_hom_apply (a : α) : Iic_Inf_hom a = Iic a := rfl

end lower_set


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

import linear_algebra.finite_dimensional
import ring_theory.integral_closure
import data.polynomial.integral_normalization

/-!
# Algebraic elements and algebraic extensions

An element of an R-algebra is algebraic over R if it is the root of a nonzero polynomial.
An R-algebra is algebraic over R if and only if all its elements are algebraic over R.
The main result in this file proves transitivity of algebraicity:
a tower of algebraic field extensions is algebraic.
-/

universes u v w

open_locale classical polynomial
open polynomial

section
variables (R : Type u) {A : Type v} [comm_ring R] [ring A] [algebra R A]

/-- An element of an R-algebra is algebraic over R if it is a root of a nonzero polynomial
with coefficients in R. -/
def is_algebraic (x : A) : Prop :=
∃ p : R[X], p ≠ 0 ∧ aeval x p = 0

/-- An element of an R-algebra is transcendental over R if it is not algebraic over R. -/
def transcendental (x : A) : Prop := ¬ is_algebraic R x

lemma is_transcendental_of_subsingleton [subsingleton R] (x : A) : transcendental R x :=
λ ⟨p, h, _⟩, h $ subsingleton.elim p 0

variables {R}

/-- A subalgebra is algebraic if all its elements are algebraic. -/
def subalgebra.is_algebraic (S : subalgebra R A) : Prop := ∀ x ∈ S, is_algebraic R x

variables (R A)

/-- An algebra is algebraic if all its elements are algebraic. -/
def algebra.is_algebraic : Prop := ∀ x : A, is_algebraic R x

variables {R A}

/-- A subalgebra is algebraic if and only if it is algebraic as an algebra. -/
lemma subalgebra.is_algebraic_iff (S : subalgebra R A) :
  S.is_algebraic ↔ @algebra.is_algebraic R S _ _ S.algebra :=
begin
  delta algebra.is_algebraic subalgebra.is_algebraic,
  rw subtype.forall',
  refine forall_congr (λ x, exists_congr (λ p, and_congr iff.rfl _)),
  have h : function.injective S.val := subtype.val_injective,
  conv_rhs { rw [← h.eq_iff, alg_hom.map_zero] },
  rw [← aeval_alg_hom_apply, S.val_apply]
end

/-- An algebra is algebraic if and only if it is algebraic as a subalgebra. -/
lemma algebra.is_algebraic_iff : algebra.is_algebraic R A ↔ (⊤ : subalgebra R A).is_algebraic :=
begin
  delta algebra.is_algebraic subalgebra.is_algebraic,
  simp only [algebra.mem_top, forall_prop_of_true, iff_self],
end

lemma is_algebraic_iff_not_injective {x : A} : is_algebraic R x ↔
  ¬ function.injective (polynomial.aeval x : R[X] →ₐ[R] A) :=
by simp only [is_algebraic, injective_iff_map_eq_zero, not_forall, and.comm, exists_prop]

end

section zero_ne_one
variables (R : Type u) {S : Type*} {A : Type v} [comm_ring R]
variables [comm_ring S] [ring A] [algebra R A] [algebra R S] [algebra S A]
variables [is_scalar_tower R S A]

/-- An integral element of an algebra is algebraic.-/
lemma is_integral.is_algebraic [nontrivial R] {x : A} : is_integral R x → is_algebraic R x :=
λ ⟨p, hp, hpx⟩, ⟨p, hp.ne_zero, hpx⟩

variables {R}

lemma is_algebraic_zero [nontrivial R] : is_algebraic R (0 : A) :=
⟨_, X_ne_zero, aeval_X 0⟩

/-- An element of `R` is algebraic, when viewed as an element of the `R`-algebra `A`. -/
lemma is_algebraic_algebra_map [nontrivial R] (x : R) : is_algebraic R (algebra_map R A x) :=
⟨_, X_sub_C_ne_zero x, by rw [_root_.map_sub, aeval_X, aeval_C, sub_self]⟩

lemma is_algebraic_one [nontrivial R] : is_algebraic R (1 : A) :=
by { rw ←_root_.map_one _, exact is_algebraic_algebra_map 1 }

lemma is_algebraic_nat [nontrivial R] (n : ℕ) : is_algebraic R (n : A) :=
by { rw ←map_nat_cast _, exact is_algebraic_algebra_map n }

lemma is_algebraic_int [nontrivial R] (n : ℤ) : is_algebraic R (n : A) :=
by { rw ←_root_.map_int_cast (algebra_map R A), exact is_algebraic_algebra_map n }

lemma is_algebraic_rat (R : Type u) {A : Type v} [division_ring A] [field R] [algebra R A] (n : ℚ) :
  is_algebraic R (n : A) :=
by { rw ←map_rat_cast (algebra_map R A), exact is_algebraic_algebra_map n }

lemma is_algebraic_of_mem_root_set {R : Type u} {A : Type v} [field R] [field A] [algebra R A]
  {p : R[X]} {x : A} (hx : x ∈ p.root_set A) : is_algebraic R x :=
⟨p, ne_zero_of_mem_root_set hx, aeval_eq_zero_of_mem_root_set hx⟩

open is_scalar_tower

lemma is_algebraic_algebra_map_of_is_algebraic {a : S} :
  is_algebraic R a → is_algebraic R (algebra_map S A a) :=
λ ⟨f, hf₁, hf₂⟩, ⟨f, hf₁, by rw [aeval_algebra_map_apply, hf₂, map_zero]⟩

/-- This is slightly more general than `is_algebraic_algebra_map_of_is_algebraic` in that it
  allows noncommutative intermediate rings `A`. -/
lemma is_algebraic_alg_hom_of_is_algebraic {B} [ring B] [algebra R B]
  (f : A →ₐ[R] B) {a : A} (h : is_algebraic R a) : is_algebraic R (f a) :=
let ⟨p, hp, ha⟩ := h in ⟨p, hp, by rw [aeval_alg_hom, f.comp_apply, ha, map_zero]⟩

/-- Transfer `algebra.is_algebraic` across an `alg_equiv`. -/
lemma _root_.alg_equiv.is_algebraic {B} [ring B] [algebra R B] (e : A ≃ₐ[R] B)
  (h : algebra.is_algebraic R A) : algebra.is_algebraic R B :=
λ b, by convert ← is_algebraic_alg_hom_of_is_algebraic e.to_alg_hom (h _); apply e.apply_symm_apply

lemma _root_.alg_equiv.is_algebraic_iff {B} [ring B] [algebra R B] (e : A ≃ₐ[R] B) :
  algebra.is_algebraic R A ↔ algebra.is_algebraic R B := ⟨e.is_algebraic, e.symm.is_algebraic⟩

lemma is_algebraic_algebra_map_iff {a : S} (h : function.injective (algebra_map S A)) :
  is_algebraic R (algebra_map S A a) ↔ is_algebraic R a :=
⟨λ ⟨p, hp0, hp⟩, ⟨p, hp0, h (by rwa [map_zero, ← aeval_algebra_map_apply])⟩,
  is_algebraic_algebra_map_of_is_algebraic⟩

lemma is_algebraic_of_pow {r : A} {n : ℕ} (hn : 0 < n) (ht : is_algebraic R (r ^ n)) :
  is_algebraic R r :=
begin
  obtain ⟨p, p_nonzero, hp⟩ := ht,
  refine ⟨polynomial.expand _ n p, _, _⟩,
  { rwa polynomial.expand_ne_zero hn },
  { rwa polynomial.expand_aeval n p r },
end

lemma transcendental.pow {r : A} (ht : transcendental R r) {n : ℕ} (hn : 0 < n) :
  transcendental R (r ^ n) :=
λ ht', ht $ is_algebraic_of_pow hn ht'

end zero_ne_one

section field
variables {K : Type u} {A : Type v} [field K] [ring A] [algebra K A]

/-- An element of an algebra over a field is algebraic if and only if it is integral.-/
lemma is_algebraic_iff_is_integral {x : A} :
  is_algebraic K x ↔ is_integral K x :=
begin
  refine ⟨_, is_integral.is_algebraic K⟩,
  rintro ⟨p, hp, hpx⟩,
  refine ⟨_, monic_mul_leading_coeff_inv hp, _⟩,
  rw [← aeval_def, alg_hom.map_mul, hpx, zero_mul],
end

protected lemma algebra.is_algebraic_iff_is_integral :
  algebra.is_algebraic K A ↔ algebra.is_integral K A :=
⟨λ h x, is_algebraic_iff_is_integral.mp (h x),
  λ h x, is_algebraic_iff_is_integral.mpr (h x)⟩

end field

namespace algebra
variables {K : Type*} {L : Type*} {R : Type*} {S : Type*} {A : Type*}
variables [field K] [field L] [comm_ring R] [comm_ring S] [comm_ring A]
variables [algebra K L] [algebra L A] [algebra K A] [is_scalar_tower K L A]
variables [algebra R S] [algebra S A] [algebra R A] [is_scalar_tower R S A]

/-- If L is an algebraic field extension of K and A is an algebraic algebra over L,
then A is algebraic over K. -/
lemma is_algebraic_trans (L_alg : is_algebraic K L) (A_alg : is_algebraic L A) :
  is_algebraic K A :=
begin
  simp only [is_algebraic, is_algebraic_iff_is_integral] at L_alg A_alg ⊢,
  exact is_integral_trans L_alg A_alg,
end

variables (K L)

/-- If x is algebraic over R, then x is algebraic over S when S is an extension of R,
  and the map from `R` to `S` is injective. -/
lemma _root_.is_algebraic_of_larger_base_of_injective (hinj : function.injective (algebra_map R S))
  {x : A} (A_alg : _root_.is_algebraic R x) : _root_.is_algebraic S x :=
let ⟨p, hp₁, hp₂⟩ := A_alg in
⟨p.map (algebra_map _ _),
  by rwa [ne.def, ← degree_eq_bot, degree_map_eq_of_injective hinj, degree_eq_bot],
  by simpa⟩

/-- If A is an algebraic algebra over R, then A is algebraic over S when S is an extension of R,
  and the map from `R` to `S` is injective. -/
lemma is_algebraic_of_larger_base_of_injective (hinj : function.injective (algebra_map R S))
  (A_alg : is_algebraic R A) : is_algebraic S A :=
λ x, is_algebraic_of_larger_base_of_injective hinj (A_alg x)

/-- If x is a algebraic over K, then x is algebraic over L when L is an extension of K -/
lemma _root_.is_algebraic_of_larger_base {x : A} (A_alg : _root_.is_algebraic K x) :
  _root_.is_algebraic L x :=
_root_.is_algebraic_of_larger_base_of_injective (algebra_map K L).injective A_alg

/-- If A is an algebraic algebra over K, then A is algebraic over L when L is an extension of K -/
lemma is_algebraic_of_larger_base (A_alg : is_algebraic K A) : is_algebraic L A :=
is_algebraic_of_larger_base_of_injective (algebra_map K L).injective A_alg

variables (K L)

/-- A field extension is integral if it is finite. -/
lemma is_integral_of_finite [finite_dimensional K L] : algebra.is_integral K L :=
λ x, is_integral_of_submodule_noetherian ⊤
  (is_noetherian.iff_fg.2 infer_instance) x algebra.mem_top

/-- A field extension is algebraic if it is finite. -/
lemma is_algebraic_of_finite [finite : finite_dimensional K L] : is_algebraic K L :=
algebra.is_algebraic_iff_is_integral.mpr (is_integral_of_finite K L)

variables {K L}

theorem is_algebraic.alg_hom_bijective
  (ha : algebra.is_algebraic K L) (f : L →ₐ[K] L) : function.bijective f :=
begin
  refine ⟨f.to_ring_hom.injective, λ b, _⟩,
  obtain ⟨p, hp, he⟩ := ha b,
  let f' : p.root_set L → p.root_set L := (root_set_maps_to' id f).restrict f _ _,
  have : function.surjective f' := finite.injective_iff_surjective.1
    (λ _ _ h, subtype.eq $ f.to_ring_hom.injective $ subtype.ext_iff.1 h),
  obtain ⟨a, ha⟩ := this ⟨b, mem_root_set.2 ⟨hp, he⟩⟩,
  exact ⟨a, subtype.ext_iff.1 ha⟩,
end

theorem _root_.alg_hom.bijective [finite_dimensional K L] (ϕ : L →ₐ[K] L) : function.bijective ϕ :=
(algebra.is_algebraic_of_finite K L).alg_hom_bijective ϕ

variables (K L)

/-- Bijection between algebra equivalences and algebra homomorphisms -/
@[simps] noncomputable
def is_algebraic.alg_equiv_equiv_alg_hom
  (ha : algebra.is_algebraic K L) : (L ≃ₐ[K] L) ≃* (L →ₐ[K] L) :=
{ to_fun := λ ϕ, ϕ.to_alg_hom,
  inv_fun := λ ϕ, alg_equiv.of_bijective ϕ (ha.alg_hom_bijective ϕ),
  left_inv := λ _, by {ext, refl},
  right_inv := λ _, by {ext, refl},
  map_mul' := λ _ _, rfl }

/-- Bijection between algebra equivalences and algebra homomorphisms -/
@[reducible] noncomputable def _root_.alg_equiv_equiv_alg_hom [finite_dimensional K L] :
  (L ≃ₐ[K] L) ≃* (L →ₐ[K] L) := (algebra.is_algebraic_of_finite K L).alg_equiv_equiv_alg_hom K L

end algebra

variables {R S : Type*} [comm_ring R] [is_domain R] [comm_ring S]

lemma exists_integral_multiple [algebra R S] {z : S} (hz : is_algebraic R z)
  (inj : ∀ x, algebra_map R S x = 0 → x = 0) :
  ∃ (x : integral_closure R S) (y ≠ (0 : R)),
    z * algebra_map R S y = x :=
begin
  rcases hz with ⟨p, p_ne_zero, px⟩,
  set a := p.leading_coeff with a_def,
  have a_ne_zero : a ≠ 0 := mt polynomial.leading_coeff_eq_zero.mp p_ne_zero,
  have y_integral : is_integral R (algebra_map R S a) := is_integral_algebra_map,
  have x_integral : is_integral R (z * algebra_map R S a) :=
    ⟨p.integral_normalization,
     monic_integral_normalization p_ne_zero,
     integral_normalization_aeval_eq_zero px inj⟩,
  exact ⟨⟨_, x_integral⟩, a, a_ne_zero, rfl⟩
end

/-- A fraction `(a : S) / (b : S)` can be reduced to `(c : S) / (d : R)`,
if `S` is the integral closure of `R` in an algebraic extension `L` of `R`. -/
lemma is_integral_closure.exists_smul_eq_mul {L : Type*} [field L]
  [algebra R S] [algebra S L] [algebra R L] [is_scalar_tower R S L] [is_integral_closure S R L]
  (h : algebra.is_algebraic R L) (inj : function.injective (algebra_map R L))
  (a : S) {b : S} (hb : b ≠ 0) : ∃ (c : S) (d ≠ (0 : R)), d • a = b * c :=
begin
  obtain ⟨c, d, d_ne, hx⟩ := exists_integral_multiple
    (h (algebra_map _ L a / algebra_map _ L b))
    ((injective_iff_map_eq_zero _).mp inj),
  refine ⟨is_integral_closure.mk' S (c : L) c.2, d, d_ne,
    is_integral_closure.algebra_map_injective S R L _⟩,
  simp only [algebra.smul_def, ring_hom.map_mul, is_integral_closure.algebra_map_mk', ← hx,
    ← is_scalar_tower.algebra_map_apply],
  rw [← mul_assoc _ (_ / _), mul_div_cancel' (algebra_map S L a), mul_comm],
  exact mt ((injective_iff_map_eq_zero _).mp (is_integral_closure.algebra_map_injective S R L) _) hb
end

section field

variables {K L : Type*} [field K] [field L] [algebra K L] (A : subalgebra K L)

lemma inv_eq_of_aeval_div_X_ne_zero {x : L} {p : K[X]}
  (aeval_ne : aeval x (div_X p) ≠ 0) :
  x⁻¹ = aeval x (div_X p) / (aeval x p - algebra_map _ _ (p.coeff 0)) :=
begin
  rw [inv_eq_iff_eq_inv, inv_div, eq_comm, div_eq_iff, sub_eq_iff_eq_add, mul_comm],
  conv_lhs { rw ← div_X_mul_X_add p },
  rw [alg_hom.map_add, alg_hom.map_mul, aeval_X, aeval_C],
  exact aeval_ne
end

lemma inv_eq_of_root_of_coeff_zero_ne_zero {x : L} {p : K[X]}
  (aeval_eq : aeval x p = 0) (coeff_zero_ne : p.coeff 0 ≠ 0) :
  x⁻¹ = - (aeval x (div_X p) / algebra_map _ _ (p.coeff 0)) :=
begin
  convert inv_eq_of_aeval_div_X_ne_zero (mt (λ h, (algebra_map K L).injective _) coeff_zero_ne),
  { rw [aeval_eq, zero_sub, div_neg] },
  rw ring_hom.map_zero,
  convert aeval_eq,
  conv_rhs { rw ← div_X_mul_X_add p },
  rw [alg_hom.map_add, alg_hom.map_mul, h, zero_mul, zero_add, aeval_C]
end

lemma subalgebra.inv_mem_of_root_of_coeff_zero_ne_zero {x : A} {p : K[X]}
  (aeval_eq : aeval x p = 0) (coeff_zero_ne : p.coeff 0 ≠ 0) : (x⁻¹ : L) ∈ A :=
begin
  suffices : (x⁻¹ : L) = (-p.coeff 0)⁻¹ • aeval x (div_X p),
  { rw [this], exact A.smul_mem (aeval x _).2 _ },
  have : aeval (x : L) p = 0, by rw [subalgebra.aeval_coe, aeval_eq, subalgebra.coe_zero],
  rw [inv_eq_of_root_of_coeff_zero_ne_zero this coeff_zero_ne, div_eq_inv_mul,
    algebra.smul_def, map_inv₀, map_neg, inv_neg, neg_mul, subalgebra.aeval_coe]
end

lemma subalgebra.inv_mem_of_algebraic {x : A} (hx : is_algebraic K (x : L)) : (x⁻¹ : L) ∈ A :=
begin
  obtain ⟨p, ne_zero, aeval_eq⟩ := hx,
  rw [subalgebra.aeval_coe, subalgebra.coe_eq_zero] at aeval_eq,
  revert ne_zero aeval_eq,
  refine p.rec_on_horner _ _ _,
  { intro h,
    contradiction },
  { intros p a hp ha ih ne_zero aeval_eq,
    refine A.inv_mem_of_root_of_coeff_zero_ne_zero aeval_eq _,
    rwa [coeff_add, hp, zero_add, coeff_C, if_pos rfl] },
  { intros p hp ih ne_zero aeval_eq,
    rw [alg_hom.map_mul, aeval_X, mul_eq_zero] at aeval_eq,
    cases aeval_eq with aeval_eq x_eq,
    { exact ih hp aeval_eq },
    { rw [x_eq, subalgebra.coe_zero, inv_zero],
      exact A.zero_mem } }
end

/-- In an algebraic extension L/K, an intermediate subalgebra is a field. -/
lemma subalgebra.is_field_of_algebraic (hKL : algebra.is_algebraic K L) : is_field A :=
{ mul_inv_cancel := λ a ha, ⟨
        ⟨a⁻¹, A.inv_mem_of_algebraic (hKL a)⟩,
        subtype.ext (mul_inv_cancel (mt (subalgebra.coe_eq_zero _).mp ha))⟩,
  .. show nontrivial A, by apply_instance,
  .. subalgebra.to_comm_ring A }

end field

section pi

variables (R' : Type u) (S' : Type v) (T' : Type w)

/-- This is not an instance as it forms a diamond with `pi.has_smul`.

See the `instance_diamonds` test for details. -/
def polynomial.has_smul_pi [semiring R'] [has_smul R' S'] :
  has_smul (R'[X]) (R' → S') :=
⟨λ p f x, eval x p • f x⟩

/-- This is not an instance as it forms a diamond with `pi.has_smul`.

See the `instance_diamonds` test for details. -/
noncomputable def polynomial.has_smul_pi' [comm_semiring R'] [semiring S'] [algebra R' S']
  [has_smul S' T'] :
  has_smul (R'[X]) (S' → T') :=
⟨λ p f x, aeval x p • f x⟩

variables {R} {S}

local attribute [instance] polynomial.has_smul_pi polynomial.has_smul_pi'

@[simp] lemma polynomial_smul_apply [semiring R'] [has_smul R' S']
  (p : R'[X]) (f : R' → S') (x : R') :
  (p • f) x = eval x p • f x := rfl

@[simp] lemma polynomial_smul_apply' [comm_semiring R'] [semiring S'] [algebra R' S']
  [has_smul S' T'] (p : R'[X]) (f : S' → T') (x : S') :
  (p • f) x = aeval x p • f x := rfl

variables [comm_semiring R'] [comm_semiring S'] [comm_semiring T'] [algebra R' S'] [algebra S' T']

/-- This is not an instance for the same reasons as `polynomial.has_smul_pi'`. -/
noncomputable def polynomial.algebra_pi :
  algebra (R'[X]) (S' → T') :=
{ to_fun := λ p z, algebra_map S' T' (aeval z p),
  map_one' := funext $ λ z, by simp only [polynomial.aeval_one, pi.one_apply, map_one],
  map_mul' := λ f g, funext $ λ z, by simp only [pi.mul_apply, map_mul],
  map_zero' := funext $ λ z, by simp only [polynomial.aeval_zero, pi.zero_apply, map_zero],
  map_add' := λ f g, funext $ λ z, by simp only [polynomial.aeval_add, pi.add_apply, map_add],
  commutes' := λ p f, funext $ λ z, mul_comm _ _,
  smul_def' := λ p f, funext $ λ z, by
    simp only [algebra.algebra_map_eq_smul_one, polynomial_smul_apply', one_mul,
      pi.mul_apply, algebra.smul_mul_assoc],
  ..polynomial.has_smul_pi' R' S' T' }

local attribute [instance] polynomial.algebra_pi

@[simp] lemma polynomial.algebra_map_pi_eq_aeval :
  (algebra_map (R'[X]) (S' → T') : R'[X] → (S' → T')) =
    λ p z, algebra_map _ _ (aeval z p) := rfl

@[simp] lemma polynomial.algebra_map_pi_self_eq_eval :
  (algebra_map (R'[X]) (R' → R') : R'[X] → (R' → R')) = λ p z, eval z p := rfl

end pi


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import tactic.apply_fun
import algebra.field.opposite
import algebra.field_power
import algebra.ring.aut
import group_theory.group_action.units
import group_theory.group_action.opposite
import algebra.ring.comp_typeclasses

/-!
# Star monoids, rings, and modules

We introduce the basic algebraic notions of star monoids, star rings, and star modules.
A star algebra is simply a star ring that is also a star module.

These are implemented as "mixin" typeclasses, so to summon a star ring (for example)
one needs to write `(R : Type) [ring R] [star_ring R]`.
This avoids difficulties with diamond inheritance.

We also define the class `star_ordered_ring R`, which says that the order on `R` respects the
star operation, i.e. an element `r` is nonnegative iff there exists an `s` such that
`r = star s * s`.

For now we simply do not introduce notations,
as different users are expected to feel strongly about the relative merits of
`r^*`, `r†`, `rᘁ`, and so on.

Our star rings are actually star semirings, but of course we can prove
`star_neg : star (-r) = - star r` when the underlying semiring is a ring.

## TODO

* In a Banach star algebra without a well-defined square root, the natural ordering is given by the
positive cone which is the closure of the sums of elements `star r * r`. A weaker version of
`star_ordered_ring` could be defined for this case. Note that the current definition has the
advantage of not requiring a topology.
-/

universes u v

open mul_opposite

/--
Notation typeclass (with no default notation!) for an algebraic structure with a star operation.
-/
class has_star (R : Type u) :=
(star : R → R)

variables {R : Type u}

export has_star (star)

/--
A star operation (e.g. complex conjugate).
-/
add_decl_doc star

/--
Typeclass for a star operation with is involutive.
-/
class has_involutive_star (R : Type u) extends has_star R :=
(star_involutive : function.involutive star)

export has_involutive_star (star_involutive)

@[simp] lemma star_star [has_involutive_star R] (r : R) : star (star r) = r :=
star_involutive _

lemma star_injective [has_involutive_star R] : function.injective (star : R → R) :=
star_involutive.injective

/-- `star` as an equivalence when it is involutive. -/
protected def equiv.star [has_involutive_star R] : equiv.perm R :=
star_involutive.to_perm _

lemma eq_star_of_eq_star [has_involutive_star R] {r s : R} (h : r = star s) : s = star r :=
by simp [h]

lemma eq_star_iff_eq_star [has_involutive_star R] {r s : R} : r = star s ↔ s = star r :=
⟨eq_star_of_eq_star, eq_star_of_eq_star⟩

lemma star_eq_iff_star_eq [has_involutive_star R] {r s : R} : star r = s ↔ star s = r :=
eq_comm.trans $ eq_star_iff_eq_star.trans eq_comm

/--
Typeclass for a trivial star operation. This is mostly meant for `ℝ`.
-/
class has_trivial_star (R : Type u) [has_star R] : Prop :=
(star_trivial : ∀ (r : R), star r = r)

export has_trivial_star (star_trivial)
attribute [simp] star_trivial

/--
A `*`-semigroup is a semigroup `R` with an involutive operations `star`
so `star (r * s) = star s * star r`.
-/
class star_semigroup (R : Type u) [semigroup R] extends has_involutive_star R :=
(star_mul : ∀ r s : R, star (r * s) = star s * star r)

export star_semigroup (star_mul)
attribute [simp] star_mul

/-- In a commutative ring, make `simp` prefer leaving the order unchanged. -/
@[simp] lemma star_mul' [comm_semigroup R] [star_semigroup R] (x y : R) :
  star (x * y) = star x * star y :=
(star_mul x y).trans (mul_comm _ _)

/-- `star` as an `mul_equiv` from `R` to `Rᵐᵒᵖ` -/
@[simps apply]
def star_mul_equiv [semigroup R] [star_semigroup R] : R ≃* Rᵐᵒᵖ :=
{ to_fun := λ x, mul_opposite.op (star x),
  map_mul' := λ x y, (star_mul x y).symm ▸ (mul_opposite.op_mul _ _),
  ..(has_involutive_star.star_involutive.to_perm star).trans op_equiv}

/-- `star` as a `mul_aut` for commutative `R`. -/
@[simps apply]
def star_mul_aut [comm_semigroup R] [star_semigroup R] : mul_aut R :=
{ to_fun := star,
  map_mul' := star_mul',
  ..(has_involutive_star.star_involutive.to_perm star) }

variables (R)

@[simp] lemma star_one [monoid R] [star_semigroup R] : star (1 : R) = 1 :=
op_injective $ (star_mul_equiv : R ≃* Rᵐᵒᵖ).map_one.trans (op_one _).symm

variables {R}

@[simp] lemma star_pow [monoid R] [star_semigroup R] (x : R) (n : ℕ) : star (x ^ n) = star x ^ n :=
op_injective $
  ((star_mul_equiv : R ≃* Rᵐᵒᵖ).to_monoid_hom.map_pow x n).trans (op_pow (star x) n).symm

@[simp] lemma star_inv [group R] [star_semigroup R] (x : R) : star (x⁻¹) = (star x)⁻¹ :=
op_injective $
  ((star_mul_equiv : R ≃* Rᵐᵒᵖ).to_monoid_hom.map_inv x).trans (op_inv (star x)).symm

@[simp] lemma star_zpow [group R] [star_semigroup R] (x : R) (z : ℤ) : star (x ^ z) = star x ^ z :=
op_injective $
  ((star_mul_equiv : R ≃* Rᵐᵒᵖ).to_monoid_hom.map_zpow x z).trans (op_zpow (star x) z).symm

/-- When multiplication is commutative, `star` preserves division. -/
@[simp] lemma star_div [comm_group R] [star_semigroup R] (x y : R) :
  star (x / y) = star x / star y :=
(star_mul_aut : R ≃* R).to_monoid_hom.map_div _ _

section
open_locale big_operators

@[simp] lemma star_prod [comm_monoid R] [star_semigroup R] {α : Type*}
  (s : finset α) (f : α → R):
  star (∏ x in s, f x) = ∏ x in s, star (f x) :=
(star_mul_aut : R ≃* R).map_prod _ _

end

/--
Any commutative monoid admits the trivial `*`-structure.

See note [reducible non-instances].
-/
@[reducible]
def star_semigroup_of_comm {R : Type*} [comm_monoid R] : star_semigroup R :=
{ star := id,
  star_involutive := λ x, rfl,
  star_mul := mul_comm }

section
local attribute [instance] star_semigroup_of_comm

/-- Note that since `star_semigroup_of_comm` is reducible, `simp` can already prove this. --/
lemma star_id_of_comm {R : Type*} [comm_semiring R] {x : R} : star x = x := rfl

end

/--
A `*`-additive monoid `R` is an additive monoid with an involutive `star` operation which
preserves addition.
-/
class star_add_monoid (R : Type u) [add_monoid R] extends has_involutive_star R :=
(star_add : ∀ r s : R, star (r + s) = star r + star s)

export star_add_monoid (star_add)
attribute [simp] star_add

/-- `star` as an `add_equiv` -/
@[simps apply]
def star_add_equiv [add_monoid R] [star_add_monoid R] : R ≃+ R :=
{ to_fun := star,
  map_add' := star_add,
  ..(has_involutive_star.star_involutive.to_perm star)}

variables (R)

@[simp] lemma star_zero [add_monoid R] [star_add_monoid R] : star (0 : R) = 0 :=
(star_add_equiv : R ≃+ R).map_zero

variables {R}

@[simp]
lemma star_eq_zero [add_monoid R] [star_add_monoid R] {x : R} : star x = 0 ↔ x = 0 :=
star_add_equiv.map_eq_zero_iff

lemma star_ne_zero [add_monoid R] [star_add_monoid R] {x : R} : star x ≠ 0 ↔ x ≠ 0 :=
star_eq_zero.not

@[simp] lemma star_neg [add_group R] [star_add_monoid R] (r : R) : star (-r) = - star r :=
(star_add_equiv : R ≃+ R).map_neg _

@[simp] lemma star_sub [add_group R] [star_add_monoid R] (r s : R) :
  star (r - s) = star r - star s :=
(star_add_equiv : R ≃+ R).map_sub _ _

@[simp] lemma star_nsmul [add_comm_monoid R] [star_add_monoid R] (x : R) (n : ℕ) :
  star (n • x) = n • star x :=
(star_add_equiv : R ≃+ R).to_add_monoid_hom.map_nsmul _ _

@[simp] lemma star_zsmul [add_comm_group R] [star_add_monoid R] (x : R) (n : ℤ) :
  star (n • x) = n • star x :=
(star_add_equiv : R ≃+ R).to_add_monoid_hom.map_zsmul _ _

section
open_locale big_operators

@[simp] lemma star_sum [add_comm_monoid R] [star_add_monoid R] {α : Type*}
  (s : finset α) (f : α → R):
  star (∑ x in s, f x) = ∑ x in s, star (f x) :=
(star_add_equiv : R ≃+ R).map_sum _ _

end

/--
A `*`-ring `R` is a (semi)ring with an involutive `star` operation which is additive
which makes `R` with its multiplicative structure into a `*`-semigroup
(i.e. `star (r * s) = star s * star r`).
-/
class star_ring (R : Type u) [non_unital_semiring R] extends star_semigroup R :=
(star_add : ∀ r s : R, star (r + s) = star r + star s)

@[priority 100]
instance star_ring.to_star_add_monoid [non_unital_semiring R] [star_ring R] : star_add_monoid R :=
{ star_add := star_ring.star_add }

/-- `star` as an `ring_equiv` from `R` to `Rᵐᵒᵖ` -/
@[simps apply]
def star_ring_equiv [non_unital_semiring R] [star_ring R] : R ≃+* Rᵐᵒᵖ :=
{ to_fun := λ x, mul_opposite.op (star x),
  ..star_add_equiv.trans (mul_opposite.op_add_equiv : R ≃+ Rᵐᵒᵖ),
  ..star_mul_equiv }

@[simp, norm_cast] lemma star_nat_cast [semiring R] [star_ring R] (n : ℕ) :
  star (n : R) = n :=
(congr_arg unop (map_nat_cast (star_ring_equiv : R ≃+* Rᵐᵒᵖ) n)).trans (unop_nat_cast _)

@[simp, norm_cast] lemma star_int_cast [ring R] [star_ring R] (z : ℤ) :
  star (z : R) = z :=
(congr_arg unop ((star_ring_equiv : R ≃+* Rᵐᵒᵖ).to_ring_hom.map_int_cast z)).trans (unop_int_cast _)

@[simp, norm_cast] lemma star_rat_cast [division_ring R] [char_zero R] [star_ring R] (r : ℚ) :
  star (r : R) = r :=
(congr_arg unop ((star_ring_equiv : R ≃+* Rᵐᵒᵖ).to_ring_hom.map_rat_cast r)).trans (unop_rat_cast _)

/-- `star` as a ring automorphism, for commutative `R`. -/
@[simps apply]
def star_ring_aut [comm_semiring R] [star_ring R] : ring_aut R :=
{ to_fun := star,
  ..star_add_equiv,
  ..star_mul_aut }

variables (R)
/-- `star` as a ring endomorphism, for commutative `R`. This is used to denote complex
conjugation, and is available under the notation `conj` in the locale `complex_conjugate`.

Note that this is the preferred form (over `star_ring_aut`, available under the same hypotheses)
because the notation `E →ₗ⋆[R] F` for an `R`-conjugate-linear map (short for
`E →ₛₗ[star_ring_end R] F`) does not pretty-print if there is a coercion involved, as would be the
case for `(↑star_ring_aut : R →* R)`. -/
def star_ring_end [comm_semiring R] [star_ring R] : R →+* R := @star_ring_aut R _ _
variables {R}

localized "notation `conj` := star_ring_end _" in complex_conjugate

/-- This is not a simp lemma, since we usually want simp to keep `star_ring_end` bundled.
 For example, for complex conjugation, we don't want simp to turn `conj x`
 into the bare function `star x` automatically since most lemmas are about `conj x`. -/
lemma star_ring_end_apply [comm_semiring R] [star_ring R] {x : R} :
  star_ring_end R x = star x := rfl

@[simp] lemma star_ring_end_self_apply [comm_semiring R] [star_ring R] (x : R) :
  star_ring_end R (star_ring_end R x) = x := star_star x

-- A more convenient name for complex conjugation
alias star_ring_end_self_apply ← complex.conj_conj
alias star_ring_end_self_apply ← is_R_or_C.conj_conj

@[simp] lemma star_inv' [division_ring R] [star_ring R] (x : R) : star (x⁻¹) = (star x)⁻¹ :=
op_injective $
  ((star_ring_equiv : R ≃+* Rᵐᵒᵖ).to_ring_hom.map_inv x).trans (op_inv (star x)).symm

@[simp] lemma star_zpow₀ [division_ring R] [star_ring R] (x : R) (z : ℤ) :
  star (x ^ z) = star x ^ z :=
op_injective $
  ((star_ring_equiv : R ≃+* Rᵐᵒᵖ).to_ring_hom.map_zpow x z).trans (op_zpow (star x) z).symm

/-- When multiplication is commutative, `star` preserves division. -/
@[simp] lemma star_div' [field R] [star_ring R] (x y : R) : star (x / y) = star x / star y :=
(star_ring_end R).map_div _ _

@[simp] lemma star_bit0 [add_monoid R] [star_add_monoid R] (r : R) :
  star (bit0 r) = bit0 (star r) :=
by simp [bit0]

@[simp] lemma star_bit1 [semiring R] [star_ring R] (r : R) : star (bit1 r) = bit1 (star r) :=
by simp [bit1]

/--
Any commutative semiring admits the trivial `*`-structure.

See note [reducible non-instances].
-/
@[reducible]
def star_ring_of_comm {R : Type*} [comm_semiring R] : star_ring R :=
{ star := id,
  star_add := λ x y, rfl,
  ..star_semigroup_of_comm }

/--
An ordered `*`-ring is a ring which is both an `ordered_add_comm_group` and a `*`-ring,
and `0 ≤ r ↔ ∃ s, r = star s * s`.
-/
class star_ordered_ring (R : Type u) [non_unital_semiring R] [partial_order R]
  extends star_ring R :=
(add_le_add_left       : ∀ a b : R, a ≤ b → ∀ c : R, c + a ≤ c + b)
(nonneg_iff            : ∀ r : R, 0 ≤ r ↔ ∃ s, r = star s * s)

namespace star_ordered_ring

variables [ring R] [partial_order R] [star_ordered_ring R]

@[priority 100] -- see note [lower instance priority]
instance : ordered_add_comm_group R :=
{ ..show ring R, by apply_instance,
  ..show partial_order R, by apply_instance,
  ..show star_ordered_ring R, by apply_instance }

end star_ordered_ring

lemma star_mul_self_nonneg
  [non_unital_semiring R] [partial_order R] [star_ordered_ring R] {r : R} : 0 ≤ star r * r :=
(star_ordered_ring.nonneg_iff _).mpr ⟨r, rfl⟩

lemma star_mul_self_nonneg'
  [non_unital_semiring R] [partial_order R] [star_ordered_ring R] {r : R} : 0 ≤ r * star r :=
by { nth_rewrite_rhs 0 [←star_star r], exact star_mul_self_nonneg }

/--
A star module `A` over a star ring `R` is a module which is a star add monoid,
and the two star structures are compatible in the sense
`star (r • a) = star r • star a`.

Note that it is up to the user of this typeclass to enforce
`[semiring R] [star_ring R] [add_comm_monoid A] [star_add_monoid A] [module R A]`, and that
the statement only requires `[has_star R] [has_star A] [has_scalar R A]`.

If used as `[comm_ring R] [star_ring R] [semiring A] [star_ring A] [algebra R A]`, this represents a
star algebra.
-/
class star_module (R : Type u) (A : Type v) [has_star R] [has_star A] [has_scalar R A] : Prop :=
(star_smul : ∀ (r : R) (a : A), star (r • a) = star r • star a)

export star_module (star_smul)
attribute [simp] star_smul

/-- A commutative star monoid is a star module over itself via `monoid.to_mul_action`. -/
instance star_semigroup.to_star_module [comm_monoid R] [star_semigroup R] : star_module R R :=
⟨star_mul'⟩

namespace ring_hom_inv_pair

/-- Instance needed to define star-linear maps over a commutative star ring
(ex: conjugate-linear maps when R = ℂ).  -/
instance [comm_semiring R] [star_ring R] :
  ring_hom_inv_pair (star_ring_end R) (star_ring_end R) :=
⟨ring_hom.ext star_star, ring_hom.ext star_star⟩

end ring_hom_inv_pair

/-! ### Instances -/

namespace units

variables [monoid R] [star_semigroup R]

instance : star_semigroup Rˣ :=
{ star := λ u,
  { val := star u,
    inv := star ↑u⁻¹,
    val_inv := (star_mul _ _).symm.trans $ (congr_arg star u.inv_val).trans $ star_one _,
    inv_val := (star_mul _ _).symm.trans $ (congr_arg star u.val_inv).trans $ star_one _ },
  star_involutive := λ u, units.ext (star_involutive _),
  star_mul := λ u v, units.ext (star_mul _ _) }

@[simp] lemma coe_star (u : Rˣ) : ↑(star u) = (star ↑u : R) := rfl
@[simp] lemma coe_star_inv (u : Rˣ) : ↑(star u)⁻¹ = (star ↑u⁻¹ : R) := rfl

instance {A : Type*} [has_star A] [has_scalar R A] [star_module R A] : star_module Rˣ A :=
⟨λ u a, (star_smul ↑u a : _)⟩

end units

lemma is_unit.star [monoid R] [star_semigroup R] {a : R} : is_unit a → is_unit (star a)
| ⟨u, hu⟩ := ⟨star u, hu ▸ rfl⟩

@[simp] lemma is_unit_star [monoid R] [star_semigroup R] {a : R} : is_unit (star a) ↔ is_unit a :=
⟨λ h, star_star a ▸ h.star, is_unit.star⟩

lemma ring.inverse_star [semiring R] [star_ring R] (a : R) :
  ring.inverse (star a) = star (ring.inverse a) :=
begin
  by_cases ha : is_unit a,
  { obtain ⟨u, rfl⟩ := ha,
    rw [ring.inverse_unit, ←units.coe_star, ring.inverse_unit, ←units.coe_star_inv], },
  rw [ring.inverse_non_unit _ ha, ring.inverse_non_unit _ (mt is_unit_star.mp ha), star_zero],
end

instance invertible.star {R : Type*} [monoid R] [star_semigroup R] (r : R) [invertible r] :
  invertible (star r) :=
{ inv_of := star (⅟r),
  inv_of_mul_self := by rw [←star_mul, mul_inv_of_self, star_one],
  mul_inv_of_self := by rw [←star_mul, inv_of_mul_self, star_one] }

lemma star_inv_of {R : Type*} [monoid R] [star_semigroup R] (r : R)
  [invertible r] [invertible (star r)] :
  star (⅟r) = ⅟(star r) :=
by { letI := invertible.star r, convert (rfl : star (⅟r) = _) }

namespace mul_opposite

/-- The opposite type carries the same star operation. -/
instance [has_star R] : has_star (Rᵐᵒᵖ) :=
{ star := λ r, op (star (r.unop)) }

@[simp] lemma unop_star [has_star R] (r : Rᵐᵒᵖ) : unop (star r) = star (unop r) := rfl
@[simp] lemma op_star [has_star R] (r : R) : op (star r) = star (op r) := rfl

instance [has_involutive_star R] : has_involutive_star (Rᵐᵒᵖ) :=
{ star_involutive := λ r, unop_injective (star_star r.unop) }

instance [monoid R] [star_semigroup R] : star_semigroup (Rᵐᵒᵖ) :=
{ star_mul := λ x y, unop_injective (star_mul y.unop x.unop) }

instance [add_monoid R] [star_add_monoid R] : star_add_monoid (Rᵐᵒᵖ) :=
{ star_add := λ x y, unop_injective (star_add x.unop y.unop) }

instance [semiring R] [star_ring R] : star_ring (Rᵐᵒᵖ) :=
{ .. mul_opposite.star_add_monoid }

end mul_opposite

/-- A commutative star monoid is a star module over its opposite via
`monoid.to_opposite_mul_action`. -/
instance star_semigroup.to_opposite_star_module [comm_monoid R] [star_semigroup R] :
  star_module Rᵐᵒᵖ R :=
⟨λ r s, star_mul' s r.unop⟩


/-
Copyright (c) 2023 David Loeffler. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Loeffler
-/
import number_theory.modular_forms.basic
import analysis.special_functions.gaussian
import analysis.calculus.series
import analysis.complex.locally_uniform_limit

/-! # Jacobi's theta function

This file defines the Jacobi theta function

$$\theta(\tau) = \sum_{n \in \mathbb{Z}} \exp (i \pi n ^ 2 \tau),$$

and proves the modular transformation properties `θ (τ + 2) = θ τ` and
`θ (-1 / τ) = (-I * τ) ^ (1 / 2) * θ τ`, using Poisson's summation formula for the latter. We also
show that `θ` is differentiable on `ℍ`, and `θ(τ) - 1` has exponential decay as `im τ → ∞`.
-/

open complex real asymptotics

open_locale real big_operators upper_half_plane manifold

/-- Jacobi's theta function `∑' (n : ℤ), exp (π * I * n ^ 2 * τ)`. -/
noncomputable def jacobi_theta (τ : ℍ) : ℂ := ∑' (n : ℤ), cexp (π * I * n ^ 2 * τ)

lemma norm_exp_mul_sq_le {z : ℂ} (hz : 0 < z.im) (n : ℤ) :
  ‖cexp (π * I * n ^ 2 * z)‖ ≤ exp (-π * z.im) ^ n.nat_abs :=
begin
  let y := rexp (-π * z.im),
  have h : y < 1, from exp_lt_one_iff.mpr (mul_neg_of_neg_of_pos (neg_lt_zero.mpr pi_pos) hz),
  refine (le_of_eq _).trans (_ : y ^ (n ^ 2) ≤ _),
  { rw [complex.norm_eq_abs, complex.abs_exp],
    have : (↑π * I * n ^ 2 * z).re = (-π * z.im) * n ^ 2,
    { rw [(by { push_cast, ring } : ↑π * I * n ^ 2 * z = ↑(π * n ^ 2) * (z * I)),
        of_real_mul_re, mul_I_re],
      ring },
    obtain ⟨m, hm⟩ := int.eq_coe_of_zero_le (sq_nonneg n),
    rw [this, exp_mul, ←int.cast_pow, rpow_int_cast, hm, zpow_coe_nat] },
  { have : n ^ 2 = ↑(n.nat_abs ^ 2), by rw [nat.cast_pow, int.nat_abs_sq],
    rw [this, zpow_coe_nat],
    exact pow_le_pow_of_le_one (exp_pos _).le h.le ((sq n.nat_abs).symm ▸ n.nat_abs.le_mul_self) },
end

lemma exists_summable_bound_exp_mul_sq {R : ℝ} (hR : 0 < R) :
  ∃ (bd : ℤ → ℝ), (summable bd) ∧
  (∀ {τ : ℂ} (hτ : R ≤ τ.im) (n : ℤ), ‖cexp (π * I * n ^ 2 * τ)‖ ≤ bd n) :=
begin
  let y := rexp (-π * R),
  have h : y < 1, from exp_lt_one_iff.mpr (mul_neg_of_neg_of_pos (neg_lt_zero.mpr pi_pos) hR),
  refine ⟨λ n, y ^ n.nat_abs, summable_int_of_summable_nat _ _, λ τ hτ n, _⟩, swap 3,
  { refine (norm_exp_mul_sq_le (hR.trans_le hτ) n).trans _,
    refine pow_le_pow_of_le_left (exp_pos _).le (real.exp_le_exp.mpr _) _,
    rwa [mul_le_mul_left_of_neg (neg_lt_zero.mpr pi_pos)] },
  all_goals { simpa only [int.nat_abs_neg, int.nat_abs_of_nat]
    using summable_geometric_of_lt_1 (real.exp_pos _).le h },
end

lemma summable_exp_mul_sq {z : ℂ} (hz : 0 < z.im) :
  summable (λ n : ℤ, cexp (π * I * n ^ 2 * z)) :=
let ⟨bd, h, h'⟩ := exists_summable_bound_exp_mul_sq hz in
  summable_norm_iff.mp (summable_of_nonneg_of_le (λ n, norm_nonneg _) (h' $ le_refl _) h)

lemma jacobi_theta_two_vadd (τ : ℍ) : jacobi_theta ((2 : ℝ) +ᵥ τ) = jacobi_theta τ :=
begin
  refine tsum_congr (λ n, _),
  rw [upper_half_plane.coe_vadd, of_real_bit0, of_real_one],
  suffices : cexp (↑π * I * ↑n ^ 2 * 2) = 1, by rw [mul_add, complex.exp_add, this, one_mul],
  rw [(by { push_cast, ring } : ↑π * I * ↑n ^ 2 * 2 = ↑(n ^ 2) * (2 * π * I)),
    complex.exp_int_mul, complex.exp_two_pi_mul_I, one_zpow],
end

lemma jacobi_theta_T_sq_smul (τ : ℍ) : jacobi_theta (modular_group.T ^ 2 • τ) = jacobi_theta τ :=
begin
  suffices : (2 : ℝ) +ᵥ τ = modular_group.T ^ (2 : ℤ) • τ, from this ▸ (jacobi_theta_two_vadd τ),
  simp only [←subtype.coe_inj, upper_half_plane.modular_T_zpow_smul, int.cast_two],
end

lemma jacobi_theta_S_smul (τ : ℍ) :
  jacobi_theta (modular_group.S • τ) = (-I * τ) ^ (1 / 2 : ℂ) * jacobi_theta τ :=
begin
  unfold jacobi_theta,
  rw [upper_half_plane.modular_S_smul, upper_half_plane.coe_mk],
  have ha : 0 < (-I * τ).re,
  { rw [neg_mul, neg_re, mul_re, I_re, I_im, zero_mul, one_mul, zero_sub, neg_neg],
    exact τ.im_pos },
  have ha' : (-I * τ) ^ (1 / 2 : ℂ) ≠ 0,
  { rw [ne.def, cpow_eq_zero_iff],
    contrapose! ha,
    rw [ha.1, zero_re] },
  have hτ : (τ : ℂ) ≠ 0, from τ.ne_zero,
  have := complex.tsum_exp_neg_mul_int_sq ha,
  rw [mul_comm ((1:ℂ) / _) _, mul_one_div, eq_div_iff ha', mul_comm _ (_ ^ _), eq_comm] at this,
  convert this using 3,
  { ext1 n,
    congr' 1,
    field_simp [hτ, I_ne_zero],
    ring_nf,
    rw [I_sq, mul_neg, mul_one, neg_mul, neg_neg] },
  { ext1 n,
    congr' 1,
    ring_nf }
end

lemma has_sum_nat_jacobi_theta (τ : ℍ) :
  has_sum (λ (n : ℕ), cexp (π * I * (n + 1) ^ 2 * τ)) ((jacobi_theta τ - 1) / 2) :=
begin
  have := (summable_exp_mul_sq τ.im_pos).has_sum.sum_nat_of_sum_int,
  rw ←@has_sum_nat_add_iff' ℂ _ _ _ _ 1 at this,
  simp_rw [finset.sum_range_one, int.cast_neg, int.cast_coe_nat, nat.cast_zero, neg_zero,
    int.cast_zero, sq (0:ℂ), mul_zero, zero_mul, neg_sq, ←mul_two, complex.exp_zero,
    add_sub_assoc, (by norm_num : (1 : ℂ) - 1 * 2 = -1), ←sub_eq_add_neg,
    nat.cast_add, nat.cast_one] at this,
  convert this.div_const 2,
  simp_rw mul_div_cancel _ two_ne_zero,
end

lemma jacobi_theta_eq_tsum_nat (τ : ℍ) :
  jacobi_theta τ = 1 + 2 * ∑' (n : ℕ), cexp (π * I * (n + 1) ^ 2 * τ) :=
by rw [(has_sum_nat_jacobi_theta τ).tsum_eq, mul_div_cancel' _ (two_ne_zero' ℂ), ←add_sub_assoc,
  add_sub_cancel']

/-- An explicit upper bound for `‖jacobi_theta τ - 1‖`. -/
lemma norm_jacobi_theta_sub_one_le (τ : ℍ) :
  ‖jacobi_theta τ - 1‖ ≤ 2 / (1 - exp (-π * τ.im)) * exp (-π * τ.im) :=
begin
  suffices : ‖∑' (n : ℕ), cexp (π * I * (n + 1) ^ 2 * τ)‖ ≤ exp (-π * τ.im) / (1 - exp (-π * τ.im)),
  { calc ‖jacobi_theta τ - 1‖ = 2 * ‖∑' (n : ℕ), cexp (π * I * (n + 1) ^ 2 * τ)‖ :
      by rw [sub_eq_iff_eq_add'.mpr (jacobi_theta_eq_tsum_nat τ), norm_mul, complex.norm_eq_abs,
        complex.abs_two]
    ... ≤ 2 * (rexp (-π * τ.im) / (1 - rexp (-π * τ.im))) :
      by rwa [mul_le_mul_left (zero_lt_two' ℝ)]
    ... = 2 / (1 - rexp (-π * τ.im)) * rexp (-π * τ.im) : by rw [div_mul_comm, mul_comm] },
  have : ∀ (n : ℕ), ‖cexp (π * I * (n + 1) ^ 2 * τ)‖ ≤ exp (-π * τ.im) ^ (n + 1),
  { intro n,
    simpa only [int.cast_add, int.cast_one] using norm_exp_mul_sq_le τ.im_pos (n + 1) },
  have s : has_sum (λ n : ℕ, rexp (-π * τ.im) ^ (n + 1)) (exp (-π * τ.im) / (1 - exp (-π * τ.im))),
  { simp_rw [pow_succ, div_eq_mul_inv, has_sum_mul_left_iff (real.exp_ne_zero _)],
    exact has_sum_geometric_of_lt_1 (exp_pos (-π * τ.im)).le
      (exp_lt_one_iff.mpr $ (mul_neg_of_neg_of_pos (neg_lt_zero.mpr pi_pos) τ.im_pos)) },
  have aux : summable (λ (n : ℕ), ‖cexp (↑π * I * (↑n + 1) ^ 2 * ↑τ)‖),
    from summable_of_nonneg_of_le (λ n, norm_nonneg _) this s.summable,
  exact (norm_tsum_le_tsum_norm aux).trans
    ((tsum_mono aux s.summable this).trans (le_of_eq s.tsum_eq)),
end

/-- The norm of `jacobi_theta τ - 1` decays exponentially as `im τ → ∞`. -/
lemma is_O_at_im_infty_jacobi_theta_sub_one :
  is_O upper_half_plane.at_im_infty (λ τ, jacobi_theta τ - 1) (λ τ, rexp (-π * τ.im)) :=
begin
  simp_rw [is_O, is_O_with, filter.eventually, upper_half_plane.at_im_infty_mem],
  refine ⟨2 / (1 - rexp (-π)), 1, (λ τ hτ, (norm_jacobi_theta_sub_one_le τ).trans _)⟩,
  rw [real.norm_eq_abs, real.abs_exp],
  refine mul_le_mul_of_nonneg_right _ (exp_pos _).le,
  rw [div_le_div_left (zero_lt_two' ℝ), sub_le_sub_iff_left, exp_le_exp, neg_mul, neg_le_neg_iff],
  { exact le_mul_of_one_le_right pi_pos.le hτ },
  { rw [sub_pos, exp_lt_one_iff, neg_mul, neg_lt_zero], exact mul_pos pi_pos τ.im_pos },
  { rw [sub_pos, exp_lt_one_iff, neg_lt_zero], exact pi_pos }
end

lemma differentiable_at_tsum_exp_mul_sq (τ : ℍ) :
  differentiable_at ℂ (λ z, ∑' (n : ℤ), cexp (π * I * n ^ 2 * z)) ↑τ :=
begin
  suffices : ∀ (y : ℝ) (hy : 0 < y),
    differentiable_on ℂ (λ z, ∑' (n : ℤ), cexp (π * I * n ^ 2 * z)) {w : ℂ | y < im w},
  from let ⟨y, hy, hy'⟩ := exists_between τ.im_pos in (this y hy).differentiable_at
    ((complex.continuous_im.is_open_preimage _ is_open_Ioi).mem_nhds (τ.coe_im ▸ hy')),
  intros y hy,
  have h1 : ∀ (n : ℤ) (w : ℂ) (hw : y < im w), differentiable_within_at ℂ
    (λ (v : ℂ), cexp (↑π * I * ↑n ^ 2 * v)) {z : ℂ | y < im z} w,
  from λ n w hw, (differentiable_at_id.const_mul _).cexp.differentiable_within_at,
  have h2 : is_open {w : ℂ | y < im w}, from continuous_im.is_open_preimage _ is_open_Ioi,
  obtain ⟨bd, bd_s, le_bd⟩ := exists_summable_bound_exp_mul_sq hy,
  exact differentiable_on_tsum_of_summable_norm bd_s h1 h2 (λ i w hw, le_bd (le_of_lt hw) i),
end

lemma mdifferentiable_jacobi_theta : mdifferentiable 𝓘(ℂ) 𝓘(ℂ) jacobi_theta :=
λ τ, (differentiable_at_tsum_exp_mul_sq τ).mdifferentiable_at.comp τ τ.mdifferentiable_coe

lemma continuous_jacobi_theta : continuous jacobi_theta := mdifferentiable_jacobi_theta.continuous


/-
1. Prove the following identities, replacing the “sorry” placeholders with actual proofs.
-/

variables p q r : Prop

example : p ∧ q ↔ q ∧ p :=
    iff.intro
    (
        assume h : p ∧ q,
        show q ∧ p, from and.intro (and.elim_right h) (and.elim_left h)
    )
    (
        assume h : q ∧ p,
        show p ∧ q, from and.intro (and.elim_right h) (and.elim_left h)
    )
-- short version
example : p ∧ q ↔ q ∧ p :=
    ⟨λ h, ⟨h.right, h.left⟩, λ h, ⟨h.right, h.left⟩⟩

example : p ∨ q ↔ q ∨ p :=
    iff.intro
    (
        assume h : p ∨ q,
        or.elim h
        (assume hp : p, show q ∨ p, from or.intro_right q hp)
        (assume hq : q, show q ∨ p, from or.intro_left p hq)
    )
    (
        assume h : q ∨ p,
        or.elim h
        (assume hq : q, show p ∨ q, from or.intro_right p hq)
        (assume hp : p, show p ∨ q, from or.intro_left q hp)
    )
-- short version
example : p ∨ q ↔ q ∨ p :=
    iff.intro
    (λ h, h.elim (λ hp, or.inr hp) (λ hq, or.inl hq))
    (λ h, h.elim (λ hq, or.inr hq) (λ hp, or.inl hp))

example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
    iff.intro
    (
        assume hl : (p ∧ q) ∧ r,
        and.intro
        (and.elim_left (and.elim_left hl))
        (and.intro (and.elim_right (and.elim_left hl)) (and.elim_right hl))
    )
    (
        assume hr : p ∧ (q ∧ r),
        and.intro
        (and.intro (and.elim_left hr) (and.elim_left (and.elim_right hr)))
        (and.elim_right (and.elim_right hr))
    )
-- short vertion
example : (p ∧ q) ∧ r ↔ p ∧ (q ∧ r) :=
    iff.intro
    (λ h, ⟨h.left.left, ⟨h.left.right, h.right⟩⟩)
    (λ h, ⟨⟨h.left, h.right.left⟩, h.right.right⟩)

example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) :=
    iff.intro
    (
        assume h : (p ∨ q) ∨ r,
        or.elim h
        (
            assume hpq : p ∨ q,
            or.elim hpq
            (
                assume hp : p,
                show p ∨ (q ∨ r), from or.intro_left (q ∨ r) hp
            )
            (
                assume hq : q,
                show p ∨ (q ∨ r), from or.intro_right p (or.intro_left r hq)
            )
        )
        (
            assume hr : r,
            show p ∨ (q ∨ r), from or.intro_right p (or.intro_right q hr)
        )
    )
    (
        assume h : p ∨ (q ∨ r),
        or.elim h
        (
            assume hp : p,
            show (p ∨ q) ∨ r, from or.intro_left r (or.intro_left q hp)
        )
        (
            assume hqr : (q ∨ r),
            or.elim hqr
            (
                assume hq : q,
                show (p ∨ q) ∨ r, from or.intro_left r (or.intro_right p hq)
            )
            (
                assume hr : r,
                show (p ∨ q) ∨ r, from or.intro_right (p ∨ q) hr
            )
        )
    )
-- short version
example : (p ∨ q) ∨ r ↔ p ∨ (q ∨ r) :=
    iff.intro
    (
        λ h,
        h.elim
        (λ hpq, hpq.elim (λ hp, or.inl hp) (λ hq, or.inr (or.inl hq)))
        (λ hr, or.inr (or.inr hr))
    )
    (
        λ h,
        h.elim
        (λ hp, or.inl (or.inl hp))
        (λ hqr, hqr.elim (λ hq, or.inl (or.inr hq)) (λ hr, or.inr hr))
    )

example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
    iff.intro
    (
        assume h : p ∧ (q ∨ r),
        have hp : p, from and.elim_left h,
        have hqr : q ∨ r, from and.elim_right h,
        or.elim hqr
        (
            assume hq : q,
            show (p ∧ q) ∨ (p ∧ r), from or.intro_left (p ∧ r) (and.intro hp hq)
        )
        (
            assume hr : r,
            show (p ∧ q) ∨ (p ∧ r), from or.intro_right (p ∧ q) (and.intro hp hr)
        )
    )
    (
        assume h : (p ∧ q) ∨ (p ∧ r),
        or.elim h
        (
            assume hpq : p ∧ q,
            have hp : p, from and.elim_left hpq,
            have hq : q, from and.elim_right hpq,
            have hqr : q ∨ r, from or.intro_left r hq,
            show p ∧ (q ∨ r), from and.intro hp hqr
        )
        (
            assume hpr : p ∧ r,
            have hp : p, from and.elim_left hpr,
            have hr : r, from and.elim_right hpr,
            have hqr : q ∨ r, from or.intro_right q hr,
            show p ∧ (q ∨ r), from and.intro hp hqr
        )
    )
-- short version
example : p ∧ (q ∨ r) ↔ (p ∧ q) ∨ (p ∧ r) :=
    iff.intro
    (
        λ h,
        h.right.elim
        (λ hq, or.inl ⟨h.left, hq⟩)
        (λ hr, or.inr ⟨h.left, hr⟩)
    )
    (
        λ h,
        h.elim
        (λ hpq, ⟨hpq.left, or.inl hpq.right⟩)
        (λ hpr, ⟨hpr.left, or.inr hpr.right⟩)
    )

example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
    iff.intro
    (
        assume h : p ∨ (q ∧ r),
        h.elim
        (
            assume hp : p,
            show (p ∨ q) ∧ (p ∨ r), from ⟨or.inl hp, or.inl hp⟩
        )
        (
            assume hqr : q ∧ r,
            show (p ∨ q) ∧ (p ∨ r), from ⟨or.inr hqr.left, or.inr hqr.right⟩
        )
    )
    (
        assume h : (p ∨ q) ∧ (p ∨ r),
        have hpq : p ∨ q, from h.left,
        have hpr : p ∨ r, from h.right,
        hpq.elim
        (
            assume hp : p,
            show p ∨ (q ∧ r), from or.inl hp
        )
        (
            assume hq : q,
            hpr.elim
            (
                assume hp : p,
                show p ∨ (q ∧ r), from or.inl hp
            )
            (
                assume hr : r,
                show p ∨ (q ∧ r), from or.inr ⟨hq, hr⟩
            )
        )
    )
-- short version
example : p ∨ (q ∧ r) ↔ (p ∨ q) ∧ (p ∨ r) :=
    iff.intro
    (
        λ h,
        h.elim
        (λ hp, ⟨or.inl hp, or.inl hp⟩)
        (λ hqr, ⟨or.inr hqr.left, or.inr hqr.right⟩)
    )
    (
        λ h,
        h.left.elim
        (λ hp, or.inl hp)
        (λ hq, h.right.elim (λ hp, or.inl hp) (λ hr, or.inr ⟨hq, hr⟩))
    )

example : (p → (q → r)) ↔ (p ∧ q → r) :=
    iff.intro
    (
        assume h : p → (q → r),
        assume hpq : p ∧ q,
        show r, from h hpq.left hpq.right
    )
    (
        assume h : p ∧ q → r,
        assume hp : p,
        assume hq : q,
        show r, from h ⟨hp, hq⟩
    )
-- short version
example : (p → (q → r)) ↔ (p ∧ q → r) :=
    iff.intro
    (λ h, λ hpq, h hpq.left hpq.right)
    (λ h : p ∧ q → r, λ hp : p, λ hq : q, h ⟨hp, hq⟩)

example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
    iff.intro
    (
        assume h : (p ∨ q) → r,
        have hpr : p → r, from
            assume hp : p,
            show r, from h (or.inl hp),
        have hqr : q → r, from
            assume hq : q,
            show r, from h (or.inr hq),
        ⟨hpr, hqr⟩
    )
    (
        assume h : (p → r) ∧ (q → r),
        assume hpq : p ∨ q,
        have hpr : p → r, from h.left,
        have hqr : q → r, from h.right,
        hpq.elim
        (
            assume hp : p,
            show r, from hpr hp
        )
        (
            assume hq : q,
            show r, from hqr hq
        )
    )
-- short version
example : ((p ∨ q) → r) ↔ (p → r) ∧ (q → r) :=
    iff.intro
    (λ h, ⟨λ hp : p, h (or.inl hp), λ hq : q, h (or.inr hq)⟩)
    (λ h, λ hpq, hpq.elim (λ hp : p, h.left hp) (λ hq : q, h.right hq))

example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
    iff.intro
    (
        assume h : ¬(p ∨ q),
        and.intro
        (
            assume hp : p,
            show false, from h (or.inl hp)
        )
        (
            assume hq : q,
            show false, from h (or.inr hq)
        )
    )
    (
        assume h : ¬p ∧ ¬q,
        assume g : p ∨ q,
        show false, from
            g.elim
            (
                assume hp : p,
                h.left hp
            )
            (
                assume hq : q,
                h.right hq
            )
    )
-- short version
example : ¬(p ∨ q) ↔ ¬p ∧ ¬q :=
    iff.intro
    (λ h, ⟨(λ hp, h (or.inl hp)), (λ hq, h (or.inr hq))⟩)
    (λ h, λ g, g.elim (λ hp, h.left hp) (λ hq, h.right hq))

example : ¬p ∨ ¬q → ¬(p ∧ q) :=
    assume h : ¬p ∨ ¬q,
    assume g : p ∧ q,
    h.elim
    (
        assume hnp : ¬p,
        show false, from hnp g.left
    )
    (
        assume hnq : ¬q,
        show false, from hnq g.right
    )
-- short version
example : ¬p ∨ ¬q → ¬(p ∧ q) :=
    λ h, λ g, h.elim (λ hnp, hnp g.left) (λ hnq, hnq g.right)

example : ¬(p ∧ ¬p) :=
    assume h : p ∧ ¬p,
    h.right h.left
-- short version
example : ¬(p ∧ ¬p) :=
    λ h, h.right h.left

example : p ∧ ¬q → ¬(p → q) :=
    assume h : p ∧ ¬q,
    assume g : p → q,
    show false, from h.right (g h.left)
-- short version
example : p ∧ ¬q → ¬(p → q) :=
    λ h, λ g, h.right (g h.left)

example : ¬p → (p → q) :=
    assume hnp : ¬p,
    assume hp : p,
    show q, from false.elim (hnp hp)
-- short version
example : ¬p → (p → q) :=
    λ hnp, λ hp, absurd hp hnp

example : (¬p ∨ q) → (p → q) :=
    assume h : ¬p ∨ q,
    assume hp : p,
    h.elim
    (
        assume hnp : ¬p,
        show q, from false.elim (hnp hp)
    )
    (
        assume hq : q,
        show q, from hq
    )
-- short version
example : (¬p ∨ q) → (p → q) :=
    λ h, λ hp : p, h.elim (λ hnp, absurd hp hnp) (λ hq, hq)

example : p ∨ false ↔ p :=
    iff.intro
    (
        assume h : p ∨ false,
        h.elim
        (
            assume hp : p,
            show p, from hp
        )
        (
            assume hf : false,
            false.elim hf
        )
    )
    (
        assume hp : p,
        show p ∨ false, from or.inl hp
    )
-- short version
example : p ∨ false ↔ p :=
    iff.intro
    (λ h, h.elim (λ hp, hp) (λ hf, false.elim hf))
    (λ hp, or.inl hp)

example : p ∧ false ↔ false :=
    iff.intro
    (
        assume h : p ∧ false,
        h.right
    )
    (
        assume h : false,
        false.elim h
    )
-- short version
example : p ∧ false ↔ false :=
    iff.intro
    (λ h, h.right)
    (λ h, false.elim h)

example : (p → q) → (¬q → ¬p) :=
    assume h : p → q,
    assume hnq : ¬q,
    assume hp : p,
    hnq (h hp)
-- short version
example : (p → q) → (¬q → ¬p) :=
    λ h, λ hnq, λ hp, hnq (h hp)


inductive bit : Type
| zero
| one

/-
You've already seen inductive definitions in Type: in
our Bit example, which we repeat here.
This definition establishes bit as a data type with
two parameterless (constant) constructors: zero and
one. A core property of inductively defined types is
that their values are exactly those provided for by
constructors. So zero and one are all of the values
of our bit type. Key idea: bit is now a type, like
nat or bool, with values bit.zero and bit.one.
-/

#check bit.zero
#check bit.one

/-
We cross a bridge that really conntects computing and
logicc. We unpack a key definition of equality in Lean.
A few examples will help explain its operation.
-/

/-
Π {β : Type}, (β → β → Prop) → Prop

Again, think of Π as ∀. We define reflexive, given
a type β, to be a predicate on binary relations on
β. Some relations are reflexive,some aren't: some
have the property of being reflexive (reflexivity),
some don't. The reflexive predicate "picks out" the
relations that have this property: it's the ones
for which there is a proof. And once we've defined
reflexive as a predicate on relations, we can even
talk about the *set of all reflexive relations on
values of a given type, β.* Here is how we write
this set using reflexive as a predicate in a set
builder expression.
-/

def reflexive_relations :=
  { r : β → β → Prop | reflexive r }

-- That's cool. It says a lot very concisely.

/-
Now we can even state and prove theorems about
relations being reflexive using the language
of *set theory* by asserting that a relation
is *in this set*
-/
example : @eq nat ∈ @reflexive_relations nat :=
begin
  -- next three lines optional, for pedagogical clarity
  show reflexive_relations eq,
  unfold reflexive_relations,
  show reflexive (@eq nat),
  exact eq_is_refl,      -- Already proved, use theorem!
end


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

import linear_algebra.projective_space.basic

/-!
# Independence in Projective Space

In this file we define independence and dependence of families of elements in projective space.

## Implementation Details

We use an inductive definition to define the independence of points in projective
space, where the only constructor assumes an independent family of vectors from the
ambient vector space. Similarly for the definition of dependence.

## Results

- A family of elements is dependent if and only if it is not independent.
- Two elements are dependent if and only if they are equal.

# Future Work

- Define collinearity in projective space.
- Prove the axioms of a projective geometry are satisfied by the dependence relation.
- Define projective linear subspaces.
-/

variables {ι K V : Type*} [field K] [add_comm_group V] [module K V] {f : ι → ℙ K V}

namespace projectivization

/-- A linearly independent family of nonzero vectors gives an independent family of points
in projective space. -/
inductive independent : (ι → ℙ K V) → Prop
| mk (f : ι → V) (hf : ∀ i : ι, f i ≠ 0) (hl : linear_independent K f) :
    independent (λ i, mk K (f i) (hf i))

/-- A family of points in a projective space is independent if and only if the representative
vectors determined by the family are linearly independent. -/
lemma independent_iff : independent f ↔ linear_independent K (projectivization.rep ∘ f) :=
begin
  refine ⟨_, λ h, _⟩,
  { rintros ⟨ff, hff, hh⟩,
    choose a ha using λ (i : ι), exists_smul_eq_mk_rep K (ff i) (hff i),
    convert hh.units_smul a,
    ext i, exact (ha i).symm },
  { convert independent.mk _ _ h,
    { ext, simp only [mk_rep] },
    { intro i, apply rep_nonzero } }
end

/-- A family of points in projective space is independent if and only if the family of
submodules which the points determine is independent in the lattice-theoretic sense. -/
lemma independent_iff_complete_lattice_independent :
  independent f ↔ (complete_lattice.independent $ λ i, (f i).submodule) :=
begin
  refine ⟨_, λ h, _⟩,
  { rintros ⟨f, hf, hi⟩,
    simpa [submodule_mk, complete_lattice.independent_iff_linear_independent_of_ne_zero hf] },
  { rw independent_iff,
    refine h.linear_independent (projectivization.submodule ∘ f) (λ i, _) (λ i, _),
    { simpa only [function.comp_app, submodule_eq] using submodule.mem_span_singleton_self _, },
    { exact rep_nonzero (f i) } },
end

/-- A linearly dependent family of nonzero vectors gives a dependent family of points
in projective space. -/
inductive dependent : (ι → ℙ K V) → Prop
| mk (f : ι → V) (hf : ∀ i : ι, f i ≠ 0) (h : ¬linear_independent K f) :
    dependent (λ i, mk K (f i) (hf i))

/-- A family of points in a projective space is dependent if and only if their
representatives are linearly dependent. -/
lemma dependent_iff : dependent f ↔ ¬ linear_independent K (projectivization.rep ∘ f) :=
begin
  refine ⟨_, λ h, _⟩,
  { rintros ⟨ff, hff, hh1⟩,
    contrapose! hh1,
    choose a ha using λ (i : ι), exists_smul_eq_mk_rep K (ff i) (hff i),
    convert hh1.units_smul a⁻¹,
    ext i,
    simp only [← ha, inv_smul_smul, pi.smul_apply', pi.inv_apply, function.comp_app] },
  { convert dependent.mk _ _ h,
    { ext i, simp only [mk_rep] },
    { exact λ i, rep_nonzero (f i) } }
end

/-- Dependence is the negation of independence. -/
lemma dependent_iff_not_independent : dependent f ↔ ¬ independent f :=
by rw [dependent_iff, independent_iff]

/-- Independence is the negation of dependence. -/
lemma independent_iff_not_dependent : independent f ↔ ¬ dependent f :=
by rw [dependent_iff_not_independent, not_not]

/-- Two points in a projective space are dependent if and only if they are equal. -/
@[simp] lemma dependent_pair_iff_eq (u v : ℙ K V) : dependent ![u, v] ↔ u = v :=
begin
  simp_rw [dependent_iff_not_independent, independent_iff, linear_independent_fin2,
    function.comp_app, matrix.cons_val_one, matrix.head_cons,
    ne.def, matrix.cons_val_zero, not_and, not_forall, not_not,
    ← mk_eq_mk_iff' K _ _ (rep_nonzero u) (rep_nonzero v), mk_rep,
    imp_iff_right_iff],
  exact or.inl (rep_nonzero v),
end

/-- Two points in a projective space are independent if and only if the points are not equal. -/
@[simp] lemma independent_pair_iff_neq (u v : ℙ K V) : independent ![u, v] ↔ u ≠ v :=
by rw [independent_iff_not_dependent, dependent_pair_iff_eq u v]

end projectivization