/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import algebra.ring logic.basic
open set

universe u
variables {α : Type u}

instance division_ring.to_domain [s : division_ring α] : domain α :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := λ a b h,
    classical.by_contradiction $ λ hn,
      division_ring.mul_ne_zero (mt or.inl hn) (mt or.inr hn) h
  ..s }

namespace units
variables [division_ring α] {a b : α}

/-- Embed an element of a division ring into the unit group.
  By combining this function with the operations on units,
  or the `/ₚ` operation, it is possible to write a division
  as a partial function with three arguments. -/
def mk0 (a : α) (ha : a ≠ 0) : units α :=
⟨a, a⁻¹, mul_inv_cancel ha, inv_mul_cancel ha⟩

@[simp] theorem inv_eq_inv (u : units α) : (↑u⁻¹ : α) = u⁻¹ :=
(mul_left_inj u).1 $ by simp

@[simp] theorem mk0_val (ha : a ≠ 0) : (mk0 a ha : α) = a := rfl

@[simp] theorem mk0_inv (ha : a ≠ 0) : ((mk0 a ha)⁻¹ : α) = a⁻¹ := rfl

end units

section division_ring
variables [s : division_ring α] {a b c : α}
include s

lemma div_eq_mul_inv : a / b = a * b⁻¹ := rfl

attribute [simp] div_one zero_div div_self

theorem divp_eq_div (a : α) (u : units α) : a /ₚ u = a / u :=
by simp [divp, (/), algebra.div]

@[simp] theorem divp_mk0 (a : α) {b : α} (hb : b ≠ 0) :
  a /ₚ units.mk0 b hb = a / b :=
divp_eq_div _ _

lemma inv_div (ha : a ≠ 0) (hb : b ≠ 0) : (a / b)⁻¹ = b / a :=
by rw [division_def, mul_inv_eq (inv_ne_zero hb) ha, division_ring.inv_inv hb, division_def]

