/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.field_theory.finite.basic
import Mathlib.data.zmod.basic
import Mathlib.data.nat.parity
import Mathlib.PostPort

namespace Mathlib

/-!
# Quadratic reciprocity.

This file contains results about quadratic residues modulo a prime number.

The main results are the law of quadratic reciprocity, `quadratic_reciprocity`, as well as the
interpretations in terms of existence of square roots depending on the congruence mod 4,
`exists_pow_two_eq_prime_iff_of_mod_four_eq_one`, and
`exists_pow_two_eq_prime_iff_of_mod_four_eq_three`.

Also proven are conditions for `-1` and `2` to be a square modulo a prime,
`exists_pow_two_eq_neg_one_iff_mod_four_ne_three` and
`exists_pow_two_eq_two_iff`

## Implementation notes

The proof of quadratic reciprocity implemented uses Gauss' lemma and Eisenstein's lemma
-/

namespace zmod

/-- Euler's Criterion: A unit `x` of `zmod p` is a square if and only if `x ^ (p / 2) = 1`. -/
theorem euler_criterion_units (p : ℕ) [fact (nat.prime p)] (x : units (zmod p)) :
    (∃ (y : units (zmod p)), y ^ bit0 1 = x) ↔ x ^ (p / bit0 1) = 1 :=
  sorry

/-- Euler's Criterion: a nonzero `a : zmod p` is a square if and only if `x ^ (p / 2) = 1`. -/
theorem euler_criterion (p : ℕ) [fact (nat.prime p)] {a : zmod p} (ha : a ≠ 0) :
    (∃ (y : zmod p), y ^ bit0 1 = a) ↔ a ^ (p / bit0 1) = 1 :=
  sorry

theorem exists_pow_two_eq_neg_one_iff_mod_four_ne_three (p : ℕ) [fact (nat.prime p)] :
    (∃ (y : zmod p), y ^ bit0 1 = -1) ↔ p % bit0 (bit0 1) ≠ bit1 1 :=
  sorry

theorem pow_div_two_eq_neg_one_or_one (p : ℕ) [fact (nat.prime p)] {a : zmod p} (ha : a ≠ 0) :
    a ^ (p / bit0 1) = 1 ∨ a ^ (p / bit0 1) = -1 :=
  sorry

/-- Wilson's Lemma: the product of `1`, ..., `p-1` is `-1` modulo `p`. -/
@[simp] theorem wilsons_lemma (p : ℕ) [fact (nat.prime p)] : ↑(nat.factorial (p - 1)) = -1 := sorry

@[simp] theorem prod_Ico_one_prime (p : ℕ) [fact (nat.prime p)] :
    (finset.prod (finset.Ico 1 p) fun (x : ℕ) => ↑x) = -1 :=
  sorry

end zmod

/-- The image of the map sending a non zero natural number `x ≤ p / 2` to the absolute value
  of the element of interger in the interval `(-p/2, p/2]` congruent to `a * x` mod p is the set
  of non zero natural numbers `x` such that `x ≤ p / 2` -/
theorem Ico_map_val_min_abs_nat_abs_eq_Ico_map_id (p : ℕ) [hp : fact (nat.prime p)] (a : zmod p)
    (hap : a ≠ 0) :
    multiset.map (fun (x : ℕ) => int.nat_abs (zmod.val_min_abs (a * ↑x)))
          (finset.val (finset.Ico 1 (Nat.succ (p / bit0 1)))) =
        multiset.map (fun (a : ℕ) => a) (finset.val (finset.Ico 1 (Nat.succ (p / bit0 1)))) :=
  sorry

theorem div_eq_filter_card {a : ℕ} {b : ℕ} {c : ℕ} (hb0 : 0 < b) (hc : a / b ≤ c) :
    a / b = finset.card (finset.filter (fun (x : ℕ) => x * b ≤ a) (finset.Ico 1 (Nat.succ c))) :=
  sorry

/-- The given sum is the number of integer points in the triangle formed by the diagonal of the
  rectangle `(0, p/2) × (0, q/2)`  -/
/-- Each of the sums in this lemma is the cardinality of the set integer points in each of the
  two triangles formed by the diagonal of the rectangle `(0, p/2) × (0, q/2)`. Adding them
  gives the number of points in the rectangle. -/
namespace zmod

/-- The Legendre symbol of `a` and `p` is an integer defined as

* `0` if `a` is `0` modulo `p`;
* `1` if `a ^ (p / 2)` is `1` modulo `p`
   (by `euler_criterion` this is equivalent to “`a` is a square modulo `p`”);
* `-1` otherwise.

-/
def legendre_sym (a : ℕ) (p : ℕ) : ℤ := ite (↑a = 0) 0 (ite (↑a ^ (p / bit0 1) = 1) 1 (-1))

theorem legendre_sym_eq_pow (a : ℕ) (p : ℕ) [hp : fact (nat.prime p)] :
    ↑(legendre_sym a p) = ↑a ^ (p / bit0 1) :=
  sorry

theorem legendre_sym_eq_one_or_neg_one (a : ℕ) (p : ℕ) (ha : ↑a ≠ 0) :
    legendre_sym a p = -1 ∨ legendre_sym a p = 1 :=
  sorry

theorem legendre_sym_eq_zero_iff (a : ℕ) (p : ℕ) : legendre_sym a p = 0 ↔ ↑a = 0 := sorry

/-- Gauss' lemma. The legendre symbol can be computed by considering the number of naturals less
  than `p/2` such that `(a * x) % p > p / 2` -/
theorem gauss_lemma (p : ℕ) [fact (nat.prime p)] {a : ℕ} [hp1 : fact (p % bit0 1 = 1)]
    (ha0 : ↑a ≠ 0) :
    legendre_sym a p =
        (-1) ^
          finset.card
            (finset.filter (fun (x : ℕ) => p / bit0 1 < val (↑a * ↑x))
              (finset.Ico 1 (Nat.succ (p / bit0 1)))) :=
  sorry

theorem legendre_sym_eq_one_iff (p : ℕ) [fact (nat.prime p)] {a : ℕ} (ha0 : ↑a ≠ 0) :
    legendre_sym a p = 1 ↔ ∃ (b : zmod p), b ^ bit0 1 = ↑a :=
  sorry

theorem eisenstein_lemma (p : ℕ) [fact (nat.prime p)] [hp1 : fact (p % bit0 1 = 1)] {a : ℕ}
    (ha1 : a % bit0 1 = 1) (ha0 : ↑a ≠ 0) :
    legendre_sym a p =
        (-1) ^ finset.sum (finset.Ico 1 (Nat.succ (p / bit0 1))) fun (x : ℕ) => x * a / p :=
  sorry

theorem quadratic_reciprocity (p : ℕ) (q : ℕ) [fact (nat.prime p)] [fact (nat.prime q)]
    [hp1 : fact (p % bit0 1 = 1)] [hq1 : fact (q % bit0 1 = 1)] (hpq : p ≠ q) :
    legendre_sym p q * legendre_sym q p = (-1) ^ (p / bit0 1 * (q / bit0 1)) :=
  sorry

-- move this

protected instance fact_prime_two : fact (nat.prime (bit0 1)) := nat.prime_two

theorem legendre_sym_two (p : ℕ) [fact (nat.prime p)] [hp1 : fact (p % bit0 1 = 1)] :
    legendre_sym (bit0 1) p = (-1) ^ (p / bit0 (bit0 1) + p / bit0 1) :=
  sorry

theorem exists_pow_two_eq_two_iff (p : ℕ) [fact (nat.prime p)] [hp1 : fact (p % bit0 1 = 1)] :
    (∃ (a : zmod p), a ^ bit0 1 = bit0 1) ↔
        p % bit0 (bit0 (bit0 1)) = 1 ∨ p % bit0 (bit0 (bit0 1)) = bit1 (bit1 1) :=
  sorry

theorem exists_pow_two_eq_prime_iff_of_mod_four_eq_one (p : ℕ) (q : ℕ) [fact (nat.prime p)]
    [fact (nat.prime q)] (hp1 : p % bit0 (bit0 1) = 1) [hq1 : fact (q % bit0 1 = 1)] :
    (∃ (a : zmod p), a ^ bit0 1 = ↑q) ↔ ∃ (b : zmod q), b ^ bit0 1 = ↑p :=
  sorry

theorem exists_pow_two_eq_prime_iff_of_mod_four_eq_three (p : ℕ) (q : ℕ) [fact (nat.prime p)]
    [fact (nat.prime q)] (hp3 : p % bit0 (bit0 1) = bit1 1) (hq3 : q % bit0 (bit0 1) = bit1 1)
    (hpq : p ≠ q) : (∃ (a : zmod p), a ^ bit0 1 = ↑q) ↔ ¬∃ (b : zmod q), b ^ bit0 1 = ↑p :=
  sorry

end Mathlib


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Simon Hudon, Alex Keizer
-/

import Qpf.MathlibPort.Fin2
import Qpf.Util.HEq
-- import Mathlib

universe u v w

abbrev DVec {n : Nat} (αs : Fin2 n → Type u)  : Type _
  := (i : Fin2 n) → αs i

abbrev Vec (α : Type _) (n : Nat)
  := @DVec n fun _ => α

namespace Vec
  def append1 {α : Type u} {n} (tl : Vec α n) (hd : α) : Vec α (.succ n)
    | .fs i   => tl i
    | .fz     => hd

  -- infixl:67 " ::: " => append1

  /-- Drop the last element from a `Vec` -/
  def drop (v : Vec α (n+1)) : Vec α n
    := fun i => v <| .fs i

  def constVec {α : Type _} (a : α) (n : Nat) : Vec α n
    := fun _ => a
end Vec

unif_hint (n : Nat) where |- Fin2 n → Type u =?= Vec.{u+1} (Type u) n
unif_hint {α : Type _} (n : Nat) where |- DVec.{u+1} (Vec.constVec α n) =?= Vec.{u+1} α n

namespace DVec
  /-- Return the last element from a `DVec` -/
  abbrev last (v : @DVec (n+1) αs ) : αs 0
    := v 0

  /-- Drop the last element from a `DVec` -/
  def drop (v : DVec αs) : DVec (Vec.drop αs)
    := fun i => v <| .fs i

  @[reducible]
  def nil : @DVec 0 αs
    := fun emp => by contradiction

  @[reducible]
  def append1 {α : Type u} {αs : Vec (Type u) n} (tl : DVec αs) (hd : α) : DVec (Vec.append1 αs α)
    | .fs i => tl i
    | .fz   => hd

  -- infixl:67 " ::: " => append1
end DVec

namespace Vec
  variable {α : Type _} {n : Nat}

  abbrev nil  : Vec α 0           := DVec.nil
  abbrev last : Vec α n.succ → α  := DVec.last
end Vec

/-
  # Notation macros
-/

syntax "!![" term,* "]" : term
macro_rules
  | `(!![])    => `(Vec.nil)
  | `(!![$x])  => `(Vec.append1 !![] $x)
  | `(!![ $xs,* , $x]) => `(Vec.append1 !![$xs,*] $x)

namespace Vec
  theorem drop_append1 {v : Vec α n} {a : α} {i : PFin2 n} :
      drop (append1 v a) i = v i :=
    rfl

  theorem drop_append1' {v : Vec α n} {a : α} :
      drop (append1 v a) = v :=
  by funext x; rfl

  theorem last_append1 {v : Vec α n} {a : α} :
    last (append1 v a) = a
  := rfl

  @[simp]
  theorem append1_drop_last (v : Vec α (n+1)) : append1 (drop v) (last v) = v :=
    funext $ fun i => by cases i; rfl; rfl

  def reverse (v : Vec α n) : Vec α n :=
    fun i => v i.inv

  @[simp]
  theorem reverse_involution {v : Vec α n} :
    v.reverse.reverse = v :=
  by
    funext i;
    dsimp only [reverse]
    apply congrArg;
    simp only [Fin2.inv, PFin2.toFin2_ofFin2_iso, PFin2.inv_involution, PFin2.ofFin2_toFin2_iso]
end Vec

namespace Vec
  /-- Create a `Vec` from a `List`. Note that this conceptually reverses the list, since in a `Vec`
      the 0th index points to the right-most element
   -/
  def ofList : (as : List α) → Vec α (as.length)
    | List.nil        => Vec.nil
    | List.cons a as  => Vec.append1 (ofList as) a

  /-- Create a `List` from a `Vec`. Note that this conceptually reverses the vector, since in a `Vec`
      the 0th index points to the right-most element
   -/
  def toList : {n : Nat} → Vec α n → List α
    | 0,    _  => List.nil
    | _+1,  v  => List.cons v.last (toList v.drop)

  @[simp]
  theorem toList_length_eq_n {v : Vec α n} :
    v.toList.length = n :=
  by
    induction n
    case zero => rfl
    case succ n ih =>
      dsimp only [toList, List.length]
      dsimp only [HAdd.hAdd, Add.add, Nat.add]
      apply congrArg
      apply ih

  @[simp]
  theorem ofList_toList_iso {v : Vec α n} :
    HEq (ofList (toList v)) v :=
  by
    apply HEq.trans (b := cast (β:=Vec α (List.length (toList v))) ?hc v);
    case hc =>
      simp only [toList_length_eq_n]
    case h₂ =>
      apply cast_heq
    case h₁ =>
      apply heq_of_eq;
      funext i;
      apply eq_of_heq;
      rw[cast_arg] <;> try (solve | simp);
      simp_heq

      induction n <;> cases i;
      case succ.fz n ih => {
        dsimp[ofList, toList, append1, last, DVec.last]
        apply hcongr <;> (try solve | intros; rfl)
        simp_heq;
        simp only [OfNat.ofNat]
        apply hcongr <;> (try solve | intros; rfl)
        simp
      }
      case succ.fs n ih i => {
        dsimp[ofList, toList, append1, drop]

        apply HEq.trans (@ih (fun i => v (.fs i)) i);
        apply hcongr <;> (try solve | intros; rfl)
        simp_heq
        apply hcongr;
        case H₂ => apply cast_heq
        case H₃ => apply congrArg; simp
        case H₄ => intro _; apply congrArg; simp

        apply hcongr <;> (try solve | intros; rfl);
        simp
      }

  theorem ofList_toList_iso' {v : Vec α n} :
    HEq (fun (j : PFin2.{u} (toList v).length) => ofList (toList v) j.toFin2)
        (fun (j : PFin2.{u} (toList v).length) => v <| PFin2.toFin2 <| cast (by rw[toList_length_eq_n]) j) :=
  by
    apply HEq.funext
    . rfl
    intro j
    have n_eq : (toList v).length = n := toList_length_eq_n;
    apply hcongr
    . apply ofList_toList_iso
    . intros
      apply hcongr <;> intros <;> (try rw[n_eq])
      . simp_heq
    . intros; simp
    . rw[n_eq]

  @[simp]
  theorem toList_ofList_iso {as : List α} :
    toList (ofList as) = as :=
  by
    induction as;
    case nil          => rfl
    case cons a as ih => simp only [toList, ofList, append1, last, DVec.last, drop, ih]

  instance : Coe (Vec (Type u) n) (TypeVec.{u} n) where
    coe v i := v i

  instance : Coe (TypeVec.{u} n) (Vec (Type u) n) where
    coe v i := v i

  instance : Coe (Fin n → α) (Vec α n) where
    coe f i := f (Fin2.inv i)

end Vec


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

! This file was ported from Lean 3 source module data.two_pointing
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Sum.Basic
import Mathbin.Logic.Nontrivial

/-!
# Two-pointings

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

This file defines `two_pointing α`, the type of two pointings of `α`. A two-pointing is the data of
two distinct terms.

This is morally a Type-valued `nontrivial`. Another type which is quite close in essence is `sym2`.
Categorically speaking, `prod` is a cospan in the category of types. This forms the category of
bipointed types. Two-pointed types form a full subcategory of those.

## References

* [nLab, *Coalgebra of the real interval*]
  (https://ncatlab.org/nlab/show/coalgebra+of+the+real+interval)
-/

open Function

variable {α β : Type _}

#print TwoPointing /-
/-- Two-pointing of a type. This is a Type-valued termed `nontrivial`. -/
@[ext]
structure TwoPointing (α : Type _) extends α × α where
  fst_ne_snd : fst ≠ snd
  deriving DecidableEq
#align two_pointing TwoPointing
-/

namespace TwoPointing

variable (p : TwoPointing α) (q : TwoPointing β)

#print TwoPointing.snd_ne_fst /-
theorem snd_ne_fst : p.snd ≠ p.fst :=
  p.fst_ne_snd.symm
#align two_pointing.snd_ne_fst TwoPointing.snd_ne_fst
-/

#print TwoPointing.swap /-
/-- Swaps the two pointed elements. -/
@[simps]
def swap : TwoPointing α :=
  ⟨(p.snd, p.fst), p.snd_ne_fst⟩
#align two_pointing.swap TwoPointing.swap
-/

#print TwoPointing.swap_fst /-
theorem swap_fst : p.symm.fst = p.snd :=
  rfl
#align two_pointing.swap_fst TwoPointing.swap_fst
-/

#print TwoPointing.swap_snd /-
theorem swap_snd : p.symm.snd = p.fst :=
  rfl
#align two_pointing.swap_snd TwoPointing.swap_snd
-/

#print TwoPointing.swap_swap /-
@[simp]
theorem swap_swap : p.symm.symm = p := by ext <;> rfl
#align two_pointing.swap_swap TwoPointing.swap_swap
-/

#print TwoPointing.to_nontrivial /-
-- See note [reducible non instances]
@[reducible]
theorem to_nontrivial : Nontrivial α :=
  ⟨⟨p.fst, p.snd, p.fst_ne_snd⟩⟩
#align two_pointing.to_nontrivial TwoPointing.to_nontrivial
-/

instance [Nontrivial α] : Nonempty (TwoPointing α) :=
  let ⟨a, b, h⟩ := exists_pair_ne α
  ⟨⟨(a, b), h⟩⟩

#print TwoPointing.nonempty_two_pointing_iff /-
@[simp]
theorem nonempty_two_pointing_iff : Nonempty (TwoPointing α) ↔ Nontrivial α :=
  ⟨fun ⟨p⟩ => p.to_nontrivial, @TwoPointing.nonempty _⟩
#align two_pointing.nonempty_two_pointing_iff TwoPointing.nonempty_two_pointing_iff
-/

section Pi

variable (α) [Nonempty α]

#print TwoPointing.pi /-
/-- The two-pointing of constant functions. -/
def pi : TwoPointing (α → β) where
  fst _ := q.fst
  snd _ := q.snd
  fst_ne_snd h := q.fst_ne_snd <| by convert congr_fun h (Classical.arbitrary α)
#align two_pointing.pi TwoPointing.pi
-/

/- warning: two_pointing.pi_fst -> TwoPointing.pi_fst is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) {β : Type.{u2}} (q : TwoPointing.{u2} β) [_inst_1 : Nonempty.{succ u1} α], Eq.{max (succ u1) (succ u2)} (α -> β) (Prod.fst.{max u1 u2, max u1 u2} (α -> β) (α -> β) (TwoPointing.toProd.{max u1 u2} (α -> β) (TwoPointing.pi.{u1, u2} α β q _inst_1))) (Function.const.{succ u2, succ u1} β α (Prod.fst.{u2, u2} β β (TwoPointing.toProd.{u2} β q)))
but is expected to have type
  forall (α : Type.{u2}) {β : Type.{u1}} (q : TwoPointing.{u1} β) [_inst_1 : Nonempty.{succ u2} α], Eq.{max (succ u2) (succ u1)} (α -> β) (Prod.fst.{max u2 u1, max u2 u1} (α -> β) (α -> β) (TwoPointing.toProd.{max u2 u1} (α -> β) (TwoPointing.pi.{u2, u1} α β q _inst_1))) (Function.const.{succ u1, succ u2} β α (Prod.fst.{u1, u1} β β (TwoPointing.toProd.{u1} β q)))
Case conversion may be inaccurate. Consider using '#align two_pointing.pi_fst TwoPointing.pi_fstₓ'. -/
@[simp]
theorem pi_fst : (q.pi α).fst = const α q.fst :=
  rfl
#align two_pointing.pi_fst TwoPointing.pi_fst

/- warning: two_pointing.pi_snd -> TwoPointing.pi_snd is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) {β : Type.{u2}} (q : TwoPointing.{u2} β) [_inst_1 : Nonempty.{succ u1} α], Eq.{max (succ u1) (succ u2)} (α -> β) (Prod.snd.{max u1 u2, max u1 u2} (α -> β) (α -> β) (TwoPointing.toProd.{max u1 u2} (α -> β) (TwoPointing.pi.{u1, u2} α β q _inst_1))) (Function.const.{succ u2, succ u1} β α (Prod.snd.{u2, u2} β β (TwoPointing.toProd.{u2} β q)))
but is expected to have type
  forall (α : Type.{u2}) {β : Type.{u1}} (q : TwoPointing.{u1} β) [_inst_1 : Nonempty.{succ u2} α], Eq.{max (succ u2) (succ u1)} (α -> β) (Prod.snd.{max u2 u1, max u2 u1} (α -> β) (α -> β) (TwoPointing.toProd.{max u2 u1} (α -> β) (TwoPointing.pi.{u2, u1} α β q _inst_1))) (Function.const.{succ u1, succ u2} β α (Prod.snd.{u1, u1} β β (TwoPointing.toProd.{u1} β q)))
Case conversion may be inaccurate. Consider using '#align two_pointing.pi_snd TwoPointing.pi_sndₓ'. -/
@[simp]
theorem pi_snd : (q.pi α).snd = const α q.snd :=
  rfl
#align two_pointing.pi_snd TwoPointing.pi_snd

end Pi

#print TwoPointing.prod /-
/-- The product of two two-pointings. -/
def prod : TwoPointing (α × β) where
  fst := (p.fst, q.fst)
  snd := (p.snd, q.snd)
  fst_ne_snd h := p.fst_ne_snd (congr_arg Prod.fst h)
#align two_pointing.prod TwoPointing.prod
-/