lemma inv_div_left (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ / b = (b * a)⁻¹ :=
by rw [mul_inv_eq ha hb]; refl

lemma neg_inv (h : a ≠ 0) : - a⁻¹ = (- a)⁻¹ :=
by rwa [inv_eq_one_div, inv_eq_one_div, div_neg_eq_neg_div]

lemma division_ring.inv_comm_of_comm (h : a ≠ 0) (H : a * b = b * a) : a⁻¹ * b = b * a⁻¹ :=
begin
  have : a⁻¹ * (b * a) * a⁻¹ = a⁻¹ * (a * b) * a⁻¹ :=
    congr_arg (λ x:α, a⁻¹ * x * a⁻¹) H.symm,
  rwa [mul_assoc, mul_assoc, mul_inv_cancel, mul_one,
       ← mul_assoc, inv_mul_cancel, one_mul] at this; exact h
end

lemma div_ne_zero (ha : a ≠ 0) (hb : b ≠ 0) : a / b ≠ 0 :=
division_ring.mul_ne_zero ha (inv_ne_zero hb)

lemma div_ne_zero_iff (hb : b ≠ 0) : a / b ≠ 0 ↔ a ≠ 0 :=
⟨mt (λ h, by simp [h]), λ ha, div_ne_zero ha hb⟩

lemma div_eq_zero_iff (hb : b ≠ 0) : a / b = 0 ↔ a = 0 :=
by haveI := classical.prop_decidable; exact
not_iff_not.1 (div_ne_zero_iff hb)

lemma add_div (a b c : α) : (a + b) / c = a / c + b / c :=
(div_add_div_same _ _ _).symm

lemma div_right_inj (hc : c ≠ 0) : a / c = b / c ↔ a = b :=
by rw [← divp_mk0 _ hc, ← divp_mk0 _ hc, divp_right_inj]

lemma sub_div (a b c : α) : (a - b) / c = a / c - b / c :=
(div_sub_div_same _ _ _).symm

lemma division_ring.inv_inj (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ = b⁻¹ ↔ a = b :=
⟨λ h, by simpa [division_ring.inv_inv, ha, hb]
  using congr_arg (λx,x⁻¹) h, congr_arg (λx,x⁻¹)⟩

lemma division_ring.inv_eq_iff (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ = b ↔ b⁻¹ = a :=
by rw [← division_ring.inv_inj (inv_ne_zero ha) hb,
       eq_comm, division_ring.inv_inv ha]

lemma div_neg (a : α) (hb : b ≠ 0) : a / -b = -(a / b) :=
by rw [← division_ring.neg_div_neg_eq _ (neg_ne_zero.2 hb), neg_neg, neg_div]

lemma div_eq_iff_mul_eq (hb : b ≠ 0) : a / b = c ↔ c * b = a :=
⟨λ h, by rw [← h, div_mul_cancel _ hb],
 λ h, by rw [← h, mul_div_cancel _ hb]⟩

end division_ring

instance field.to_integral_domain [F : field α] : integral_domain α :=
{ ..F, ..division_ring.to_domain }

section
variables [field α] {a b c d : α}

lemma div_eq_inv_mul : a / b = b⁻¹ * a := mul_comm _ _

lemma inv_add_inv {a b : α} (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ + b⁻¹ = (a + b) / (a * b) :=
by rw [inv_eq_one_div, inv_eq_one_div, one_div_add_one_div ha hb]

lemma inv_sub_inv {a b : α} (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ - b⁻¹ = (b - a) / (a * b) :=
by rw [inv_eq_one_div, inv_eq_one_div, div_sub_div _ _ ha hb, one_mul, mul_one]

lemma mul_div_right_comm (a b c : α) : (a * b) / c = (a / c) * b :=
(div_mul_eq_mul_div _ _ _).symm

lemma mul_comm_div (a b c : α) : (a / b) * c = a * (c / b) :=
by rw [← mul_div_assoc, mul_div_right_comm]

lemma div_mul_comm (a b c : α) : (a / b) * c = (c / b) * a :=
by rw [div_mul_eq_mul_div, mul_comm, mul_div_right_comm]

lemma mul_div_comm (a b c : α) : a * (b / c) = b * (a / c) :=
by rw [← mul_div_assoc, mul_comm, mul_div_assoc]

lemma field.div_right_comm (a : α) (hb : b ≠ 0) (hc : c ≠ 0) : (a / b) / c = (a / c) / b :=
by rw [field.div_div_eq_div_mul _ hb hc, field.div_div_eq_div_mul _ hc hb, mul_comm]

lemma field.div_div_div_cancel_right (a : α) (hb : b ≠ 0) (hc : c ≠ 0) : (a / c) / (b / c) = a / b :=
by rw [field.div_div_eq_mul_div _ hb hc, div_mul_cancel _ hc]

lemma field.div_mul_div_cancel (a : α) (hb : b ≠ 0) (hc : c ≠ 0) : (a / c) * (c / b) = a / b :=
by rw [← mul_div_assoc, div_mul_cancel _ hc]

lemma div_eq_div_iff (hb : b ≠ 0) (hd : d ≠ 0) : a / b = c / d ↔ a * d = c * b :=
(domain.mul_right_inj (mul_ne_zero' hb hd)).symm.trans $
by rw [← mul_assoc, div_mul_cancel _ hb,
       ← mul_assoc, mul_right_comm, div_mul_cancel _ hd]

lemma field.div_div_cancel (ha : a ≠ 0) (hb : b ≠ 0) : a / (a / b) = b :=
by rw [div_eq_mul_inv, inv_div ha hb, mul_div_cancel' _ ha]

end

section
variables [discrete_field α] {a b c : α}

attribute [simp] inv_zero div_zero

lemma inv_sub_inv_eq (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ - b⁻¹ = (b - a) / (a * b) :=
have a * b ≠ 0, by simp [mul_eq_zero_iff_eq_zero_or_eq_zero, ha, hb],
calc (a⁻¹ - b⁻¹) = ((a⁻¹ - b⁻¹) * (a * b)) / (a * b) : by rwa [mul_div_cancel]
  ... = _ :
  begin
    simp [mul_add, add_mul, hb, mul_assoc, mul_comm, mul_left_comm],
    rw [mul_comm a, mul_assoc, mul_comm a⁻¹, mul_inv_cancel ha],
    simp
  end

-- lemma inv_sub_inv_eq (ha : a ≠ 0) (hb : b ≠ 0) : a⁻¹ - b⁻¹ = (b - a) / (a * b) :=
-- have a * b ≠ 0, by simp [mul_eq_zero_iff_eq_zero_or_eq_zero, ha, hb],
-- calc (a⁻¹ - b⁻¹) = ((a⁻¹ - b⁻¹) * (a * b)) / (a * b) : by rewrite_search

lemma div_right_comm (a b c : α) : (a / b) / c = (a / c) / b :=
if b0 : b = 0 then by simp [b0] else
if c0 : c = 0 then by simp [c0] else
field.div_right_comm _ b0 c0

lemma div_div_div_cancel_right (a b : α) (hc : c ≠ 0) : (a / c) / (b / c) = a / b :=
if b0 : b = 0 then by simp [b0] else
field.div_div_div_cancel_right _ b0 hc

lemma div_mul_div_cancel (a : α) (hb : b ≠ 0) (hc : c ≠ 0) : (a / c) * (c / b) = a / b :=
if b0 : b = 0 then by simp [b0] else
field.div_mul_div_cancel _ b0 hc

lemma div_div_cancel (ha : a ≠ 0) : a / (a / b) = b :=
if b0 : b = 0 then by simp [b0] else
field.div_div_cancel ha b0

end

@[reducible] def is_field_hom {α β} [division_ring α] [division_ring β] (f : α → β) := is_ring_hom f

namespace is_field_hom
open is_ring_hom

section
variables {β : Type*} [division_ring α] [division_ring β]
variables (f : α → β) [is_field_hom f] {x y : α}

lemma map_ne_zero : f x ≠ 0 ↔ x ≠ 0 :=
⟨mt $ λ h, h.symm ▸ map_zero f,
 λ x0 h, one_ne_zero $ calc
    1 = f (x * x⁻¹) : by rw [mul_inv_cancel x0, map_one f]
  ... = 0 : by rw [map_mul f, h, zero_mul]⟩

lemma map_eq_zero : f x = 0 ↔ x = 0 :=
by haveI := classical.dec; exact not_iff_not.1 (map_ne_zero f)

lemma map_inv' (h : x ≠ 0) : f x⁻¹ = (f x)⁻¹ :=
(domain.mul_left_inj ((map_ne_zero f).2 h)).1 $
by rw [mul_inv_cancel ((map_ne_zero f).2 h), ← map_mul f, mul_inv_cancel h, map_one f]

lemma map_div' (h : y ≠ 0) : f (x / y) = f x / f y :=
by simp [division_def, map_mul f, map_inv' f h]

end

section
variables {β : Type*} [discrete_field α] [discrete_field β]
variables (f : α → β) [is_field_hom f] {x y : α}

lemma map_inv : f x⁻¹ = (f x)⁻¹ :=
classical.by_cases (by rintro rfl; simp [map_zero f]) (map_inv' f)

lemma map_div : f (x / y) = f x / f y :=
by simp [division_def, map_mul f, map_inv f]

end

end is_field_hom


import tactic
import data.fintype.basic
import group_theory.subgroup
import group_theory.coset
import group_theory.group_action
import group_theory.order_of_element

open_locale classical
open_locale big_operators
noncomputable theory

section finset

-- goes to data/finset/basic.lean

/-- Two sets are disjoint iff they are disjoint as finsets. -/
lemma disjoint_finset_iff_disjoint {α : Type*} [fintype α] {s t : set α} :
  disjoint s t ↔ disjoint s.to_finset t.to_finset :=
begin
  rw [disjoint, disjoint, le_bot_iff, le_bot_iff],
  change _ ∩ _ = ∅ ↔ _ ∩ _ = ∅,
  rw ←set.to_finset_inter,
  split,
  { intro h, simp_rw h, ext, simp },
  { intro h, ext, rw ←set.mem_to_finset, rw h, simp }
end

lemma Union_to_finset_eq_bind {ι α : Type*} [fintype ι] [fintype α] (f : ι → set α) :
  (⋃ i : ι, f i).to_finset = (finset.univ : finset ι).bind(λ i, (f i).to_finset) := by ext; simp

end finset

section group_action

-- into group_theory/group_action.lean

variables {α β : Type*} [group α] [mul_action α β]

/-- Class equation for a group action. f is an indexed set of representatives
of all the orbits. -/
theorem card_set_eq_sum_card_orbits [fintype β] {ι : Type*} (f : ι → β) [fintype ι]
    (hcover : (⋃ i : ι, (mul_action.orbit α (f i))) = set.univ)
    (hdisjoint : ∀ i j : ι, i ≠ j → disjoint (mul_action.orbit α (f i)) (mul_action.orbit α (f j))) :
  fintype.card β = ∑ i : ι, fintype.card(mul_action.orbit α (f i)) :=
begin
  simp_rw ←set.to_finset_card,
  have hcover' : (finset.univ : finset ι).bind(λ s, (mul_action.orbit α (f s)).to_finset) = finset.univ,
  { rw [←Union_to_finset_eq_bind, ←set.to_finset_univ], simp_rw hcover, congr },
  change finset.univ.card = _,
  rw [←hcover', finset.card_bind],
  exact λ i _ j _ hxyne, disjoint_finset_iff_disjoint.mp (hdisjoint i j hxyne),
end

end group_action

section group

variables {α β : Type*} [group α] [mul_action α β]

def index_subgroup [fintype α] (b : subgroup α) : ℕ :=
  fintype.card(quotient_group.quotient b)

/-- finite version of Lagrange's theorem: the cardinality of a group is
the product of the index of a subgroup times the cardinality of the subgroup.
Follows directly from `group_equiv_quotient_times_subgroup` -/
def card_group_eq_index_subgroup_mul_card_subgroup [fintype α] (b : subgroup α) :
  fintype.card α = index_subgroup b * fintype.card b := card_eq_card_quotient_mul_card_subgroup _

def one_le_card_group [fintype α] :
  1 ≤ fintype.card α := by rw ←finset.card_singleton (1 : α); apply finset.card_le_of_subset; simp

def index_subgroup_eq_div [fintype α] (b : subgroup α) :
  index_subgroup b = fintype.card α / fintype.card b :=
  (nat.div_eq_of_eq_mul_left one_le_card_group (card_group_eq_index_subgroup_mul_card_subgroup b)).symm

def conj_action (α : Type*) [group α] : mul_action α α := {
  smul := λ a b, a * b * a⁻¹,
  one_smul := by simp,
  mul_smul := λ a b c, by group,
}

/-- Equivalence class of g under conjugation. -/
def conj_class (g : α) : set α := {a : α | is_conj g a}

lemma mem_conj_class_iff (g₁ g₂ : α) : g₁ ∈ conj_class g₂ ↔ is_conj g₂ g₁ := by rw conj_class; simp

lemma mem_self_conj_class (g : α) : g ∈ conj_class g := is_conj_refl g

local attribute [instance] conj_action

/-- The conjugation class of an element is the same as the orbit of that
element of the group acting on itself under conjugation.-/
lemma conj_class_eq_orbit_conj_action (g : α) :
  conj_class g = mul_action.orbit α g :=
begin
  ext,
  split;
  { rw [mem_conj_class_iff, mul_action.mem_orbit_iff],
    intros ha,
    rcases ha with ⟨m, hm⟩,
    use m, rw ←hm,
    refl},
end

/-- The centralizer of a set of group elements. -/
def centralizer (s : set α) : subgroup α := {
  carrier := {x : α | ∀ a ∈ s, x * a = a * x},
  one_mem' := by simp,
  mul_mem' := λ x y hx hy a ha, by rw [mul_assoc, hy a ha, ←mul_assoc, hx a ha, mul_assoc],
  inv_mem' := λ x hx a ha, by rw [←mul_right_inj x, ←mul_assoc, mul_inv_self, one_mul, ←mul_assoc, hx a ha, mul_inv_cancel_right],
}

/-- As a shortcut, the centralizer of a single group element. -/
def centralizer_element (s : α) : subgroup α :=
  centralizer {s}

/-- The stabilizer of an element of the group acting on itself under
conjugation is the same as the centralizer of that element. -/
lemma conj_stabilizer_eq_centralizer (g : α) :
  (mul_action.stabilizer α g) = (centralizer_element g) :=
begin
  ext,
  simp only [mul_action.stabilizer, centralizer_element, centralizer, set.mem_singleton_iff, forall_eq],
  change (x * g * x⁻¹ = g) ↔ x * g = g * x,
  split,
  { intro hx, apply mul_right_cancel, rw hx, exact eq_mul_inv_of_mul_eq rfl },
  { intro hx, rw hx, exact mul_inv_eq_of_eq_mul rfl }
end

lemma card_conj_class_eq_index_centralizer [fintype α] (s : α) :
  fintype.card(conj_class s) = index_subgroup(centralizer_element s) :=
begin
  apply fintype.card_congr,
  simp_rw [conj_class_eq_orbit_conj_action, ←conj_stabilizer_eq_centralizer],
  apply mul_action.orbit_equiv_quotient_stabilizer,
end

/-- Class equation for finite groups: f is an index set of representatives of
the non-trivial conjugation classes (the trivial ones are all size one, and
contain each an element of the center of the group). -/
theorem card_eq_card_center_add_sum_card_centralizers' [fintype α] {ι : Type*} [fintype ι] (f : ι → α)
    (hcover : (⋃ s : ι, (conj_class (f s))) = (set.univ \ (subgroup.center α)))
    (hdisjoint : ∀ i j : ι, i ≠ j → disjoint (conj_class (f i)) (conj_class (f j))) :
  fintype.card α = fintype.card(subgroup.center α) + ∑ s : ι, index_subgroup(centralizer_element (f s)) :=
begin
  simp_rw [←card_conj_class_eq_index_centralizer, ←set.to_finset_card],
  change finset.univ.card = fintype.card ↥((subgroup.center α).carrier) + _,
  have hcover' : (finset.univ : finset ι).bind(λ s, (conj_class (f s)).to_finset) = finset.univ \ (subgroup.center α).carrier.to_finset,
  { rw [←Union_to_finset_eq_bind, ←set.to_finset_univ],
    simp_rw hcover, tidy },
  rw [←finset.sdiff_union_of_subset (subgroup.center α).carrier.to_finset.subset_univ,
      finset.card_disjoint_union (finset.sdiff_disjoint), add_comm, ←hcover', finset.card_bind],
  { rw [add_left_inj, set.to_finset_card] },
  exact λ i _ j _ hxyne, disjoint_finset_iff_disjoint.mp (hdisjoint i j hxyne),
end

end group


-- Introducción de la conjunción en Lean
-- =====================================

-- Demostrar que de P y (P → Q) se deduce P ∧ Q.

import tactic

variables (P Q : Prop)

-- 1ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
begin
  split,
  { exact hP },
  { apply hPQ,
    exact hP },
end

-- 2ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
begin
  split,
  { exact hP },
  { exact hPQ hP },
end

-- 3ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
begin
  have hQ : Q := hPQ hP,
  show P ∧ Q, by exact ⟨hP, hQ⟩,
end

-- 4ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
begin
  show P ∧ Q, by exact ⟨hP, hPQ hP⟩,
end

-- 5ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
begin
  exact ⟨hP, hPQ hP⟩,
end

-- 6ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
by exact ⟨hP, hPQ hP⟩

-- 7ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
⟨hP, hPQ hP⟩

-- 8ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
and.intro hP (hPQ hP)

-- 9ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
by tauto

-- 10ª demostración
example
  (hP : P)
  (hPQ : P → Q)
  : P ∧ Q :=
by finish


/-
Copyright (c) 2022 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov
-/
import data.set.intervals.basic

/-!
# Intervals in `with_top α` and `with_bot α`

In this file we prove various lemmas about `set.image`s and `set.preimage`s of intervals under
`coe : α → with_top α` and `coe : α → with_bot α`.
-/

open set

variables {α : Type*}

/-! ### `with_top` -/

namespace with_top

@[simp] lemma preimage_coe_top : (coe : α → with_top α) ⁻¹' {⊤} = (∅ : set α) :=
eq_empty_of_subset_empty $ λ a, coe_ne_top

variables [partial_order α] {a b : α}

lemma range_coe : range (coe : α → with_top α) = Iio ⊤ :=
begin
  ext x,
  rw [mem_Iio, lt_top_iff_ne_top, mem_range, ← none_eq_top, option.ne_none_iff_exists],
  refl,
end

@[simp] lemma preimage_coe_Ioi : (coe : α → with_top α) ⁻¹' (Ioi a) = Ioi a := ext $ λ x, coe_lt_coe
@[simp] lemma preimage_coe_Ici : (coe : α → with_top α) ⁻¹' (Ici a) = Ici a := ext $ λ x, coe_le_coe
@[simp] lemma preimage_coe_Iio : (coe : α → with_top α) ⁻¹' (Iio a) = Iio a := ext $ λ x, coe_lt_coe
@[simp] lemma preimage_coe_Iic : (coe : α → with_top α) ⁻¹' (Iic a) = Iic a := ext $ λ x, coe_le_coe

@[simp] lemma preimage_coe_Icc : (coe : α → with_top α) ⁻¹' (Icc a b) = Icc a b :=
by simp [← Ici_inter_Iic]

@[simp] lemma preimage_coe_Ico : (coe : α → with_top α) ⁻¹' (Ico a b) = Ico a b :=
by simp [← Ici_inter_Iio]

@[simp] lemma preimage_coe_Ioc : (coe : α → with_top α) ⁻¹' (Ioc a b) = Ioc a b :=
by simp [← Ioi_inter_Iic]

@[simp] lemma preimage_coe_Ioo : (coe : α → with_top α) ⁻¹' (Ioo a b) = Ioo a b :=
by simp [← Ioi_inter_Iio]

@[simp] lemma preimage_coe_Iio_top : (coe : α → with_top α) ⁻¹' (Iio ⊤) = univ :=
by rw [← range_coe, preimage_range]

@[simp] lemma preimage_coe_Ico_top : (coe : α → with_top α) ⁻¹' (Ico a ⊤) = Ici a :=
by simp [← Ici_inter_Iio]

@[simp] lemma preimage_coe_Ioo_top : (coe : α → with_top α) ⁻¹' (Ioo a ⊤) = Ioi a :=
by simp [← Ioi_inter_Iio]

lemma image_coe_Ioi : (coe : α → with_top α) '' (Ioi a) = Ioo a ⊤ :=
by rw [← preimage_coe_Ioi, image_preimage_eq_inter_range, range_coe, Ioi_inter_Iio]

lemma image_coe_Ici : (coe : α → with_top α) '' (Ici a) = Ico a ⊤ :=
by rw [← preimage_coe_Ici, image_preimage_eq_inter_range, range_coe, Ici_inter_Iio]

lemma image_coe_Iio : (coe : α → with_top α) '' (Iio a) = Iio a :=
by rw [← preimage_coe_Iio, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (Iio_subset_Iio le_top)]

lemma image_coe_Iic : (coe : α → with_top α) '' (Iic a) = Iic a :=
by rw [← preimage_coe_Iic, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (Iic_subset_Iio.2 $ coe_lt_top a)]

lemma image_coe_Icc : (coe : α → with_top α) '' (Icc a b) = Icc a b :=
by rw [← preimage_coe_Icc, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Icc_subset_Iic_self $ Iic_subset_Iio.2 $ coe_lt_top b)]

lemma image_coe_Ico : (coe : α → with_top α) '' (Ico a b) = Ico a b :=
by rw [← preimage_coe_Ico, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Ico_subset_Iio_self $ Iio_subset_Iio le_top)]

lemma image_coe_Ioc : (coe : α → with_top α) '' (Ioc a b) = Ioc a b :=
by rw [← preimage_coe_Ioc, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Ioc_subset_Iic_self $ Iic_subset_Iio.2 $ coe_lt_top b)]

lemma image_coe_Ioo : (coe : α → with_top α) '' (Ioo a b) = Ioo a b :=
by rw [← preimage_coe_Ioo, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Ioo_subset_Iio_self $ Iio_subset_Iio le_top)]

end with_top

/-! ### `with_bot` -/

namespace with_bot

@[simp] lemma preimage_coe_bot : (coe : α → with_bot α) ⁻¹' {⊥} = (∅ : set α) :=
@with_top.preimage_coe_top αᵒᵈ

variables [partial_order α] {a b : α}

lemma range_coe : range (coe : α → with_bot α) = Ioi ⊥ := @with_top.range_coe αᵒᵈ _

@[simp] lemma preimage_coe_Ioi : (coe : α → with_bot α) ⁻¹' (Ioi a) = Ioi a := ext $ λ x, coe_lt_coe
@[simp] lemma preimage_coe_Ici : (coe : α → with_bot α) ⁻¹' (Ici a) = Ici a := ext $ λ x, coe_le_coe
@[simp] lemma preimage_coe_Iio : (coe : α → with_bot α) ⁻¹' (Iio a) = Iio a := ext $ λ x, coe_lt_coe
@[simp] lemma preimage_coe_Iic : (coe : α → with_bot α) ⁻¹' (Iic a) = Iic a := ext $ λ x, coe_le_coe

@[simp] lemma preimage_coe_Icc : (coe : α → with_bot α) ⁻¹' (Icc a b) = Icc a b :=
by simp [← Ici_inter_Iic]

@[simp] lemma preimage_coe_Ico : (coe : α → with_bot α) ⁻¹' (Ico a b) = Ico a b :=
by simp [← Ici_inter_Iio]

@[simp] lemma preimage_coe_Ioc : (coe : α → with_bot α) ⁻¹' (Ioc a b) = Ioc a b :=
by simp [← Ioi_inter_Iic]

@[simp] lemma preimage_coe_Ioo : (coe : α → with_bot α) ⁻¹' (Ioo a b) = Ioo a b :=
by simp [← Ioi_inter_Iio]

@[simp] lemma preimage_coe_Ioi_bot : (coe : α → with_bot α) ⁻¹' (Ioi ⊥) = univ :=
by rw [← range_coe, preimage_range]

@[simp] lemma preimage_coe_Ioc_bot : (coe : α → with_bot α) ⁻¹' (Ioc ⊥ a) = Iic a :=
by simp [← Ioi_inter_Iic]

@[simp] lemma preimage_coe_Ioo_bot : (coe : α → with_bot α) ⁻¹' (Ioo ⊥ a) = Iio a :=
by simp [← Ioi_inter_Iio]

lemma image_coe_Iio : (coe : α → with_bot α) '' (Iio a) = Ioo ⊥ a :=
by rw [← preimage_coe_Iio, image_preimage_eq_inter_range, range_coe, inter_comm, Ioi_inter_Iio]

lemma image_coe_Iic : (coe : α → with_bot α) '' (Iic a) = Ioc ⊥ a :=
by rw [← preimage_coe_Iic, image_preimage_eq_inter_range, range_coe, inter_comm, Ioi_inter_Iic]

lemma image_coe_Ioi : (coe : α → with_bot α) '' (Ioi a) = Ioi a :=
by rw [← preimage_coe_Ioi, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (Ioi_subset_Ioi bot_le)]

lemma image_coe_Ici : (coe : α → with_bot α) '' (Ici a) = Ici a :=
by rw [← preimage_coe_Ici, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (Ici_subset_Ioi.2 $ bot_lt_coe a)]

lemma image_coe_Icc : (coe : α → with_bot α) '' (Icc a b) = Icc a b :=
by rw [← preimage_coe_Icc, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Icc_subset_Ici_self $ Ici_subset_Ioi.2 $ bot_lt_coe a)]

lemma image_coe_Ioc : (coe : α → with_bot α) '' (Ioc a b) = Ioc a b :=
by rw [← preimage_coe_Ioc, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Ioc_subset_Ioi_self $ Ioi_subset_Ioi bot_le)]

lemma image_coe_Ico : (coe : α → with_bot α) '' (Ico a b) = Ico a b :=
by rw [← preimage_coe_Ico, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Ico_subset_Ici_self $ Ici_subset_Ioi.2 $ bot_lt_coe a)]

lemma image_coe_Ioo : (coe : α → with_bot α) '' (Ioo a b) = Ioo a b :=
by rw [← preimage_coe_Ioo, image_preimage_eq_inter_range, range_coe,
  inter_eq_self_of_subset_left (subset.trans Ioo_subset_Ioi_self $ Ioi_subset_Ioi bot_le)]

end with_bot


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import algebra.big_operators.finprod
import data.set.pointwise
import topology.algebra.mul_action

/-!
# Theory of topological monoids

In this file we define mixin classes `has_continuous_mul` and `has_continuous_add`. While in many
applications the underlying type is a monoid (multiplicative or additive), we do not require this in
the definitions.
-/

universes u v
open classical set filter topological_space
open_locale classical topological_space big_operators pointwise

variables {ι α X M N : Type*} [topological_space X]

@[to_additive]
lemma continuous_one [topological_space M] [has_one M] : continuous (1 : X → M) :=
@continuous_const _ _ _ _ 1

/-- Basic hypothesis to talk about a topological additive monoid or a topological additive
semigroup. A topological additive monoid over `M`, for example, is obtained by requiring both the
instances `add_monoid M` and `has_continuous_add M`. -/
class has_continuous_add (M : Type u) [topological_space M] [has_add M] : Prop :=
(continuous_add : continuous (λ p : M × M, p.1 + p.2))

/-- Basic hypothesis to talk about a topological monoid or a topological semigroup.
A topological monoid over `M`, for example, is obtained by requiring both the instances `monoid M`
and `has_continuous_mul M`. -/
@[to_additive]
class has_continuous_mul (M : Type u) [topological_space M] [has_mul M] : Prop :=
(continuous_mul : continuous (λ p : M × M, p.1 * p.2))

section has_continuous_mul

variables [topological_space M] [has_mul M] [has_continuous_mul M]

@[to_additive]
lemma continuous_mul : continuous (λp:M×M, p.1 * p.2) :=
has_continuous_mul.continuous_mul

@[to_additive]
instance has_continuous_mul.has_continuous_smul :
  has_continuous_smul M M :=
⟨continuous_mul⟩

@[continuity, to_additive]
lemma continuous.mul {f g : X → M} (hf : continuous f) (hg : continuous g) :
  continuous (λx, f x * g x) :=
continuous_mul.comp (hf.prod_mk hg : _)

@[to_additive]
lemma continuous_mul_left (a : M) : continuous (λ b:M, a * b) :=
continuous_const.mul continuous_id

@[to_additive]
lemma continuous_mul_right (a : M) : continuous (λ b:M, b * a) :=
continuous_id.mul continuous_const

@[to_additive]
lemma continuous_on.mul {f g : X → M} {s : set X} (hf : continuous_on f s)
  (hg : continuous_on g s) :
  continuous_on (λx, f x * g x) s :=
(continuous_mul.comp_continuous_on (hf.prod hg) : _)

@[to_additive]
lemma tendsto_mul {a b : M} : tendsto (λp:M×M, p.fst * p.snd) (𝓝 (a, b)) (𝓝 (a * b)) :=
continuous_iff_continuous_at.mp has_continuous_mul.continuous_mul (a, b)

@[to_additive]
lemma filter.tendsto.mul {f g : α → M} {x : filter α} {a b : M}
  (hf : tendsto f x (𝓝 a)) (hg : tendsto g x (𝓝 b)) :
  tendsto (λx, f x * g x) x (𝓝 (a * b)) :=
tendsto_mul.comp (hf.prod_mk_nhds hg)

@[to_additive]
lemma filter.tendsto.const_mul (b : M) {c : M} {f : α → M} {l : filter α}
  (h : tendsto (λ (k:α), f k) l (𝓝 c)) : tendsto (λ (k:α), b * f k) l (𝓝 (b * c)) :=
tendsto_const_nhds.mul h

@[to_additive]
lemma filter.tendsto.mul_const (b : M) {c : M} {f : α → M} {l : filter α}
  (h : tendsto (λ (k:α), f k) l (𝓝 c)) : tendsto (λ (k:α), f k * b) l (𝓝 (c * b)) :=
h.mul tendsto_const_nhds

/-- Construct a unit from limits of units and their inverses. -/
@[to_additive filter.tendsto.add_units "Construct an additive unit from limits of additive units
and their negatives.", simps]
def filter.tendsto.units [topological_space N] [monoid N] [has_continuous_mul N] [t2_space N]
  {f : ι → Nˣ} {r₁ r₂ : N} {l : filter ι} [l.ne_bot]
  (h₁ : tendsto (λ x, ↑(f x)) l (𝓝 r₁)) (h₂ : tendsto (λ x, ↑(f x)⁻¹) l (𝓝 r₂)) : Nˣ :=
{ val := r₁,
  inv := r₂,
  val_inv := tendsto_nhds_unique (by simpa using h₁.mul h₂) tendsto_const_nhds,
  inv_val := tendsto_nhds_unique (by simpa using h₂.mul h₁) tendsto_const_nhds }

@[to_additive]
lemma continuous_at.mul {f g : X → M} {x : X} (hf : continuous_at f x) (hg : continuous_at g x) :
  continuous_at (λx, f x * g x) x :=
hf.mul hg

@[to_additive]
lemma continuous_within_at.mul {f g : X → M} {s : set X} {x : X} (hf : continuous_within_at f s x)
  (hg : continuous_within_at g s x) :
  continuous_within_at (λx, f x * g x) s x :=
hf.mul hg

@[to_additive]
instance [topological_space N] [has_mul N] [has_continuous_mul N] : has_continuous_mul (M × N) :=
⟨((continuous_fst.comp continuous_fst).mul (continuous_fst.comp continuous_snd)).prod_mk
 ((continuous_snd.comp continuous_fst).mul (continuous_snd.comp continuous_snd))⟩

@[to_additive]
instance pi.has_continuous_mul {C : ι → Type*} [∀ i, topological_space (C i)]
  [∀ i, has_mul (C i)] [∀ i, has_continuous_mul (C i)] : has_continuous_mul (Π i, C i) :=
{ continuous_mul := continuous_pi (λ i, continuous.mul
    ((continuous_apply i).comp continuous_fst) ((continuous_apply i).comp continuous_snd)) }

/-- A version of `pi.has_continuous_mul` for non-dependent functions. It is needed because sometimes
Lean fails to use `pi.has_continuous_mul` for non-dependent functions. -/
@[to_additive "A version of `pi.has_continuous_add` for non-dependent functions. It is needed
because sometimes Lean fails to use `pi.has_continuous_add` for non-dependent functions."]
instance pi.has_continuous_mul' : has_continuous_mul (ι → M) :=
pi.has_continuous_mul

@[priority 100, to_additive]
instance has_continuous_mul_of_discrete_topology [topological_space N]
  [has_mul N] [discrete_topology N] : has_continuous_mul N :=
⟨continuous_of_discrete_topology⟩

open_locale filter

open function

@[to_additive]
lemma has_continuous_mul.of_nhds_one {M : Type u} [monoid M] [topological_space M]
  (hmul : tendsto (uncurry ((*) : M → M → M)) (𝓝 1 ×ᶠ 𝓝 1) $ 𝓝 1)
  (hleft : ∀ x₀ : M, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1))
  (hright : ∀ x₀ : M, 𝓝 x₀ = map (λ x, x*x₀) (𝓝 1)) : has_continuous_mul M :=
⟨begin
    rw continuous_iff_continuous_at,
    rintros ⟨x₀, y₀⟩,
    have key : (λ p : M × M, x₀ * p.1 * (p.2 * y₀)) = ((λ x, x₀*x) ∘ (λ x, x*y₀)) ∘ (uncurry (*)),
    { ext p, simp [uncurry, mul_assoc] },
    have key₂ : (λ x, x₀*x) ∘ (λ x, y₀*x) = λ x, (x₀ *y₀)*x,
    { ext x, simp },
    calc map (uncurry (*)) (𝓝 (x₀, y₀))
        = map (uncurry (*)) (𝓝 x₀ ×ᶠ 𝓝 y₀) : by rw nhds_prod_eq
    ... = map (λ (p : M × M), x₀ * p.1 * (p.2 * y₀)) ((𝓝 1) ×ᶠ (𝓝 1))
            : by rw [uncurry, hleft x₀, hright y₀, prod_map_map_eq, filter.map_map]
    ... = map ((λ x, x₀ * x) ∘ λ x, x * y₀) (map (uncurry (*)) (𝓝 1 ×ᶠ 𝓝 1))
            : by { rw [key, ← filter.map_map], }
    ... ≤ map ((λ (x : M), x₀ * x) ∘ λ x, x * y₀) (𝓝 1) : map_mono hmul
    ... = 𝓝 (x₀*y₀) : by rw [← filter.map_map, ← hright, hleft y₀, filter.map_map, key₂, ← hleft]
  end⟩

@[to_additive]
lemma has_continuous_mul_of_comm_of_nhds_one (M : Type u) [comm_monoid M] [topological_space M]
  (hmul : tendsto (uncurry ((*) : M → M → M)) (𝓝 1 ×ᶠ 𝓝 1) (𝓝 1))
  (hleft : ∀ x₀ : M, 𝓝 x₀ = map (λ x, x₀*x) (𝓝 1)) : has_continuous_mul M :=
begin
  apply has_continuous_mul.of_nhds_one hmul hleft,
  intros x₀,
  simp_rw [mul_comm, hleft x₀]
end

end has_continuous_mul

section pointwise_limits

variables (M₁ M₂ : Type*) [topological_space M₂] [t2_space M₂]

@[to_additive] lemma is_closed_set_of_map_one [has_one M₁] [has_one M₂] :
  is_closed {f : M₁ → M₂ | f 1 = 1} :=
is_closed_eq (continuous_apply 1) continuous_const

@[to_additive] lemma is_closed_set_of_map_mul [has_mul M₁] [has_mul M₂] [has_continuous_mul M₂] :
  is_closed {f : M₁ → M₂ | ∀ x y, f (x * y) = f x * f y} :=
begin
  simp only [set_of_forall],
  exact is_closed_Inter (λ x, is_closed_Inter (λ y, is_closed_eq (continuous_apply _)
    ((continuous_apply _).mul (continuous_apply _))))
end

variables {M₁ M₂} [mul_one_class M₁] [mul_one_class M₂] [has_continuous_mul M₂]
  {F : Type*} [monoid_hom_class F M₁ M₂] {l : filter α}

/-- Construct a bundled monoid homomorphism `M₁ →* M₂` from a function `f` and a proof that it
belongs to the closure of the range of the coercion from `M₁ →* M₂` (or another type of bundled
homomorphisms that has a `monoid_hom_class` instance) to `M₁ → M₂`. -/
@[to_additive "Construct a bundled additive monoid homomorphism `M₁ →+ M₂` from a function `f`
and a proof that it belongs to the closure of the range of the coercion from `M₁ →+ M₂` (or another
type of bundled homomorphisms that has a `add_monoid_hom_class` instance) to `M₁ → M₂`.",
  simps { fully_applied := ff }]
def monoid_hom_of_mem_closure_range_coe (f : M₁ → M₂)
  (hf : f ∈ closure (range (λ (f : F) (x : M₁), f x))) : M₁ →* M₂ :=
{ to_fun := f,
  map_one' := (is_closed_set_of_map_one M₁ M₂).closure_subset_iff.2 (range_subset_iff.2 map_one) hf,
  map_mul' := (is_closed_set_of_map_mul M₁ M₂).closure_subset_iff.2
    (range_subset_iff.2 map_mul) hf }

/-- Construct a bundled monoid homomorphism from a pointwise limit of monoid homomorphisms. -/
@[to_additive "Construct a bundled additive monoid homomorphism from a pointwise limit of additive
monoid homomorphisms", simps { fully_applied := ff }]
def monoid_hom_of_tendsto (f : M₁ → M₂) (g : α → F) [l.ne_bot]
  (h : tendsto (λ a x, g a x) l (𝓝 f)) : M₁ →* M₂ :=
monoid_hom_of_mem_closure_range_coe f $ mem_closure_of_tendsto h $
  eventually_of_forall $ λ a, mem_range_self _

variables (M₁ M₂)

@[to_additive] lemma monoid_hom.is_closed_range_coe :
  is_closed (range (coe_fn : (M₁ →* M₂) → (M₁ → M₂))) :=
is_closed_of_closure_subset $ λ f hf, ⟨monoid_hom_of_mem_closure_range_coe f hf, rfl⟩

end pointwise_limits

namespace submonoid

@[to_additive] instance [topological_space α] [monoid α] [has_continuous_mul α] (S : submonoid α) :
  has_continuous_mul S :=
{ continuous_mul :=
  begin
    rw embedding_subtype_coe.to_inducing.continuous_iff,
    exact (continuous_subtype_coe.comp continuous_fst).mul
      (continuous_subtype_coe.comp continuous_snd)
  end }

end submonoid

section has_continuous_mul

variables [topological_space M] [monoid M] [has_continuous_mul M]

@[to_additive]
lemma submonoid.top_closure_mul_self_subset (s : submonoid M) :
  (closure (s : set M)) * closure (s : set M) ⊆ closure (s : set M) :=
calc
(closure (s : set M)) * closure (s : set M)
    = (λ p : M × M, p.1 * p.2) '' (closure ((s : set M) ×ˢ (s : set M))) : by simp [closure_prod_eq]
... ⊆ closure ((λ p : M × M, p.1 * p.2) '' ((s : set M) ×ˢ (s : set M))) :
  image_closure_subset_closure_image continuous_mul
... = closure s : by simp [s.coe_mul_self_eq]

@[to_additive]
lemma submonoid.top_closure_mul_self_eq (s : submonoid M) :
  (closure (s : set M)) * closure (s : set M) = closure (s : set M) :=
subset.antisymm
  s.top_closure_mul_self_subset
  (λ x hx, ⟨x, 1, hx, subset_closure s.one_mem, mul_one _⟩)

/-- The (topological-space) closure of a submonoid of a space `M` with `has_continuous_mul` is
itself a submonoid. -/
@[to_additive "The (topological-space) closure of an additive submonoid of a space `M` with
`has_continuous_add` is itself an additive submonoid."]
def submonoid.topological_closure (s : submonoid M) : submonoid M :=
{ carrier := closure (s : set M),
  one_mem' := subset_closure s.one_mem,
  mul_mem' := λ a b ha hb, s.top_closure_mul_self_subset ⟨a, b, ha, hb, rfl⟩ }

@[to_additive]
instance submonoid.topological_closure_has_continuous_mul (s : submonoid M) :
  has_continuous_mul (s.topological_closure) :=
{ continuous_mul :=
  begin
    apply continuous_induced_rng,
    change continuous (λ p : s.topological_closure × s.topological_closure, (p.1 : M) * (p.2 : M)),
    continuity,
  end }

@[to_additive]
lemma submonoid.submonoid_topological_closure (s : submonoid M) :
  s ≤ s.topological_closure :=
subset_closure

@[to_additive]
lemma submonoid.is_closed_topological_closure (s : submonoid M) :
  is_closed (s.topological_closure : set M) :=
by convert is_closed_closure

@[to_additive]
lemma submonoid.topological_closure_minimal
  (s : submonoid M) {t : submonoid M} (h : s ≤ t) (ht : is_closed (t : set M)) :
  s.topological_closure ≤ t :=
closure_minimal h ht

/-- If a submonoid of a topological monoid is commutative, then so is its topological closure. -/
@[to_additive "If a submonoid of an additive topological monoid is commutative, then so is its
topological closure."]
def submonoid.comm_monoid_topological_closure [t2_space M] (s : submonoid M)
  (hs : ∀ (x y : s), x * y = y * x) : comm_monoid s.topological_closure :=
{ mul_comm :=
  begin
    intros a b,
    have h₁ : (s.topological_closure : set M) = closure s := rfl,
    let f₁ := λ (x : M × M), x.1 * x.2,
    let f₂ := λ (x : M × M), x.2 * x.1,
    let S : set (M × M) := (s : set M) ×ˢ (s : set M),
    have h₃ : set.eq_on f₁ f₂ (closure S),
    { refine set.eq_on.closure _ continuous_mul (by continuity),
      intros x hx,
      rw [set.mem_prod] at hx,
      rcases hx with ⟨hx₁, hx₂⟩,
      change ((⟨x.1, hx₁⟩ : s) : M) * (⟨x.2, hx₂⟩ : s) = (⟨x.2, hx₂⟩ : s) * (⟨x.1, hx₁⟩ : s),
      exact_mod_cast hs _ _ },
    ext,
    change f₁ ⟨a, b⟩ = f₂ ⟨a, b⟩,
    refine h₃ _,
    rw [closure_prod_eq, set.mem_prod],
    exact ⟨by simp [←h₁], by simp [←h₁]⟩
  end,
  ..s.topological_closure.to_monoid }

@[to_additive exists_open_nhds_zero_half]
lemma exists_open_nhds_one_split {s : set M} (hs : s ∈ 𝓝 (1 : M)) :
  ∃ V : set M, is_open V ∧ (1 : M) ∈ V ∧ ∀ (v ∈ V) (w ∈ V), v * w ∈ s :=
have ((λa:M×M, a.1 * a.2) ⁻¹' s) ∈ 𝓝 ((1, 1) : M × M),
  from tendsto_mul (by simpa only [one_mul] using hs),
by simpa only [prod_subset_iff] using exists_nhds_square this

@[to_additive exists_nhds_zero_half]
lemma exists_nhds_one_split {s : set M} (hs : s ∈ 𝓝 (1 : M)) :
  ∃ V ∈ 𝓝 (1 : M), ∀ (v ∈ V) (w ∈ V), v * w ∈ s :=
let ⟨V, Vo, V1, hV⟩ := exists_open_nhds_one_split hs
in ⟨V, is_open.mem_nhds Vo V1, hV⟩

@[to_additive exists_nhds_zero_quarter]
lemma exists_nhds_one_split4 {u : set M} (hu : u ∈ 𝓝 (1 : M)) :
  ∃ V ∈ 𝓝 (1 : M),
    ∀ {v w s t}, v ∈ V → w ∈ V → s ∈ V → t ∈ V → v * w * s * t ∈ u :=
begin
  rcases exists_nhds_one_split hu with ⟨W, W1, h⟩,
  rcases exists_nhds_one_split W1 with ⟨V, V1, h'⟩,
  use [V, V1],
  intros v w s t v_in w_in s_in t_in,
  simpa only [mul_assoc] using h _ (h' v v_in w w_in) _ (h' s s_in t t_in)
end

/-- Given a neighborhood `U` of `1` there is an open neighborhood `V` of `1`
such that `VV ⊆ U`. -/
@[to_additive "Given a open neighborhood `U` of `0` there is a open neighborhood `V` of `0`
  such that `V + V ⊆ U`."]
lemma exists_open_nhds_one_mul_subset {U : set M} (hU : U ∈ 𝓝 (1 : M)) :
  ∃ V : set M, is_open V ∧ (1 : M) ∈ V ∧ V * V ⊆ U :=
begin
  rcases exists_open_nhds_one_split hU with ⟨V, Vo, V1, hV⟩,
  use [V, Vo, V1],
  rintros _ ⟨x, y, hx, hy, rfl⟩,
  exact hV _ hx _ hy
end

@[to_additive]
lemma is_compact.mul {s t : set M} (hs : is_compact s) (ht : is_compact t) : is_compact (s * t) :=
by { rw [← image_mul_prod], exact (hs.prod ht).image continuous_mul }

@[to_additive]
lemma tendsto_list_prod {f : ι → α → M} {x : filter α} {a : ι → M} :
  ∀ l:list ι, (∀i∈l, tendsto (f i) x (𝓝 (a i))) →
    tendsto (λb, (l.map (λc, f c b)).prod) x (𝓝 ((l.map a).prod))
| []       _ := by simp [tendsto_const_nhds]
| (f :: l) h :=
  begin
    simp only [list.map_cons, list.prod_cons],
    exact (h f (list.mem_cons_self _ _)).mul
      (tendsto_list_prod l (assume c hc, h c (list.mem_cons_of_mem _ hc)))
  end

@[to_additive]
lemma continuous_list_prod {f : ι → X → M} (l : list ι)
  (h : ∀i∈l, continuous (f i)) :
  continuous (λa, (l.map (λi, f i a)).prod) :=
continuous_iff_continuous_at.2 $ assume x, tendsto_list_prod l $ assume c hc,
  continuous_iff_continuous_at.1 (h c hc) x

@[continuity, to_additive]
lemma continuous_pow : ∀ n : ℕ, continuous (λ a : M, a ^ n)
| 0 := by simpa using continuous_const
| (k+1) := by { simp only [pow_succ], exact continuous_id.mul (continuous_pow _) }

instance add_monoid.has_continuous_const_smul_nat {A} [add_monoid A] [topological_space A]
  [has_continuous_add A] : has_continuous_const_smul ℕ A := ⟨continuous_nsmul⟩

instance add_monoid.has_continuous_smul_nat {A} [add_monoid A] [topological_space A]
  [has_continuous_add A] : has_continuous_smul ℕ A :=
⟨continuous_uncurry_of_discrete_topology continuous_nsmul⟩

@[continuity, to_additive continuous.nsmul]
lemma continuous.pow {f : X → M} (h : continuous f) (n : ℕ) :
  continuous (λ b, (f b) ^ n) :=
(continuous_pow n).comp h

@[to_additive]
lemma continuous_on_pow {s : set M} (n : ℕ) : continuous_on (λ x, x ^ n) s :=
(continuous_pow n).continuous_on

@[to_additive]
lemma continuous_at_pow (x : M) (n : ℕ) : continuous_at (λ x, x ^ n) x :=
(continuous_pow n).continuous_at

@[to_additive filter.tendsto.nsmul]
lemma filter.tendsto.pow {l : filter α} {f : α → M} {x : M} (hf : tendsto f l (𝓝 x)) (n : ℕ) :
  tendsto (λ x, f x ^ n) l (𝓝 (x ^ n)) :=
(continuous_at_pow _ _).tendsto.comp hf

@[to_additive continuous_within_at.nsmul]
lemma continuous_within_at.pow {f : X → M} {x : X} {s : set X} (hf : continuous_within_at f s x)
  (n : ℕ) : continuous_within_at (λ x, f x ^ n) s x :=
hf.pow n

@[to_additive continuous_at.nsmul]
lemma continuous_at.pow {f : X → M} {x : X} (hf : continuous_at f x) (n : ℕ) :
  continuous_at (λ x, f x ^ n) x :=
hf.pow n

@[to_additive continuous_on.nsmul]
lemma continuous_on.pow {f : X → M} {s : set X} (hf : continuous_on f s) (n : ℕ) :
  continuous_on (λ x, f x ^ n) s :=
λ x hx, (hf x hx).pow n

end has_continuous_mul

namespace mul_opposite

/-- If multiplication is continuous in `α`, then it also is in `αᵐᵒᵖ`. -/
@[to_additive "If addition is continuous in `α`, then it also is in `αᵃᵒᵖ`."]
instance [topological_space α] [has_mul α] [has_continuous_mul α] : has_continuous_mul αᵐᵒᵖ :=
⟨ let h₁ := @continuous_mul α _ _ _ in
  let h₂ : continuous (λ p : α × α, _) := continuous_snd.prod_mk continuous_fst in
  continuous_induced_rng $ (h₁.comp h₂).comp (continuous_unop.prod_map continuous_unop) ⟩

end mul_opposite

namespace units

open mul_opposite

variables [topological_space α] [monoid α] [has_continuous_mul α]

/-- If multiplication on a monoid is continuous, then multiplication on the units of the monoid,
with respect to the induced topology, is continuous.

Inversion is also continuous, but we register this in a later file, `topology.algebra.group`,
because the predicate `has_continuous_inv` has not yet been defined. -/
@[to_additive "If addition on an additive monoid is continuous, then addition on the additive units
of the monoid, with respect to the induced topology, is continuous.

Negation is also continuous, but we register this in a later file, `topology.algebra.group`, because
the predicate `has_continuous_neg` has not yet been defined."]
instance : has_continuous_mul αˣ :=
⟨ let h := @continuous_mul (α × αᵐᵒᵖ) _ _ _ in
  continuous_induced_rng $ h.comp $ continuous_embed_product.prod_map continuous_embed_product ⟩

end units

section

variables [topological_space M] [comm_monoid M]

@[to_additive]
lemma submonoid.mem_nhds_one (S : submonoid M) (oS : is_open (S : set M)) :
  (S : set M) ∈ 𝓝 (1 : M) :=
is_open.mem_nhds oS S.one_mem

variable [has_continuous_mul M]

@[to_additive]
lemma tendsto_multiset_prod {f : ι → α → M} {x : filter α} {a : ι → M} (s : multiset ι) :
  (∀ i ∈ s, tendsto (f i) x (𝓝 (a i))) →
    tendsto (λb, (s.map (λc, f c b)).prod) x (𝓝 ((s.map a).prod)) :=
by { rcases s with ⟨l⟩, simpa using tendsto_list_prod l }

@[to_additive]
lemma tendsto_finset_prod {f : ι → α → M} {x : filter α} {a : ι → M} (s : finset ι) :
  (∀ i ∈ s, tendsto (f i) x (𝓝 (a i))) → tendsto (λb, ∏ c in s, f c b) x (𝓝 (∏ c in s, a c)) :=
tendsto_multiset_prod _

@[continuity, to_additive]
lemma continuous_multiset_prod {f : ι → X → M} (s : multiset ι) :
  (∀i ∈ s, continuous (f i)) → continuous (λ a, (s.map (λ i, f i a)).prod) :=
by { rcases s with ⟨l⟩, simpa using continuous_list_prod l }

@[continuity, to_additive]
lemma continuous_finset_prod {f : ι → X → M} (s : finset ι) :
  (∀ i ∈ s, continuous (f i)) → continuous (λa, ∏ i in s, f i a) :=
continuous_multiset_prod _

open function

@[to_additive]
lemma locally_finite.exists_finset_mul_support {M : Type*} [comm_monoid M] {f : ι → X → M}
  (hf : locally_finite (λ i, mul_support $ f i)) (x₀ : X) :
  ∃ I : finset ι, ∀ᶠ x in 𝓝 x₀, mul_support (λ i, f i x) ⊆ I :=
begin
  rcases hf x₀ with ⟨U, hxU, hUf⟩,
  refine ⟨hUf.to_finset, mem_of_superset hxU $ λ y hy i hi, _⟩,
  rw [hUf.coe_to_finset],
  exact ⟨y, hi, hy⟩
end

@[to_additive] lemma finprod_eventually_eq_prod {M : Type*} [comm_monoid M]
  {f : ι → X → M} (hf : locally_finite (λ i, mul_support (f i))) (x : X) :
  ∃ s : finset ι, ∀ᶠ y in 𝓝 x, (∏ᶠ i, f i y) = ∏ i in s, f i y :=
let ⟨I, hI⟩ := hf.exists_finset_mul_support x in
  ⟨I, hI.mono (λ y hy, finprod_eq_prod_of_mul_support_subset _ $ λ i hi, hy hi)⟩

@[to_additive] lemma continuous_finprod {f : ι → X → M} (hc : ∀ i, continuous (f i))
  (hf : locally_finite (λ i, mul_support (f i))) :
  continuous (λ x, ∏ᶠ i, f i x) :=
begin
  refine continuous_iff_continuous_at.2 (λ x, _),
  rcases finprod_eventually_eq_prod hf x with ⟨s, hs⟩,
  refine continuous_at.congr _ (eventually_eq.symm hs),
  exact tendsto_finset_prod _ (λ i hi, (hc i).continuous_at),
end

@[to_additive] lemma continuous_finprod_cond {f : ι → X → M} {p : ι → Prop}
  (hc : ∀ i, p i → continuous (f i)) (hf : locally_finite (λ i, mul_support (f i))) :
  continuous (λ x, ∏ᶠ i (hi : p i), f i x) :=
begin
  simp only [← finprod_subtype_eq_finprod_cond],
  exact continuous_finprod (λ i, hc i i.2) (hf.comp_injective subtype.coe_injective)
end

end

instance additive.has_continuous_add {M} [h : topological_space M] [has_mul M]
  [has_continuous_mul M] : @has_continuous_add (additive M) h _ :=
{ continuous_add := @continuous_mul M _ _ _ }

instance multiplicative.has_continuous_mul {M} [h : topological_space M] [has_add M]
  [has_continuous_add M] : @has_continuous_mul (multiplicative M) h _ :=
{ continuous_mul := @continuous_add M _ _ _ }

section lattice_ops

variables {ι' : Sort*} [has_mul M] [has_mul N] {ts : set (topological_space M)}
  (h : Π t ∈ ts, @has_continuous_mul M t _) {ts' : ι' → topological_space M}
  (h' : Π i, @has_continuous_mul M (ts' i) _) {t₁ t₂ : topological_space M}
  (h₁ : @has_continuous_mul M t₁ _) (h₂ : @has_continuous_mul M t₂ _)
  {t : topological_space N} [has_continuous_mul N] {F : Type*}
  [mul_hom_class F M N] (f : F)

@[to_additive] lemma has_continuous_mul_Inf :
  @has_continuous_mul M (Inf ts) _ :=
{ continuous_mul := continuous_Inf_rng (λ t ht, continuous_Inf_dom₂ ht ht
  (@has_continuous_mul.continuous_mul M t _ (h t ht))) }

include h'

@[to_additive] lemma has_continuous_mul_infi :
  @has_continuous_mul M (⨅ i, ts' i) _ :=
by {rw ← Inf_range, exact has_continuous_mul_Inf (set.forall_range_iff.mpr h')}

omit h'

include h₁ h₂

@[to_additive] lemma has_continuous_mul_inf :
  @has_continuous_mul M (t₁ ⊓ t₂) _ :=
by {rw inf_eq_infi, refine has_continuous_mul_infi (λ b, _), cases b; assumption}

omit h₁ h₂

@[to_additive] lemma has_continuous_mul_induced :
  @has_continuous_mul M (t.induced f) _ :=
{ continuous_mul :=
    begin
      letI : topological_space M := t.induced f,
      refine continuous_induced_rng _,
      simp_rw [function.comp, map_mul],
      change continuous ((λ p : N × N, p.1 * p.2) ∘ (prod.map f f)),
      exact continuous_mul.comp (continuous_induced_dom.prod_map continuous_induced_dom),
    end }

end lattice_ops


import SciLean.Core
import SciLean.Mechanics
import SciLean.Operators.ODE
import SciLean.Solver.Solver
import SciLean.Data.DataArray
import SciLean.Core.Extra
import SciLean.Functions.Trigonometric

import SciLean.Data.FunRec

-- set_option synthInstance.maxHeartbeats 50000
set_option synthInstance.maxSize 10000

def g : ℝ := 9.81

open SciLean

variable (f : Fin n → ℝ × ℝ)

#check λ [i] => f i

example : IsSmooth λ (θ : ℝ) => (⟨Math.sin θ, Math.cos θ⟩ : ℝ^{2}) := by infer_instance

example : IsSmooth λ (x : ℝ) => (λ [i] => x : ℝ^{2}) := by infer_instance

#check ((λ (x : ℝ) => (λ [i] => x : ℝ^{2}))† rewrite_by (simp; trace_state))

example : IsSmooth λ (θ : ℝ) => ((Math.sin θ) : ℝ) := by infer_instance

def ParticleLagrangian {n} (ϕ : ℝ^{d} → ℝ) (m : ℝ^{n}) (x v : ℝ^{d}^{n}) : ℝ :=
  ∑ i, (0.5:ℝ) * m[i] * ∥v[i]∥² - ∑ i, m[i] * ϕ x[i]

def chainConstraint {n} (l : ℝ^{n}) (x : ℝ^{2}^{n+1}) : Prop := ∀ i : Fin n, ∥x[i.succ] - x[⟨i, sorry_proof⟩]∥ = l[i]
def chainConstraintFun {n} (l : ℝ^{n}) (x : ℝ^{2}^{n+1}) : ℝ^{n} := λ [i] => l[i]*l[i] - ∥x[i.succ] - x[⟨i, sorry_proof⟩]∥²
def chainConstraintLhs {n} (l : ℝ^{n}) (x : ℝ^{2}^{n+1}) := λ i : Fin n => ∥x[i.succ] - x[⟨i, sorry_proof⟩]∥
def chainConstraintRhs {n} (l : ℝ^{n}) (x : ℝ^{2}^{n+1}) := λ i : Fin n => l[i]

instance [PowType Cont (Fin n) Elem] : GetElem Cont ℕ Elem (λ _ idx => idx < n) where
  getElem c i h := c[⟨i,h⟩]

instance [PowType Cont (Fin n × Fin m) Elem] : GetElem Cont (ℕ×ℕ) Elem (λ _ idx => idx.1 < n ∧ idx.2 < m) where
  getElem c i h := c[(⟨i.1,h.1⟩,⟨i.2,h.2⟩)]

-- ...

def endPoints {n n' : Nat} (l r : ℝ^{2}) (x : ℝ^{2}^{n+1}) (x' : ℝ^{2}^{n'+1}) : ℝ^{2} × ℝ^{2} × ℝ^{2} × ℝ^{2} :=
  (-- top chain constraints
   x[0] - l,
   x[⟨n,sorry⟩] - r,
   -- bottow chain constraints
   x'[0] - x[⟨(n+1)/4, sorry⟩],
   x'[⟨n',sorry⟩] - x[⟨3*(n+1)/4, sorry⟩])
argument x
  isSmooth, diff, hasAdjDiff, adjDiff
argument x'
  isSmooth, diff, hasAdjDiff, adjDiff

#check ode_solve

#check ReaderM NewtonSettings X

Approx (X → Y → X × Y) (constrained_ode_solve f g)

-- evolve and project, version 1
Approx ({x : X // g x = 0} → {x : X // g x = 0})
  (λ x =>
    let x' := ode_solve f Δt x.1
    let μ  := solve μ', g (x' + ∂† g x' μ') = 0
    x' + ∂† g x' μ)
=>
Approx (X → X) (constrained_ode_solve f g Δt)

-- evolve and project, version 2
Approx (X → X)
  (λ x =>
    let x' := ode_solve f Δt x
    let μ  := solve μ', g (x + (x' - x) + ∂† g x μ') = 0  -- how can I Taylor this and use the fact that `g x = 0`?
    x' + ∂† g x' μ)
=>
Approx (X → X) (constrained_ode_solve f g Δt)

-- This is exact rewrite under some conditions on `f` and `g`
-- The condition on `g` is probably  `(g x ≠ 0) → let J := ∂ g x; IsInv (J ∘ J†)` this is saying that `J` is surjective map
Approx ({x : X // g x = c} → {x : X // g x = c})
  (λ x =>
    let f' := λ x'' =>
      let μ := solve μ', ∂ g x'' (∂† g x'' μ') = - ∂ g x'' (f x'')
      f x + ∂† g x μ
    let x' := ode_solve f' Δt x
    x')
=>
Approx (X → X) (constrained_ode_solve f g Δt)

-- but I want
-- we can use (f : X → X) => λ x y => (f x, y)
--            (f : X → Y → X × Y) => (λ x => (f x 0).1)
Approx (X → Y → X × Y) (constrained_ode_solve f g Δt)

(settings : IterLinSolverSettings) (A' : Approx (X → Y) (λ x => A x))
=>
Approx ((x₀ : X) → X) (A⁻¹ y)

(x dx : X) → Approx ((x₀ : X) → X) ((∂† f x)⁻¹ dx)

Approx (NewtonSettings → (x₀ : X) → X)
  (solve x, f x = 0)

Approx (X → X)
  (solve x, f x = 0)

-- evolve and reflect  -- inspired by advection reflection sovler
ApproxSolution (ℝ → X×Y → X×Y)
  (λ Δt x₀ μ₀ =>
    let evolve := ode_solve f (Δt/2)
    let x' := evolve x
    let μ  := 2 * solve μ', g (x' + ∂† g x' μ') = 0
    let x'' := evolve (x' + ∂† g x' μ)
    (x'', μ))

-- let u' := ode_solve f t₀ u₀
0 = ∇ u', L u' + ⟪μ, g u'⟫
let    := u' + solve μ, g u'

#exit
def L' (m : ℝ×ℝ) (x v : ℝ^{2}×ℝ^{2}) : ℝ :=
    (m.1/2) * ∥v.1∥² + (m.2/2) * ∥v.2∥² - m.1 * g * x.1[1] - m.2 * g * x.2[1]
argument x
  isSmooth, diff, hasAdjDiff, adjDiff
argument v
  isSmooth, diff, hasAdjDiff, adjDiff

def parm (l : ℝ × ℝ) (θ : ℝ^{2}) : ℝ^{2}×ℝ^{2} :=
  let d₁ : ℝ^{2} := ⟨Math.sin θ[0], Math.cos θ[0]⟩
  let d₂ : ℝ^{2} := ⟨Math.sin θ[1], Math.cos θ[1]⟩
  -- (l.1 * d₁, l.1 * d₁ + l.2 * d₂)
  (d₁, d₂)
argument θ
  isSmooth

def parm' {n} (l : ℝ^{n}) (θ : ℝ^{n}) (x₀ : ℝ^{2}) : (ℝ^{2})^{n+1} := Id.run do
  let mut x : (ℝ^{2})^{n+1} := 0
  let mut y := x₀
  for h : i in [0:n] do
    let i : Fin n := ⟨i, h.2⟩
    let next := i.succ
    let dir : ℝ^{2} := ⟨Math.cos (θ[i]), Math.sin (θ[i])⟩
    y += l[i] * dir
    x[next] := y
  x

-- This impelementation is paying for zero initialization
def parm'' {n} (l : ℝ^{n}) (θ : ℝ^{n}) (x₀ : ℝ^{2}) : (ℝ^{2})^{n+1} := Id.run do
  let mut x : (ℝ^{2})^{n+1} := 0
  let mut y := x₀
  for h : i in [0:n] do
    let i : Fin n := ⟨i, h.2⟩
    let next := i.succ
    let dir : ℝ^{2} := ⟨Math.cos (θ[i]), Math.sin (θ[i])⟩
    y := y + l[i] * dir
    x[next] := y
  x

-- There is no way the index access `θ[⟨n',sorry⟩]` and `l[⟨n', sorry⟩]` can be proven correct
-- Can be fixed by changing the definition of `funRec`
def parm''' {n} (l : ℝ^{n}) (θ : ℝ^{n}) (x₀ : ℝ^{2}) : (ℝ^{2})^{n+1} := funRec (n+1) 0 step (reserveElem (n+1) 0)
  where
    step : (n' : Nat) → ((ℝ^{2})^{n'}) → (ℝ^{2})^{n'+1}
    | 0, x => (λ [i] => x₀)
    | n'+1, x =>
      let dir : ℝ^{2} := ⟨Math.cos (θ[⟨n',sorry_proof⟩]), Math.sin (θ[⟨n',sorry_proof⟩])⟩
      let y := x[⟨n', by simp⟩] + l[⟨n', sorry_proof⟩] * dir
      pushElem 1 y x

example (x₀ : ℝ^{2}) (n' : Nat) : IsSmooth λ (x : (ℝ^{2})^{n'}) => pushElem (Cont:=(ℝ^{2}^{·})) 1 x₀ x := by infer_instance
example (x : (ℝ^{2})^{n'}) (n' : Nat) : IsSmooth λ (x₀ : ℝ^{2}) => pushElem (Cont:=(ℝ^{2}^{·})) 1 x₀ x := by infer_instance

instance {α : Nat → Type} [Vec X] [∀ n, Vec (α n)]
  (f : X → (n : Nat) → α n → α (n + 1)) [∀ n, IsSmooth (λ x => f x n)] [∀ x n, IsSmooth (f x n)] (n : Nat)
  : IsSmooth (λ x => funRec n m (f x)) := sorry_proof

@[simp ↓]
theorem funRec.arg_x.diff_simp {α : Nat → Type} [Vec X] [∀ n, Vec (α n)]
  (f : (n : Nat) → α n → α (n + 1)) [∀ n, IsSmooth (f n)] (n m : Nat)
  : ∂ (λ x => funRec n m f x)
    =
    λ x dx => (funRec (α:=λ n' => α n' × α n') n m (λ n' (x',dx') => (f n' x', ∂ (f n') x' dx')) (x,dx)).2 := sorry_proof

@[simp ↓]
theorem funRec.arg_f.diff_simp {α : Nat → Type} [Vec X] [∀ n, Vec (α n)]
  (f : X → (n : Nat) → α n → α (n + 1)) [∀ n, IsSmooth (λ x => f x n)] [∀ x n, IsSmooth (f x n)] (n : Nat)
  : ∂ (λ x => funRec n m (f x))
    =
    λ x dx y => (∂ (funRec (α:=λ n' => X × α n') n m (λ n' xy' => (xy'.1, f xy'.1 n' xy'.2))) (x,y) (dx,0)).2 := sorry_proof

set_option trace.Meta.Tactic.simp.discharge true in
set_option trace.Meta.Tactic.simp.unify true in
def parm'''' {n} (l : ℝ^{n}) (θ : ℝ^{n}) (x₀ : ℝ) : ℝ^{n+1} :=
  let step (n' : Nat) (x : ℝ^{n'}) : ℝ^{n'+1} := pushElem (Cont:=(ℝ^{·})) 1 (θ[⟨n',sorry⟩]) x
  funRec (n+1) 0 step 0
argument θ
  -- isSmooth := by simp[parm'''']; infer_instance,
  diff by
    simp[parm'''']
    enter [θ,x,a]
    simp only [funRec.arg_x.diff_simp (α:= λ n' => ℝ^{n} × ℝ^{n'})]
    simp --  (λ n' y => (y.1, pushElem 1 (y.1[⟨n',sorry⟩]) (y.snd))) (n+1) 0]

def parm'''' {n} (l : ℝ^{n}) (θ : ℝ^{n}) (x₀ : ℝ^{2}) : (ℝ^{2})^{n+1} := step 1 n (λ [i] => x₀)
  where
    step : (n m : Nat) → ((ℝ^{2})^{n+1-m}) → (ℝ^{2})^{n+1}
    | n, 0, x => x
    | n, m+1, x => pushElem 1 sorry (step n m x)
    -- | n'+1, x =>
    --   let dir : ℝ^{2} := ⟨Math.cos (θ[⟨n',sorry_proof⟩]), Math.sin (θ[⟨n',sorry_proof⟩])⟩
    --   let y := x[⟨n', by simp⟩] + l[⟨n', sorry_proof⟩] * dir
    --   pushElem 1 y x

def L (m l : ℝ×ℝ) (θ ω : ℝ^{2}) :=
  (L' m (parm l θ) (ⅆ (t:=0), parm l (θ + (t:ℝ) * ω)))
    rewrite_by
      simp

def solver (m l : ℝ×ℝ) (steps : Nat) : Impl (ode_solve (LagrangianSystem (L m l))) :=
by
  simp [L, pure_impl, PureImpl]
  conv in (L _ _) =>
    simp [L, L', parm]
    pattern (differential _); rmlamlet; enter [θ, ω]; simp  -- autodiff

  simp -- Lagrangian is in a nice form now

  conv =>
    pattern (LagrangianSystem _); whnf

  admit

def solver_0 (m k l : ℝ) (steps : Nat) : Impl (λ x v : Q => (L m k l) x v) :=
by
  simp [LagrangianSystem, L, L', parm, gradient]

  conv =>
    pattern (differential _); rmlamlet; enter [x, dx]; simp -- autodiff

  simp

  finish_impl

def solver_1 (m k l : ℝ) (steps : Nat) : Impl (λ x v : Q => ∇(swap (L m k l) v) x) :=
by
  conv in (L _ _ _) =>
    enter [θ, ω]
    simp [L, L', parm]
    rmlamlet
    simp

  simp [gradient]

  conv =>
    pattern (differential _); rmlamlet; enter [x, dx]; simp -- autodiff

  conv in (dual _) =>
    pattern (dual _); rmlamlet; simp  -- autodual

  .

  finish_impl

def solver_2 (m k l : ℝ) (steps : Nat) : Impl (λ x v : Q => ∇(∂ (L m k l) x v) v) :=
by

  conv in (L _ _ _) =>
    enter [θ, ω]
    simp [L, L', parm]
    rmlamlet
    simp

  conv =>
    pattern (differential _); enter [x, dx, y]; rmlamlet; simp -- autodiff (we need to introduce all arguments!)

  conv =>                                                     -- autograd - part1
    pattern (gradient _)
    enter [x]
    simp [gradient]
    pattern (differential _); enter [x, dx]; rmlamlet; simp   -- autodiff

  conv =>
    pattern (dual _); rmlamlet; simp                         -- autograd - part2

  .

  finish_impl

def solver_3 (m k l : ℝ) (steps : Nat) : Impl (λ x v : Q => ∂(∇((L m k l) x)) v) :=
by

  conv in (L _ _ _) =>
    simp [L, L', parm]
    { pattern (differential _); rmlamlet; enter [θ, ω]; simp }  -- autodiff

  simp -- Lagrangian is in a nice form now

  conv =>                                                     -- autograd - part1
    pattern (gradient _)
    enter [x]
    simp [gradient]
    pattern (differential _); enter [x, dx]; rmlamlet; simp   -- autodiff

  conv =>
    pattern (dual _); rmlamlet; simp                         -- autograd - part2

  conv =>
    pattern (differential _); enter [x, dx]; rmlamlet; simp -- autodiff

  conv =>
    enter [1,x,v]
    rmlamlet

  finish_impl


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors : Anne Baanen
-/

import algebra.algebra.basic
import ring_theory.subring

/-!
# Subfields

Let `K` be a field. This file defines the "bundled" subfield type `subfield K`, a type
whose terms correspond to subfields of `K`. This is the preferred way to talk
about subfields in mathlib. Unbundled subfields (`s : set K` and `is_subfield s`)
are not in this file, and they will ultimately be deprecated.

We prove that subfields are a complete lattice, and that you can `map` (pushforward) and
`comap` (pull back) them along ring homomorphisms.

We define the `closure` construction from `set R` to `subfield R`, sending a subset of `R`
to the subfield it generates, and prove that it is a Galois insertion.

## Main definitions

Notation used here:

`(K : Type u) [field K] (L : Type u) [field L] (f g : K →+* L)`
`(A : subfield K) (B : subfield L) (s : set K)`

* `subfield R` : the type of subfields of a ring `R`.

* `instance : complete_lattice (subfield R)` : the complete lattice structure on the subfields.

* `subfield.closure` : subfield closure of a set, i.e., the smallest subfield that includes the set.

* `subfield.gi` : `closure : set M → subfield M` and coercion `coe : subfield M → set M`
  form a `galois_insertion`.

* `comap f B : subfield K` : the preimage of a subfield `B` along the ring homomorphism `f`

* `map f A : subfield L` : the image of a subfield `A` along the ring homomorphism `f`.

* `prod A B : subfield (K × L)` : the product of subfields

* `f.field_range : subfield B` : the range of the ring homomorphism `f`.

* `eq_locus_field f g : subfield K` : given ring homomorphisms `f g : K →+* R`,
     the subfield of `K` where `f x = g x`

## Implementation notes

A subfield is implemented as a subring which is is closed under `⁻¹`.

Lattice inclusion (e.g. `≤` and `⊓`) is used rather than set notation (`⊆` and `∩`), although
`∈` is defined as membership of a subfield's underlying set.

## Tags
subfield, subfields
-/

open_locale big_operators
universes u v w

variables {K : Type u} {L : Type v} {M : Type w} [field K] [field L] [field M]

set_option old_structure_cmd true

/-- `subfield R` is the type of subfields of `R`. A subfield of `R` is a subset `s` that is a
  multiplicative submonoid and an additive subgroup. Note in particular that it shares the
  same 0 and 1 as R. -/
structure subfield (K : Type u) [field K] extends subring K :=
(inv_mem' : ∀ x ∈ carrier, x⁻¹ ∈ carrier)

/-- Reinterpret a `subfield` as a `subring`. -/
add_decl_doc subfield.to_subring

namespace subfield

/-- The underlying `add_subgroup` of a subfield. -/
def to_add_subgroup (s : subfield K) : add_subgroup K :=
{ ..s.to_subring.to_add_subgroup }

/-- The underlying submonoid of a subfield. -/
def to_submonoid (s : subfield K) : submonoid K :=
{ ..s.to_subring.to_submonoid }

instance : has_coe (subfield K) (set K) := ⟨subfield.carrier⟩

@[simp] lemma coe_to_subring (s : subfield K) : (s.to_subring : set K) = s :=
rfl

instance : has_coe_to_sort (subfield K) := ⟨Type*, λ S, S.carrier⟩

instance : has_mem K (subfield K) := ⟨λ m S, m ∈ (S : set K)⟩

@[simp] lemma mem_mk (s : set K) (ho hm hz ha hn hi) (x : K) :
  x ∈ subfield.mk s ho hm hz ha hn hi ↔ x ∈ s := iff.rfl

@[simp] lemma mem_to_subring (s : subfield K) (x : K) :
  x ∈ s.to_subring ↔ x ∈ s := iff.rfl

end subfield

protected lemma subfield.exists {s : subfield K} {p : s → Prop} :
  (∃ x : s, p x) ↔ ∃ x ∈ s, p ⟨x, ‹x ∈ s›⟩ :=
set_coe.exists

protected lemma subfield.forall {s : subfield K} {p : s → Prop} :
  (∀ x : s, p x) ↔ ∀ x ∈ s, p ⟨x, ‹x ∈ s›⟩ :=
set_coe.forall

/-- A `subring` containing inverses is a `subfield`. -/
def subring.to_subfield (s : subring K) (hinv : ∀ x ∈ s, x⁻¹ ∈ s) : subfield K :=
{ inv_mem' := hinv
  ..s }

namespace subfield

variables (s t : subfield K)

/-- Two subfields are equal if the underlying subsets are equal. -/
theorem ext' ⦃s t : subfield K⦄ (h : (s : set K) = t) : s = t :=
by { cases s, cases t, congr' }

/-- Two subfields are equal if and only if the underlying subsets are equal. -/
protected theorem ext'_iff {s t : subfield K}  : s = t ↔ (s : set K) = t :=
⟨λ h, h ▸ rfl, λ h, ext' h⟩

/-- Two subfields are equal if they have the same elements. -/
@[ext] theorem ext {S T : subfield K} (h : ∀ x, x ∈ S ↔ x ∈ T) : S = T := ext' $ set.ext h

/-- A subfield contains the ring's 1. -/
theorem one_mem : (1 : K) ∈ s := s.one_mem'

/-- A subfield contains the ring's 0. -/
theorem zero_mem : (0 : K) ∈ s := s.zero_mem'

/-- A subfield is closed under multiplication. -/
theorem mul_mem : ∀ {x y : K}, x ∈ s → y ∈ s → x * y ∈ s := s.mul_mem'

/-- A subfield is closed under addition. -/
theorem add_mem : ∀ {x y : K}, x ∈ s → y ∈ s → x + y ∈ s := s.add_mem'

/-- A subfield is closed under negation. -/
theorem neg_mem : ∀ {x : K}, x ∈ s → -x ∈ s := s.neg_mem'

/-- A subfield is closed under subtraction. -/
theorem sub_mem {x y : K} : x ∈ s → y ∈ s → x - y ∈ s := s.to_subring.sub_mem

/-- A subfield is closed under inverses. -/
theorem inv_mem : ∀ {x : K}, x ∈ s → x⁻¹ ∈ s := s.inv_mem'

/-- A subfield is closed under division. -/
theorem div_mem {x y : K} (hx : x ∈ s) (hy : y ∈ s) : x / y ∈ s :=
by { rw div_eq_mul_inv, exact s.mul_mem hx (s.inv_mem hy) }

/-- Product of a list of elements in a subfield is in the subfield. -/
lemma list_prod_mem {l : list K} : (∀ x ∈ l, x ∈ s) → l.prod ∈ s :=
s.to_submonoid.list_prod_mem

/-- Sum of a list of elements in a subfield is in the subfield. -/
lemma list_sum_mem {l : list K} : (∀ x ∈ l, x ∈ s) → l.sum ∈ s :=
s.to_add_subgroup.list_sum_mem

/-- Product of a multiset of elements in a subfield is in the subfield. -/
lemma multiset_prod_mem (m : multiset K) :
  (∀ a ∈ m, a ∈ s) → m.prod ∈ s :=
s.to_submonoid.multiset_prod_mem m

/-- Sum of a multiset of elements in a `subfield` is in the `subfield`. -/
lemma multiset_sum_mem (m : multiset K) :
  (∀ a ∈ m, a ∈ s) → m.sum ∈ s :=
s.to_add_subgroup.multiset_sum_mem m

/-- Product of elements of a subfield indexed by a `finset` is in the subfield. -/
lemma prod_mem {ι : Type*} {t : finset ι} {f : ι → K} (h : ∀ c ∈ t, f c ∈ s) :
  ∏ i in t, f i ∈ s :=
s.to_submonoid.prod_mem h

/-- Sum of elements in a `subfield` indexed by a `finset` is in the `subfield`. -/
lemma sum_mem {ι : Type*} {t : finset ι} {f : ι → K} (h : ∀ c ∈ t, f c ∈ s) :
  ∑ i in t, f i ∈ s :=
s.to_add_subgroup.sum_mem h

lemma pow_mem {x : K} (hx : x ∈ s) (n : ℕ) : x^n ∈ s := s.to_submonoid.pow_mem hx n

lemma gsmul_mem {x : K} (hx : x ∈ s) (n : ℤ) :
  n •ℤ x ∈ s := s.to_add_subgroup.gsmul_mem hx n

lemma coe_int_mem (n : ℤ) : (n : K) ∈ s :=
by simp only [← gsmul_one, gsmul_mem, one_mem]

/-- A subfield inherits a field structure -/
instance to_field : field s :=
{ inv := λ x, ⟨x⁻¹, s.inv_mem x.2⟩,
  inv_zero := subtype.ext inv_zero,
  mul_inv_cancel := λ x hx, subtype.ext (mul_inv_cancel (mt s.to_subring.coe_eq_zero_iff.mp hx)),
  exists_pair_ne := ⟨⟨0, s.zero_mem⟩, ⟨1, s.one_mem⟩, mt subtype.mk_eq_mk.mp zero_ne_one⟩,
  ..subring.subring.domain s.to_subring }

@[simp, norm_cast] lemma coe_add (x y : s) : (↑(x + y) : K) = ↑x + ↑y := rfl
@[simp, norm_cast] lemma coe_neg (x : s) : (↑(-x) : K) = -↑x := rfl
@[simp, norm_cast] lemma coe_mul (x y : s) : (↑(x * y) : K) = ↑x * ↑y := rfl
@[simp, norm_cast] lemma coe_inv (x : s) : (↑(x⁻¹) : K) = (↑x)⁻¹ := rfl
@[simp, norm_cast] lemma coe_zero : ((0 : s) : K) = 0 := rfl
@[simp, norm_cast] lemma coe_one : ((1 : s) : K) = 1 := rfl

/-- The embedding from a subfield of the field `K` to `K`. -/
def subtype (s : subfield K) : s →+* K :=
{ to_fun := coe,
 .. s.to_submonoid.subtype, .. s.to_add_subgroup.subtype }

instance to_algebra : algebra s K := ring_hom.to_algebra s.subtype

@[simp] theorem coe_subtype : ⇑s.subtype = coe := rfl

instance : algebra s K := s.subtype.to_algebra

/-! # Partial order -/

instance : partial_order (subfield K) :=
{ le := λ s t, ∀ ⦃x⦄, x ∈ s → x ∈ t,
  .. partial_order.lift (coe : subfield K → set K) ext' }

variables {s t}

lemma le_def : s ≤ t ↔ ∀ ⦃x : K⦄, x ∈ s → x ∈ t := iff.rfl

@[simp, norm_cast] lemma coe_subset_coe : (s : set K) ⊆ t ↔ s ≤ t := iff.rfl

@[simp, norm_cast] lemma coe_ssubset_coe : (s : set K) ⊂ t ↔ s < t := iff.rfl

@[simp, norm_cast]
lemma mem_coe {m : K} : m ∈ (s : set K) ↔ m ∈ s := iff.rfl

variables (s t)

@[simp, norm_cast]
lemma coe_coe (s : subfield K) : ↥(s : set K) = s := rfl

@[simp] lemma mem_to_submonoid {s : subfield K} {x : K} : x ∈ s.to_submonoid ↔ x ∈ s := iff.rfl
@[simp] lemma coe_to_submonoid : (s.to_submonoid : set K) = s := rfl
@[simp] lemma mem_to_add_subgroup {s : subfield K} {x : K} :
  x ∈ s.to_add_subgroup ↔ x ∈ s := iff.rfl
@[simp] lemma coe_to_add_subgroup : (s.to_add_subgroup : set K) = s := rfl

/-! # top -/

/-- The subfield of `K` containing all elements of `K`. -/
instance : has_top (subfield K) :=
⟨{ inv_mem' := λ x _, subring.mem_top x, .. (⊤ : subring K)}⟩

instance : inhabited (subfield K) := ⟨⊤⟩

@[simp] lemma mem_top (x : K) : x ∈ (⊤ : subfield K) := set.mem_univ x

@[simp] lemma coe_top : ((⊤ : subfield K) : set K) = set.univ := rfl

/-! # comap -/

variables (f : K →+* L)

/-- The preimage of a subfield along a ring homomorphism is a subfield. -/
def comap (s : subfield L) : subfield K :=
{ inv_mem' := λ x hx, show f (x⁻¹) ∈ s, by { rw f.map_inv, exact s.inv_mem hx },
  .. s.to_subring.comap f }

@[simp] lemma coe_comap (s : subfield L) : (s.comap f : set K) = f ⁻¹' s := rfl

@[simp]
lemma mem_comap {s : subfield L} {f : K →+* L} {x : K} : x ∈ s.comap f ↔ f x ∈ s := iff.rfl

lemma comap_comap (s : subfield M) (g : L →+* M) (f : K →+* L) :
  (s.comap g).comap f = s.comap (g.comp f) :=
rfl

/-! # map -/

/-- The image of a subfield along a ring homomorphism is a subfield. -/
def map (s : subfield K) : subfield L :=
{ inv_mem' := by { rintros _ ⟨x, hx, rfl⟩, exact ⟨x⁻¹, s.inv_mem hx, f.map_inv x⟩ },
  .. s.to_subring.map f }

@[simp] lemma coe_map : (s.map f : set L) = f '' s := rfl

@[simp] lemma mem_map {f : K →+* L} {s : subfield K} {y : L} :
  y ∈ s.map f ↔ ∃ x ∈ s, f x = y :=
set.mem_image_iff_bex

lemma map_map (g : L →+* M) (f : K →+* L) : (s.map f).map g = s.map (g.comp f) :=
ext' $ set.image_image _ _ _

lemma map_le_iff_le_comap {f : K →+* L} {s : subfield K} {t : subfield L} :
  s.map f ≤ t ↔ s ≤ t.comap f :=
set.image_subset_iff

lemma gc_map_comap (f : K →+* L) : galois_connection (map f) (comap f) :=
λ S T, map_le_iff_le_comap

end subfield

namespace ring_hom

variables (g : L →+* M) (f : K →+* L)

/-! # range -/

/-- The range of a ring homomorphism, as a subfield of the target. -/
def field_range : subfield L := (⊤ : subfield K).map f

@[simp] lemma coe_field_range : (f.field_range : set L) = set.range f := set.image_univ

@[simp] lemma mem_field_range {f : K →+* L} {y : L} : y ∈ f.range ↔ ∃ x, f x = y :=
by simp [range]

lemma map_field_range : f.field_range.map g = (g.comp f).field_range :=
(⊤ : subfield K).map_map g f

end ring_hom

namespace subfield

/-! # inf -/

/-- The inf of two subfields is their intersection. -/
instance : has_inf (subfield K) :=
⟨λ s t,
  { inv_mem' := λ x hx, subring.mem_inf.mpr
      ⟨s.inv_mem (subring.mem_inf.mp hx).1,
       t.inv_mem (subring.mem_inf.mp hx).2⟩,
    .. s.to_subring ⊓ t.to_subring }⟩

@[simp] lemma coe_inf (p p' : subfield K) : ((p ⊓ p' : subfield K) : set K) = p ∩ p' := rfl

@[simp] lemma mem_inf {p p' : subfield K} {x : K} : x ∈ p ⊓ p' ↔ x ∈ p ∧ x ∈ p' := iff.rfl

instance : has_Inf (subfield K) :=
⟨λ S,
  { inv_mem' := begin
      rintros x hx,
      apply subring.mem_Inf.mpr,
      rintro _ ⟨p, p_mem, rfl⟩,
      exact p.inv_mem (subring.mem_Inf.mp hx p.to_subring ⟨p, p_mem, rfl⟩),
    end,
    .. Inf (subfield.to_subring '' S) }⟩

@[simp, norm_cast] lemma coe_Inf (S : set (subfield K)) :
  ((Inf S : subfield K) : set K) = ⋂ s ∈ S, ↑s :=
show ((Inf (subfield.to_subring '' S) : subring K) : set K) = ⋂ s ∈ S, ↑s,
begin
  ext x,
  rw [subring.coe_Inf, set.mem_Inter, set.mem_Inter],
  exact ⟨λ h s s' ⟨s_mem, s'_eq⟩, h s.to_subring _ ⟨⟨s, s_mem, rfl⟩, s'_eq⟩,
         λ h s s' ⟨⟨s'', s''_mem, s_eq⟩, (s'_eq : ↑s = s')⟩,
           h s'' _ ⟨s''_mem, by simp [←s_eq, ← s'_eq]⟩⟩
end

lemma mem_Inf {S : set (subfield K)} {x : K} : x ∈ Inf S ↔ ∀ p ∈ S, x ∈ p :=
subring.mem_Inf.trans
  ⟨λ h p hp, h p.to_subring ⟨p, hp, rfl⟩,
   λ h p ⟨p', hp', p_eq⟩, p_eq ▸ h p' hp'⟩

@[simp] lemma Inf_to_subring (s : set (subfield K)) :
  (Inf s).to_subring = ⨅ t ∈ s, subfield.to_subring t :=
begin
  ext x,
  rw [mem_to_subring, mem_Inf],
  erw subring.mem_Inf,
  exact ⟨λ h p ⟨p', hp⟩, hp ▸ subring.mem_Inf.mpr (λ p ⟨hp', hp⟩, hp ▸ h _ hp'),
         λ h p hp, h p.to_subring ⟨p, subring.ext (λ x,
           ⟨λ hx, subring.mem_Inf.mp hx _ ⟨hp, rfl⟩,
            λ hx, subring.mem_Inf.mpr (λ p' ⟨hp, p'_eq⟩, p'_eq ▸ hx)⟩)⟩⟩
end

lemma is_glb_Inf (S : set (subfield K)) : is_glb S (Inf S) :=
begin
  refine is_glb.of_image (λ s t, show (s : set K) ≤ t ↔ s ≤ t, from coe_subset_coe) _,
  convert is_glb_binfi,
  exact coe_Inf _
end

/-- Subfields of a ring form a complete lattice. -/
instance : complete_lattice (subfield K) :=
{ top := ⊤,
  le_top := λ s x hx, trivial,
  inf := (⊓),
  inf_le_left := λ s t x, and.left,
  inf_le_right := λ s t x, and.right,
  le_inf := λ s t₁ t₂ h₁ h₂ x hx, ⟨h₁ hx, h₂ hx⟩,
  .. complete_lattice_of_Inf (subfield K) is_glb_Inf }

/-! # subfield closure of a subset -/

/-- The `subfield` generated by a set. -/
def closure (s : set K) : subfield K :=
{ carrier := { (x / y) | (x ∈ subring.closure s) (y ∈ subring.closure s) },
  zero_mem' := ⟨0, subring.zero_mem _, 1, subring.one_mem _, div_one _⟩,
  one_mem' := ⟨1, subring.one_mem _, 1, subring.one_mem _, div_one _⟩,
  neg_mem' := λ x ⟨y, hy, z, hz, x_eq⟩, ⟨-y, subring.neg_mem _ hy, z, hz, x_eq ▸ neg_div _ _⟩,
  inv_mem' := λ x ⟨y, hy, z, hz, x_eq⟩, ⟨z, hz, y, hy, x_eq ▸ inv_div.symm⟩,
  add_mem' := λ x y x_mem y_mem, begin
    obtain ⟨nx, hnx, dx, hdx, rfl⟩ := id x_mem,
    obtain ⟨ny, hny, dy, hdy, rfl⟩ := id y_mem,
    by_cases hx0 : dx = 0, { rwa [hx0, div_zero, zero_add] },
    by_cases hy0 : dy = 0, { rwa [hy0, div_zero, add_zero] },
    exact ⟨nx * dy + dx * ny,
          subring.add_mem _ (subring.mul_mem _ hnx hdy) (subring.mul_mem _ hdx hny),
          dx * dy, subring.mul_mem _ hdx hdy,
          (div_add_div nx ny hx0 hy0).symm⟩
  end,
  mul_mem' := λ x y x_mem y_mem, begin
    obtain ⟨nx, hnx, dx, hdx, rfl⟩ := id x_mem,
    obtain ⟨ny, hny, dy, hdy, rfl⟩ := id y_mem,
    exact ⟨nx * ny, subring.mul_mem _ hnx hny,
           dx * dy, subring.mul_mem _ hdx hdy,
           (div_mul_div _ _ _ _).symm⟩
  end }

lemma mem_closure_iff {s : set K} {x} :
  x ∈ closure s ↔ ∃ (y ∈ subring.closure s) (z ∈ subring.closure s), y / z = x := iff.rfl

lemma subring_closure_le (s : set K) : subring.closure s ≤ (closure s).to_subring :=
λ x hx, ⟨x, hx, 1, subring.one_mem _, div_one x⟩

/-- The subfield generated by a set includes the set. -/
@[simp] lemma subset_closure {s : set K} : s ⊆ closure s :=
set.subset.trans subring.subset_closure (subring_closure_le s)

lemma mem_closure {x : K} {s : set K} : x ∈ closure s ↔ ∀ S : subfield K, s ⊆ S → x ∈ S :=
⟨λ ⟨y, hy, z, hz, x_eq⟩ t le, x_eq ▸
  t.div_mem
    (subring.mem_closure.mp hy t.to_subring le)
    (subring.mem_closure.mp hz t.to_subring le),
  λ h, h (closure s) subset_closure⟩

/-- A subfield `t` includes `closure s` if and only if it includes `s`. -/
@[simp]
lemma closure_le {s : set K} {t : subfield K} : closure s ≤ t ↔ s ⊆ t :=
⟨set.subset.trans subset_closure, λ h x hx, mem_closure.mp hx t h⟩

/-- Subfield closure of a set is monotone in its argument: if `s ⊆ t`,
then `closure s ≤ closure t`. -/
lemma closure_mono ⦃s t : set K⦄ (h : s ⊆ t) : closure s ≤ closure t :=
closure_le.2 $ set.subset.trans h subset_closure

lemma closure_eq_of_le {s : set K} {t : subfield K} (h₁ : s ⊆ t) (h₂ : t ≤ closure s) :
  closure s = t :=
le_antisymm (closure_le.2 h₁) h₂

/-- An induction principle for closure membership. If `p` holds for `1`, and all elements
of `s`, and is preserved under addition, negation, and multiplication, then `p` holds for all elements
of the closure of `s`. -/
@[elab_as_eliminator]
lemma closure_induction {s : set K} {p : K → Prop} {x} (h : x ∈ closure s)
  (Hs : ∀ x ∈ s, p x) (H1 : p 1)
  (Hadd : ∀ x y, p x → p y → p (x + y))
  (Hneg : ∀ x, p x → p (-x))
  (Hinv : ∀ x, p x → p (x⁻¹))
  (Hmul : ∀ x y, p x → p y → p (x * y)) : p x :=
(@closure_le _ _ _ ⟨p, H1, Hmul,
  @add_neg_self K _ 1 ▸ Hadd _ _ H1 (Hneg _ H1), Hadd, Hneg, Hinv⟩).2 Hs h

variable (K)
/-- `closure` forms a Galois insertion with the coercion to set. -/
protected def gi : galois_insertion (@closure K _) coe :=
{ choice := λ s _, closure s,
  gc := λ s t, closure_le,
  le_l_u := λ s, subset_closure,
  choice_eq := λ s h, rfl }

variable {K}

/-- Closure of a subfield `S` equals `S`. -/
lemma closure_eq (s : subfield K) : closure (s : set K) = s := (subfield.gi K).l_u_eq s

@[simp] lemma closure_empty : closure (∅ : set K) = ⊥ := (subfield.gi K).gc.l_bot

@[simp] lemma closure_univ : closure (set.univ : set K) = ⊤ := @coe_top K _ ▸ closure_eq ⊤

lemma closure_union (s t : set K) : closure (s ∪ t) = closure s ⊔ closure t :=
(subfield.gi K).gc.l_sup

lemma closure_Union {ι} (s : ι → set K) : closure (⋃ i, s i) = ⨆ i, closure (s i) :=
(subfield.gi K).gc.l_supr

lemma closure_sUnion (s : set (set K)) : closure (⋃₀ s) = ⨆ t ∈ s, closure t :=
(subfield.gi K).gc.l_Sup

lemma map_sup (s t : subfield K) (f : K →+* L) : (s ⊔ t).map f = s.map f ⊔ t.map f :=
(gc_map_comap f).l_sup

lemma map_supr {ι : Sort*} (f : K →+* L) (s : ι → subfield K) :
  (supr s).map f = ⨆ i, (s i).map f :=
(gc_map_comap f).l_supr

lemma comap_inf (s t : subfield L) (f : K →+* L) : (s ⊓ t).comap f = s.comap f ⊓ t.comap f :=
(gc_map_comap f).u_inf

lemma comap_infi {ι : Sort*} (f : K →+* L) (s : ι → subfield L) :
  (infi s).comap f = ⨅ i, (s i).comap f :=
(gc_map_comap f).u_infi

@[simp] lemma map_bot (f : K →+* L) : (⊥ : subfield K).map f = ⊥ :=
(gc_map_comap f).l_bot

@[simp] lemma comap_top (f : K →+* L) : (⊤ : subfield L).comap f = ⊤ :=
(gc_map_comap f).u_top

/-- The underlying set of a non-empty directed Sup of subfields is just a union of the subfields.
  Note that this fails without the directedness assumption (the union of two subfields is
  typically not a subfield) -/
lemma mem_supr_of_directed {ι} [hι : nonempty ι] {S : ι → subfield K} (hS : directed (≤) S)
  {x : K} : x ∈ (⨆ i, S i) ↔ ∃ i, x ∈ S i :=
begin
  refine ⟨_, λ ⟨i, hi⟩, (le_def.1 $ le_supr S i) hi⟩,
  suffices : x ∈ closure (⋃ i, (S i : set K)) → ∃ i, x ∈ S i,
  by simpa only [closure_Union, closure_eq],
  refine λ hx, closure_induction hx (λ x, set.mem_Union.mp) _ _ _ _ _,
  { exact hι.elim (λ i, ⟨i, (S i).one_mem⟩) },
  { rintros x y ⟨i, hi⟩ ⟨j, hj⟩,
    obtain ⟨k, hki, hkj⟩ := hS i j,
    exact ⟨k, (S k).add_mem (hki hi) (hkj hj)⟩ },
  { rintros x ⟨i, hi⟩,
    exact ⟨i, (S i).neg_mem hi⟩ },
  { rintros x ⟨i, hi⟩,
    exact ⟨i, (S i).inv_mem hi⟩ },
  { rintros x y ⟨i, hi⟩ ⟨j, hj⟩,
    obtain ⟨k, hki, hkj⟩ := hS i j,
    exact ⟨k, (S k).mul_mem (hki hi) (hkj hj)⟩ }
end

lemma coe_supr_of_directed {ι} [hι : nonempty ι] {S : ι → subfield K} (hS : directed (≤) S) :
  ((⨆ i, S i : subfield K) : set K) = ⋃ i, ↑(S i) :=
set.ext $ λ x, by simp [mem_supr_of_directed hS]

lemma mem_Sup_of_directed_on {S : set (subfield K)} (Sne : S.nonempty)
  (hS : directed_on (≤) S) {x : K} :
  x ∈ Sup S ↔ ∃ s ∈ S, x ∈ s :=
begin
  haveI : nonempty S := Sne.to_subtype,
  simp only [Sup_eq_supr', mem_supr_of_directed hS.directed_coe, set_coe.exists, subtype.coe_mk]
end

lemma coe_Sup_of_directed_on {S : set (subfield K)} (Sne : S.nonempty) (hS : directed_on (≤) S) :
  (↑(Sup S) : set K) = ⋃ s ∈ S, ↑s :=
set.ext $ λ x, by simp [mem_Sup_of_directed_on Sne hS]

end subfield

namespace ring_hom

variables {s : subfield K}

open subfield

/-- Restrict the codomain of a ring homomorphism to a subfield that includes the range. -/
def cod_restrict_field (f : K →+* L)
  (s : subfield L) (h : ∀ x, f x ∈ s) : K →+* s :=
{ to_fun := λ x, ⟨f x, h x⟩,
  map_add' := λ x y, subtype.eq $ f.map_add x y,
  map_zero' := subtype.eq f.map_zero,
  map_mul' := λ x y, subtype.eq $ f.map_mul x y,
  map_one' := subtype.eq f.map_one }

/-- Restriction of a ring homomorphism to a subfield of the domain. -/
def restrict_field (f : K →+* L) (s : subfield K) : s →+* L := f.comp s.subtype

@[simp] lemma restrict_field_apply (f : K →+* L) (x : s) : f.restrict_field s x = f x := rfl

/-- Restriction of a ring homomorphism to its range interpreted as a subfield. -/
def range_restrict_field (f : K →+* L) : K →+* f.range :=
f.cod_restrict' f.range $ λ x, ⟨x, subfield.mem_top x, rfl⟩

@[simp] lemma coe_range_restrict_field (f : K →+* L) (x : K) :
  (f.range_restrict_field x : L) = f x := rfl

/-- The subfield of elements `x : R` such that `f x = g x`, i.e.,
the equalizer of f and g as a subfield of R -/
def eq_locus_field (f g : K →+* L) : subfield K :=
{ inv_mem' := λ x (hx : f x = g x), show f x⁻¹ = g x⁻¹, by rw [f.map_inv, g.map_inv, hx],
  carrier := {x | f x = g x}, .. (f : K →+* L).eq_locus g }

/-- If two ring homomorphisms are equal on a set, then they are equal on its subfield closure. -/
lemma eq_on_field_closure {f g : K →+* L} {s : set K} (h : set.eq_on f g s) :
  set.eq_on f g (closure s) :=
show closure s ≤ f.eq_locus_field g, from closure_le.2 h

lemma eq_of_eq_on_subfield_top {f g : K →+* L} (h : set.eq_on f g (⊤ : subfield K)) :
  f = g :=
ext $ λ x, h trivial

lemma eq_of_eq_on_of_field_closure_eq_top {s : set K} (hs : closure s = ⊤) {f g : K →+* L}
  (h : s.eq_on f g) : f = g :=
eq_of_eq_on_subfield_top $ hs ▸ eq_on_field_closure h

lemma field_closure_preimage_le (f : K →+* L) (s : set L) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, mem_coe.2 $ mem_comap.2 $ subset_closure hx

/-- The image under a ring homomorphism of the subfield generated by a set equals
the subfield generated by the image of the set. -/
lemma map_field_closure (f : K →+* L) (s : set K) :
  (closure s).map f = closure (f '' s) :=
le_antisymm
  (map_le_iff_le_comap.2 $ le_trans (closure_mono $ set.subset_preimage_image _ _)
    (field_closure_preimage_le _ _))
  (closure_le.2 $ set.image_subset _ subset_closure)

end ring_hom

namespace subfield

open ring_hom

/-- The ring homomorphism associated to an inclusion of subfields. -/
def inclusion {S T : subfield K} (h : S ≤ T) : S →+* T :=
S.subtype.cod_restrict_field _ (λ x, h x.2)

@[simp] lemma field_range_subtype (s : subfield K) : s.subtype.field_range = s :=
ext' $ (coe_srange _).trans subtype.range_coe

end subfield

namespace ring_equiv

variables {s t : subfield K}

/-- Makes the identity isomorphism from a proof two subfields of a multiplicative
    monoid are equal. -/
def subfield_congr (h : s = t) : s ≃+* t :=
{ map_mul' :=  λ _ _, rfl, map_add' := λ _ _, rfl, ..equiv.set_congr $ subfield.ext'_iff.1 h }

end ring_equiv

namespace subfield

variables {s : set K}

lemma closure_preimage_le (f : K →+* L) (s : set L) :
  closure (f ⁻¹' s) ≤ (closure s).comap f :=
closure_le.2 $ λ x hx, mem_coe.2 $ mem_comap.2 $ subset_closure hx

end subfield


opaque f : Nat → Nat
axiom f_eq (x : Nat) : f (f x) = x

theorem ex1 (x : Nat) (h : f (f x) = x) : (let y := x*x; if f (f x) = x then 1 else y + 1) = 1 := by
  simp (config := { zeta := false }) only [h]
  trace_state
  simp

#print ex1 -- uses let_congr

theorem ex2 (x z : Nat) (h : f (f x) = x) (h' : z = x) : (let y := f (f x); y) = z := by
  simp (config := { zeta := false }) only [h]
  trace_state
  simp [h']

#print ex2 -- uses let_val_congr

theorem ex3 (x z : Nat) : (let α := Nat; (fun x : α => 0 + x)) = id := by
  simp (config := { zeta := false })
  trace_state -- should not simplify let body since `fun α : Nat => fun x : α => 0 + x` is not type correct
  simp [id]

theorem ex4 (p : Prop) (h : p) : (let n := 10; fun x : { z : Nat // z < n } => x = x) = fun z => p := by
  simp (config := { zeta := false })
  trace_state
  simp [h]

#print ex4 -- uses let_body_congr


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

! This file was ported from Lean 3 source module group_theory.p_group
! leanprover-community/mathlib commit f694c7dead66f5d4c80f446c796a5aad14707f0e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Zmod.Basic
import Mathbin.GroupTheory.Index
import Mathbin.GroupTheory.GroupAction.ConjAct
import Mathbin.GroupTheory.GroupAction.Quotient
import Mathbin.GroupTheory.Perm.Cycle.Type
import Mathbin.GroupTheory.SpecificGroups.Cyclic
import Mathbin.Tactic.IntervalCases

/-!
# p-groups

This file contains a proof that if `G` is a `p`-group acting on a finite set `α`,
then the number of fixed points of the action is congruent mod `p` to the cardinality of `α`.
It also contains proofs of some corollaries of this lemma about existence of fixed points.
-/

open BigOperators

open Fintype MulAction

variable (p : ℕ) (G : Type _) [Group G]

/-- A p-group is a group in which every element has prime power order -/
def IsPGroup : Prop :=
  ∀ g : G, ∃ k : ℕ, g ^ p ^ k = 1
#align is_p_group IsPGroup

variable {p} {G}

namespace IsPGroup

theorem iff_orderOf [hp : Fact p.Prime] : IsPGroup p G ↔ ∀ g : G, ∃ k : ℕ, orderOf g = p ^ k :=
  forall_congr' fun g =>
    ⟨fun ⟨k, hk⟩ =>
      Exists.imp (fun j => Exists.snd)
        ((Nat.dvd_prime_pow hp.out).mp (orderOf_dvd_of_pow_eq_one hk)),
      Exists.imp fun k hk => by rw [← hk, pow_orderOf_eq_one]⟩
#align is_p_group.iff_order_of IsPGroup.iff_orderOf

theorem of_card [Fintype G] {n : ℕ} (hG : card G = p ^ n) : IsPGroup p G := fun g =>
  ⟨n, by rw [← hG, pow_card_eq_one]⟩
#align is_p_group.of_card IsPGroup.of_card

theorem of_bot : IsPGroup p (⊥ : Subgroup G) :=
  of_card (Subgroup.card_bot.trans (pow_zero p).symm)
#align is_p_group.of_bot IsPGroup.of_bot

theorem iff_card [Fact p.Prime] [Fintype G] : IsPGroup p G ↔ ∃ n : ℕ, card G = p ^ n :=
  by
  have hG : card G ≠ 0 := card_ne_zero
  refine' ⟨fun h => _, fun ⟨n, hn⟩ => of_card hn⟩
  suffices ∀ q ∈ Nat.factors (card G), q = p
    by
    use (card G).factors.length
    rw [← List.prod_replicate, ← List.eq_replicate_of_mem this, Nat.prod_factors hG]
  intro q hq
  obtain ⟨hq1, hq2⟩ := (Nat.mem_factors hG).mp hq
  haveI : Fact q.prime := ⟨hq1⟩
  obtain ⟨g, hg⟩ := exists_prime_orderOf_dvd_card q hq2
  obtain ⟨k, hk⟩ := (iff_order_of.mp h) g
  exact (hq1.pow_eq_iff.mp (hg.symm.trans hk).symm).1.symm
#align is_p_group.iff_card IsPGroup.iff_card

section GIsPGroup

variable (hG : IsPGroup p G)

include hG

theorem of_injective {H : Type _} [Group H] (ϕ : H →* G) (hϕ : Function.Injective ϕ) :
    IsPGroup p H := by
  simp_rw [IsPGroup, ← hϕ.eq_iff, ϕ.map_pow, ϕ.map_one]
  exact fun h => hG (ϕ h)
#align is_p_group.of_injective IsPGroup.of_injective

theorem to_subgroup (H : Subgroup G) : IsPGroup p H :=
  hG.of_injective H.Subtype Subtype.coe_injective
#align is_p_group.to_subgroup IsPGroup.to_subgroup

theorem of_surjective {H : Type _} [Group H] (ϕ : G →* H) (hϕ : Function.Surjective ϕ) :
    IsPGroup p H :=
  by
  refine' fun h => Exists.elim (hϕ h) fun g hg => Exists.imp (fun k hk => _) (hG g)
  rw [← hg, ← ϕ.map_pow, hk, ϕ.map_one]
#align is_p_group.of_surjective IsPGroup.of_surjective

theorem to_quotient (H : Subgroup G) [H.Normal] : IsPGroup p (G ⧸ H) :=
  hG.ofSurjective (QuotientGroup.mk' H) Quotient.surjective_Quotient_mk''
#align is_p_group.to_quotient IsPGroup.to_quotient

theorem of_equiv {H : Type _} [Group H] (ϕ : G ≃* H) : IsPGroup p H :=
  hG.ofSurjective ϕ.toMonoidHom ϕ.Surjective
#align is_p_group.of_equiv IsPGroup.of_equiv

theorem orderOf_coprime {n : ℕ} (hn : p.coprime n) (g : G) : (orderOf g).coprime n :=
  let ⟨k, hk⟩ := hG g
  (hn.pow_leftₓ k).coprime_dvd_left (orderOf_dvd_of_pow_eq_one hk)
#align is_p_group.order_of_coprime IsPGroup.orderOf_coprime

/-- If `gcd(p,n) = 1`, then the `n`th power map is a bijection. -/
noncomputable def powEquiv {n : ℕ} (hn : p.coprime n) : G ≃ G :=
  let h : ∀ g : G, (Nat.card (Subgroup.zpowers g)).coprime n := fun g =>
    order_eq_card_zpowers' g ▸ hG.orderOf_coprime hn g
  { toFun := (· ^ n)
    invFun := fun g => (powCoprime (h g)).symm ⟨g, Subgroup.mem_zpowers g⟩
    left_inv := fun g =>
      Subtype.ext_iff.1 <|
        (powCoprime (h (g ^ n))).left_inv
          ⟨g, _, Subtype.ext_iff.1 <| (powCoprime (h g)).left_inv ⟨g, Subgroup.mem_zpowers g⟩⟩
    right_inv := fun g =>
      Subtype.ext_iff.1 <| (powCoprime (h g)).right_inv ⟨g, Subgroup.mem_zpowers g⟩ }
#align is_p_group.pow_equiv IsPGroup.powEquiv

@[simp]
theorem powEquiv_apply {n : ℕ} (hn : p.coprime n) (g : G) : hG.powEquiv hn g = g ^ n :=
  rfl
#align is_p_group.pow_equiv_apply IsPGroup.powEquiv_apply

@[simp]
theorem powEquiv_symm_apply {n : ℕ} (hn : p.coprime n) (g : G) :
    (hG.powEquiv hn).symm g = g ^ (orderOf g).gcdB n := by rw [order_eq_card_zpowers'] <;> rfl
#align is_p_group.pow_equiv_symm_apply IsPGroup.powEquiv_symm_apply

variable [hp : Fact p.Prime]

include hp

/-- If `p ∤ n`, then the `n`th power map is a bijection. -/
@[reducible]
noncomputable def powEquiv' {n : ℕ} (hn : ¬p ∣ n) : G ≃ G :=
  powEquiv hG (hp.out.coprime_iff_not_dvd.mpr hn)
#align is_p_group.pow_equiv' IsPGroup.powEquiv'

theorem index (H : Subgroup G) [H.FiniteIndex] : ∃ n : ℕ, H.index = p ^ n :=
  by
  haveI := H.normal_core.fintype_quotient_of_finite_index
  obtain ⟨n, hn⟩ := iff_card.mp (hG.to_quotient H.normal_core)
  obtain ⟨k, hk1, hk2⟩ :=
    (Nat.dvd_prime_pow hp.out).mp
      ((congr_arg _ (H.normal_core.index_eq_card.trans hn)).mp
        (Subgroup.index_dvd_of_le H.normal_core_le))
  exact ⟨k, hk2⟩
#align is_p_group.index IsPGroup.index

theorem card_eq_or_dvd : Nat.card G = 1 ∨ p ∣ Nat.card G :=
  by
  cases fintypeOrInfinite G
  · obtain ⟨n, hn⟩ := iff_card.mp hG
    rw [Nat.card_eq_fintype_card, hn]
    cases n
    · exact Or.inl rfl
    · exact Or.inr ⟨p ^ n, rfl⟩
  · rw [Nat.card_eq_zero_of_infinite]
    exact Or.inr ⟨0, rfl⟩
#align is_p_group.card_eq_or_dvd IsPGroup.card_eq_or_dvd

theorem nontrivial_iff_card [Fintype G] : Nontrivial G ↔ ∃ n > 0, card G = p ^ n :=
  ⟨fun hGnt =>
    let ⟨k, hk⟩ := iff_card.1 hG
    ⟨k,
      Nat.pos_of_ne_zero fun hk0 => by
        rw [hk0, pow_zero] at hk <;> exact fintype.one_lt_card.ne' hk,
      hk⟩,
    fun ⟨k, hk0, hk⟩ =>
    one_lt_card_iff_nontrivial.1 <| hk.symm ▸ one_lt_pow (Fact.out p.Prime).one_lt (ne_of_gt hk0)⟩
#align is_p_group.nontrivial_iff_card IsPGroup.nontrivial_iff_card

variable {α : Type _} [MulAction G α]

theorem card_orbit (a : α) [Fintype (orbit G a)] : ∃ n : ℕ, card (orbit G a) = p ^ n :=
  by
  let ϕ := orbit_equiv_quotient_stabilizer G a
  haveI := Fintype.ofEquiv (orbit G a) ϕ
  haveI := (stabilizer G a).finiteIndex_of_finite_quotient
  rw [card_congr ϕ, ← Subgroup.index_eq_card]
  exact hG.index (stabilizer G a)
#align is_p_group.card_orbit IsPGroup.card_orbit

variable (α) [Fintype α]

/-- If `G` is a `p`-group acting on a finite set `α`, then the number of fixed points
  of the action is congruent mod `p` to the cardinality of `α` -/
theorem card_modEq_card_fixedPoints [Fintype (fixedPoints G α)] :
    card α ≡ card (fixedPoints G α) [MOD p] := by
  classical
    calc
      card α = card (Σy : Quotient (orbit_rel G α), { x // Quotient.mk'' x = y }) :=
        card_congr (Equiv.sigmaFiberEquiv (@Quotient.mk'' _ (orbit_rel G α))).symm
      _ = ∑ a : Quotient (orbit_rel G α), card { x // Quotient.mk'' x = a } := (card_sigma _)
      _ ≡ ∑ a : fixed_points G α, 1 [MOD p] := _
      _ = _ := by simp <;> rfl

    rw [← ZMod.eq_iff_modEq_nat p, Nat.cast_sum, Nat.cast_sum]
    have key :
      ∀ x,
        card { y // (Quotient.mk'' y : Quotient (orbit_rel G α)) = Quotient.mk'' x } =
          card (orbit G x) :=
      fun x => by simp only [Quotient.eq''] <;> congr
    refine'
      Eq.symm
        (Finset.sum_bij_ne_zero (fun a _ _ => Quotient.mk'' a.1) (fun _ _ _ => Finset.mem_univ _)
          (fun a₁ a₂ _ _ _ _ h =>
            Subtype.eq ((mem_fixed_points' α).mp a₂.2 a₁.1 (Quotient.exact' h)))
          (fun b => Quotient.inductionOn' b fun b _ hb => _) fun a ha _ => by
          rw [key, mem_fixed_points_iff_card_orbit_eq_one.mp a.2])
    obtain ⟨k, hk⟩ := hG.card_orbit b
    have : k = 0 :=
      le_zero_iff.1
        (Nat.le_of_lt_succ
          (lt_of_not_ge
            (mt (pow_dvd_pow p)
              (by
                rwa [pow_one, ← hk, ← Nat.modEq_zero_iff_dvd, ← ZMod.eq_iff_modEq_nat, ← key,
                  Nat.cast_zero]))))
    exact
      ⟨⟨b, mem_fixed_points_iff_card_orbit_eq_one.2 <| by rw [hk, this, pow_zero]⟩,
        Finset.mem_univ _, ne_of_eq_of_ne Nat.cast_one one_ne_zero, rfl⟩
#align is_p_group.card_modeq_card_fixed_points IsPGroup.card_modEq_card_fixedPoints

/-- If a p-group acts on `α` and the cardinality of `α` is not a multiple
  of `p` then the action has a fixed point. -/
theorem nonempty_fixed_point_of_prime_not_dvd_card (hpα : ¬p ∣ card α) [Finite (fixedPoints G α)] :
    (fixedPoints G α).Nonempty :=
  @Set.nonempty_of_nonempty_subtype _ _
    (by
      cases nonempty_fintype (fixed_points G α)
      rw [← card_pos_iff, pos_iff_ne_zero]
      contrapose! hpα
      rw [← Nat.modEq_zero_iff_dvd, ← hpα]
      exact hG.card_modeq_card_fixed_points α)
#align is_p_group.nonempty_fixed_point_of_prime_not_dvd_card IsPGroup.nonempty_fixed_point_of_prime_not_dvd_card

/-- If a p-group acts on `α` and the cardinality of `α` is a multiple
  of `p`, and the action has one fixed point, then it has another fixed point. -/
theorem exists_fixed_point_of_prime_dvd_card_of_fixed_point (hpα : p ∣ card α) {a : α}
    (ha : a ∈ fixedPoints G α) : ∃ b, b ∈ fixedPoints G α ∧ a ≠ b :=
  by
  cases nonempty_fintype (fixed_points G α)
  have hpf : p ∣ card (fixed_points G α) :=
    nat.modeq_zero_iff_dvd.mp ((hG.card_modeq_card_fixed_points α).symm.trans hpα.modeq_zero_nat)
  have hα : 1 < card (fixed_points G α) :=
    (Fact.out p.prime).one_lt.trans_le (Nat.le_of_dvd (card_pos_iff.2 ⟨⟨a, ha⟩⟩) hpf)
  exact
    let ⟨⟨b, hb⟩, hba⟩ := exists_ne_of_one_lt_card hα ⟨a, ha⟩
    ⟨b, hb, fun hab => hba (by simp_rw [hab])⟩
#align is_p_group.exists_fixed_point_of_prime_dvd_card_of_fixed_point IsPGroup.exists_fixed_point_of_prime_dvd_card_of_fixed_point

theorem center_nontrivial [Nontrivial G] [Finite G] : Nontrivial (Subgroup.center G) := by
  classical
    cases nonempty_fintype G
    have := (hG.of_equiv ConjAct.toConjAct).exists_fixed_point_of_prime_dvd_card_of_fixed_point G
    rw [ConjAct.fixedPoints_eq_center] at this
    obtain ⟨g, hg⟩ := this _ (Subgroup.center G).one_mem
    · exact ⟨⟨1, ⟨g, hg.1⟩, mt subtype.ext_iff.mp hg.2⟩⟩
    · obtain ⟨n, hn0, hn⟩ := hG.nontrivial_iff_card.mp inferInstance
      exact hn.symm ▸ dvd_pow_self _ (ne_of_gt hn0)
#align is_p_group.center_nontrivial IsPGroup.center_nontrivial

theorem bot_lt_center [Nontrivial G] [Finite G] : ⊥ < Subgroup.center G :=
  by
  haveI := center_nontrivial hG
  cases nonempty_fintype G
  classical exact
      bot_lt_iff_ne_bot.mpr ((Subgroup.center G).one_lt_card_iff_ne_bot.mp Fintype.one_lt_card)
#align is_p_group.bot_lt_center IsPGroup.bot_lt_center

end GIsPGroup

theorem to_le {H K : Subgroup G} (hK : IsPGroup p K) (hHK : H ≤ K) : IsPGroup p H :=
  hK.of_injective (Subgroup.inclusion hHK) fun a b h =>
    Subtype.ext (show _ from Subtype.ext_iff.mp h)
#align is_p_group.to_le IsPGroup.to_le

theorem to_inf_left {H K : Subgroup G} (hH : IsPGroup p H) : IsPGroup p (H ⊓ K : Subgroup G) :=
  hH.to_le inf_le_left
#align is_p_group.to_inf_left IsPGroup.to_inf_left

theorem to_inf_right {H K : Subgroup G} (hK : IsPGroup p K) : IsPGroup p (H ⊓ K : Subgroup G) :=
  hK.to_le inf_le_right
#align is_p_group.to_inf_right IsPGroup.to_inf_right

theorem map {H : Subgroup G} (hH : IsPGroup p H) {K : Type _} [Group K] (ϕ : G →* K) :
    IsPGroup p (H.map ϕ) := by
  rw [← H.subtype_range, MonoidHom.map_range]
  exact hH.of_surjective (ϕ.restrict H).range_restrict (ϕ.restrict H).rangeRestrict_surjective
#align is_p_group.map IsPGroup.map

theorem comap_of_ker_isPGroup {H : Subgroup G} (hH : IsPGroup p H) {K : Type _} [Group K]
    (ϕ : K →* G) (hϕ : IsPGroup p ϕ.ker) : IsPGroup p (H.comap ϕ) :=
  by
  intro g
  obtain ⟨j, hj⟩ := hH ⟨ϕ g.1, g.2⟩
  rw [Subtype.ext_iff, H.coe_pow, Subtype.coe_mk, ← ϕ.map_pow] at hj
  obtain ⟨k, hk⟩ := hϕ ⟨g.1 ^ p ^ j, hj⟩
  rwa [Subtype.ext_iff, ϕ.ker.coe_pow, Subtype.coe_mk, ← pow_mul, ← pow_add] at hk
  exact ⟨j + k, by rwa [Subtype.ext_iff, (H.comap ϕ).coe_pow]⟩
#align is_p_group.comap_of_ker_is_p_group IsPGroup.comap_of_ker_isPGroup

theorem ker_isPGroup_of_injective {K : Type _} [Group K] {ϕ : K →* G} (hϕ : Function.Injective ϕ) :
    IsPGroup p ϕ.ker :=
  (congr_arg (fun Q : Subgroup K => IsPGroup p Q) (ϕ.ker_eq_bot_iff.mpr hϕ)).mpr IsPGroup.of_bot
#align is_p_group.ker_is_p_group_of_injective IsPGroup.ker_isPGroup_of_injective

theorem comap_of_injective {H : Subgroup G} (hH : IsPGroup p H) {K : Type _} [Group K] (ϕ : K →* G)
    (hϕ : Function.Injective ϕ) : IsPGroup p (H.comap ϕ) :=
  hH.comap_of_ker_isPGroup ϕ (ker_isPGroup_of_injective hϕ)
#align is_p_group.comap_of_injective IsPGroup.comap_of_injective

theorem comap_subtype {H : Subgroup G} (hH : IsPGroup p H) {K : Subgroup G} :
    IsPGroup p (H.comap K.Subtype) :=
  hH.comap_of_injective K.Subtype Subtype.coe_injective
#align is_p_group.comap_subtype IsPGroup.comap_subtype

theorem to_sup_of_normal_right {H K : Subgroup G} (hH : IsPGroup p H) (hK : IsPGroup p K)
    [K.Normal] : IsPGroup p (H ⊔ K : Subgroup G) :=
  by
  rw [← QuotientGroup.ker_mk' K, ← Subgroup.comap_map_eq]
  apply (hH.map (QuotientGroup.mk' K)).comap_of_ker_isPGroup
  rwa [QuotientGroup.ker_mk']
#align is_p_group.to_sup_of_normal_right IsPGroup.to_sup_of_normal_right

theorem to_sup_of_normal_left {H K : Subgroup G} (hH : IsPGroup p H) (hK : IsPGroup p K)
    [H.Normal] : IsPGroup p (H ⊔ K : Subgroup G) :=
  (congr_arg (fun H : Subgroup G => IsPGroup p H) sup_comm).mp (to_sup_of_normal_right hK hH)
#align is_p_group.to_sup_of_normal_left IsPGroup.to_sup_of_normal_left

theorem to_sup_of_normal_right' {H K : Subgroup G} (hH : IsPGroup p H) (hK : IsPGroup p K)
    (hHK : H ≤ K.normalizer) : IsPGroup p (H ⊔ K : Subgroup G) :=
  let hHK' :=
    to_sup_of_normal_right (hH.of_equiv (Subgroup.subgroupOfEquivOfLe hHK).symm)
      (hK.of_equiv (Subgroup.subgroupOfEquivOfLe Subgroup.le_normalizer).symm)
  ((congr_arg (fun H : Subgroup K.normalizer => IsPGroup p H)
            (Subgroup.sup_subgroupOf_eq hHK Subgroup.le_normalizer)).mp
        hHK').of_equiv
    (Subgroup.subgroupOfEquivOfLe (sup_le hHK Subgroup.le_normalizer))
#align is_p_group.to_sup_of_normal_right' IsPGroup.to_sup_of_normal_right'

theorem to_sup_of_normal_left' {H K : Subgroup G} (hH : IsPGroup p H) (hK : IsPGroup p K)
    (hHK : K ≤ H.normalizer) : IsPGroup p (H ⊔ K : Subgroup G) :=
  (congr_arg (fun H : Subgroup G => IsPGroup p H) sup_comm).mp (to_sup_of_normal_right' hK hH hHK)
#align is_p_group.to_sup_of_normal_left' IsPGroup.to_sup_of_normal_left'

/-- finite p-groups with different p have coprime orders -/
theorem coprime_card_of_ne {G₂ : Type _} [Group G₂] (p₁ p₂ : ℕ) [hp₁ : Fact p₁.Prime]
    [hp₂ : Fact p₂.Prime] (hne : p₁ ≠ p₂) (H₁ : Subgroup G) (H₂ : Subgroup G₂) [Fintype H₁]
    [Fintype H₂] (hH₁ : IsPGroup p₁ H₁) (hH₂ : IsPGroup p₂ H₂) :
    Nat.coprime (Fintype.card H₁) (Fintype.card H₂) :=
  by
  obtain ⟨n₁, heq₁⟩ := iff_card.mp hH₁; rw [heq₁]; clear heq₁
  obtain ⟨n₂, heq₂⟩ := iff_card.mp hH₂; rw [heq₂]; clear heq₂
  exact Nat.coprime_pow_primes _ _ hp₁.elim hp₂.elim hne
#align is_p_group.coprime_card_of_ne IsPGroup.coprime_card_of_ne

/-- p-groups with different p are disjoint -/
theorem disjoint_of_ne (p₁ p₂ : ℕ) [hp₁ : Fact p₁.Prime] [hp₂ : Fact p₂.Prime] (hne : p₁ ≠ p₂)
    (H₁ H₂ : Subgroup G) (hH₁ : IsPGroup p₁ H₁) (hH₂ : IsPGroup p₂ H₂) : Disjoint H₁ H₂ :=
  by
  rw [Subgroup.disjoint_def]
  intro x hx₁ hx₂
  obtain ⟨n₁, hn₁⟩ := iff_order_of.mp hH₁ ⟨x, hx₁⟩
  obtain ⟨n₂, hn₂⟩ := iff_order_of.mp hH₂ ⟨x, hx₂⟩
  rw [← orderOf_subgroup, Subgroup.coe_mk] at hn₁ hn₂
  have : p₁ ^ n₁ = p₂ ^ n₂ := by rw [← hn₁, ← hn₂]
  rcases n₁.eq_zero_or_pos with (rfl | hn₁)
  · simpa using hn₁
  · exact absurd (eq_of_prime_pow_eq hp₁.out.prime hp₂.out.prime hn₁ this) hne
#align is_p_group.disjoint_of_ne IsPGroup.disjoint_of_ne

section P2comm

variable [Fintype G] [Fact p.Prime] {n : ℕ} (hGpn : card G = p ^ n)

include hGpn

open Subgroup

/-- The cardinality of the `center` of a `p`-group is `p ^ k` where `k` is positive. -/
theorem card_center_eq_prime_pow (hn : 0 < n) [Fintype (center G)] :
    ∃ k > 0, card (center G) = p ^ k :=
  by
  have hcG := to_subgroup (of_card hGpn) (center G)
  rcases iff_card.1 hcG with ⟨k, hk⟩
  haveI : Nontrivial G := (nontrivial_iff_card <| of_card hGpn).2 ⟨n, hn, hGpn⟩
  exact (nontrivial_iff_card hcG).mp (center_nontrivial (of_card hGpn))
#align is_p_group.card_center_eq_prime_pow IsPGroup.card_center_eq_prime_pow

omit hGpn

/-- The quotient by the center of a group of cardinality `p ^ 2` is cyclic. -/
theorem cyclic_center_quotient_of_card_eq_prime_sq (hG : card G = p ^ 2) :
    IsCyclic (G ⧸ center G) := by
  classical
    rcases card_center_eq_prime_pow hG zero_lt_two with ⟨k, hk0, hk⟩
    rw [card_eq_card_quotient_mul_card_subgroup (center G), mul_comm, hk] at hG
    have hk2 := (Nat.pow_dvd_pow_iff_le_right (Fact.out p.prime).one_lt).1 ⟨_, hG.symm⟩
    interval_cases
    · rw [sq, pow_one, mul_right_inj' (Fact.out p.prime).NeZero] at hG
      exact isCyclic_of_prime_card hG
    ·
      exact
        @isCyclic_of_subsingleton _ _
          ⟨Fintype.card_le_one_iff.1
              (mul_right_injective₀ (pow_ne_zero 2 (NeZero.ne p))
                  (hG.trans (mul_one (p ^ 2)).symm)).le⟩
#align is_p_group.cyclic_center_quotient_of_card_eq_prime_sq IsPGroup.cyclic_center_quotient_of_card_eq_prime_sq

/-- A group of order `p ^ 2` is commutative. See also `is_p_group.commutative_of_card_eq_prime_sq`
for just the proof that `∀ a b, a * b = b * a` -/
def commGroupOfCardEqPrimeSq (hG : card G = p ^ 2) : CommGroup G :=
  @commGroupOfCycleCenterQuotient _ _ _ _ (cyclic_center_quotient_of_card_eq_prime_sq hG) _
    (QuotientGroup.ker_mk' (center G)).le
#align is_p_group.comm_group_of_card_eq_prime_sq IsPGroup.commGroupOfCardEqPrimeSq

/-- A group of order `p ^ 2` is commutative. See also `is_p_group.comm_group_of_card_eq_prime_sq`
for the `comm_group` instance. -/
theorem commutative_of_card_eq_prime_sq (hG : card G = p ^ 2) : ∀ a b : G, a * b = b * a :=
  (commGroupOfCardEqPrimeSq hG).mul_comm
#align is_p_group.commutative_of_card_eq_prime_sq IsPGroup.commutative_of_card_eq_prime_sq

end P2comm

end IsPGroup