/- warning: two_pointing.prod_fst -> TwoPointing.prod_fst is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (p : TwoPointing.{u1} α) (q : TwoPointing.{u2} β), Eq.{max (succ u1) (succ u2)} (Prod.{u1, u2} α β) (Prod.fst.{max u1 u2, max u1 u2} (Prod.{u1, u2} α β) (Prod.{u1, u2} α β) (TwoPointing.toProd.{max u1 u2} (Prod.{u1, u2} α β) (TwoPointing.prod.{u1, u2} α β p q))) (Prod.mk.{u1, u2} α β (Prod.fst.{u1, u1} α α (TwoPointing.toProd.{u1} α p)) (Prod.fst.{u2, u2} β β (TwoPointing.toProd.{u2} β q)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (p : TwoPointing.{u2} α) (q : TwoPointing.{u1} β), Eq.{max (succ u2) (succ u1)} (Prod.{u2, u1} α β) (Prod.fst.{max u2 u1, max u2 u1} (Prod.{u2, u1} α β) (Prod.{u2, u1} α β) (TwoPointing.toProd.{max u2 u1} (Prod.{u2, u1} α β) (TwoPointing.prod.{u2, u1} α β p q))) (Prod.mk.{u2, u1} α β (Prod.fst.{u2, u2} α α (TwoPointing.toProd.{u2} α p)) (Prod.fst.{u1, u1} β β (TwoPointing.toProd.{u1} β q)))
Case conversion may be inaccurate. Consider using '#align two_pointing.prod_fst TwoPointing.prod_fstₓ'. -/
@[simp]
theorem prod_fst : (p.Prod q).fst = (p.fst, q.fst) :=
  rfl
#align two_pointing.prod_fst TwoPointing.prod_fst

/- warning: two_pointing.prod_snd -> TwoPointing.prod_snd is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (p : TwoPointing.{u1} α) (q : TwoPointing.{u2} β), Eq.{max (succ u1) (succ u2)} (Prod.{u1, u2} α β) (Prod.snd.{max u1 u2, max u1 u2} (Prod.{u1, u2} α β) (Prod.{u1, u2} α β) (TwoPointing.toProd.{max u1 u2} (Prod.{u1, u2} α β) (TwoPointing.prod.{u1, u2} α β p q))) (Prod.mk.{u1, u2} α β (Prod.snd.{u1, u1} α α (TwoPointing.toProd.{u1} α p)) (Prod.snd.{u2, u2} β β (TwoPointing.toProd.{u2} β q)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (p : TwoPointing.{u2} α) (q : TwoPointing.{u1} β), Eq.{max (succ u2) (succ u1)} (Prod.{u2, u1} α β) (Prod.snd.{max u2 u1, max u2 u1} (Prod.{u2, u1} α β) (Prod.{u2, u1} α β) (TwoPointing.toProd.{max u2 u1} (Prod.{u2, u1} α β) (TwoPointing.prod.{u2, u1} α β p q))) (Prod.mk.{u2, u1} α β (Prod.snd.{u2, u2} α α (TwoPointing.toProd.{u2} α p)) (Prod.snd.{u1, u1} β β (TwoPointing.toProd.{u1} β q)))
Case conversion may be inaccurate. Consider using '#align two_pointing.prod_snd TwoPointing.prod_sndₓ'. -/
@[simp]
theorem prod_snd : (p.Prod q).snd = (p.snd, q.snd) :=
  rfl
#align two_pointing.prod_snd TwoPointing.prod_snd

#print TwoPointing.sum /-
/-- The sum of two pointings. Keeps the first point from the left and the second point from the
right. -/
protected def sum : TwoPointing (Sum α β) :=
  ⟨(Sum.inl p.fst, Sum.inr q.snd), Sum.inl_ne_inr⟩
#align two_pointing.sum TwoPointing.sum
-/

/- warning: two_pointing.sum_fst -> TwoPointing.sum_fst is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (p : TwoPointing.{u1} α) (q : TwoPointing.{u2} β), Eq.{max (succ u1) (succ u2)} (Sum.{u1, u2} α β) (Prod.fst.{max u1 u2, max u1 u2} (Sum.{u1, u2} α β) (Sum.{u1, u2} α β) (TwoPointing.toProd.{max u1 u2} (Sum.{u1, u2} α β) (TwoPointing.sum.{u1, u2} α β p q))) (Sum.inl.{u1, u2} α β (Prod.fst.{u1, u1} α α (TwoPointing.toProd.{u1} α p)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (p : TwoPointing.{u2} α) (q : TwoPointing.{u1} β), Eq.{max (succ u2) (succ u1)} (Sum.{u2, u1} α β) (Prod.fst.{max u2 u1, max u2 u1} (Sum.{u2, u1} α β) (Sum.{u2, u1} α β) (TwoPointing.toProd.{max u2 u1} (Sum.{u2, u1} α β) (TwoPointing.sum.{u2, u1} α β p q))) (Sum.inl.{u2, u1} α β (Prod.fst.{u2, u2} α α (TwoPointing.toProd.{u2} α p)))
Case conversion may be inaccurate. Consider using '#align two_pointing.sum_fst TwoPointing.sum_fstₓ'. -/
@[simp]
theorem sum_fst : (p.Sum q).fst = Sum.inl p.fst :=
  rfl
#align two_pointing.sum_fst TwoPointing.sum_fst

/- warning: two_pointing.sum_snd -> TwoPointing.sum_snd is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (p : TwoPointing.{u1} α) (q : TwoPointing.{u2} β), Eq.{max (succ u1) (succ u2)} (Sum.{u1, u2} α β) (Prod.snd.{max u1 u2, max u1 u2} (Sum.{u1, u2} α β) (Sum.{u1, u2} α β) (TwoPointing.toProd.{max u1 u2} (Sum.{u1, u2} α β) (TwoPointing.sum.{u1, u2} α β p q))) (Sum.inr.{u1, u2} α β (Prod.snd.{u2, u2} β β (TwoPointing.toProd.{u2} β q)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (p : TwoPointing.{u2} α) (q : TwoPointing.{u1} β), Eq.{max (succ u2) (succ u1)} (Sum.{u2, u1} α β) (Prod.snd.{max u2 u1, max u2 u1} (Sum.{u2, u1} α β) (Sum.{u2, u1} α β) (TwoPointing.toProd.{max u2 u1} (Sum.{u2, u1} α β) (TwoPointing.sum.{u2, u1} α β p q))) (Sum.inr.{u2, u1} α β (Prod.snd.{u1, u1} β β (TwoPointing.toProd.{u1} β q)))
Case conversion may be inaccurate. Consider using '#align two_pointing.sum_snd TwoPointing.sum_sndₓ'. -/
@[simp]
theorem sum_snd : (p.Sum q).snd = Sum.inr q.snd :=
  rfl
#align two_pointing.sum_snd TwoPointing.sum_snd

#print TwoPointing.bool /-
/-- The `ff`, `tt` two-pointing of `bool`. -/
protected def bool : TwoPointing Bool :=
  ⟨(false, true), Bool.false_ne_true⟩
#align two_pointing.bool TwoPointing.bool
-/

#print TwoPointing.bool_fst /-
@[simp]
theorem bool_fst : TwoPointing.bool.fst = false :=
  rfl
#align two_pointing.bool_fst TwoPointing.bool_fst
-/

#print TwoPointing.bool_snd /-
@[simp]
theorem bool_snd : TwoPointing.bool.snd = true :=
  rfl
#align two_pointing.bool_snd TwoPointing.bool_snd
-/

instance : Inhabited (TwoPointing Bool) :=
  ⟨TwoPointing.bool⟩

#print TwoPointing.prop /-
/-- The `false`, `true` two-pointing of `Prop`. -/
protected def prop : TwoPointing Prop :=
  ⟨(False, True), false_ne_true⟩
#align two_pointing.Prop TwoPointing.prop
-/

#print TwoPointing.prop_fst /-
@[simp]
theorem prop_fst : TwoPointing.prop.fst = False :=
  rfl
#align two_pointing.Prop_fst TwoPointing.prop_fst
-/

#print TwoPointing.prop_snd /-
@[simp]
theorem prop_snd : TwoPointing.prop.snd = True :=
  rfl
#align two_pointing.Prop_snd TwoPointing.prop_snd
-/

end TwoPointing


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import data.set.pointwise
import group_theory.submonoid.operations

/-! # Pointwise instances on `submonoid`s and `add_submonoid`s

This file provides:

* `submonoid.has_inv`
* `add_submonoid.has_neg`

and the actions

* `submonoid.pointwise_mul_action`
* `add_submonoid.pointwise_mul_action`

which matches the action of `mul_action_set`.

These are all available in the `pointwise` locale.

Additionally, it provides `add_submonoid.has_mul`, which is available globally to match
`submodule.has_mul`.

## Implementation notes

Most of the lemmas in this file are direct copies of lemmas from `algebra/pointwise.lean`.
While the statements of these lemmas are defeq, we repeat them here due to them not being
syntactically equal. Before adding new lemmas here, consider if they would also apply to the action
on `set`s.

-/

open set

variables {α : Type*} {G : Type*} {M : Type*} {R : Type*} {A : Type*}
variables [monoid M] [add_monoid A]

namespace submonoid

variables [group G]

open_locale pointwise

/-- The submonoid with every element inverted. -/
@[to_additive /-" The additive submonoid with every element negated. "-/]
protected def has_inv : has_inv (submonoid G):=
{ inv := λ S,
  { carrier := (S : set G)⁻¹,
    one_mem' := show (1 : G)⁻¹ ∈ S, by { rw inv_one, exact S.one_mem },
    mul_mem' := λ a b (ha : a⁻¹ ∈ S) (hb : b⁻¹ ∈ S), show (a * b)⁻¹ ∈ S,
      by { rw mul_inv_rev, exact S.mul_mem hb ha } } }

localized "attribute [instance] submonoid.has_inv" in pointwise
open_locale pointwise

@[simp, to_additive] lemma coe_inv (S : submonoid G) : ↑(S⁻¹) = (S : set G)⁻¹ := rfl

@[simp, to_additive] lemma mem_inv {g : G} {S : submonoid G} : g ∈ S⁻¹ ↔ g⁻¹ ∈ S := iff.rfl

@[to_additive] instance : has_involutive_inv (submonoid G) :=
set_like.coe_injective.has_involutive_inv _ $ λ _, rfl

@[simp, to_additive] lemma inv_le_inv (S T : submonoid G) : S⁻¹ ≤ T⁻¹ ↔ S ≤ T :=
set_like.coe_subset_coe.symm.trans set.inv_subset_inv

@[to_additive] lemma inv_le (S T : submonoid G) : S⁻¹ ≤ T ↔ S ≤ T⁻¹ :=
set_like.coe_subset_coe.symm.trans set.inv_subset

/-- `submonoid.has_inv` as an order isomorphism. -/
@[to_additive /-" `add_submonoid.has_neg` as an order isomorphism "-/, simps]
def inv_order_iso : submonoid G ≃o submonoid G :=
{ to_equiv := equiv.inv _,
  map_rel_iff' := inv_le_inv }

@[to_additive] lemma closure_inv (s : set G) : closure s⁻¹ = (closure s)⁻¹ :=
begin
  apply le_antisymm,
  { rw [closure_le, coe_inv, ←set.inv_subset, inv_inv],
    exact subset_closure },
  { rw [inv_le, closure_le, coe_inv, ←set.inv_subset],
    exact subset_closure }
end

@[simp, to_additive]
lemma inv_inf (S T : submonoid G) : (S ⊓ T)⁻¹ = S⁻¹ ⊓ T⁻¹ :=
set_like.coe_injective set.inter_inv

@[simp, to_additive]
lemma inv_sup (S T : submonoid G) : (S ⊔ T)⁻¹ = S⁻¹ ⊔ T⁻¹ :=
(inv_order_iso : submonoid G ≃o submonoid G).map_sup S T

@[simp, to_additive]
lemma inv_bot : (⊥ : submonoid G)⁻¹ = ⊥ :=
set_like.coe_injective $ (set.inv_singleton 1).trans $ congr_arg _ inv_one

@[simp, to_additive]
lemma inv_top : (⊤ : submonoid G)⁻¹ = ⊤ :=
set_like.coe_injective $ set.inv_univ

@[simp, to_additive]
lemma inv_infi {ι : Sort*} (S : ι → submonoid G) : (⨅ i, S i)⁻¹ = ⨅ i, (S i)⁻¹ :=
(inv_order_iso : submonoid G ≃o submonoid G).map_infi _

@[simp, to_additive]
lemma inv_supr {ι : Sort*} (S : ι → submonoid G) : (⨆ i, S i)⁻¹ = ⨆ i, (S i)⁻¹ :=
(inv_order_iso : submonoid G ≃o submonoid G).map_supr _

end submonoid

namespace submonoid

section monoid
variables [monoid α] [mul_distrib_mul_action α M]

/-- The action on a submonoid corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action α (submonoid M) :=
{ smul := λ a S, S.map (mul_distrib_mul_action.to_monoid_End _ _ a),
  one_smul := λ S, (congr_arg (λ f, S.map f) (monoid_hom.map_one _)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (monoid_hom.map_mul _ _ _)).trans (S.map_map _ _).symm,}

localized "attribute [instance] submonoid.pointwise_mul_action" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_smul (a : α) (S : submonoid M) : ↑(a • S) = a • (S : set M) := rfl

lemma smul_mem_pointwise_smul (m : M) (a : α) (S : submonoid M) : m ∈ S → a • m ∈ a • S :=
(set.smul_mem_smul_set : _ → _ ∈ a • (S : set M))

lemma mem_smul_pointwise_iff_exists (m : M) (a : α) (S : submonoid M) :
  m ∈ a • S ↔ ∃ (s : M), s ∈ S ∧ a • s = m :=
(set.mem_smul_set : m ∈ a • (S : set M) ↔ _)

instance pointwise_central_scalar [mul_distrib_mul_action αᵐᵒᵖ M] [is_central_scalar α M] :
  is_central_scalar α (submonoid M) :=
⟨λ a S, congr_arg (λ f, S.map f) $ monoid_hom.ext $ by exact op_smul_eq_smul _⟩

end monoid

section group
variables [group α] [mul_distrib_mul_action α M]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff {a : α} {S : submonoid M} {x : M} :
  a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {a : α} {S : submonoid M} {x : M} :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem

lemma mem_inv_pointwise_smul_iff {a : α} {S : submonoid M} {x : M} : x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {a : α} {S T : submonoid M} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff

lemma pointwise_smul_subset_iff {a : α} {S T : submonoid M} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff

lemma subset_pointwise_smul_iff {a : α} {S T : submonoid M} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff

end group

section group_with_zero
variables [group_with_zero α] [mul_distrib_mul_action α M]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) (S : submonoid M)
  (x : M) : a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff₀ ha (S : set M) x

lemma mem_inv_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) (S : submonoid M) (x : M) :
  x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff₀ ha (S : set M) x

@[simp] lemma pointwise_smul_le_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) {S T : submonoid M} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff₀ ha

lemma pointwise_smul_le_iff₀ {a : α} (ha : a ≠ 0) {S T : submonoid M} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff₀ ha

lemma le_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) {S T : submonoid M} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff₀ ha

end group_with_zero

open_locale pointwise

@[to_additive]
lemma mem_closure_inv {G : Type*} [group G] (S : set G) (x : G) :
  x ∈ submonoid.closure S⁻¹ ↔ x⁻¹ ∈ submonoid.closure S :=
by rw [closure_inv, mem_inv]

end submonoid

namespace add_submonoid

section monoid
variables [monoid α] [distrib_mul_action α A]

/-- The action on an additive submonoid corresponding to applying the action to every element.

This is available as an instance in the `pointwise` locale. -/
protected def pointwise_mul_action : mul_action α (add_submonoid A) :=
{ smul := λ a S, S.map (distrib_mul_action.to_add_monoid_End _ _ a),
  one_smul := λ S, (congr_arg (λ f, S.map f) (monoid_hom.map_one _)).trans S.map_id,
  mul_smul := λ a₁ a₂ S,
    (congr_arg (λ f, S.map f) (monoid_hom.map_mul _ _ _)).trans (S.map_map _ _).symm,}

localized "attribute [instance] add_submonoid.pointwise_mul_action" in pointwise
open_locale pointwise

@[simp] lemma coe_pointwise_smul (a : α) (S : add_submonoid A) : ↑(a • S) = a • (S : set A) := rfl

lemma smul_mem_pointwise_smul (m : A) (a : α) (S : add_submonoid A) : m ∈ S → a • m ∈ a • S :=
(set.smul_mem_smul_set : _ → _ ∈ a • (S : set A))

instance pointwise_central_scalar [distrib_mul_action αᵐᵒᵖ A] [is_central_scalar α A] :
  is_central_scalar α (add_submonoid A) :=
⟨λ a S, congr_arg (λ f, S.map f) $ add_monoid_hom.ext $ by exact op_smul_eq_smul _⟩

end monoid

section group
variables [group α] [distrib_mul_action α A]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff {a : α} {S : add_submonoid A} {x : A} :
  a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff

lemma mem_pointwise_smul_iff_inv_smul_mem {a : α} {S : add_submonoid A} {x : A} :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem

lemma mem_smul_pointwise_iff_exists (m : A) (a : α) (S : add_submonoid A) :
  m ∈ a • S ↔ ∃ (s : A), s ∈ S ∧ a • s = m :=
(set.mem_smul_set : m ∈ a • (S : set A) ↔ _)

lemma mem_inv_pointwise_smul_iff {a : α} {S : add_submonoid A} {x : A} : x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff

@[simp] lemma pointwise_smul_le_pointwise_smul_iff {a : α} {S T : add_submonoid A} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff

lemma pointwise_smul_le_iff {a : α} {S T : add_submonoid A} : a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff

lemma le_pointwise_smul_iff {a : α} {S T : add_submonoid A} : S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff

end group

section group_with_zero
variables [group_with_zero α] [distrib_mul_action α A]

open_locale pointwise

@[simp] lemma smul_mem_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) (S : add_submonoid A)
  (x : A) : a • x ∈ a • S ↔ x ∈ S :=
smul_mem_smul_set_iff₀ ha (S : set A) x

lemma mem_pointwise_smul_iff_inv_smul_mem₀ {a : α} (ha : a ≠ 0) (S : add_submonoid A) (x : A) :
  x ∈ a • S ↔ a⁻¹ • x ∈ S :=
mem_smul_set_iff_inv_smul_mem₀ ha (S : set A) x

lemma mem_inv_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) (S : add_submonoid A) (x : A) :
  x ∈ a⁻¹ • S ↔ a • x ∈ S :=
mem_inv_smul_set_iff₀ ha (S : set A) x

@[simp] lemma pointwise_smul_le_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) {S T : add_submonoid A} :
  a • S ≤ a • T ↔ S ≤ T :=
set_smul_subset_set_smul_iff₀ ha

lemma pointwise_smul_le_iff₀ {a : α} (ha : a ≠ 0) {S T : add_submonoid A} :
  a • S ≤ T ↔ S ≤ a⁻¹ • T :=
set_smul_subset_iff₀ ha

lemma le_pointwise_smul_iff₀ {a : α} (ha : a ≠ 0) {S T : add_submonoid A} :
  S ≤ a • T ↔ a⁻¹ • S ≤ T :=
subset_set_smul_iff₀ ha

end group_with_zero

open_locale pointwise

end add_submonoid

/-! ### Elementwise multiplication of two additive submonoids

These definitions are a cut-down versions of the ones around `submodule.has_mul`, as that API is
usually more useful. -/
namespace add_submonoid

variables [non_unital_non_assoc_semiring R]

/-- Multiplication of additive submonoids of a semiring R. The additive submonoid `S * T` is the
smallest R-submodule of `R` containing the elements `s * t` for `s ∈ S` and `t ∈ T`. -/
instance : has_mul (add_submonoid R) :=
⟨λ M N, ⨆ s : M, N.map $ add_monoid_hom.mul s.1⟩

theorem mul_mem_mul {M N : add_submonoid R} {m n : R} (hm : m ∈ M) (hn : n ∈ N) : m * n ∈ M * N :=
(le_supr _ ⟨m, hm⟩ : _ ≤ M * N) ⟨n, hn, rfl⟩

theorem mul_le {M N P : add_submonoid R} : M * N ≤ P ↔ ∀ (m ∈ M) (n ∈ N), m * n ∈ P :=
⟨λ H m hm n hn, H $ mul_mem_mul hm hn,
λ H, supr_le $ λ ⟨m, hm⟩, map_le_iff_le_comap.2 $ λ n hn, H m hm n hn⟩

@[elab_as_eliminator] protected theorem mul_induction_on
  {M N : add_submonoid R}
  {C : R → Prop} {r : R} (hr : r ∈ M * N)
  (hm : ∀ (m ∈ M) (n ∈ N), C (m * n))
  (ha : ∀ x y, C x → C y → C (x + y)) : C r :=
(@mul_le _ _ _ _ ⟨C, ha, by simpa only [zero_mul] using hm _ (zero_mem _) _ (zero_mem _)⟩).2 hm hr

open_locale pointwise

variables R
-- this proof is copied directly from `submodule.span_mul_span`
theorem closure_mul_closure (S T : set R) : closure S * closure T = closure (S * T) :=
begin
  apply le_antisymm,
  { rw mul_le, intros a ha b hb,
    apply closure_induction ha,
    work_on_goal 1 { intros, apply closure_induction hb,
      work_on_goal 1 { intros, exact subset_closure ⟨_, _, ‹_›, ‹_›, rfl⟩ } },
    all_goals { intros, simp only [mul_zero, zero_mul, zero_mem,
        left_distrib, right_distrib, mul_smul_comm, smul_mul_assoc],
      solve_by_elim [add_mem _ _, zero_mem _]
        { max_depth := 4, discharger := tactic.interactive.apply_instance } } },
  { rw closure_le, rintros _ ⟨a, b, ha, hb, rfl⟩,
    exact mul_mem_mul (subset_closure ha) (subset_closure hb) }
end
variables {R}

@[simp] theorem mul_bot (S : add_submonoid R) : S * ⊥ = ⊥ :=
eq_bot_iff.2 $ mul_le.2 $ λ m hm n hn, by rw [add_submonoid.mem_bot] at hn ⊢; rw [hn, mul_zero]

@[simp] theorem bot_mul (S : add_submonoid R) : ⊥ * S = ⊥ :=
eq_bot_iff.2 $ mul_le.2 $ λ m hm n hn, by rw [add_submonoid.mem_bot] at hm ⊢; rw [hm, zero_mul]

@[mono] theorem mul_le_mul {M N P Q : add_submonoid R} (hmp : M ≤ P) (hnq : N ≤ Q) :
  M * N ≤ P * Q :=
mul_le.2 $ λ m hm n hn, mul_mem_mul (hmp hm) (hnq hn)

theorem mul_le_mul_left {M N P : add_submonoid R} (h : M ≤ N) : M * P ≤ N * P :=
mul_le_mul h (le_refl P)

theorem mul_le_mul_right {M N P : add_submonoid R} (h : N ≤ P) : M * N ≤ M * P :=
mul_le_mul (le_refl M) h

lemma mul_subset_mul {M N : add_submonoid R} : (↑M : set R) * (↑N : set R) ⊆ (↑(M * N) : set R) :=
by { rintros _ ⟨i, j, hi, hj, rfl⟩, exact mul_mem_mul hi hj }

end add_submonoid


/-
Copyright (c) 2022 Markus Himmel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Markus Himmel
-/
import category_theory.epi_mono

/-!
# Balanced categories

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

A category is called balanced if any morphism that is both monic and epic is an isomorphism.

Balanced categories arise frequently. For example, categories in which every monomorphism
(or epimorphism) is strong are balanced. Examples of this are abelian categories and toposes, such
as the category of types.

-/

universes v u

namespace category_theory
variables {C : Type u} [category.{v} C]

section
variables (C)

/-- A category is called balanced if any morphism that is both monic and epic is an isomorphism. -/
class balanced : Prop :=
(is_iso_of_mono_of_epi : ∀ {X Y : C} (f : X ⟶ Y) [mono f] [epi f], is_iso f)

end

lemma is_iso_of_mono_of_epi [balanced C] {X Y : C} (f : X ⟶ Y) [mono f] [epi f] : is_iso f :=
balanced.is_iso_of_mono_of_epi _

lemma is_iso_iff_mono_and_epi [balanced C] {X Y : C} (f : X ⟶ Y) : is_iso f ↔ mono f ∧ epi f :=
⟨λ _, by exactI ⟨infer_instance, infer_instance⟩, λ ⟨_, _⟩, by exactI is_iso_of_mono_of_epi _⟩

section
local attribute [instance] is_iso_of_mono_of_epi

lemma balanced_opposite [balanced C] : balanced Cᵒᵖ :=
{ is_iso_of_mono_of_epi := λ X Y f fmono fepi,
    by { rw ← quiver.hom.op_unop f, exactI is_iso_of_op _ } }

end

end category_theory


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

Type of continuous maps and the compact-open topology on them.
-/
import topology.subset_properties
import topology.continuous_function.basic
import topology.homeomorph
import tactic.tidy

/-!
# The compact-open topology

In this file, we define the compact-open topology on the set of continuous maps between two
topological spaces.

## Main definitions

* `compact_open` is the compact-open topology on `C(α, β)`. It is declared as an instance.
* `ev` is the evaluation map `C(α, β) × α → β`. It is continuous as long as `α` is locally compact.
* `coev` is the coevaluation map `β → C(α, β × α)`. It is always continuous.
* `continuous_map.curry` is the currying map `C(α × β, γ) → C(α, C(β, γ))`. This map always exists
  and it is continuous as long as `α × β` is locally compact.
* `continuous_map.uncurry` is the uncurrying map `C(α, C(β, γ)) → C(α × β, γ)`. For this map to
  exist, we need `β` to be locally compact. If `α` is also locally compact, then this map is
  continuous.
* `homeomorph.curry` combines the currying and uncurrying operations into a homeomorphism
  `C(α × β, γ) ≃ₜ C(α, C(β, γ))`. This homeomorphism exists if `α` and `β` are locally compact.

## Tags

compact-open, curry, function space
-/

open set
open_locale topological_space

namespace continuous_map

section compact_open
variables {α : Type*} {β : Type*} {γ : Type*}
variables [topological_space α] [topological_space β] [topological_space γ]

def compact_open.gen (s : set α) (u : set β) : set C(α,β) := {f | f '' s ⊆ u}

-- The compact-open topology on the space of continuous maps α → β.
instance compact_open : topological_space C(α, β) :=
topological_space.generate_from
  {m | ∃ (s : set α) (hs : is_compact s) (u : set β) (hu : is_open u), m = compact_open.gen s u}

private lemma is_open_gen {s : set α} (hs : is_compact s) {u : set β} (hu : is_open u) :
  is_open (compact_open.gen s u) :=
topological_space.generate_open.basic _ (by dsimp [mem_set_of_eq]; tauto)

section functorial

variables {g : β → γ} (hg : continuous g)

def induced (f : C(α, β)) : C(α, γ) := ⟨g ∘ f, hg.comp f.continuous⟩

private lemma preimage_gen {s : set α} (hs : is_compact s) {u : set γ} (hu : is_open u) :
  continuous_map.induced hg ⁻¹' (compact_open.gen s u) = compact_open.gen s (g ⁻¹' u) :=
begin
  ext ⟨f, _⟩,
  change g ∘ f '' s ⊆ u ↔ f '' s ⊆ g ⁻¹' u,
  rw [image_comp, image_subset_iff]
end

/-- C(α, -) is a functor. -/
lemma continuous_induced : continuous (continuous_map.induced hg : C(α, β) → C(α, γ)) :=
continuous_generated_from $ assume m ⟨s, hs, u, hu, hm⟩,
  by rw [hm, preimage_gen hg hs hu]; exact is_open_gen hs (hu.preimage hg)

end functorial

section ev

variables (α β)
def ev (p : C(α, β) × α) : β := p.1 p.2

variables {α β}
-- The evaluation map C(α, β) × α → β is continuous if α is locally compact.
lemma continuous_ev [locally_compact_space α] : continuous (ev α β) :=
continuous_iff_continuous_at.mpr $ assume ⟨f, x⟩ n hn,
  let ⟨v, vn, vo, fxv⟩ := mem_nhds_sets_iff.mp hn in
  have v ∈ 𝓝 (f x), from mem_nhds_sets vo fxv,
  let ⟨s, hs, sv, sc⟩ :=
    locally_compact_space.local_compact_nhds x (f ⁻¹' v)
      (f.continuous.tendsto x this) in
  let ⟨u, us, uo, xu⟩ := mem_nhds_sets_iff.mp hs in
  show (ev α β) ⁻¹' n ∈ 𝓝 (f, x), from
  let w := set.prod (compact_open.gen s v) u in
  have w ⊆ ev α β ⁻¹' n, from assume ⟨f', x'⟩ ⟨hf', hx'⟩, calc
    f' x' ∈ f' '' s  : mem_image_of_mem f' (us hx')
    ...       ⊆ v            : hf'
    ...       ⊆ n            : vn,
  have is_open w, from (is_open_gen sc vo).prod uo,
  have (f, x) ∈ w, from ⟨image_subset_iff.mpr sv, xu⟩,
  mem_nhds_sets_iff.mpr ⟨w, by assumption, by assumption, by assumption⟩

end ev

section coev

variables (α β)
def coev (b : β) : C(α, β × α) := ⟨λ a, (b, a), continuous.prod_mk continuous_const continuous_id⟩

variables {α β}
lemma image_coev {y : β} (s : set α) : (coev α β y) '' s = set.prod {y} s := by tidy

-- The coevaluation map β → C(α, β × α) is continuous (always).
lemma continuous_coev : continuous (coev α β) :=
continuous_generated_from $ begin
  rintros _ ⟨s, sc, u, uo, rfl⟩,
  rw is_open_iff_forall_mem_open,
  intros y hy,
  change (coev α β y) '' s ⊆ u at hy,
  rw image_coev s at hy,
  rcases generalized_tube_lemma compact_singleton sc uo hy
    with ⟨v, w, vo, wo, yv, sw, vwu⟩,
  refine ⟨v, _, vo, singleton_subset_iff.mp yv⟩,
  intros y' hy',
  change (coev α β y') '' s ⊆ u,
  rw image_coev s,
  exact subset.trans (prod_mono (singleton_subset_iff.mpr hy') sw) vwu
end

end coev

section curry

/-- Auxiliary definition, see `continuous_map.curry` and `homeomorph.curry`. -/
def curry' (f : C(α × β, γ)) (a : α) : C(β, γ) := ⟨function.curry f a⟩

/-- If a map `α × β → γ` is continuous, then its curried form `α → C(β, γ)` is continuous. -/
lemma continuous_curry' (f : C(α × β, γ)) : continuous (curry' f) :=
have hf : curry' f = continuous_map.induced f.continuous_to_fun ∘ coev _ _, by { ext, refl },
hf ▸ continuous.comp (continuous_induced f.continuous_to_fun) continuous_coev

/-- To show continuity of a map `α → C(β, γ)`, it suffices to show that its uncurried form
    `α × β → γ` is continuous. -/
lemma continuous_of_continuous_uncurry (f : α → C(β, γ))
  (h : continuous (function.uncurry (λ x y, f x y))) : continuous f :=
by { convert continuous_curry' ⟨_, h⟩, ext, refl }

/-- The curried form of a continuous map `α × β → γ` as a continuous map `α → C(β, γ)`.
    If `a × β` is locally compact, this is continuous. If `α` and `β` are both locally
    compact, then this is a homeomorphism, see `homeomorph.curry`. -/
def curry (f : C(α × β, γ)) : C(α, C(β, γ)) :=
⟨_, continuous_curry' f⟩

/-- The currying process is a continuous map between function spaces. -/
lemma continuous_curry [locally_compact_space (α × β)] :
  continuous (curry : C(α × β, γ) → C(α, C(β, γ))) :=
begin
  apply continuous_of_continuous_uncurry,
  apply continuous_of_continuous_uncurry,
  rw ←homeomorph.comp_continuous_iff' (homeomorph.prod_assoc _ _ _).symm,
  convert continuous_ev;
  tidy
end

/-- The uncurried form of a continuous map `α → C(β, γ)` is a continuous map `α × β → γ`. -/
lemma continuous_uncurry_of_continuous [locally_compact_space β] (f : C(α, C(β, γ))) :
  continuous (function.uncurry (λ x y, f x y)) :=
have hf : function.uncurry (λ x y, f x y) = ev β γ ∘ prod.map f id, by { ext, refl },
hf ▸ continuous.comp continuous_ev $ continuous.prod_map f.2 id.2

/-- The uncurried form of a continuous map `α → C(β, γ)` as a continuous map `α × β → γ` (if `β` is
    locally compact). If `α` is also locally compact, then this is a homeomorphism between the two
    function spaces, see `homeomorph.curry`. -/
def uncurry [locally_compact_space β] (f : C(α, C(β, γ))) : C(α × β, γ) :=
⟨_, continuous_uncurry_of_continuous f⟩

/-- The uncurrying process is a continuous map between function spaces. -/
lemma continuous_uncurry [locally_compact_space α] [locally_compact_space β] :
  continuous (uncurry : C(α, C(β, γ)) → C(α × β, γ)) :=
begin
  apply continuous_of_continuous_uncurry,
  rw ←homeomorph.comp_continuous_iff' (homeomorph.prod_assoc _ _ _),
  apply continuous.comp continuous_ev (continuous.prod_map continuous_ev id.2);
  apply_instance
end

end curry

end compact_open

end continuous_map

open continuous_map

namespace homeomorph
variables {α : Type*} {β : Type*} {γ : Type*}
variables [topological_space α] [topological_space β] [topological_space γ]

/-- Currying as a homeomorphism between the function spaces `C(α × β, γ)` and `C(α, C(β, γ))`. -/
def curry [locally_compact_space α] [locally_compact_space β] : C(α × β, γ) ≃ₜ C(α, C(β, γ)) :=
⟨⟨curry, uncurry, by tidy, by tidy⟩, continuous_curry, continuous_uncurry⟩

/-- If `α` has a single element, then `β` is homeomorphic to `C(α, β)`. -/
def continuous_map_of_unique [unique α] : β ≃ₜ C(α, β) :=
{ to_fun := continuous_map.induced continuous_fst ∘ coev α β,
  inv_fun := ev α β ∘ (λ f, (f, default α)),
  left_inv := λ a, rfl,
  right_inv := λ f, by { ext, rw unique.eq_default x, refl },
  continuous_to_fun := continuous.comp (continuous_induced _) continuous_coev,
  continuous_inv_fun :=
    continuous.comp continuous_ev (continuous.prod_mk continuous_id continuous_const) }

@[simp]

@[simp] lemma continuous_map_of_unique_symm_apply [unique α] (f : C(α, β)) :
  continuous_map_of_unique.symm f = f (default α) :=
rfl

end homeomorph


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

import data.nat.factorization.basic
import data.set_like.fintype
import group_theory.group_action.conj_act
import group_theory.p_group
import group_theory.noncomm_pi_coprod
import order.atoms.finite

/-!
# Sylow theorems

The Sylow theorems are the following results for every finite group `G` and every prime number `p`.

* There exists a Sylow `p`-subgroup of `G`.
* All Sylow `p`-subgroups of `G` are conjugate to each other.
* Let `nₚ` be the number of Sylow `p`-subgroups of `G`, then `nₚ` divides the index of the Sylow
  `p`-subgroup, `nₚ ≡ 1 [MOD p]`, and `nₚ` is equal to the index of the normalizer of the Sylow
  `p`-subgroup in `G`.

## Main definitions

* `sylow p G` : The type of Sylow `p`-subgroups of `G`.

## Main statements

* `exists_subgroup_card_pow_prime`: A generalization of Sylow's first theorem:
  For every prime power `pⁿ` dividing the cardinality of `G`,
  there exists a subgroup of `G` of order `pⁿ`.
* `is_p_group.exists_le_sylow`: A generalization of Sylow's first theorem:
  Every `p`-subgroup is contained in a Sylow `p`-subgroup.
* `sylow.card_eq_multiplicity`: The cardinality of a Sylow group is `p ^ n`
 where `n` is the multiplicity of `p` in the group order.
* `sylow_conjugate`: A generalization of Sylow's second theorem:
  If the number of Sylow `p`-subgroups is finite, then all Sylow `p`-subgroups are conjugate.
* `card_sylow_modeq_one`: A generalization of Sylow's third theorem:
  If the number of Sylow `p`-subgroups is finite, then it is congruent to `1` modulo `p`.
-/

open fintype mul_action subgroup

section infinite_sylow

variables (p : ℕ) (G : Type*) [group G]

/-- A Sylow `p`-subgroup is a maximal `p`-subgroup. -/
structure sylow extends subgroup G :=
(is_p_group' : is_p_group p to_subgroup)
(is_maximal' : ∀ {Q : subgroup G}, is_p_group p Q → to_subgroup ≤ Q → Q = to_subgroup)

variables {p} {G}

namespace sylow

instance : has_coe (sylow p G) (subgroup G) := ⟨sylow.to_subgroup⟩

@[simp] lemma to_subgroup_eq_coe {P : sylow p G} : P.to_subgroup = ↑P := rfl

@[ext] lemma ext {P Q : sylow p G} (h : (P : subgroup G) = Q) : P = Q :=
by cases P; cases Q; congr'

lemma ext_iff {P Q : sylow p G} : P = Q ↔ (P : subgroup G) = Q :=
⟨congr_arg coe, ext⟩

instance : set_like (sylow p G) G :=
{ coe := coe,
  coe_injective' := λ P Q h, ext (set_like.coe_injective h) }

instance : subgroup_class (sylow p G) G :=
{ mul_mem := λ s _ _, s.mul_mem',
  one_mem := λ s, s.one_mem',
  inv_mem := λ s _, s.inv_mem' }

variables (P : sylow p G)

/-- The action by a Sylow subgroup is the action by the underlying group. -/
instance mul_action_left {α : Type*} [mul_action G α] : mul_action P α :=
subgroup.mul_action ↑P

variables {K : Type*} [group K] (ϕ : K →* G) {N : subgroup G}

/-- The preimage of a Sylow subgroup under a p-group-kernel homomorphism is a Sylow subgroup. -/
def comap_of_ker_is_p_group (hϕ : is_p_group p ϕ.ker) (h : ↑P ≤ ϕ.range) : sylow p K :=
{ P.1.comap ϕ with
  is_p_group' := P.2.comap_of_ker_is_p_group ϕ hϕ,
  is_maximal' := λ Q hQ hle, by
  { rw ← P.3 (hQ.map ϕ) (le_trans (ge_of_eq (map_comap_eq_self h)) (map_mono hle)),
    exact (comap_map_eq_self ((P.1.ker_le_comap ϕ).trans hle)).symm }, }

@[simp] lemma coe_comap_of_ker_is_p_group (hϕ : is_p_group p ϕ.ker) (h : ↑P ≤ ϕ.range) :
  ↑(P.comap_of_ker_is_p_group ϕ hϕ h) = subgroup.comap ϕ ↑P := rfl

/-- The preimage of a Sylow subgroup under an injective homomorphism is a Sylow subgroup. -/
def comap_of_injective (hϕ : function.injective ϕ) (h : ↑P ≤ ϕ.range) : sylow p K :=
P.comap_of_ker_is_p_group ϕ (is_p_group.ker_is_p_group_of_injective hϕ) h

@[simp] lemma coe_comap_of_injective (hϕ : function.injective ϕ) (h : ↑P ≤ ϕ.range) :
  ↑(P.comap_of_injective ϕ hϕ h) = subgroup.comap ϕ ↑P := rfl

/-- A sylow subgroup of G is also a sylow subgroup of a subgroup of G. -/
protected def subtype (h : ↑P ≤ N) : sylow p N :=
P.comap_of_injective N.subtype subtype.coe_injective (by rwa [subtype_range])

@[simp] lemma coe_subtype (h : ↑P ≤ N) : ↑(P.subtype h) = subgroup_of ↑P N := rfl

lemma subtype_injective {P Q : sylow p G} {hP : ↑P ≤ N} {hQ : ↑Q ≤ N}
  (h : P.subtype hP = Q.subtype hQ) : P = Q :=
begin
  rw set_like.ext_iff at h ⊢,
  exact λ g, ⟨λ hg, (h ⟨g, hP hg⟩).mp hg, λ hg, (h ⟨g, hQ hg⟩).mpr hg⟩,
end

end sylow

/-- A generalization of **Sylow's first theorem**.
  Every `p`-subgroup is contained in a Sylow `p`-subgroup. -/
lemma is_p_group.exists_le_sylow {P : subgroup G} (hP : is_p_group p P) :
  ∃ Q : sylow p G, P ≤ Q :=
exists.elim (zorn_nonempty_partial_order₀ {Q : subgroup G | is_p_group p Q} (λ c hc1 hc2 Q hQ,
⟨ { carrier := ⋃ (R : c), R,
    one_mem' := ⟨Q, ⟨⟨Q, hQ⟩, rfl⟩, Q.one_mem⟩,
    inv_mem' := λ g ⟨_, ⟨R, rfl⟩, hg⟩, ⟨R, ⟨R, rfl⟩, R.1.inv_mem hg⟩,
    mul_mem' := λ g h ⟨_, ⟨R, rfl⟩, hg⟩ ⟨_, ⟨S, rfl⟩, hh⟩, (hc2.total R.2 S.2).elim
      (λ T, ⟨S, ⟨S, rfl⟩, S.1.mul_mem (T hg) hh⟩) (λ T, ⟨R, ⟨R, rfl⟩, R.1.mul_mem hg (T hh)⟩) },
  λ ⟨g, _, ⟨S, rfl⟩, hg⟩, by
  { refine exists_imp_exists (λ k hk, _) (hc1 S.2 ⟨g, hg⟩),
    rwa [subtype.ext_iff, coe_pow] at hk ⊢ },
  λ M hM g hg, ⟨M, ⟨⟨M, hM⟩, rfl⟩, hg⟩⟩) P hP) (λ Q ⟨hQ1, hQ2, hQ3⟩, ⟨⟨Q, hQ1, hQ3⟩, hQ2⟩)

instance sylow.nonempty : nonempty (sylow p G) :=
nonempty_of_exists is_p_group.of_bot.exists_le_sylow

noncomputable instance sylow.inhabited : inhabited (sylow p G) :=
classical.inhabited_of_nonempty sylow.nonempty

lemma sylow.exists_comap_eq_of_ker_is_p_group {H : Type*} [group H] (P : sylow p H)
  {f : H →* G} (hf : is_p_group p f.ker) : ∃ Q : sylow p G, (Q : subgroup G).comap f = P :=
exists_imp_exists (λ Q hQ, P.3 (Q.2.comap_of_ker_is_p_group f hf) (map_le_iff_le_comap.mp hQ))
  (P.2.map f).exists_le_sylow

lemma sylow.exists_comap_eq_of_injective {H : Type*} [group H] (P : sylow p H)
  {f : H →* G} (hf : function.injective f) : ∃ Q : sylow p G, (Q : subgroup G).comap f = P :=
P.exists_comap_eq_of_ker_is_p_group (is_p_group.ker_is_p_group_of_injective hf)

lemma sylow.exists_comap_subtype_eq {H : subgroup G} (P : sylow p H) :
  ∃ Q : sylow p G, (Q : subgroup G).comap H.subtype = P :=
P.exists_comap_eq_of_injective subtype.coe_injective

/-- If the kernel of `f : H →* G` is a `p`-group,
  then `fintype (sylow p G)` implies `fintype (sylow p H)`. -/
noncomputable def sylow.fintype_of_ker_is_p_group {H : Type*} [group H]
  {f : H →* G} (hf : is_p_group p f.ker) [fintype (sylow p G)] : fintype (sylow p H) :=
let h_exists := λ P : sylow p H, P.exists_comap_eq_of_ker_is_p_group hf,
  g : sylow p H → sylow p G := λ P, classical.some (h_exists P),
  hg : ∀ P : sylow p H, (g P).1.comap f = P := λ P, classical.some_spec (h_exists P) in
fintype.of_injective g (λ P Q h, sylow.ext (by simp only [←hg, h]))

/-- If `f : H →* G` is injective, then `fintype (sylow p G)` implies `fintype (sylow p H)`. -/
noncomputable def sylow.fintype_of_injective {H : Type*} [group H]
  {f : H →* G} (hf : function.injective f) [fintype (sylow p G)] : fintype (sylow p H) :=
sylow.fintype_of_ker_is_p_group (is_p_group.ker_is_p_group_of_injective hf)

/-- If `H` is a subgroup of `G`, then `fintype (sylow p G)` implies `fintype (sylow p H)`. -/
noncomputable instance (H : subgroup G) [fintype (sylow p G)] : fintype (sylow p H) :=
sylow.fintype_of_injective H.subtype_injective

/-- If `H` is a subgroup of `G`, then `finite (sylow p G)` implies `finite (sylow p H)`. -/
instance (H : subgroup G) [finite (sylow p G)] : finite (sylow p H) :=
by { casesI nonempty_fintype (sylow p G), apply_instance }

open_locale pointwise

/-- `subgroup.pointwise_mul_action` preserves Sylow subgroups. -/
instance sylow.pointwise_mul_action {α : Type*} [group α] [mul_distrib_mul_action α G] :
  mul_action α (sylow p G) :=
{ smul := λ g P, ⟨g • P, P.2.map _, λ Q hQ hS, inv_smul_eq_iff.mp (P.3 (hQ.map _)
    (λ s hs, (congr_arg (∈ g⁻¹ • Q) (inv_smul_smul g s)).mp
      (smul_mem_pointwise_smul (g • s) g⁻¹ Q (hS (smul_mem_pointwise_smul s g P hs)))))⟩,
  one_smul := λ P, sylow.ext (one_smul α P),
  mul_smul := λ g h P, sylow.ext (mul_smul g h P) }

lemma sylow.pointwise_smul_def {α : Type*} [group α] [mul_distrib_mul_action α G]
  {g : α} {P : sylow p G} : ↑(g • P) = g • (P : subgroup G) := rfl

instance sylow.mul_action : mul_action G (sylow p G) :=
comp_hom _ mul_aut.conj

lemma sylow.smul_def {g : G} {P : sylow p G} : g • P = mul_aut.conj g • P := rfl

lemma sylow.coe_subgroup_smul {g : G} {P : sylow p G} :
  ↑(g • P) = mul_aut.conj g • (P : subgroup G) := rfl

lemma sylow.coe_smul {g : G} {P : sylow p G} :
  ↑(g • P) = mul_aut.conj g • (P : set G) := rfl

lemma sylow.smul_le {P : sylow p G} {H : subgroup G} (hP : ↑P ≤ H) (h : H) : ↑(h • P) ≤ H :=
subgroup.conj_smul_le_of_le hP h

lemma sylow.smul_subtype {P : sylow p G} {H : subgroup G} (hP : ↑P ≤ H) (h : H) :
  h • P.subtype hP = (h • P).subtype (sylow.smul_le hP h) :=
sylow.ext (subgroup.conj_smul_subgroup_of hP h)

lemma sylow.smul_eq_iff_mem_normalizer {g : G} {P : sylow p G} :
  g • P = P ↔ g ∈ (P : subgroup G).normalizer :=
begin
  rw [eq_comm, set_like.ext_iff, ←inv_mem_iff, mem_normalizer_iff, inv_inv],
  exact forall_congr (λ h, iff_congr iff.rfl ⟨λ ⟨a, b, c⟩, (congr_arg _ c).mp
    ((congr_arg (∈ P.1) (mul_aut.inv_apply_self G (mul_aut.conj g) a)).mpr b),
    λ hh, ⟨(mul_aut.conj g)⁻¹ h, hh, mul_aut.apply_inv_self G (mul_aut.conj g) h⟩⟩),
end

lemma sylow.smul_eq_of_normal {g : G} {P : sylow p G} [h : (P : subgroup G).normal] :
  g • P = P :=
by simp only [sylow.smul_eq_iff_mem_normalizer, normalizer_eq_top.mpr h, mem_top]

lemma subgroup.sylow_mem_fixed_points_iff (H : subgroup G) {P : sylow p G} :
  P ∈ fixed_points H (sylow p G) ↔ H ≤ (P : subgroup G).normalizer :=
by simp_rw [set_like.le_def, ←sylow.smul_eq_iff_mem_normalizer]; exact subtype.forall

lemma is_p_group.inf_normalizer_sylow {P : subgroup G} (hP : is_p_group p P) (Q : sylow p G) :
  P ⊓ (Q : subgroup G).normalizer = P ⊓ Q :=
le_antisymm (le_inf inf_le_left (sup_eq_right.mp (Q.3 (hP.to_inf_left.to_sup_of_normal_right'
  Q.2 inf_le_right) le_sup_right))) (inf_le_inf_left P le_normalizer)

lemma is_p_group.sylow_mem_fixed_points_iff
  {P : subgroup G} (hP : is_p_group p P) {Q : sylow p G} :
  Q ∈ fixed_points P (sylow p G) ↔ P ≤ Q :=
by rw [P.sylow_mem_fixed_points_iff, ←inf_eq_left, hP.inf_normalizer_sylow, inf_eq_left]

/-- A generalization of **Sylow's second theorem**.
  If the number of Sylow `p`-subgroups is finite, then all Sylow `p`-subgroups are conjugate. -/
instance [hp : fact p.prime] [finite (sylow p G)] : is_pretransitive G (sylow p G) :=
⟨λ P Q, by
{ classical,
  casesI nonempty_fintype (sylow p G),
  have H := λ {R : sylow p G} {S : orbit G P},
  calc S ∈ fixed_points R (orbit G P)
      ↔ S.1 ∈ fixed_points R (sylow p G) : forall_congr (λ a, subtype.ext_iff)
  ... ↔ R.1 ≤ S : R.2.sylow_mem_fixed_points_iff
  ... ↔ S.1.1 = R : ⟨λ h, R.3 S.1.2 h, ge_of_eq⟩,
  suffices : set.nonempty (fixed_points Q (orbit G P)),
  { exact exists.elim this (λ R hR, (congr_arg _ (sylow.ext (H.mp hR))).mp R.2) },
  apply Q.2.nonempty_fixed_point_of_prime_not_dvd_card,
  refine λ h, hp.out.not_dvd_one (nat.modeq_zero_iff_dvd.mp _),
  calc 1 = card (fixed_points P (orbit G P)) : _
     ... ≡ card (orbit G P) [MOD p] : (P.2.card_modeq_card_fixed_points (orbit G P)).symm
     ... ≡ 0 [MOD p] : nat.modeq_zero_iff_dvd.mpr h,
  rw ← set.card_singleton (⟨P, mem_orbit_self P⟩ : orbit G P),
  refine card_congr' (congr_arg _ (eq.symm _)),
  rw set.eq_singleton_iff_unique_mem,
  exact ⟨H.mpr rfl, λ R h, subtype.ext (sylow.ext (H.mp h))⟩ }⟩

variables (p) (G)

/-- A generalization of **Sylow's third theorem**.
  If the number of Sylow `p`-subgroups is finite, then it is congruent to `1` modulo `p`. -/
lemma card_sylow_modeq_one [fact p.prime] [fintype (sylow p G)] : card (sylow p G) ≡ 1 [MOD p] :=
begin
  refine sylow.nonempty.elim (λ P : sylow p G, _),
  have : fixed_points P.1 (sylow p G) = {P} :=
  set.ext (λ Q : sylow p G, calc Q ∈ fixed_points P (sylow p G)
      ↔ P.1 ≤ Q : P.2.sylow_mem_fixed_points_iff
  ... ↔ Q.1 = P.1 : ⟨P.3 Q.2, ge_of_eq⟩
  ... ↔ Q ∈ {P} : sylow.ext_iff.symm.trans set.mem_singleton_iff.symm),
  haveI : fintype (fixed_points P.1 (sylow p G)), { rw this, apply_instance },
  have : card (fixed_points P.1 (sylow p G)) = 1, { simp [this] },
  exact (P.2.card_modeq_card_fixed_points (sylow p G)).trans (by rw this),
end

lemma not_dvd_card_sylow [hp : fact p.prime] [fintype (sylow p G)] : ¬ p ∣ card (sylow p G) :=
λ h, hp.1.ne_one (nat.dvd_one.mp ((nat.modeq_iff_dvd' zero_le_one).mp
  ((nat.modeq_zero_iff_dvd.mpr h).symm.trans (card_sylow_modeq_one p G))))

variables {p} {G}

/-- Sylow subgroups are isomorphic -/
def sylow.equiv_smul (P : sylow p G) (g : G) : P ≃* (g • P : sylow p G) :=
equiv_smul (mul_aut.conj g) ↑P

/-- Sylow subgroups are isomorphic -/
noncomputable def sylow.equiv [fact p.prime] [finite (sylow p G)] (P Q : sylow p G) :
  P ≃* Q :=
begin
  rw ← classical.some_spec (exists_smul_eq G P Q),
  exact P.equiv_smul (classical.some (exists_smul_eq G P Q)),
end

@[simp] lemma sylow.orbit_eq_top [fact p.prime] [finite (sylow p G)] (P : sylow p G) :
  orbit G P = ⊤ :=
top_le_iff.mp (λ Q hQ, exists_smul_eq G P Q)

lemma sylow.stabilizer_eq_normalizer (P : sylow p G) :
  stabilizer G P = (P : subgroup G).normalizer :=
ext (λ g, sylow.smul_eq_iff_mem_normalizer)

lemma sylow.conj_eq_normalizer_conj_of_mem_centralizer
  [fact p.prime] [finite (sylow p G)] (P : sylow p G) (x g : G)
  (hx : x ∈ (P : subgroup G).centralizer) (hy : g⁻¹ * x * g ∈ (P : subgroup G).centralizer) :
  ∃ n ∈ (P : subgroup G).normalizer, g⁻¹ * x * g = n⁻¹ * x * n :=
begin
  have h1 : ↑P ≤ (zpowers x).centralizer,
  { rwa [le_centralizer_iff, zpowers_le] },
  have h2 : ↑(g • P) ≤ (zpowers x).centralizer,
  { rw [le_centralizer_iff, zpowers_le],
    rintros - ⟨z, hz, rfl⟩,
    specialize hy z hz,
    rwa [←mul_assoc, ←eq_mul_inv_iff_mul_eq, mul_assoc, mul_assoc, mul_assoc, ←mul_assoc,
      eq_inv_mul_iff_mul_eq, ←mul_assoc, ←mul_assoc] at hy },
  obtain ⟨h, hh⟩ := exists_smul_eq (zpowers x).centralizer ((g • P).subtype h2) (P.subtype h1),
  simp_rw [sylow.smul_subtype, smul_def, smul_smul] at hh,
  refine ⟨h * g, sylow.smul_eq_iff_mem_normalizer.mp (sylow.subtype_injective hh), _⟩,
  rw [←mul_assoc, commute.right_comm (h.prop x (mem_zpowers x)), mul_inv_rev, inv_mul_cancel_right]
end

lemma sylow.conj_eq_normalizer_conj_of_mem [fact p.prime] [finite (sylow p G)] (P : sylow p G)
  [hP : (P : subgroup G).is_commutative] (x g : G) (hx : x ∈ P) (hy : g⁻¹ * x * g ∈ P) :
  ∃ n ∈ (P : subgroup G).normalizer, g⁻¹ * x * g = n⁻¹ * x * n :=
P.conj_eq_normalizer_conj_of_mem_centralizer x g (le_centralizer P hx) (le_centralizer P hy)

/-- Sylow `p`-subgroups are in bijection with cosets of the normalizer of a Sylow `p`-subgroup -/
noncomputable def sylow.equiv_quotient_normalizer [fact p.prime] [fintype (sylow p G)]
  (P : sylow p G) : sylow p G ≃ G ⧸ (P : subgroup G).normalizer :=
calc sylow p G ≃ (⊤ : set (sylow p G)) : (equiv.set.univ (sylow p G)).symm
... ≃ orbit G P : by rw P.orbit_eq_top
... ≃ G ⧸ (stabilizer G P) : orbit_equiv_quotient_stabilizer G P
... ≃ G ⧸ (P : subgroup G).normalizer : by rw P.stabilizer_eq_normalizer

noncomputable instance [fact p.prime] [fintype (sylow p G)] (P : sylow p G) :
  fintype (G ⧸ (P : subgroup G).normalizer) :=
of_equiv (sylow p G) P.equiv_quotient_normalizer

lemma card_sylow_eq_card_quotient_normalizer [fact p.prime] [fintype (sylow p G)] (P : sylow p G) :
  card (sylow p G) = card (G ⧸ (P : subgroup G).normalizer) :=
card_congr P.equiv_quotient_normalizer

lemma card_sylow_eq_index_normalizer [fact p.prime] [fintype (sylow p G)] (P : sylow p G) :
  card (sylow p G) = (P : subgroup G).normalizer.index :=
(card_sylow_eq_card_quotient_normalizer P).trans (P : subgroup G).normalizer.index_eq_card.symm

lemma card_sylow_dvd_index [fact p.prime] [fintype (sylow p G)] (P : sylow p G) :
  card (sylow p G) ∣ (P : subgroup G).index :=
((congr_arg _ (card_sylow_eq_index_normalizer P)).mp dvd_rfl).trans (index_dvd_of_le le_normalizer)

lemma not_dvd_index_sylow' [hp : fact p.prime] (P : sylow p G) [(P : subgroup G).normal]
  [finite_index (P : subgroup G)] : ¬ p ∣ (P : subgroup G).index :=
begin
  intro h,
  haveI := (P : subgroup G).fintype_quotient_of_finite_index,
  rw index_eq_card at h,
  obtain ⟨x, hx⟩ := exists_prime_order_of_dvd_card p h,
  have h := is_p_group.of_card ((order_eq_card_zpowers.symm.trans hx).trans (pow_one p).symm),
  let Q := (zpowers x).comap (quotient_group.mk' (P : subgroup G)),
  have hQ : is_p_group p Q,
  { apply h.comap_of_ker_is_p_group,
    rw [quotient_group.ker_mk],
    exact P.2 },
  replace hp := mt order_of_eq_one_iff.mpr (ne_of_eq_of_ne hx hp.1.ne_one),
  rw [←zpowers_eq_bot, ←ne, ←bot_lt_iff_ne_bot, ←comap_lt_comap_of_surjective
    (quotient_group.mk'_surjective _), monoid_hom.comap_bot, quotient_group.ker_mk] at hp,
  exact hp.ne' (P.3 hQ hp.le),
end

lemma not_dvd_index_sylow [hp : fact p.prime] [finite (sylow p G)] (P : sylow p G)
  (hP : relindex ↑P (P : subgroup G).normalizer ≠ 0) : ¬ p ∣ (P : subgroup G).index :=
begin
  casesI nonempty_fintype (sylow p G),
  rw [←relindex_mul_index le_normalizer, ←card_sylow_eq_index_normalizer],
  haveI : (P.subtype le_normalizer : subgroup (P : subgroup G).normalizer).normal :=
  subgroup.normal_in_normalizer,
  haveI : finite_index ↑(P.subtype le_normalizer) := ⟨hP⟩,
  replace hP := not_dvd_index_sylow' (P.subtype le_normalizer),
  exact hp.1.not_dvd_mul hP (not_dvd_card_sylow p G),
end

/-- **Frattini's Argument**: If `N` is a normal subgroup of `G`, and if `P` is a Sylow `p`-subgroup
  of `N`, then `N_G(P) ⊔ N = G`. -/
lemma sylow.normalizer_sup_eq_top {p : ℕ} [fact p.prime] {N : subgroup G} [N.normal]
  [finite (sylow p N)] (P : sylow p N) : ((↑P : subgroup N).map N.subtype).normalizer ⊔ N = ⊤ :=
begin
  refine top_le_iff.mp (λ g hg, _),
  obtain ⟨n, hn⟩ := exists_smul_eq N ((mul_aut.conj_normal g : mul_aut N) • P) P,
  rw [←inv_mul_cancel_left ↑n g, sup_comm],
  apply mul_mem_sup (N.inv_mem n.2),
  rw [sylow.smul_def, ←mul_smul, ←mul_aut.conj_normal_coe, ←mul_aut.conj_normal.map_mul,
      sylow.ext_iff, sylow.pointwise_smul_def, pointwise_smul_def] at hn,
  refine λ x, (mem_map_iff_mem (show function.injective (mul_aut.conj (↑n * g)).to_monoid_hom,
    from (mul_aut.conj (↑n * g)).injective)).symm.trans _,
  rw [map_map, ←(congr_arg (map N.subtype) hn), map_map],
  refl,
end

/-- **Frattini's Argument**: If `N` is a normal subgroup of `G`, and if `P` is a Sylow `p`-subgroup
  of `N`, then `N_G(P) ⊔ N = G`. -/
lemma sylow.normalizer_sup_eq_top' {p : ℕ} [fact p.prime] {N : subgroup G} [N.normal]
  [finite (sylow p N)] (P : sylow p G) (hP : ↑P ≤ N) : (P : subgroup G).normalizer ⊔ N = ⊤ :=
by rw [← sylow.normalizer_sup_eq_top (P.subtype hP), P.coe_subtype, subgroup_of_map_subtype,
  inf_of_le_left hP]

end infinite_sylow

open equiv equiv.perm finset function list quotient_group
open_locale big_operators
universes u v w
variables {G : Type u} {α : Type v} {β : Type w} [group G]

local attribute [instance, priority 10] subtype.fintype set_fintype classical.prop_decidable

lemma quotient_group.card_preimage_mk [fintype G] (s : subgroup G)
  (t : set (G ⧸ s)) : fintype.card (quotient_group.mk ⁻¹' t) =
  fintype.card s * fintype.card t :=
by rw [← fintype.card_prod, fintype.card_congr
  (preimage_mk_equiv_subgroup_times_set _ _)]

namespace sylow

open subgroup submonoid mul_action

lemma mem_fixed_points_mul_left_cosets_iff_mem_normalizer {H : subgroup G} [finite ↥(H : set G)]
  {x : G} :
  (x : G ⧸ H) ∈ fixed_points H (G ⧸ H) ↔ x ∈ normalizer H :=
⟨λ hx, have ha : ∀ {y : G ⧸ H}, y ∈ orbit H (x : G ⧸ H) → y = x,
  from λ _, ((mem_fixed_points' _).1 hx _),
  inv_mem_iff.1 (mem_normalizer_fintype (λ n (hn : n ∈ H),
    have (n⁻¹ * x)⁻¹ * x ∈ H := quotient_group.eq.1 (ha (mem_orbit _ ⟨n⁻¹, H.inv_mem hn⟩)),
    show _ ∈ H, by {rw [mul_inv_rev, inv_inv] at this, convert this, rw inv_inv}
    )),
λ (hx : ∀ (n : G), n ∈ H ↔ x * n * x⁻¹ ∈ H),
(mem_fixed_points' _).2 $ λ y, quotient.induction_on' y $ λ y hy, quotient_group.eq.2
  (let ⟨⟨b, hb₁⟩, hb₂⟩ := hy in
  have hb₂ : (b * x)⁻¹ * y ∈ H := quotient_group.eq.1 hb₂,
  inv_mem_iff.1 $ (hx _).2 $ (mul_mem_cancel_left (inv_mem hb₁)).1
  $ by rw hx at hb₂;
    simpa [mul_inv_rev, mul_assoc] using hb₂)⟩

/-- The fixed points of the action of `H` on its cosets correspond to `normalizer H / H`. -/
def fixed_points_mul_left_cosets_equiv_quotient (H : subgroup G) [finite (H : set G)] :
  mul_action.fixed_points H (G ⧸ H) ≃
  normalizer H ⧸ (subgroup.comap ((normalizer H).subtype : normalizer H →* G) H) :=
@subtype_quotient_equiv_quotient_subtype G (normalizer H : set G) (id _) (id _) (fixed_points _ _)
  (λ a, (@mem_fixed_points_mul_left_cosets_iff_mem_normalizer _ _ _ ‹_› _).symm)
  (by { intros, rw setoid_has_equiv, simp only [left_rel_apply], refl })

/-- If `H` is a `p`-subgroup of `G`, then the index of `H` inside its normalizer is congruent
  mod `p` to the index of `H`.  -/
lemma card_quotient_normalizer_modeq_card_quotient [fintype G] {p : ℕ} {n : ℕ} [hp : fact p.prime]
  {H : subgroup G} (hH : fintype.card H = p ^ n) :
  card (normalizer H ⧸ (subgroup.comap ((normalizer H).subtype : normalizer H →* G) H))
  ≡ card (G ⧸ H) [MOD p] :=
begin
  rw [← fintype.card_congr (fixed_points_mul_left_cosets_equiv_quotient H)],
  exact ((is_p_group.of_card hH).card_modeq_card_fixed_points _).symm
end

/-- If `H` is a subgroup of `G` of cardinality `p ^ n`, then the cardinality of the
  normalizer of `H` is congruent mod `p ^ (n + 1)` to the cardinality of `G`.  -/
lemma card_normalizer_modeq_card [fintype G] {p : ℕ} {n : ℕ} [hp : fact p.prime]
  {H : subgroup G} (hH : fintype.card H = p ^ n) :
  card (normalizer H) ≡ card G [MOD p ^ (n + 1)] :=
have H.subgroup_of (normalizer H) ≃ H, from (subgroup_of_equiv_of_le le_normalizer).to_equiv,
begin
  rw [card_eq_card_quotient_mul_card_subgroup H,
      card_eq_card_quotient_mul_card_subgroup (H.subgroup_of (normalizer H)),
      fintype.card_congr this, hH, pow_succ],
  exact (card_quotient_normalizer_modeq_card_quotient hH).mul_right' _
end

/-- If `H` is a `p`-subgroup but not a Sylow `p`-subgroup, then `p` divides the
  index of `H` inside its normalizer. -/
lemma prime_dvd_card_quotient_normalizer [fintype G] {p : ℕ} {n : ℕ} [hp : fact p.prime]
  (hdvd : p ^ (n + 1) ∣ card G) {H : subgroup G} (hH : fintype.card H = p ^ n) :
  p ∣ card (normalizer H ⧸ (subgroup.comap ((normalizer H).subtype : normalizer H →* G) H)) :=
let ⟨s, hs⟩ := exists_eq_mul_left_of_dvd hdvd in
have hcard : card (G ⧸ H) = s * p :=
  (mul_left_inj' (show card H ≠ 0, from fintype.card_ne_zero)).1
    (by rwa [← card_eq_card_quotient_mul_card_subgroup H, hH, hs,
      pow_succ', mul_assoc, mul_comm p]),
have hm : s * p % p =
  card (normalizer H ⧸ (subgroup.comap ((normalizer H).subtype : normalizer H →* G) H)) % p :=
  hcard ▸ (card_quotient_normalizer_modeq_card_quotient hH).symm,
nat.dvd_of_mod_eq_zero
  (by rwa [nat.mod_eq_zero_of_dvd (dvd_mul_left _ _), eq_comm] at hm)

/-- If `H` is a `p`-subgroup but not a Sylow `p`-subgroup of cardinality `p ^ n`,
  then `p ^ (n + 1)` divides the cardinality of the normalizer of `H`. -/
lemma prime_pow_dvd_card_normalizer [fintype G] {p : ℕ} {n : ℕ} [hp : fact p.prime]
  (hdvd : p ^ (n + 1) ∣ card G) {H : subgroup G} (hH : fintype.card H = p ^ n) :
  p ^ (n + 1) ∣ card (normalizer H) :=
nat.modeq_zero_iff_dvd.1 ((card_normalizer_modeq_card hH).trans
  hdvd.modeq_zero_nat)

/-- If `H` is a subgroup of `G` of cardinality `p ^ n`,
  then `H` is contained in a subgroup of cardinality `p ^ (n + 1)`
  if `p ^ (n + 1)` divides the cardinality of `G` -/
theorem exists_subgroup_card_pow_succ [fintype G] {p : ℕ} {n : ℕ} [hp : fact p.prime]
  (hdvd : p ^ (n + 1) ∣ card G) {H : subgroup G} (hH : fintype.card H = p ^ n) :
  ∃ K : subgroup G, fintype.card K = p ^ (n + 1) ∧ H ≤ K :=
let ⟨s, hs⟩ := exists_eq_mul_left_of_dvd hdvd in
have hcard : card (G ⧸ H) = s * p :=
  (mul_left_inj' (show card H ≠ 0, from fintype.card_ne_zero)).1
    (by rwa [← card_eq_card_quotient_mul_card_subgroup H, hH, hs,
      pow_succ', mul_assoc, mul_comm p]),
have hm : s * p % p =
  card (normalizer H ⧸ (H.subgroup_of H.normalizer)) % p :=
  card_congr (fixed_points_mul_left_cosets_equiv_quotient H) ▸ hcard ▸
    (is_p_group.of_card hH).card_modeq_card_fixed_points _,
have hm' : p ∣ card (normalizer H ⧸ (H.subgroup_of H.normalizer)) :=
  nat.dvd_of_mod_eq_zero
    (by rwa [nat.mod_eq_zero_of_dvd (dvd_mul_left _ _), eq_comm] at hm),
let ⟨x, hx⟩ := @exists_prime_order_of_dvd_card _ (quotient_group.quotient.group _) _ _ hp hm' in
have hequiv : H ≃ (H.subgroup_of H.normalizer) :=
  (subgroup_of_equiv_of_le le_normalizer).symm.to_equiv,
⟨subgroup.map ((normalizer H).subtype)
  (subgroup.comap (mk' (H.subgroup_of H.normalizer)) (zpowers x)),
begin
  show card ↥(map H.normalizer.subtype
    (comap (mk' (H.subgroup_of H.normalizer)) (subgroup.zpowers x))) = p ^ (n + 1),
  suffices : card ↥(subtype.val '' ((subgroup.comap (mk' (H.subgroup_of H.normalizer))
    (zpowers x)) : set (↥(H.normalizer)))) = p^(n+1),
  { convert this using 2 },
  rw [set.card_image_of_injective
        (subgroup.comap (mk' (H.subgroup_of H.normalizer)) (zpowers x) : set (H.normalizer))
        subtype.val_injective,
      pow_succ', ← hH, fintype.card_congr hequiv, ← hx, order_eq_card_zpowers,
      ← fintype.card_prod],
  exact @fintype.card_congr _ _ (id _) (id _) (preimage_mk_equiv_subgroup_times_set _ _)
end,
begin
  assume y hy,
  simp only [exists_prop, subgroup.coe_subtype, mk'_apply, subgroup.mem_map, subgroup.mem_comap],
  refine ⟨⟨y, le_normalizer hy⟩, ⟨0, _⟩, rfl⟩,
  rw [zpow_zero, eq_comm, quotient_group.eq_one_iff],
  simpa using hy
end⟩

/-- If `H` is a subgroup of `G` of cardinality `p ^ n`,
  then `H` is contained in a subgroup of cardinality `p ^ m`
  if `n ≤ m` and `p ^ m` divides the cardinality of `G` -/
theorem exists_subgroup_card_pow_prime_le [fintype G] (p : ℕ) : ∀ {n m : ℕ} [hp : fact p.prime]
  (hdvd : p ^ m ∣ card G) (H : subgroup G) (hH : card H = p ^ n) (hnm : n ≤ m),
  ∃ K : subgroup G, card K = p ^ m ∧ H ≤ K
| n m := λ hp hdvd H hH hnm,
  (lt_or_eq_of_le hnm).elim
    (λ hnm : n < m,
      have h0m : 0 < m, from (lt_of_le_of_lt n.zero_le hnm),
      have wf : m - 1 < m,  from nat.sub_lt h0m zero_lt_one,
      have hnm1 : n ≤ m - 1, from le_tsub_of_add_le_right hnm,
      let ⟨K, hK⟩ := @exists_subgroup_card_pow_prime_le n (m - 1) hp
        (nat.pow_dvd_of_le_of_pow_dvd tsub_le_self hdvd) H hH hnm1 in
      have hdvd' : p ^ ((m - 1) + 1) ∣ card G, by rwa [tsub_add_cancel_of_le h0m.nat_succ_le],
      let ⟨K', hK'⟩ := @exists_subgroup_card_pow_succ _ _ _ _ _ hp hdvd' K hK.1 in
      ⟨K', by rw [hK'.1, tsub_add_cancel_of_le h0m.nat_succ_le], le_trans hK.2 hK'.2⟩)
    (λ hnm : n = m, ⟨H, by simp [hH, hnm]⟩)

/-- A generalisation of **Sylow's first theorem**. If `p ^ n` divides
  the cardinality of `G`, then there is a subgroup of cardinality `p ^ n` -/
theorem exists_subgroup_card_pow_prime [fintype G] (p : ℕ) {n : ℕ} [fact p.prime]
  (hdvd : p ^ n ∣ card G) : ∃ K : subgroup G, fintype.card K = p ^ n :=
let ⟨K, hK⟩ := exists_subgroup_card_pow_prime_le p hdvd ⊥ (by simp) n.zero_le in
⟨K, hK.1⟩

lemma pow_dvd_card_of_pow_dvd_card [fintype G] {p n : ℕ} [hp : fact p.prime] (P : sylow p G)
  (hdvd : p ^ n ∣ card G) : p ^ n ∣ card P :=
(hp.1.coprime_pow_of_not_dvd (not_dvd_index_sylow P
  index_ne_zero_of_finite)).symm.dvd_of_dvd_mul_left ((index_mul_card P.1).symm ▸ hdvd)

lemma dvd_card_of_dvd_card [fintype G] {p : ℕ} [fact p.prime] (P : sylow p G)
  (hdvd : p ∣ card G) : p ∣ card P :=
begin
  rw ← pow_one p at hdvd,
  have key := P.pow_dvd_card_of_pow_dvd_card hdvd,
  rwa pow_one at key,
end

/-- Sylow subgroups are Hall subgroups. -/
lemma card_coprime_index [fintype G] {p : ℕ} [hp : fact p.prime] (P : sylow p G) :
  (card P).coprime (index (P : subgroup G)) :=
let ⟨n, hn⟩ := is_p_group.iff_card.mp P.2 in
hn.symm ▸ (hp.1.coprime_pow_of_not_dvd (not_dvd_index_sylow P index_ne_zero_of_finite)).symm

lemma ne_bot_of_dvd_card [fintype G] {p : ℕ} [hp : fact p.prime] (P : sylow p G)
  (hdvd : p ∣ card G) : (P : subgroup G) ≠ ⊥ :=
begin
  refine λ h, hp.out.not_dvd_one _,
  have key : p ∣ card (P : subgroup G) := P.dvd_card_of_dvd_card hdvd,
  rwa [h, card_bot] at key,
end

/-- The cardinality of a Sylow group is `p ^ n`
 where `n` is the multiplicity of `p` in the group order. -/
lemma card_eq_multiplicity [fintype G] {p : ℕ} [hp : fact p.prime] (P : sylow p G) :
  card P = p ^ nat.factorization (card G) p :=
begin
  obtain ⟨n, heq : card P = _⟩ := is_p_group.iff_card.mp (P.is_p_group'),
  refine nat.dvd_antisymm _ (P.pow_dvd_card_of_pow_dvd_card (nat.ord_proj_dvd _ p)),
  rw [heq, ←hp.out.pow_dvd_iff_dvd_ord_proj (show card G ≠ 0, from card_ne_zero), ←heq],
  exact P.1.card_subgroup_dvd_card,
end

lemma subsingleton_of_normal {p : ℕ} [fact p.prime] [finite (sylow p G)] (P : sylow p G)
  (h : (P : subgroup G).normal) : subsingleton (sylow p G) :=
begin
  apply subsingleton.intro,
  intros Q R,
  obtain ⟨x, h1⟩ := exists_smul_eq G P Q,
  obtain ⟨x, h2⟩ := exists_smul_eq G P R,
  rw sylow.smul_eq_of_normal at h1 h2,
  rw [← h1, ← h2],
end

section pointwise

open_locale pointwise

lemma characteristic_of_normal {p : ℕ} [fact p.prime] [finite (sylow p G)] (P : sylow p G)
  (h : (P : subgroup G).normal) :
  (P : subgroup G).characteristic :=
begin
  haveI := sylow.subsingleton_of_normal P h,
  rw characteristic_iff_map_eq,
  intros Φ,
  show (Φ • P).to_subgroup = P.to_subgroup,
  congr,
end

end pointwise

lemma normal_of_normalizer_normal {p : ℕ} [fact p.prime] [finite (sylow p G)]
  (P : sylow p G) (hn : (↑P : subgroup G).normalizer.normal) :
  (↑P : subgroup G).normal :=
by rw [← normalizer_eq_top, ← normalizer_sup_eq_top' P le_normalizer, sup_idem]

@[simp] lemma normalizer_normalizer {p : ℕ} [fact p.prime] [finite (sylow p G)] (P : sylow p G) :
 (↑P : subgroup G).normalizer.normalizer = (↑P : subgroup G).normalizer :=
begin
  have := normal_of_normalizer_normal (P.subtype (le_normalizer.trans le_normalizer)),
  simp_rw [←normalizer_eq_top, coe_subtype, ← subgroup_of_normalizer_eq le_normalizer,
    ← subgroup_of_normalizer_eq le_rfl, subgroup_of_self] at this,
  rw [←subtype_range (P : subgroup G).normalizer.normalizer, monoid_hom.range_eq_map, ←this rfl],
  exact map_comap_eq_self (le_normalizer.trans (ge_of_eq (subtype_range _))),
end

lemma normal_of_all_max_subgroups_normal [finite G]
  (hnc : ∀ (H : subgroup G), is_coatom H → H.normal)
  {p : ℕ} [fact p.prime] [finite (sylow p G)] (P : sylow p G) :
  (↑P : subgroup G).normal :=
normalizer_eq_top.mp begin
  rcases eq_top_or_exists_le_coatom ((↑P : subgroup G).normalizer) with heq | ⟨K, hK, hNK⟩,
  { exact heq },
  { haveI := hnc _ hK,
    have hPK : ↑P ≤ K := le_trans le_normalizer hNK,
    refine (hK.1 _).elim,
    rw [← sup_of_le_right hNK, P.normalizer_sup_eq_top' hPK] },
end

lemma normal_of_normalizer_condition (hnc : normalizer_condition G)
 {p : ℕ} [fact p.prime] [finite (sylow p G)] (P : sylow p G) :
 (↑P : subgroup G).normal :=
normalizer_eq_top.mp $ normalizer_condition_iff_only_full_group_self_normalizing.mp hnc _ $
  normalizer_normalizer _

open_locale big_operators

/-- If all its sylow groups are normal, then a finite group is isomorphic to the direct product
of these sylow groups.
-/
noncomputable
def direct_product_of_normal [fintype G]
  (hn : ∀ {p : ℕ} [fact p.prime] (P : sylow p G), (↑P : subgroup G).normal) :
  (Π p : (card G).factorization.support, Π P : sylow p G, (↑P : subgroup G)) ≃* G :=
begin
  set ps := (fintype.card G).factorization.support,

  -- “The” sylow group for p
  let P : Π p, sylow p G := default,

  have hcomm : pairwise (λ (p₁ p₂ : ps), ∀ (x y : G), x ∈ P p₁ → y ∈ P p₂ → commute x y),
  { rintros ⟨p₁, hp₁⟩ ⟨p₂, hp₂⟩ hne,
    haveI hp₁' := fact.mk (nat.prime_of_mem_factorization hp₁),
    haveI hp₂' := fact.mk (nat.prime_of_mem_factorization hp₂),
    have hne' : p₁ ≠ p₂, by simpa using hne,
    apply subgroup.commute_of_normal_of_disjoint _ _ (hn (P p₁)) (hn (P p₂)),
    apply is_p_group.disjoint_of_ne p₁ p₂ hne' _ _ (P p₁).is_p_group' (P p₂).is_p_group', },

  refine mul_equiv.trans _ _,
  -- There is only one sylow group for each p, so the inner product is trivial
  show (Π p : ps, Π P : sylow p G, P) ≃* (Π p : ps, P p),
  { -- here we need to help the elaborator with an explicit instantiation
    apply @mul_equiv.Pi_congr_right ps (λ p, (Π P : sylow p G, P)) (λ p, P p) _ _ ,
    rintro ⟨p, hp⟩,
    haveI hp' := fact.mk (nat.prime_of_mem_factorization hp),
    haveI := subsingleton_of_normal _ (hn (P p)),
    change (Π (P : sylow p G), P) ≃* P p,
    exact mul_equiv.Pi_subsingleton _ _, },

  show (Π p : ps, P p) ≃* G,
  apply mul_equiv.of_bijective (subgroup.noncomm_pi_coprod hcomm),
  apply (bijective_iff_injective_and_card _).mpr,
  split,

  show injective _,
  { apply subgroup.injective_noncomm_pi_coprod_of_independent,
    apply independent_of_coprime_order hcomm,
    rintros ⟨p₁, hp₁⟩ ⟨p₂, hp₂⟩ hne,
    haveI hp₁' := fact.mk (nat.prime_of_mem_factorization hp₁),
    haveI hp₂' := fact.mk (nat.prime_of_mem_factorization hp₂),
    have hne' : p₁ ≠ p₂, by simpa using hne,
    apply is_p_group.coprime_card_of_ne p₁ p₂ hne' _ _ (P p₁).is_p_group' (P p₂).is_p_group', },

  show card (Π (p : ps), P p) = card G,
  { calc card (Π (p : ps), P p)
        = ∏ (p : ps), card ↥(P p) : fintype.card_pi
    ... = ∏ (p : ps), p.1 ^ (card G).factorization p.1 :
      begin
        congr' 1 with ⟨p, hp⟩,
        exact @card_eq_multiplicity _ _ _ p ⟨nat.prime_of_mem_factorization hp⟩ (P p)
      end
    ... = ∏ p in ps, p ^ (card G).factorization p :
      finset.prod_finset_coe (λ p, p ^ (card G).factorization p) _
    ... = (card G).factorization.prod pow : rfl
    ... = card G : nat.factorization_prod_pow_eq_self fintype.card_ne_zero }
end

end sylow