/-
Copyright (c) 2021 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import algebra.order.archimedean
import algebra.order.floor
import algebra.order.sub
import algebra.order.with_zero
import order.lattice_intervals
import order.complete_lattice_intervals

/-!
# The type of nonnegative elements

This file defines instances and prove some properties about the nonnegative elements
`{x : α // 0 ≤ x}` of an arbitrary type `α`.

Currently we only state instances and states some `simp`/`norm_cast` lemmas.

When `α` is `ℝ`, this will give us some properties about `ℝ≥0`.

## Main declarations

* `{x : α // 0 ≤ x}` is a `canonically_linear_ordered_add_monoid` if `α` is a `linear_ordered_ring`.
* `{x : α // 0 ≤ x}` is a `linear_ordered_comm_group_with_zero` if `α` is a `linear_ordered_field`.

## Implementation Notes

Instead of `{x : α // 0 ≤ x}` we could also use `set.Ici (0 : α)`, which is definitionally equal.
However, using the explicit subtype has a big advantage: when writing and element explicitly
with a proof of nonnegativity as `⟨x, hx⟩`, the `hx` is expected to have type `0 ≤ x`. If we would
use `Ici 0`, then the type is expected to be `x ∈ Ici 0`. Although these types are definitionally
equal, this often confuses the elaborator. Similar problems arise when doing cases on an element.

The disadvantage is that we have to duplicate some instances about `set.Ici` to this subtype.
-/

open set

variables {α : Type*}

namespace nonneg

/-- This instance uses data fields from `subtype.partial_order` to help type-class inference.
The `set.Ici` data fields are definitionally equal, but that requires unfolding semireducible
definitions, so type-class inference won't see this. -/
instance order_bot [preorder α] {a : α} : order_bot {x : α // a ≤ x} :=
{ ..set.Ici.order_bot }

lemma bot_eq [preorder α] {a : α} : (⊥ : {x : α // a ≤ x}) = ⟨a, le_rfl⟩ := rfl

instance no_max_order [partial_order α] [no_max_order α] {a : α} : no_max_order {x : α // a ≤ x} :=
set.Ici.no_max_order

instance semilattice_inf [semilattice_inf α] {a : α} : semilattice_inf {x : α // a ≤ x} :=
set.Ici.semilattice_inf

instance densely_ordered [preorder α] [densely_ordered α] {a : α} :
  densely_ordered {x : α // a ≤ x} :=
show densely_ordered (Ici a), from set.densely_ordered

/-- If `Sup ∅ ≤ a` then `{x : α // a ≤ x}` is a `conditionally_complete_linear_order`. -/
@[reducible]
protected noncomputable def conditionally_complete_linear_order
  [conditionally_complete_linear_order α] {a : α} :
  conditionally_complete_linear_order {x : α // a ≤ x} :=
{ .. @ord_connected_subset_conditionally_complete_linear_order α (set.Ici a) _ ⟨⟨a, le_rfl⟩⟩ _ }

/-- If `Sup ∅ ≤ a` then `{x : α // a ≤ x}` is a `conditionally_complete_linear_order_bot`.

This instance uses data fields from `subtype.linear_order` to help type-class inference.
The `set.Ici` data fields are definitionally equal, but that requires unfolding semireducible
definitions, so type-class inference won't see this. -/
@[reducible]
protected noncomputable def conditionally_complete_linear_order_bot
  [conditionally_complete_linear_order α] {a : α} (h : Sup ∅ ≤ a) :
  conditionally_complete_linear_order_bot {x : α // a ≤ x} :=
{ cSup_empty := (function.funext_iff.1
    (@subset_Sup_def α (set.Ici a) _ ⟨⟨a, le_rfl⟩⟩) ∅).trans $ subtype.eq $
      by { rw bot_eq, cases h.lt_or_eq with h2 h2, { simp [h2.not_le] }, simp [h2] },
  ..nonneg.order_bot,
  ..nonneg.conditionally_complete_linear_order }

instance inhabited [preorder α] {a : α} : inhabited {x : α // a ≤ x} :=
⟨⟨a, le_rfl⟩⟩

instance has_zero [has_zero α] [preorder α] : has_zero {x : α // 0 ≤ x} :=
⟨⟨0, le_rfl⟩⟩

@[simp, norm_cast]
protected lemma coe_zero [has_zero α] [preorder α] : ((0 : {x : α // 0 ≤ x}) : α) = 0 := rfl

@[simp] lemma mk_eq_zero [has_zero α] [preorder α] {x : α} (hx : 0 ≤ x) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) = 0 ↔ x = 0 :=
subtype.ext_iff

instance has_add [add_zero_class α] [preorder α] [covariant_class α α (+) (≤)] :
  has_add {x : α // 0 ≤ x} :=
⟨λ x y, ⟨x + y, add_nonneg x.2 y.2⟩⟩

@[simp] lemma mk_add_mk [add_zero_class α] [preorder α] [covariant_class α α (+) (≤)] {x y : α}
  (hx : 0 ≤ x) (hy : 0 ≤ y) : (⟨x, hx⟩ : {x : α // 0 ≤ x}) + ⟨y, hy⟩ = ⟨x + y, add_nonneg hx hy⟩ :=
rfl

@[simp, norm_cast]
protected lemma coe_add [add_zero_class α] [preorder α] [covariant_class α α (+) (≤)]
  (a b : {x : α // 0 ≤ x}) : ((a + b : {x : α // 0 ≤ x}) : α) = a + b := rfl

instance has_nsmul [add_monoid α] [preorder α] [covariant_class α α (+) (≤)] :
  has_scalar ℕ {x : α // 0 ≤ x} :=
⟨λ n x, ⟨n • x, nsmul_nonneg x.prop n⟩⟩

@[simp] lemma nsmul_mk [add_monoid α] [preorder α] [covariant_class α α (+) (≤)] (n : ℕ)
  {x : α} (hx : 0 ≤ x) : (n • ⟨x, hx⟩ : {x : α // 0 ≤ x}) = ⟨n • x, nsmul_nonneg hx n⟩ :=
rfl

@[simp, norm_cast]
protected lemma coe_nsmul [add_monoid α] [preorder α] [covariant_class α α (+) (≤)]
  (n : ℕ) (a : {x : α // 0 ≤ x}) : ((n • a : {x : α // 0 ≤ x}) : α) = n • a := rfl

instance ordered_add_comm_monoid [ordered_add_comm_monoid α] :
  ordered_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_add_comm_monoid _ rfl (λ x y, rfl) (λ _ _, rfl)

instance linear_ordered_add_comm_monoid [linear_ordered_add_comm_monoid α] :
  linear_ordered_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.linear_ordered_add_comm_monoid _ rfl (λ x y, rfl) (λ _ _, rfl)

instance ordered_cancel_add_comm_monoid [ordered_cancel_add_comm_monoid α] :
  ordered_cancel_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_cancel_add_comm_monoid _ rfl (λ x y, rfl) (λ _ _, rfl)

instance linear_ordered_cancel_add_comm_monoid [linear_ordered_cancel_add_comm_monoid α] :
  linear_ordered_cancel_add_comm_monoid {x : α // 0 ≤ x} :=
subtype.coe_injective.linear_ordered_cancel_add_comm_monoid _ rfl (λ x y, rfl) (λ _ _, rfl)

/-- Coercion `{x : α // 0 ≤ x} → α` as a `add_monoid_hom`. -/
def coe_add_monoid_hom [ordered_add_comm_monoid α] : {x : α // 0 ≤ x} →+ α :=
⟨coe, nonneg.coe_zero, nonneg.coe_add⟩

@[norm_cast]
lemma nsmul_coe [ordered_add_comm_monoid α] (n : ℕ) (r : {x : α // 0 ≤ x}) :
  ↑(n • r) = n • (r : α) :=
nonneg.coe_add_monoid_hom.map_nsmul _ _

instance archimedean [ordered_add_comm_monoid α] [archimedean α] : archimedean {x : α // 0 ≤ x} :=
⟨ assume x y pos_y,
  let ⟨n, hr⟩ := archimedean.arch (x : α) (pos_y : (0 : α) < y) in
  ⟨n, show (x : α) ≤ (n • y : {x : α // 0 ≤ x}), by simp [*, -nsmul_eq_mul, nsmul_coe]⟩ ⟩

instance has_one [ordered_semiring α] : has_one {x : α // 0 ≤ x} :=
{ one := ⟨1, zero_le_one⟩ }

@[simp, norm_cast]
protected lemma coe_one [ordered_semiring α] : ((1 : {x : α // 0 ≤ x}) : α) = 1 := rfl

@[simp] lemma mk_eq_one [ordered_semiring α] {x : α} (hx : 0 ≤ x) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) = 1 ↔ x = 1 :=
subtype.ext_iff

instance has_mul [ordered_semiring α] : has_mul {x : α // 0 ≤ x} :=
{ mul := λ x y, ⟨x * y, mul_nonneg x.2 y.2⟩ }

@[simp, norm_cast]
protected lemma coe_mul [ordered_semiring α] (a b : {x : α // 0 ≤ x}) :
  ((a * b : {x : α // 0 ≤ x}) : α) = a * b := rfl

@[simp] lemma mk_mul_mk [ordered_semiring α] {x y : α} (hx : 0 ≤ x) (hy : 0 ≤ y) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) * ⟨y, hy⟩ = ⟨x * y, mul_nonneg hx hy⟩ :=
rfl

instance has_pow [ordered_semiring α] : has_pow {x : α // 0 ≤ x} ℕ :=
{ pow := λ x n, ⟨x ^ n, pow_nonneg x.2 n⟩ }

@[simp, norm_cast]
protected lemma coe_pow [ordered_semiring α] (a : {x : α // 0 ≤ x}) (n : ℕ) :
  ((a ^ n: {x : α // 0 ≤ x}) : α) = a ^ n := rfl

@[simp] lemma mk_pow [ordered_semiring α] {x : α} (hx : 0 ≤ x) (n : ℕ) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) ^ n = ⟨x ^ n, pow_nonneg hx n⟩ :=
rfl

instance ordered_semiring [ordered_semiring α] : ordered_semiring {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_semiring _
  rfl rfl (λ x y, rfl) (λ x y, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance ordered_comm_semiring [ordered_comm_semiring α] : ordered_comm_semiring {x : α // 0 ≤ x} :=
subtype.coe_injective.ordered_comm_semiring _
  rfl rfl (λ x y, rfl) (λ x y, rfl) (λ _ _, rfl) (λ _ _, rfl)

-- These prevent noncomputable instances being found, as it does not require `linear_order` which
-- is frequently non-computable.
instance monoid_with_zero [ordered_semiring α] : monoid_with_zero {x : α // 0 ≤ x} :=
by apply_instance

instance comm_monoid_with_zero [ordered_comm_semiring α] : comm_monoid_with_zero {x : α // 0 ≤ x} :=
by apply_instance

instance nontrivial [linear_ordered_semiring α] : nontrivial {x : α // 0 ≤ x} :=
⟨ ⟨0, 1, λ h, zero_ne_one (congr_arg subtype.val h)⟩ ⟩

instance linear_ordered_semiring [linear_ordered_semiring α] :
  linear_ordered_semiring {x : α // 0 ≤ x} :=
subtype.coe_injective.linear_ordered_semiring _
  rfl rfl (λ x y, rfl) (λ x y, rfl) (λ _ _, rfl) (λ _ _, rfl)

instance linear_ordered_comm_monoid_with_zero [linear_ordered_comm_ring α] :
  linear_ordered_comm_monoid_with_zero {x : α // 0 ≤ x} :=
{ mul_le_mul_left := λ a b h c, mul_le_mul_of_nonneg_left h c.2,
  ..nonneg.linear_ordered_semiring,
  ..nonneg.ordered_comm_semiring }

/-- Coercion `{x : α // 0 ≤ x} → α` as a `ring_hom`. -/
def coe_ring_hom [ordered_semiring α] : {x : α // 0 ≤ x} →+* α :=
⟨coe, nonneg.coe_one, nonneg.coe_mul, nonneg.coe_zero, nonneg.coe_add⟩

@[simp, norm_cast]
protected lemma coe_nat_cast [ordered_semiring α] (n : ℕ) : ((↑n : {x : α // 0 ≤ x}) : α) = n :=
map_nat_cast (coe_ring_hom : {x : α // 0 ≤ x} →+* α) n

instance has_inv [linear_ordered_field α] : has_inv {x : α // 0 ≤ x} :=
{ inv := λ x, ⟨x⁻¹, inv_nonneg.mpr x.2⟩ }

@[simp, norm_cast]
protected lemma coe_inv [linear_ordered_field α] (a : {x : α // 0 ≤ x}) :
  ((a⁻¹ : {x : α // 0 ≤ x}) : α) = a⁻¹ := rfl

@[simp] lemma inv_mk [linear_ordered_field α] {x : α} (hx : 0 ≤ x) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x})⁻¹ = ⟨x⁻¹, inv_nonneg.mpr hx⟩ :=
rfl

instance linear_ordered_comm_group_with_zero [linear_ordered_field α] :
  linear_ordered_comm_group_with_zero {x : α // 0 ≤ x} :=
{ inv_zero := by { ext, exact inv_zero },
  mul_inv_cancel := by { intros a ha, ext, refine mul_inv_cancel (mt (λ h, _) ha), ext, exact h },
  ..nonneg.nontrivial,
  ..nonneg.has_inv,
  ..nonneg.linear_ordered_comm_monoid_with_zero }

instance has_div [linear_ordered_field α] : has_div {x : α // 0 ≤ x} :=
{ div := λ x y, ⟨x / y, div_nonneg x.2 y.2⟩ }

@[simp, norm_cast]
protected lemma coe_div [linear_ordered_field α] (a b : {x : α // 0 ≤ x}) :
  ((a / b : {x : α // 0 ≤ x}) : α) = a / b := rfl

@[simp] lemma mk_div_mk [linear_ordered_field α] {x y : α} (hx : 0 ≤ x) (hy : 0 ≤ y) :
  (⟨x, hx⟩ : {x : α // 0 ≤ x}) / ⟨y, hy⟩ = ⟨x / y, div_nonneg hx hy⟩ :=
rfl

instance canonically_ordered_add_monoid [ordered_ring α] :
  canonically_ordered_add_monoid {x : α // 0 ≤ x} :=
{ le_iff_exists_add     := λ ⟨a, ha⟩ ⟨b, hb⟩,
    by simpa only [mk_add_mk, subtype.exists, subtype.mk_eq_mk] using le_iff_exists_nonneg_add a b,
  ..nonneg.ordered_add_comm_monoid,
  ..nonneg.order_bot }

instance canonically_ordered_comm_semiring [ordered_comm_ring α] [no_zero_divisors α] :
  canonically_ordered_comm_semiring {x : α // 0 ≤ x} :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := by { rintro ⟨a, ha⟩ ⟨b, hb⟩, simp },
  ..nonneg.canonically_ordered_add_monoid,
  ..nonneg.ordered_comm_semiring }

instance canonically_linear_ordered_add_monoid [linear_ordered_ring α] :
  canonically_linear_ordered_add_monoid {x : α // 0 ≤ x} :=
{ ..subtype.linear_order _, ..nonneg.canonically_ordered_add_monoid }

instance floor_semiring [ordered_semiring α] [floor_semiring α] : floor_semiring {r : α // 0 ≤ r} :=
{ floor := λ a, ⌊(a : α)⌋₊,
  ceil := λ a, ⌈(a : α)⌉₊,
  floor_of_neg := λ a ha, floor_semiring.floor_of_neg ha,
  gc_floor := λ a n ha, begin
    refine (floor_semiring.gc_floor (show 0 ≤ (a : α), from ha)).trans _,
    rw [←subtype.coe_le_coe, nonneg.coe_nat_cast]
  end,
  gc_ceil := λ a n, begin
    refine (floor_semiring.gc_ceil (a : α) n).trans _,
    rw [←subtype.coe_le_coe, nonneg.coe_nat_cast]
  end}

@[norm_cast] lemma nat_floor_coe [ordered_semiring α] [floor_semiring α] (a : {r : α // 0 ≤ r}) :
  ⌊(a : α)⌋₊ = ⌊a⌋₊ := rfl

@[norm_cast] lemma nat_ceil_coe [ordered_semiring α] [floor_semiring α] (a : {r : α // 0 ≤ r}) :
  ⌈(a : α)⌉₊ = ⌈a⌉₊  := rfl

section linear_order

variables [has_zero α] [linear_order α]

/-- The function `a ↦ max a 0` of type `α → {x : α // 0 ≤ x}`. -/
def to_nonneg (a : α) : {x : α // 0 ≤ x} :=
⟨max a 0, le_max_right _ _⟩

@[simp]
lemma coe_to_nonneg {a : α} : (to_nonneg a : α) = max a 0 := rfl

@[simp]
lemma to_nonneg_of_nonneg {a : α} (h : 0 ≤ a) : to_nonneg a = ⟨a, h⟩ :=
by simp [to_nonneg, h]

@[simp]
lemma to_nonneg_coe {a : {x : α // 0 ≤ x}} : to_nonneg (a : α) = a :=
by { cases a with a ha, exact to_nonneg_of_nonneg ha }

@[simp]
lemma to_nonneg_le {a : α} {b : {x : α // 0 ≤ x}} : to_nonneg a ≤ b ↔ a ≤ b :=
by { cases b with b hb, simp [to_nonneg, hb] }

@[simp]
lemma to_nonneg_lt {a : {x : α // 0 ≤ x}} {b : α} : a < to_nonneg b ↔ ↑a < b :=
by { cases a with a ha, simp [to_nonneg, ha.not_lt] }

instance has_sub [has_sub α] : has_sub {x : α // 0 ≤ x} :=
⟨λ x y, to_nonneg (x - y)⟩

@[simp] lemma mk_sub_mk [has_sub α] {x y : α}
  (hx : 0 ≤ x) (hy : 0 ≤ y) : (⟨x, hx⟩ : {x : α // 0 ≤ x}) - ⟨y, hy⟩ = to_nonneg (x - y) :=
rfl

end linear_order

instance has_ordered_sub [linear_ordered_ring α] : has_ordered_sub {x : α // 0 ≤ x} :=
⟨by { rintro ⟨a, ha⟩ ⟨b, hb⟩ ⟨c, hc⟩, simp only [sub_le_iff_le_add, subtype.mk_le_mk, mk_sub_mk,
  mk_add_mk, to_nonneg_le, subtype.coe_mk]}⟩

end nonneg


/-
Copyright (c) 2016 Andrew Zipperer. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Zipperer, Jeremy Avigad

Basic group theory: subgroups, homomorphisms on a set, homomorphic images, cosets,
  normal cosets and the normalizer, the kernel of a homomorphism, the centralizer, etc.

For notation a * S and S * a for cosets, open the namespace "coset_notation".
For notation a^b and S^a, open the namespace "conj_notation".

TODO: homomorphisms on sets should be refactored and moved to algebra.
-/
import data.set algebra.homomorphism theories.move
open eq.ops set function

namespace group_theory

variables {A B C : Type}

/- subgroups -/

structure is_one_closed [class] [has_one A] (S : set A) : Prop :=
(one_mem : one ∈ S)

proposition one_mem [has_one A] {S : set A} [is_one_closed S] : 1 ∈ S :=
is_one_closed.one_mem _ S

structure is_mul_closed [class] [has_mul A] (S : set A) : Prop :=
(mul_mem : ∀₀ a ∈ S, ∀₀ b ∈ S, a * b ∈ S)

proposition mul_mem [has_mul A] {S : set A} [is_mul_closed S] {a b : A} (aS : a ∈ S) (bS : b ∈ S) :
  a * b ∈ S :=
is_mul_closed.mul_mem _ S aS bS

structure is_inv_closed [class] [has_inv A] (S : set A) : Prop :=
(inv_mem : ∀₀ a ∈ S, a⁻¹ ∈ S)

proposition inv_mem [has_inv A] {S : set A} [is_inv_closed S] {a : A} (aS : a ∈ S) : a⁻¹ ∈ S :=
is_inv_closed.inv_mem _ S aS

structure is_subgroup [class] [group A] (S : set A)
  extends is_one_closed S, is_mul_closed S, is_inv_closed S : Prop

section groupA
  variable [group A]

  proposition mem_of_inv_mem {a : A} {S : set A} [is_subgroup S] (H : a⁻¹ ∈ S) : a ∈ S :=
  have (a⁻¹)⁻¹ ∈ S, from inv_mem H,
  by rewrite inv_inv at this; apply this

  proposition inv_mem_iff (a : A) (S : set A) [is_subgroup S] : a⁻¹ ∈ S ↔ a ∈ S :=
  iff.intro mem_of_inv_mem inv_mem

  proposition is_subgroup_univ [instance] : is_subgroup (@univ A) :=
  ⦃ is_subgroup,
    one_mem := trivial,
    mul_mem := λ a au b bu, trivial,
    inv_mem := λ a au, trivial ⦄

  proposition is_subgroup_inter [instance] (G H : set A) [is_subgroup G] [is_subgroup H] :
    is_subgroup (G ∩ H) :=
  ⦃ is_subgroup,
    one_mem := and.intro one_mem one_mem,
    mul_mem := λ a ai b bi, and.intro (mul_mem (and.left ai) (and.left bi))
                   (mul_mem (and.right ai) (and.right bi)),
    inv_mem := λ a ai, and.intro (inv_mem (and.left ai)) (inv_mem (and.right ai)) ⦄
end groupA

/- homomorphisms on sets -/

section has_mulABC
  variables [has_mul A] [has_mul B] [has_mul C]

  -- in group theory, we can use is_hom for is_mul_hom
  abbreviation is_hom := @is_mul_hom

  definition is_hom_on [class] (f : A → B) (S : set A) : Prop :=
    ∀₀ a₁ ∈ S, ∀₀ a₂ ∈ S, f (a₁ * a₂) = f a₁ * f a₂

  proposition hom_on_mul (f : A → B) {S : set A} [H : is_hom_on f S] {a₁ a₂ : A}
      (a₁S : a₁ ∈ S) (a₂S : a₂ ∈ S) : f (a₁ * a₂) = (f a₁) * (f a₂) :=
    H a₁S a₂S

  proposition is_hom_on_of_is_hom (f : A → B) (S : set A) [H : is_hom f] : is_hom_on f S :=
  forallb_of_forall₂ S S (hom_mul f)

  proposition is_hom_of_is_hom_on_univ (f : A → B) [H : is_hom_on f univ] : is_hom f :=
  is_mul_hom.mk (forall_of_forallb_univ₂ H)

  proposition is_hom_on_univ_iff (f : A → B) : is_hom_on f univ ↔ is_hom f :=
  iff.intro (λH, is_hom_of_is_hom_on_univ f) (λ H, is_hom_on_of_is_hom f univ)

  proposition is_hom_on_of_subset (f : A → B) {S T : set A} (ssubt : S ⊆ T) [H : is_hom_on f T] :
    is_hom_on f S :=
  forallb_of_subset₂ ssubt ssubt H

  proposition is_hom_on_id (S : set A) : is_hom_on id S :=
  have H : is_hom (@id A), from is_mul_hom_id,
  is_hom_on_of_is_hom id S

  proposition is_hom_on_comp {S : set A} {T : set B} {g : B → C} {f : A → B}
    (H₁ : is_hom_on f S) (H₂ : is_hom_on g T) (H₃ : maps_to f S T) : is_hom_on (g ∘ f) S :=
  take a₁, assume a₁S, take a₂, assume a₂S,
  have f a₁ ∈ T, from H₃ a₁S,
  have f a₂ ∈ T, from H₃ a₂S,
  show g (f (a₁ * a₂)) = g (f a₁) * g (f a₂), by rewrite [H₁ a₁S a₂S, H₂ `f a₁ ∈ T` `f a₂ ∈ T`]
end has_mulABC

section groupAB
  variables [group A] [group B]

  proposition hom_on_one (f : A → B) (G : set A) [is_subgroup G] [H : is_hom_on f G] : f 1 = 1 :=
  have f 1 * f 1 = f 1 * 1, by rewrite [-H one_mem one_mem, *mul_one],
  eq_of_mul_eq_mul_left' this

  proposition hom_on_inv (f : A → B) {G : set A} [is_subgroup G] [H : is_hom_on f G]
      {a : A} (aG : a ∈ G) :
    f a⁻¹ = (f a)⁻¹ :=
  have f a⁻¹ * f a = 1, by rewrite [-H (inv_mem aG) aG, mul.left_inv, hom_on_one f G],
  eq_inv_of_mul_eq_one this

  proposition is_subgroup_image [instance] (f : A → B) (G : set A)
    [is_subgroup G] [is_hom_on f G] :
  is_subgroup (f ' G) :=
  ⦃ is_subgroup,
    one_mem := mem_image one_mem (hom_on_one f G),
    mul_mem := λ a afG b bfG,
      obtain c (cG : c ∈ G)(Hc : f c = a), from afG,
      obtain d (dG : d ∈ G)(Hd : f d = b), from bfG,
      show a * b ∈ f ' G, from mem_image (mul_mem cG dG) (by rewrite [hom_on_mul f cG dG, Hc, Hd]),
    inv_mem := λ a afG,
      obtain c (cG : c ∈ G)(Hc : f c = a), from afG,
      show a⁻¹ ∈ f ' G, from mem_image (inv_mem cG) (by rewrite [hom_on_inv f cG, Hc]) ⦄
end groupAB

/- cosets -/

definition lcoset [has_mul A] (a : A) (N : set A) : set A := (mul a) 'N
definition rcoset [has_mul A] (N : set A) (a : A) : set A := (mul^~ a) 'N

-- overload multiplication
namespace coset_notation
  infix * := lcoset
  infix * := rcoset
end coset_notation

open coset_notation

section has_mulA
  variable [has_mul A]

  proposition mul_mem_lcoset {S : set A} {x : A} (a : A) (xS : x ∈ S) : a * x ∈ a * S :=
  mem_image_of_mem (mul a) xS

  proposition mul_mem_rcoset [has_mul A] {S : set A} {x : A} (xS : x ∈ S) (a : A) :
    x * a ∈ S * a :=
  mem_image_of_mem (mul^~ a) xS

  definition lcoset_equiv (S : set A) (a b : A) : Prop := a * S = b * S

  proposition equivalence_lcoset_equiv (S : set A) : equivalence (lcoset_equiv S) :=
  mk_equivalence (lcoset_equiv S) (λ a, rfl) (λ a b, !eq.symm) (λ a b c, !eq.trans)

  proposition lcoset_subset_lcoset {S T : set A} (a : A) (H : S ⊆ T) : a * S ⊆ a * T :=
  image_subset _ H

  proposition rcoset_subset_rcoset {S T : set A} (H : S ⊆ T) (a : A) : S * a ⊆ T * a :=
  image_subset _ H

  proposition image_lcoset_of_is_hom_on {B : Type} [has_mul B] {f : A → B} {S : set A} {a : A}
      {G : set A} (SsubG : S ⊆ G) (aG : a ∈ G) [is_hom_on f G] :
    f ' (a * S) = f a * f ' S :=
  ext (take x, iff.intro
    (assume fas : x ∈ f ' (a * S),
      obtain t [s (sS : s ∈ S) (seq : a * s = t)] (teq : f t = x), from fas,
      have x = f a * f s, by rewrite [-teq, -seq, hom_on_mul f aG (SsubG sS)],
      show x ∈ f a * f ' S, by rewrite this; apply mul_mem_lcoset _ (mem_image_of_mem _ sS))
    (assume fafs : x ∈ f a * f ' S,
      obtain t [s (sS : s ∈ S) (seq : f s = t)] (teq : f a * t = x), from fafs,
      have x = f (a * s), by rewrite [-teq, -seq, hom_on_mul f aG (SsubG sS)],
      show x ∈ f ' (a * S), by rewrite this; exact mem_image_of_mem _ (mul_mem_lcoset _ sS)))

  proposition image_rcoset_of_is_hom_on {B : Type} [has_mul B] {f : A → B} {S : set A} {a : A}
    {G : set A} (SsubG : S ⊆ G) (aG : a ∈ G) [is_hom_on f G] :
  f ' (S * a) = f ' S * f a :=
  ext (take x, iff.intro
    (assume fas : x ∈ f ' (S * a),
      obtain t [s (sS : s ∈ S) (seq : s * a = t)] (teq : f t = x), from fas,
      have x = f s * f a, by rewrite [-teq, -seq, hom_on_mul f (SsubG sS) aG],
      show x ∈ f ' S * f a, by rewrite this; exact mul_mem_rcoset (mem_image_of_mem _ sS) _)
    (assume fafs : x ∈ f ' S * f a,
      obtain t [s (sS : s ∈ S) (seq : f s = t)] (teq : t * f a = x), from fafs,
      have x = f (s * a), by rewrite [-teq, -seq, hom_on_mul f (SsubG sS) aG],
      show x ∈ f ' (S * a), by rewrite this; exact mem_image_of_mem _ (mul_mem_rcoset sS _)))

  proposition image_lcoset_of_is_hom {B : Type} [has_mul B] (f : A → B) (a : A) (S : set A)
      [is_hom f] :
    f ' (a * S) = f a * f ' S :=
  have is_hom_on f univ, from is_hom_on_of_is_hom f univ,
  image_lcoset_of_is_hom_on (subset_univ S) !mem_univ

  proposition image_rcoset_of_is_hom {B : Type} [has_mul B] (f : A → B) (S : set A) (a : A)
      [is_hom f] :
    f ' (S * a) = f ' S * f a :=
  have is_hom_on f univ, from is_hom_on_of_is_hom f univ,
  image_rcoset_of_is_hom_on (subset_univ S) !mem_univ
end has_mulA

section semigroupA
  variable [semigroup A]

  proposition rcoset_rcoset (S : set A) (a b : A) : S * a * b = S * (a * b) :=
  have H : (mul^~ b) ∘ (mul^~ a) = mul^~ (a * b), from funext (take x, !mul.assoc),
  calc
    S * a * b = ((mul^~ b) ∘ (mul^~ a)) 'S : image_comp
          ... = S * (a * b)                : by rewrite [↑rcoset, H]

  proposition lcoset_lcoset (S : set A) (a b : A) : a * (b * S)  = (a * b) * S :=
  have H : (mul a) ∘ (mul b) = mul (a * b), from funext (take x, !mul.assoc⁻¹),
  calc
    a * (b * S) = ((mul a) ∘ (mul b)) 'S : image_comp
            ... = (a * b) * S            : by rewrite [↑lcoset, H]

  proposition lcoset_rcoset [semigroup A] (S : set A) (a b : A) : a * S * b = a * (S * b) :=
  have H : (mul^~ b) ∘ (mul a) = (mul a) ∘ (mul^~ b), from funext (take x, !mul.assoc),
  calc
    a * S * b = ((mul^~ b) ∘ (mul a)) 'S : image_comp
          ... = ((mul a) ∘ (mul^~ b)) 'S : H
          ... = a * (S * b)              : image_comp
end semigroupA

section monoidA
  variable [monoid A]

  proposition one_lcoset (S : set A) : 1 * S = S :=
  ext (take x, iff.intro
    (suppose x ∈ 1 * S,
      obtain s (sS : s ∈ S) (eqx : 1 * s = x), from this,
      show x ∈ S, by rewrite [-eqx, one_mul]; apply sS)
    (suppose x ∈ S,
      have 1 * x ∈ 1 * S, from mem_image_of_mem (mul 1) this,
      show x ∈ 1 * S, by rewrite one_mul at this; apply this))

  proposition rcoset_one (S : set A) : S * 1 = S :=
  ext (take x, iff.intro
    (suppose x ∈ S * 1,
      obtain s (sS : s ∈ S) (eqx : s * 1 = x), from this,
      show x ∈ S, by rewrite [-eqx, mul_one]; apply sS)
    (suppose x ∈ S,
      have x * 1 ∈ S * 1, from mem_image_of_mem (mul^~ 1) this,
      show x ∈ S * 1, by rewrite mul_one at this; apply this))
end monoidA

section groupA
  variable [group A]

  proposition lcoset_inv_lcoset (a : A) (S : set A) : a * (a⁻¹ * S) = S :=
  by rewrite [lcoset_lcoset, mul.right_inv, one_lcoset]

  proposition inv_lcoset_lcoset (a : A) (S : set A) : a⁻¹ * (a * S) = S :=
  by rewrite [lcoset_lcoset, mul.left_inv, one_lcoset]

  proposition rcoset_inv_rcoset (S : set A) (a : A) : (S * a⁻¹) * a = S :=
  by rewrite [rcoset_rcoset, mul.left_inv, rcoset_one]

  proposition rcoset_rcoset_inv (S : set A) (a : A) : (S * a) * a⁻¹ = S :=
  by rewrite [rcoset_rcoset, mul.right_inv, rcoset_one]

  proposition eq_of_lcoset_eq_lcoset {a : A} {S T : set A} (H : a * S = a * T) : S = T :=
  by rewrite [-inv_lcoset_lcoset a S, -inv_lcoset_lcoset a T, H]

  proposition eq_of_rcoset_eq_rcoset {a : A} {S T : set A} (H : S * a = T * a) : S = T :=
  by rewrite [-rcoset_rcoset_inv S a, -rcoset_rcoset_inv T a, H]

  proposition mem_of_mul_mem_lcoset {a b : A} {S : set A} (abaS : a * b ∈ a * S) : b ∈ S :=
  have a⁻¹ * (a * b) ∈ a⁻¹ * (a * S), from mul_mem_lcoset _ abaS,
  by rewrite [inv_mul_cancel_left at this, inv_lcoset_lcoset at this]; apply this

  proposition mul_mem_lcoset_iff (a b : A) (S : set A) : a * b ∈ a * S ↔ b ∈ S :=
  iff.intro !mem_of_mul_mem_lcoset !mul_mem_lcoset

  proposition mem_of_mul_mem_rcoset {a b : A} {S : set A} (abSb : a * b ∈ S * b) : a ∈ S :=
  have (a * b) * b⁻¹ ∈ (S * b) * b⁻¹, from mul_mem_rcoset abSb _,
  by rewrite [mul_inv_cancel_right at this, rcoset_rcoset_inv at this]; apply this

  proposition mul_mem_rcoset_iff (a b : A) (S : set A) : a * b ∈ S * b ↔ a ∈ S :=
  iff.intro !mem_of_mul_mem_rcoset (λ H, mul_mem_rcoset H _)

  proposition inv_mul_mem_of_mem_lcoset {a b : A} {S : set A} (abS : a ∈ b * S) : b⁻¹ * a ∈ S :=
  have b⁻¹ * a ∈ b⁻¹ * (b * S), from mul_mem_lcoset b⁻¹ abS,
  by rewrite inv_lcoset_lcoset at this; apply this

  proposition mem_lcoset_of_inv_mul_mem {a b : A} {S : set A} (H : b⁻¹ * a ∈ S) : a ∈ b * S :=
  have b * (b⁻¹ * a) ∈ b * S, from mul_mem_lcoset b H,
  by rewrite mul_inv_cancel_left at this; apply this

  proposition mem_lcoset_iff (a b : A) (S : set A) : a ∈ b * S ↔ b⁻¹ * a ∈ S :=
  iff.intro inv_mul_mem_of_mem_lcoset mem_lcoset_of_inv_mul_mem

  proposition mul_inv_mem_of_mem_rcoset {a b : A} {S : set A} (aSb : a ∈ S * b) : a * b⁻¹ ∈ S :=
  have a * b⁻¹ ∈ (S * b) * b⁻¹, from mul_mem_rcoset aSb b⁻¹,
  by rewrite rcoset_rcoset_inv at this; apply this

  proposition mem_rcoset_of_mul_inv_mem {a b : A} {S : set A} (H : a * b⁻¹ ∈ S) : a ∈ S * b :=
  have a * b⁻¹ * b ∈ S * b, from mul_mem_rcoset H b,
  by rewrite inv_mul_cancel_right at this; apply this

  proposition mem_rcoset_iff (a b : A) (S : set A) : a ∈ S * b ↔ a * b⁻¹ ∈ S :=
  iff.intro mul_inv_mem_of_mem_rcoset mem_rcoset_of_mul_inv_mem

  proposition lcoset_eq_iff_eq_inv_lcoset (a : A) (S T : set A) : (a * S = T) ↔ (S = a⁻¹ * T) :=
  iff.intro (assume H, by rewrite [-H, inv_lcoset_lcoset])
      (assume H, by rewrite [H, lcoset_inv_lcoset])

  proposition rcoset_eq_iff_eq_rcoset_inv (a : A) (S T : set A) : (S * a = T) ↔ (S = T * a⁻¹) :=
  iff.intro (assume H, by rewrite [-H, rcoset_rcoset_inv])
      (assume H, by rewrite [H, rcoset_inv_rcoset])

  proposition lcoset_inter (a : A) (S T : set A) [is_subgroup S] [is_subgroup T] :
    a * (S ∩ T) = (a * S) ∩ (a * T) :=
  eq_of_subset_of_subset
    (image_inter_subset _ S T)
    (take b, suppose b ∈ (a * S) ∩ (a * T),
      obtain [s [smem (seq : a * s = b)]] [t [tmem (teq : a * t = b)]], from this,
      have s = t, from eq_of_mul_eq_mul_left' (eq.trans seq (eq.symm teq)),
      show b ∈ a * (S ∩ T),
        begin
          rewrite -seq,
          apply mul_mem_lcoset,
          apply and.intro smem,
          rewrite this, apply tmem
        end)

  proposition inter_rcoset (a : A) (S T : set A) [is_subgroup S] [is_subgroup T] :
    (S ∩ T) * a = (S * a) ∩ (T * a) :=
  eq_of_subset_of_subset
    (image_inter_subset _ S T)
    (take b, suppose b ∈ (S * a) ∩ (T * a),
      obtain [s [smem (seq : s * a = b)]] [t [tmem (teq : t * a = b)]], from this,
      have s = t, from eq_of_mul_eq_mul_right' (eq.trans seq (eq.symm teq)),
      show b ∈ (S ∩ T) * a,
        begin
          rewrite -seq,
          apply mul_mem_rcoset,
          apply and.intro smem,
          rewrite this, apply tmem
        end)
end groupA

section subgroupG
  variables [group A] {G : set A} [is_subgroup G]

  proposition lcoset_eq_self_of_mem {a : A} (aG : a ∈ G) : a * G = G :=
  ext (take x, iff.intro
    (assume xaG, obtain g [gG xeq], from xaG,
      show x ∈ G, by rewrite -xeq; exact (mul_mem aG gG))
    (assume xG, show x ∈ a * G, from mem_image
      (show a⁻¹ * x ∈ G, from (mul_mem (inv_mem aG) xG)) !mul_inv_cancel_left))

  proposition rcoset_eq_self_of_mem {a : A} (aG : a ∈ G) : G * a = G :=
  ext (take x, iff.intro
    (assume xGa, obtain g [gG xeq], from xGa,
      show x ∈ G, by rewrite -xeq; exact (mul_mem gG aG))
    (assume xG, show x ∈ G * a, from mem_image
      (show x * a⁻¹ ∈ G, from (mul_mem xG (inv_mem aG))) !inv_mul_cancel_right))

  proposition mem_lcoset_self (a : A) : a ∈ a * G :=
  by rewrite [-mul_one a at {1}]; exact mul_mem_lcoset a one_mem

  proposition mem_rcoset_self (a : A) : a ∈ G * a :=
  by rewrite [-one_mul a at {1}]; exact mul_mem_rcoset one_mem a

  proposition mem_of_lcoset_eq_self {a : A} (H : a * G = G) : a ∈ G :=
  by rewrite [-H]; exact mem_lcoset_self a

  proposition mem_of_rcoset_eq_self {a : A} (H : G * a = G) : a ∈ G :=
  by rewrite [-H]; exact mem_rcoset_self a

  variable (G)

  proposition lcoset_eq_self_iff (a : A) : a * G = G ↔ a ∈ G :=
  iff.intro mem_of_lcoset_eq_self lcoset_eq_self_of_mem

  proposition rcoset_eq_self_iff (a : A) : G * a = G ↔ a ∈ G :=
  iff.intro mem_of_rcoset_eq_self rcoset_eq_self_of_mem

  variable {G}

  proposition lcoset_eq_lcoset {a b : A} (H : b⁻¹ * a ∈ G) : a * G = b * G :=
  have b⁻¹ * (a * G) = b⁻¹ * (b * G),
    by rewrite [inv_lcoset_lcoset, lcoset_lcoset, lcoset_eq_self_of_mem H],
  eq_of_lcoset_eq_lcoset this

  proposition inv_mul_mem_of_lcoset_eq_lcoset {a b : A} (H : a * G = b * G) : b⁻¹ * a ∈ G :=
  mem_of_lcoset_eq_self (by rewrite [-lcoset_lcoset, H, inv_lcoset_lcoset])

  proposition lcoset_eq_lcoset_iff (a b : A) : a * G = b * G ↔ b⁻¹ * a ∈ G :=
  iff.intro inv_mul_mem_of_lcoset_eq_lcoset lcoset_eq_lcoset

  proposition rcoset_eq_rcoset {a b : A} (H : a * b⁻¹ ∈ G) : G * a = G * b :=
  have G * a * b⁻¹ = G * b * b⁻¹,
    by rewrite [rcoset_rcoset_inv, rcoset_rcoset, rcoset_eq_self_of_mem H],
  eq_of_rcoset_eq_rcoset this

  proposition mul_inv_mem_of_rcoset_eq_rcoset {a b : A} (H : G * a = G * b) : a * b⁻¹ ∈ G :=
  mem_of_rcoset_eq_self (by rewrite [-rcoset_rcoset, H, rcoset_rcoset_inv])

  proposition rcoset_eq_rcoset_iff (a b : A) : G * a = G * b ↔ a * b⁻¹ ∈ G :=
  iff.intro mul_inv_mem_of_rcoset_eq_rcoset rcoset_eq_rcoset
end subgroupG

/- normal cosets and the normalizer -/

section has_mulA
  variable [has_mul A]

  abbreviation normalizes [reducible] (a : A) (S : set A) : Prop := a * S = S * a

  definition is_normal [class] (S : set A) : Prop := ∀ a, normalizes a S

  definition normalizer (S : set A) : set A := { a : A | normalizes a S }

  definition is_normal_in [class] (S T : set A) : Prop := T ⊆ normalizer S

  abbreviation normalizer_in [reducible] (S T : set A) : set A := T ∩ normalizer S

  proposition lcoset_eq_rcoset (a : A) (S : set A) [H : is_normal S] : a * S = S * a := H a

  proposition subset_normalizer (S T : set A) [H : is_normal_in T S] : S ⊆ normalizer T := H

  proposition lcoset_eq_rcoset_of_mem {a : A} (S : set A) {T : set A} [H : is_normal_in S T]
      (amemT : a ∈ T) :
    a * S = S * a := H amemT

  proposition is_normal_in_of_is_normal (S T : set A) [H : is_normal S] : is_normal_in S T :=
  forallb_of_forall T H

  proposition is_normal_of_is_normal_in_univ {S : set A} (H : is_normal_in S univ) :
    is_normal S :=
  forall_of_forallb_univ H

  proposition is_normal_in_univ_iff_is_normal (S : set A) : is_normal_in S univ ↔ is_normal S :=
  forallb_univ_iff_forall _

   proposition is_normal_in_of_subset {S T U : set A} (H : T ⊆ U) (H' : is_normal_in S U) :
    is_normal_in S T :=
  forallb_of_subset H H'

  proposition normalizes_of_mem_normalizer {a : A} {S : set A} (H : a ∈ normalizer S) :
    normalizes a S := H

  proposition mem_normalizer_iff_normalizes (a : A) (S : set A) :
    a ∈ normalizer S ↔ normalizes a S := iff.refl _

  proposition is_normal_in_normalizer [instance] (S : set A) : is_normal_in S (normalizer S) :=
  subset.refl (normalizer S)
end has_mulA

section groupA
  variable [group A]

  proposition is_normal_in_of_forall_subset {S G : set A} [is_subgroup G]
    (H : ∀₀ x ∈ G, x * S ⊆ S * x) :
  is_normal_in S G :=
  take x, assume xG,
  show x * S = S * x, from eq_of_subset_of_subset (H xG)
    (have x * (x⁻¹ * S) * x ⊆ x * (S * x⁻¹) * x,
      from rcoset_subset_rcoset (lcoset_subset_lcoset x (H (inv_mem xG))) x,
      show S * x ⊆ x * S,
        begin
         rewrite [lcoset_inv_lcoset at this, lcoset_rcoset at this, rcoset_inv_rcoset at this],
         exact this
       end)

  proposition is_normal_of_forall_subset {S : set A} (H : ∀ x, x * S ⊆ S * x) : is_normal S :=
  begin
    rewrite [-is_normal_in_univ_iff_is_normal],
    apply is_normal_in_of_forall_subset,
    intro x xuniv, exact H x
  end

  proposition subset_normalizer_self (G : set A) [is_subgroup G] : G ⊆ normalizer G :=
  take a, assume aG, show a * G = G * a,
    by rewrite [lcoset_eq_self_of_mem aG, rcoset_eq_self_of_mem aG]
end groupA

section normalG
  variables [group A] (G : set A) [is_normal G]

  proposition lcoset_equiv_mul {a₁ a₂ b₁ b₂ : A}
    (H₁ : lcoset_equiv G a₁ a₂) (H₂ : lcoset_equiv G b₁ b₂) : lcoset_equiv G (a₁ * b₁) (a₂ * b₂) :=
  begin
    unfold lcoset_equiv at *,
    rewrite [-lcoset_lcoset, H₂, lcoset_eq_rcoset, -lcoset_rcoset, H₁, lcoset_rcoset,
             -lcoset_eq_rcoset, lcoset_lcoset]
  end

  proposition lcoset_equiv_inv {a₁ a₂ : A} (H : lcoset_equiv G a₁ a₂) : lcoset_equiv G a₁⁻¹ a₂⁻¹ :=
  begin
    unfold lcoset_equiv at *,
    have a₁⁻¹ * G = a₂⁻¹ * (a₂ * G) * a₁⁻¹, by rewrite [inv_lcoset_lcoset, lcoset_eq_rcoset],
    rewrite [this, -H, lcoset_rcoset, lcoset_eq_rcoset, rcoset_rcoset_inv]
  end
end normalG

/- the normalizer is a subgroup -/

section semigroupA
  variable [semigroup A]

  proposition mul_mem_normalizer {S : set A} {a b : A}
    (Ha : a ∈ normalizer S) (Hb : b ∈ normalizer S) : a * b ∈ normalizer S :=
  show a * b * S = S * (a * b),
    by rewrite [-lcoset_lcoset, normalizes_of_mem_normalizer Hb, -lcoset_rcoset,
                normalizes_of_mem_normalizer Ha, rcoset_rcoset]
end semigroupA

section monoidA
  variable [monoid A]

  proposition one_mem_normalizer (S : set A) : 1 ∈ normalizer S :=
  by rewrite [↑normalizer, mem_set_of_iff, one_lcoset, rcoset_one]
end monoidA

section groupA
  variable [group A]

  proposition inv_mem_normalizer {S : set A} {a : A} (H : a ∈ normalizer S) : a⁻¹ ∈ normalizer S :=
  have a⁻¹ * S = S * a⁻¹,
  begin
    apply iff.mp (rcoset_eq_iff_eq_rcoset_inv _ _ _),
    rewrite [lcoset_rcoset, -normalizes_of_mem_normalizer H, inv_lcoset_lcoset]
  end,
  by rewrite [↑normalizer, mem_set_of_iff, this]

  proposition is_subgroup_normalizer [instance] (S : set A) : is_subgroup (normalizer S) :=
  ⦃ is_subgroup,
    one_mem := one_mem_normalizer S,
    mul_mem := λ a Ha b Hb, mul_mem_normalizer Ha Hb,
    inv_mem := λ a H, inv_mem_normalizer H⦄
end groupA

section subgroupG
  variables [group A] {G : set A} [is_subgroup G]

  proposition normalizes_image_of_is_hom_on [group B] {a : A} (aG : a ∈ G) {S : set A}
      (SsubG : S ⊆ G) (H : normalizes a S) (f : A → B) [is_hom_on f G] :
    normalizes (f a) (f ' S) :=
  by rewrite [-image_lcoset_of_is_hom_on SsubG aG, -image_rcoset_of_is_hom_on SsubG aG,
              ↑normalizes at H, H]

  proposition is_normal_in_image_image [group B] {S T : set A} (SsubT : S ⊆ T)
      [H : is_normal_in S T] (f : A → B) [is_subgroup T] [is_hom_on f T] :
    is_normal_in (f ' S) (f ' T) :=
  take a, assume afT,
  obtain b [bT (beq : f b = a)], from afT,
  show normalizes a (f ' S),
    begin rewrite -beq, apply (normalizes_image_of_is_hom_on bT SsubT (H bT)) end

  proposition normalizes_image_of_is_hom [group B] {a : A} {S : set A}
      (H : normalizes a S) (f : A → B) [is_hom f] :
    normalizes (f a) (f ' S) :=
  by rewrite [-image_lcoset_of_is_hom f a S, -image_rcoset_of_is_hom f S a,
              ↑normalizes at H, H]

  proposition is_normal_in_image_image_univ [group B] {S : set A}
      [H : is_normal S] (f : A → B) [is_hom f] :
    is_normal_in (f ' S) (f ' univ) :=
  take a, assume afT,
  obtain b [buniv (beq : f b = a)], from afT,
  show normalizes a (f ' S),
    begin rewrite -beq, apply (normalizes_image_of_is_hom (H b) f) end
end subgroupG

/- conjugation -/

definition conj [reducible] [group A] (a b : A) : A := b⁻¹ * a * b

definition set_conj [reducible] [group A] (S : set A)(a : A) : set A := a⁻¹ * S * a
-- conj^~ a ' S

namespace conj_notation
  infix `^` := conj
  infix `^` := set_conj
end conj_notation

open conj_notation

section groupA
  variables [group A]

  proposition set_conj_eq_image_conj (S : set A) (a : A) : S^a = conj^~ a 'S :=
  eq.symm !image_comp

  proposition set_conj_eq_self_of_normalizes {S : set A} {a : A} (H : normalizes a S) : S^a = S :=
  by rewrite [lcoset_rcoset, ↑normalizes at H, -H, inv_lcoset_lcoset]

  proposition normalizes_of_set_conj_eq_self {S : set A} {a : A} (H : S^a = S) : normalizes a S :=
  by rewrite [-H at {1}, ↑set_conj, lcoset_rcoset, lcoset_inv_lcoset]

  proposition set_conj_eq_self_iff_normalizes (S : set A) (a : A) : S^a = S ↔ normalizes a S :=
  iff.intro normalizes_of_set_conj_eq_self set_conj_eq_self_of_normalizes

  proposition set_conj_eq_self_of_mem_normalizer {S : set A} {a : A} (H : a ∈ normalizer S) :
    S^a = S := set_conj_eq_self_of_normalizes H

  proposition mem_normalizer_of_set_conj_eq_self {S : set A} {a : A} (H : S^a = S) :
    a ∈ normalizer S := normalizes_of_set_conj_eq_self H

  proposition set_conj_eq_self_iff_mem_normalizer (S : set A) (a : A) :
    S^a = S ↔ a ∈ normalizer S :=
  iff.intro mem_normalizer_of_set_conj_eq_self set_conj_eq_self_of_mem_normalizer

  proposition conj_one (a : A) : a ^ (1 : A) = a :=
  by rewrite [↑conj, one_inv, one_mul, mul_one]

  proposition conj_conj (a b c : A) : (a^b)^c = a^(b * c) :=
  by rewrite [↑conj, mul_inv, *mul.assoc]

  proposition conj_inv (a b : A) : (a^b)⁻¹ = (a⁻¹)^b :=
  by rewrite[mul_inv, mul_inv, inv_inv, mul.assoc]

  proposition mul_conj (a b c : A) : (a * b)^c = a^c * b^c :=
  by rewrite[↑conj, *mul.assoc, mul_inv_cancel_left]
end groupA

/- the kernel -/

definition ker [has_one B] (f : A → B) : set A := { x | f x = 1 }

section hasoneB
  variable [has_one B]

  proposition eq_one_of_mem_ker {f : A → B} {a : A} (H : a ∈ ker f) : f a = 1 := H

  proposition mem_ker_iff (f : A → B) (a : A) : a ∈ ker f ↔ f a = 1 := iff.rfl

  proposition ker_eq_preimage_one (f : A → B) : ker f = f '- '{1} :=
  ext (take x, by rewrite [mem_ker_iff, -mem_preimage_iff, mem_singleton_iff])

  definition ker_in (f : A → B) (S : set A) : set A := ker f ∩ S

  proposition ker_in_univ (f : A → B) : ker_in f univ = ker f :=
  !inter_univ
end hasoneB

section groupAB
  variables [group A] [group B]
  variable  {f : A → B}

  proposition eq_of_mul_inv_mem_ker [is_hom f] {a₁ a₂ : A} (H : a₁ * a₂⁻¹ ∈ ker f) :
    f a₁ = f a₂ :=
  eq_of_mul_inv_eq_one (by rewrite [-hom_inv f, -hom_mul f]; exact H)

  proposition mul_inv_mem_ker_of_eq [is_hom f] {a₁ a₂ : A} (H : f a₁ = f a₂) :
    a₁ * a₂⁻¹ ∈ ker f :=
  show f (a₁ * a₂⁻¹) = 1, by rewrite [hom_mul f, hom_inv f, H, mul.right_inv]

  proposition eq_iff_mul_inv_mem_ker [is_hom f] (a₁ a₂ : A) : f a₁ = f a₂ ↔ a₁ * a₂⁻¹ ∈ ker f :=
  iff.intro mul_inv_mem_ker_of_eq eq_of_mul_inv_mem_ker

  proposition eq_of_mul_inv_mem_ker_in {G : set A} [is_subgroup G] [is_hom_on f G]
      {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G) (H : a₁ * a₂⁻¹ ∈ ker_in f G) :
    f a₁ = f a₂ :=
  eq_of_mul_inv_eq_one (by rewrite [-hom_on_inv f a₂G, -hom_on_mul f a₁G (inv_mem a₂G)];
    exact and.left H)

  proposition mul_inv_mem_ker_in_of_eq {G : set A} [is_subgroup G] [is_hom_on f G]
      {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G) (H : f a₁ = f a₂) :
    a₁ * a₂⁻¹ ∈ ker_in f G :=
  and.intro
    (show f (a₁ * a₂⁻¹) = 1,
      by rewrite [hom_on_mul f a₁G (inv_mem a₂G), hom_on_inv f a₂G, H, mul.right_inv])
    (mul_mem a₁G (inv_mem a₂G))

  proposition eq_iff_mul_inv_mem_ker_in {G : set A} [is_subgroup G] [is_hom_on f G]
      {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G) :
    f a₁ = f a₂ ↔ a₁ * a₂⁻¹ ∈ ker_in f G :=
  iff.intro (mul_inv_mem_ker_in_of_eq a₁G a₂G) (eq_of_mul_inv_mem_ker_in a₁G a₂G)

  -- Ouch! These versions are not equivalent to the ones before.

  proposition eq_of_inv_mul_mem_ker [is_hom f] {a₁ a₂ : A} (H : a₁⁻¹ * a₂ ∈ ker f) :
    f a₁ = f a₂ :=
  eq.symm (eq_of_inv_mul_eq_one (by rewrite [-hom_inv f, -hom_mul f]; exact H))

  proposition inv_mul_mem_ker_of_eq [is_hom f] {a₁ a₂ : A} (H : f a₁ = f a₂) :
    a₁⁻¹ * a₂ ∈ ker f :=
  show f (a₁⁻¹ * a₂) = 1, by rewrite [hom_mul f, hom_inv f, H, mul.left_inv]

  proposition eq_iff_inv_mul_mem_ker [is_hom f] (a₁ a₂ : A) : f a₁ = f a₂ ↔ a₁⁻¹ * a₂ ∈ ker f :=
  iff.intro inv_mul_mem_ker_of_eq eq_of_inv_mul_mem_ker

  proposition eq_of_inv_mul_mem_ker_in {G : set A} [is_subgroup G] [is_hom_on f G]
      {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G) (H : a₁⁻¹ * a₂ ∈ ker_in f G) :
    f a₁ = f a₂ :=
  eq.symm (eq_of_inv_mul_eq_one (by rewrite [-hom_on_inv f a₁G, -hom_on_mul f (inv_mem a₁G) a₂G];
    exact and.left H))

  proposition inv_mul_mem_ker_in_of_eq {G : set A} [is_subgroup G] [is_hom_on f G]
      {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G) (H : f a₁ = f a₂) :
    a₁⁻¹ * a₂ ∈ ker_in f G :=
  and.intro
    (show f (a₁⁻¹ * a₂) = 1,
      by rewrite [hom_on_mul f (inv_mem a₁G) a₂G, hom_on_inv f a₁G, H, mul.left_inv])
    (mul_mem (inv_mem a₁G) a₂G)

  proposition eq_iff_inv_mul_mem_ker_in {G : set A} [is_subgroup G] [is_hom_on f G]
      {a₁ a₂ : A} (a₁G : a₁ ∈ G) (a₂G : a₂ ∈ G) :
    f a₁ = f a₂ ↔ a₁⁻¹ * a₂ ∈ ker_in f G :=
  iff.intro (inv_mul_mem_ker_in_of_eq a₁G a₂G) (eq_of_inv_mul_mem_ker_in a₁G a₂G)

  proposition eq_one_of_eq_one_of_injective [is_hom f] (H : injective f) {x : A}
      (H' : f x = 1) :
    x = 1 :=
  H (by rewrite [H', hom_one f])

  proposition eq_one_iff_eq_one_of_injective [is_hom f] (H : injective f) (x : A) :
    f x = 1 ↔ x = 1 :=
  iff.intro (eq_one_of_eq_one_of_injective H) (λ H', by rewrite [H', hom_one f])

  proposition injective_of_forall_eq_one [is_hom f] (H : ∀ x, f x = 1 → x = 1) : injective f :=
  take a₁ a₂, assume Heq,
  have f (a₁ * a₂⁻¹) = 1, by rewrite [hom_mul f, hom_inv f, Heq, mul.right_inv],
  eq_of_mul_inv_eq_one (H _ this)

  proposition injective_of_ker_eq_singleton_one [is_hom f] (H : ker f = '{1}) : injective f :=
  injective_of_forall_eq_one
    (take x, suppose x ∈ ker f, by rewrite [H at this]; exact eq_of_mem_singleton this)

  proposition ker_eq_singleton_one_of_injective [is_hom f] (H : injective f) : ker f = '{1} :=
  ext (take x, by rewrite [mem_ker_iff, mem_singleton_iff, eq_one_iff_eq_one_of_injective H])

  variable (f)
  proposition injective_iff_ker_eq_singleton_one [is_hom f] : injective f ↔ ker f = '{1} :=
  iff.intro ker_eq_singleton_one_of_injective injective_of_ker_eq_singleton_one
  variable {f}

  proposition eq_one_of_eq_one_of_inj_on {G : set A} [is_subgroup G] [is_hom_on f G]
    (H : inj_on f G) {x : A} (xG : x ∈ G) (H' : f x = 1) :
    x = 1 :=
  H xG one_mem (by rewrite [H', hom_on_one f G])

  proposition eq_one_iff_eq_one_of_inj_on {G : set A} [is_subgroup G] [is_hom_on f G]
    (H : inj_on f G) {x : A} (xG : x ∈ G) [is_hom_on f G] :
    f x = 1 ↔ x = 1 :=
  iff.intro (eq_one_of_eq_one_of_inj_on H xG) (λ H', by rewrite [H', hom_on_one f G])

  proposition inj_on_of_forall_eq_one {G : set A} [is_subgroup G] [is_hom_on f G]
    (H : ∀₀ x ∈ G, f x = 1 → x = 1) : inj_on f G :=
  take a₁ a₂, assume a₁G a₂G Heq,
  have f (a₁ * a₂⁻¹) = 1,
    by rewrite [hom_on_mul f a₁G (inv_mem a₂G), hom_on_inv f a₂G, Heq, mul.right_inv],
  eq_of_mul_inv_eq_one (H (mul_mem a₁G (inv_mem a₂G)) this)

  proposition inj_on_of_ker_in_eq_singleton_one {G : set A} [is_subgroup G] [is_hom_on f G]
    (H : ker_in f G = '{1}) : inj_on f G :=
  inj_on_of_forall_eq_one
    (take x, assume xG fxone,
      have x ∈ ker_in f G, from and.intro fxone xG,
      by rewrite [H at this]; exact eq_of_mem_singleton this)

  proposition ker_in_eq_singleton_one_of_inj_on {G : set A} [is_subgroup G] [is_hom_on f G]
    (H : inj_on f G) : ker_in f G = '{1} :=
  ext (take x,
    begin
      rewrite [↑ker_in, mem_inter_iff, mem_ker_iff, mem_singleton_iff],
      apply iff.intro,
        {intro H', cases H' with fxone xG, exact eq_one_of_eq_one_of_inj_on H xG fxone},
      intro xone, rewrite xone, split, exact hom_on_one f G, exact one_mem
    end)

  variable (f)
  proposition inj_on_iff_ker_in_eq_singleton_one (G : set A) [is_subgroup G] [is_hom_on f G] :
    inj_on f G ↔ ker_in f G = '{1} :=
  iff.intro ker_in_eq_singleton_one_of_inj_on inj_on_of_ker_in_eq_singleton_one
  variable {f}

  proposition conj_mem_ker [is_hom f] {a₁ : A} (a₂ : A) (H : a₁ ∈ ker f) : a₁^a₂ ∈ ker f :=
  show f (a₁^a₂) = 1,
    by rewrite [↑conj, *(hom_mul f), hom_inv f, eq_one_of_mem_ker H, mul_one, mul.left_inv]

  variable (f)

  proposition is_subgroup_ker_in [instance] (S : set A) [is_subgroup S] [is_hom_on f S] :
    is_subgroup (ker_in f S) :=
  ⦃ is_subgroup,
    one_mem := and.intro (hom_on_one f S) one_mem,
    mul_mem := λ a aker b bker,
                 obtain (fa : f a = 1) (aS : a ∈ S), from aker,
                 obtain (fb : f b = 1) (bS : b ∈ S), from bker,
                 and.intro (show f (a * b) = 1, by rewrite [hom_on_mul f aS bS, fa, fb, one_mul])
                   (mul_mem aS bS),
    inv_mem := λ a aker,
                 obtain (fa : f a = 1) (aS : a ∈ S), from aker,
                 and.intro (show f (a⁻¹) = 1, by rewrite [hom_on_inv f aS, fa, one_inv])
                   (inv_mem aS)
  ⦄

  proposition is_subgroup_ker [instance] [is_hom f] : is_subgroup (ker f) :=
  begin
    rewrite [-ker_in_univ f],
    have is_hom_on f univ, from is_hom_on_of_is_hom f univ,
    apply is_subgroup_ker_in f univ
  end

  proposition is_normal_in_ker_in [instance] (G : set A) [is_subgroup G] [is_hom_on f G] :
    is_normal_in (ker_in f G) G :=
  is_normal_in_of_forall_subset
    (take x, assume xG, take y, assume yker,
      obtain z [[(fz : f z = 1) zG] (yeq : x * z = y)], from yker,
      have y = x * z * x⁻¹ * x, by rewrite [yeq, inv_mul_cancel_right],
      show y ∈ ker_in f G * x,
        begin
          rewrite this,
          apply mul_mem_rcoset,
          apply and.intro,
          show f (x * z * x⁻¹) = 1,
            by rewrite [hom_on_mul f (mul_mem xG zG) (inv_mem xG), hom_on_mul f xG zG, fz,
                        hom_on_inv f xG, mul_one, mul.right_inv],
          show x * z * x⁻¹ ∈ G, from mul_mem (mul_mem xG zG) (inv_mem xG)
        end)

  proposition is_normal_ker [instance] [H : is_hom f] : is_normal (ker f) :=
  begin
    rewrite [-ker_in_univ, -is_normal_in_univ_iff_is_normal],
    apply is_normal_in_ker_in,
    exact is_hom_on_of_is_hom f univ
  end

end groupAB

section subgroupH
  variables [group A] [group B] {H : set A} [is_subgroup H]
  variables {f : A → B} [is_hom f]

  proposition subset_ker_of_forall (hyp : ∀ x y, x * H = y * H → f x = f y) : H ⊆ ker f :=
  take h, assume hH,
  have h * H = 1 * H, by rewrite [lcoset_eq_self_of_mem hH, one_lcoset],
  have f h = f 1, from hyp h 1 this,
  show f h = 1, by rewrite [this, hom_one f]

  proposition eq_of_lcoset_eq_lcoset_of_subset_ker {x y : A} (hyp₀ : x * H = y * H) (hyp₁ : H ⊆ ker f) :
    f x = f y :=
  have y⁻¹ * x ∈ H, from inv_mul_mem_of_lcoset_eq_lcoset hyp₀,
  eq.symm (eq_of_inv_mul_mem_ker (hyp₁ this))

  variables (H f)
  proposition subset_ker_iff : H ⊆ ker f ↔ ∀ x y, x * H = y * H → f x = f y :=
  iff.intro (λ h₁ x y h₀, eq_of_lcoset_eq_lcoset_of_subset_ker h₀ h₁) subset_ker_of_forall
end subgroupH

section subgroupGH
  variables [group A] [group B] {G H : set A} [is_subgroup G] [is_subgroup H]
  variables {f : A → B} [is_hom_on f G]

  proposition subset_ker_in_of_forall (hyp₀ : ∀₀ x ∈ G, ∀₀ y ∈ G, x * H = y * H → f x = f y)
      (hyp₁ : H ⊆ G) :
    H ⊆ ker_in f G :=
  take h, assume hH,
    have hG : h ∈ G, from hyp₁ hH,
    and.intro
      (have h * H = 1 * H, by rewrite [lcoset_eq_self_of_mem hH, one_lcoset],
        have f h = f 1, from hyp₀ hG one_mem this,
        show f h = 1, by rewrite [this, hom_on_one f G])
      hG

  proposition eq_of_lcoset_eq_lcoset_of_subset_ker_in {x : A} (xG : x ∈ G) {y : A} (yG : y ∈ G)
      (hyp₀ : x * H = y * H) (hyp₁ : H ⊆ ker_in f G) :
    f x = f y :=
  have y⁻¹ * x ∈ H, from inv_mul_mem_of_lcoset_eq_lcoset hyp₀,
  eq.symm (eq_of_inv_mul_mem_ker_in yG xG (hyp₁ this))

  variables (H f)
  proposition subset_ker_in_iff :
    H ⊆ ker_in f G ↔ (H ⊆ G ∧ ∀₀ x ∈ G, ∀₀ y ∈ G, x * H = y * H → f x = f y) :=
  iff.intro
    (λ h₁, and.intro
      (subset.trans h₁ (inter_subset_right _ _))
      (λ x xG y yG h₀, eq_of_lcoset_eq_lcoset_of_subset_ker_in xG yG h₀ h₁))
    (λ h, subset_ker_in_of_forall (and.right h) (and.left h))
end subgroupGH

/- the centralizer -/

section has_mulA
  variable [has_mul A]

  abbreviation centralizes [reducible] (a : A) (S : set A) : Prop := ∀₀ b ∈ S, a * b = b * a

  definition centralizer (S : set A) : set A := { a : A | centralizes a S }

  abbreviation is_centralized_by (S T : set A) : Prop := T ⊆ centralizer S

  abbreviation centralizer_in (S T : set A) : set A := T ∩ centralizer S

  proposition mem_centralizer_iff_centralizes (a : A) (S : set A) :
    a ∈ centralizer S ↔ centralizes a S := iff.refl _

  proposition normalizes_of_centralizes {a : A} {S : set A} (H : centralizes a S) :
    normalizes a S :=
  ext (take b, iff.intro
    (suppose b ∈ a * S,
      obtain s [ains (beq : a * s = b)], from this,
      show b ∈ S * a, by rewrite[-beq, H ains]; apply mem_image_of_mem _ ains)
    (suppose b ∈ S * a,
      obtain s [ains (beq : s * a = b)], from this,
      show b ∈ a * S, by rewrite[-beq, -H ains]; apply mem_image_of_mem _ ains))

  proposition centralizer_subset_normalizer (S : set A) : centralizer S ⊆ normalizer S :=
  λ a acent, normalizes_of_centralizes acent

  proposition centralizer_subset_centralizer {S T : set A} (ssubt : S ⊆ T) :
    centralizer T ⊆ centralizer S :=
  λ x xCentT s sS, xCentT _ (ssubt sS)
end has_mulA

section groupA
  variable [group A]

  proposition is_subgroup_centralizer [instance] [group A] (S : set A) :
    is_subgroup (centralizer S) :=
  ⦃ is_subgroup,
    one_mem := λ b bS, by rewrite [one_mul, mul_one],
    mul_mem := λ a acent b bcent c cS, by rewrite [mul.assoc, bcent cS, -*mul.assoc, acent cS],
    inv_mem := λ a acent c cS, eq_mul_inv_of_mul_eq
      (by rewrite [mul.assoc, -acent cS, inv_mul_cancel_left])⦄
end groupA

/- the subgroup generated by a set -/

section groupA
  variable [group A]

  inductive subgroup_generated_by (S : set A) : A → Prop :=
  | generators_mem : ∀ x, x ∈ S → subgroup_generated_by S x
  | one_mem        : subgroup_generated_by S 1
  | mul_mem        : ∀ x y, subgroup_generated_by S x → subgroup_generated_by S y →
                       subgroup_generated_by S (x * y)
  | inv_mem        : ∀ x, subgroup_generated_by S x → subgroup_generated_by S (x⁻¹)

  theorem generators_subset_subgroup_generated_by (S : set A) : S ⊆ subgroup_generated_by S :=
  subgroup_generated_by.generators_mem

  theorem is_subgroup_subgroup_generated_by [instance] (S : set A) :
    is_subgroup (subgroup_generated_by S) :=
  ⦃ is_subgroup,
    one_mem := subgroup_generated_by.one_mem S,
    mul_mem := λ a amem b bmem, subgroup_generated_by.mul_mem a b amem bmem,
    inv_mem := λ a amem, subgroup_generated_by.inv_mem a amem ⦄

  theorem subgroup_generated_by_subset {S G : set A} [is_subgroup G] (H : S ⊆ G) :
    subgroup_generated_by S ⊆ G :=
  begin
    intro x xgenS,
    induction xgenS with a aS a b agen bgen aG bG a agen aG,
      {exact H aS},
      {exact one_mem},
      {exact mul_mem aG bG},
    exact inv_mem aG
  end
end groupA

end group_theory


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Aaron Anderson
-/
import ring_theory.unique_factorization_domain
import ring_theory.int.basic
import number_theory.divisors
import algebra.is_prime_pow

/-!
# Squarefree elements of monoids
An element of a monoid is squarefree when it is not divisible by any squares
except the squares of units.

## Main Definitions
 - `squarefree r` indicates that `r` is only divisible by `x * x` if `x` is a unit.

## Main Results
 - `multiplicity.squarefree_iff_multiplicity_le_one`: `x` is `squarefree` iff for every `y`, either
  `multiplicity y x ≤ 1` or `is_unit y`.
 - `unique_factorization_monoid.squarefree_iff_nodup_factors`: A nonzero element `x` of a unique
 factorization monoid is squarefree iff `factors x` has no duplicate factors.
 - `nat.squarefree_iff_nodup_factors`: A positive natural number `x` is squarefree iff
  the list `factors x` has no duplicate factors.
## Tags
squarefree, multiplicity

-/

variables {R : Type*}

/-- An element of a monoid is squarefree if the only squares that
  divide it are the squares of units. -/
def squarefree [monoid R] (r : R) : Prop := ∀ x : R, x * x ∣ r → is_unit x

@[simp]
lemma is_unit.squarefree [comm_monoid R] {x : R} (h : is_unit x) :
  squarefree x :=
λ y hdvd, is_unit_of_mul_is_unit_left (is_unit_of_dvd_unit hdvd h)

@[simp]
lemma squarefree_one [comm_monoid R] : squarefree (1 : R) :=
is_unit_one.squarefree

@[simp]
lemma not_squarefree_zero [monoid_with_zero R] [nontrivial R] : ¬ squarefree (0 : R) :=
begin
  erw [not_forall],
  exact ⟨0, by simp⟩,
end

lemma squarefree.ne_zero [monoid_with_zero R] [nontrivial R] {m : R}
  (hm : squarefree (m : R)) : m ≠ 0 :=
begin
  rintro rfl,
  exact not_squarefree_zero hm,
end

@[simp]
lemma irreducible.squarefree [comm_monoid R] {x : R} (h : irreducible x) :
  squarefree x :=
begin
  rintros y ⟨z, hz⟩,
  rw mul_assoc at hz,
  rcases h.is_unit_or_is_unit hz with hu | hu,
  { exact hu },
  { apply is_unit_of_mul_is_unit_left hu },
end

@[simp]
lemma prime.squarefree [cancel_comm_monoid_with_zero R] {x : R} (h : prime x) :
  squarefree x :=
h.irreducible.squarefree

lemma squarefree.of_mul_left [comm_monoid R] {m n : R} (hmn : squarefree (m * n)) : squarefree m :=
(λ p hp, hmn p (dvd_mul_of_dvd_left hp n))

lemma squarefree.of_mul_right [comm_monoid R] {m n : R} (hmn : squarefree (m * n)) : squarefree n :=
(λ p hp, hmn p (dvd_mul_of_dvd_right hp m))

lemma squarefree_of_dvd_of_squarefree [comm_monoid R]
  {x y : R} (hdvd : x ∣ y) (hsq : squarefree y) :
  squarefree x :=
λ a h, hsq _ (h.trans hdvd)

namespace multiplicity

section comm_monoid

variables [comm_monoid R] [decidable_rel (has_dvd.dvd : R → R → Prop)]

lemma squarefree_iff_multiplicity_le_one (r : R) :
  squarefree r ↔ ∀ x : R, multiplicity x r ≤ 1 ∨ is_unit x :=
begin
  refine forall_congr (λ a, _),
  rw [← sq, pow_dvd_iff_le_multiplicity, or_iff_not_imp_left, not_le, imp_congr],
  swap, { refl },
  convert enat.add_one_le_iff_lt (enat.coe_ne_top 1),
  norm_cast,
end

end comm_monoid

section cancel_comm_monoid_with_zero

variables [cancel_comm_monoid_with_zero R] [wf_dvd_monoid R]

lemma finite_prime_left {a b : R} (ha : prime a) (hb : b ≠ 0) :
  multiplicity.finite a b :=
begin
  classical,
  revert hb,
  refine wf_dvd_monoid.induction_on_irreducible b (by contradiction) (λ u hu hu', _)
    (λ b p hb hp ih hpb, _),
  { rw [multiplicity.finite_iff_dom, multiplicity.is_unit_right ha.not_unit hu],
    exact enat.dom_coe 0, },
  { refine multiplicity.finite_mul ha
      (multiplicity.finite_iff_dom.mpr (enat.dom_of_le_coe (show multiplicity a p ≤ ↑1, from _)))
      (ih hb),
    norm_cast,
    exact (((multiplicity.squarefree_iff_multiplicity_le_one p).mp hp.squarefree a)
      .resolve_right ha.not_unit) }
end

end cancel_comm_monoid_with_zero

end multiplicity

section irreducible
variables [comm_monoid_with_zero R] [wf_dvd_monoid R]

lemma irreducible_sq_not_dvd_iff_eq_zero_and_no_irreducibles_or_squarefree (r : R) :
  (∀ x : R, irreducible x → ¬ x * x ∣ r) ↔ ((r = 0 ∧ ∀ x : R, ¬irreducible x) ∨ squarefree r) :=
begin
  symmetry,
  split,
  { rintro (⟨rfl, h⟩ | h),
    { simpa using h },
    intros x hx t,
    exact hx.not_unit (h x t) },
  intro h,
  rcases eq_or_ne r 0 with rfl | hr,
  { exact or.inl (by simpa using h) },
  right,
  intros x hx,
  by_contra i,
  have : x ≠ 0,
  { rintro rfl,
    apply hr,
    simpa only [zero_dvd_iff, mul_zero] using hx},
  obtain ⟨j, hj₁, hj₂⟩ := wf_dvd_monoid.exists_irreducible_factor i this,
  exact h _ hj₁ ((mul_dvd_mul hj₂ hj₂).trans hx),
end

lemma squarefree_iff_irreducible_sq_not_dvd_of_ne_zero {r : R} (hr : r ≠ 0) :
  squarefree r ↔ ∀ x : R, irreducible x → ¬ x * x ∣ r :=
by simpa [hr] using (irreducible_sq_not_dvd_iff_eq_zero_and_no_irreducibles_or_squarefree r).symm

lemma squarefree_iff_irreducible_sq_not_dvd_of_exists_irreducible
  {r : R} (hr : ∃ (x : R), irreducible x) :
  squarefree r ↔ ∀ x : R, irreducible x → ¬ x * x ∣ r :=
begin
  rw [irreducible_sq_not_dvd_iff_eq_zero_and_no_irreducibles_or_squarefree, ←not_exists],
  simp only [hr, not_true, false_or, and_false],
end

end irreducible

namespace unique_factorization_monoid
variables [cancel_comm_monoid_with_zero R] [nontrivial R] [unique_factorization_monoid R]
variables [normalization_monoid R]

lemma squarefree_iff_nodup_normalized_factors [decidable_eq R] {x : R} (x0 : x ≠ 0) :
  squarefree x ↔ multiset.nodup (normalized_factors x) :=
begin
  have drel : decidable_rel (has_dvd.dvd : R → R → Prop),
  { classical,
    apply_instance, },
  haveI := drel,
  rw [multiplicity.squarefree_iff_multiplicity_le_one, multiset.nodup_iff_count_le_one],
  split; intros h a,
  { by_cases hmem : a ∈ normalized_factors x,
    { have ha := irreducible_of_normalized_factor _ hmem,
      rcases h a with h | h,
      { rw ← normalize_normalized_factor _ hmem,
        rw [multiplicity_eq_count_normalized_factors ha x0] at h,
        assumption_mod_cast },
      { have := ha.1, contradiction, } },
    { simp [multiset.count_eq_zero_of_not_mem hmem] } },
  { rw or_iff_not_imp_right, intro hu,
    by_cases h0 : a = 0,
    { simp [h0, x0] },
    rcases wf_dvd_monoid.exists_irreducible_factor hu h0 with ⟨b, hib, hdvd⟩,
    apply le_trans (multiplicity.multiplicity_le_multiplicity_of_dvd_left hdvd),
    rw [multiplicity_eq_count_normalized_factors hib x0],
    specialize h (normalize b),
    assumption_mod_cast }
end

lemma dvd_pow_iff_dvd_of_squarefree {x y : R} {n : ℕ} (hsq : squarefree x) (h0 : n ≠ 0) :
  x ∣ y ^ n ↔ x ∣ y :=
begin
  classical,
  by_cases hx : x = 0,
  { simp [hx, pow_eq_zero_iff (nat.pos_of_ne_zero h0)] },
  by_cases hy : y = 0,
  { simp [hy, zero_pow (nat.pos_of_ne_zero h0)] },
  refine ⟨λ h, _, λ h, h.pow h0⟩,
  rw [dvd_iff_normalized_factors_le_normalized_factors hx (pow_ne_zero n hy),
    normalized_factors_pow,
    ((squarefree_iff_nodup_normalized_factors hx).1 hsq).le_nsmul_iff_le h0] at h,
  rwa dvd_iff_normalized_factors_le_normalized_factors hx hy,
end

end unique_factorization_monoid

namespace nat

lemma squarefree_iff_nodup_factors {n : ℕ} (h0 : n ≠ 0) :
  squarefree n ↔ n.factors.nodup :=
begin
  rw [unique_factorization_monoid.squarefree_iff_nodup_normalized_factors h0, nat.factors_eq],
  simp,
end

theorem squarefree_iff_prime_squarefree {n : ℕ} : squarefree n ↔ ∀ x, prime x → ¬ x * x ∣ n :=
squarefree_iff_irreducible_sq_not_dvd_of_exists_irreducible ⟨_, prime_two⟩

/-- Assuming that `n` has no factors less than `k`, returns the smallest prime `p` such that
  `p^2 ∣ n`. -/
def min_sq_fac_aux : ℕ → ℕ → option ℕ
| n k :=
  if h : n < k * k then none else
  have nat.sqrt n + 2 - (k + 2) < nat.sqrt n + 2 - k,
    by { rw nat.add_sub_add_right, exact nat.min_fac_lemma n k h },
  if k ∣ n then
    let n' := n / k in
    have nat.sqrt n' + 2 - (k + 2) < nat.sqrt n + 2 - k, from
      lt_of_le_of_lt (nat.sub_le_sub_right
        (nat.add_le_add_right (nat.sqrt_le_sqrt $ nat.div_le_self _ _) _) _) this,
    if k ∣ n' then some k else min_sq_fac_aux n' (k + 2)
  else min_sq_fac_aux n (k + 2)
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ ⟨n, k⟩, nat.sqrt n + 2 - k)⟩]}

/-- Returns the smallest prime factor `p` of `n` such that `p^2 ∣ n`, or `none` if there is no
  such `p` (that is, `n` is squarefree). See also `squarefree_iff_min_sq_fac`. -/
def min_sq_fac (n : ℕ) : option ℕ :=
if 2 ∣ n then
  let n' := n / 2 in
  if 2 ∣ n' then some 2 else min_sq_fac_aux n' 3
else min_sq_fac_aux n 3

/-- The correctness property of the return value of `min_sq_fac`.
  * If `none`, then `n` is squarefree;
  * If `some d`, then `d` is a minimal square factor of `n` -/
def min_sq_fac_prop (n : ℕ) : option ℕ → Prop
| none := squarefree n
| (some d) := prime d ∧ d * d ∣ n ∧ ∀ p, prime p → p * p ∣ n → d ≤ p

theorem min_sq_fac_prop_div (n) {k} (pk : prime k) (dk : k ∣ n) (dkk : ¬ k * k ∣ n)
  {o} (H : min_sq_fac_prop (n / k) o) : min_sq_fac_prop n o :=
begin
  have : ∀ p, prime p → p*p ∣ n → k*(p*p) ∣ n := λ p pp dp,
    have _ := (coprime_primes pk pp).2 (λ e, by { subst e, contradiction }),
    (coprime_mul_iff_right.2 ⟨this, this⟩).mul_dvd_of_dvd_of_dvd dk dp,
  cases o with d,
  { rw [min_sq_fac_prop, squarefree_iff_prime_squarefree] at H ⊢,
    exact λ p pp dp, H p pp ((dvd_div_iff dk).2 (this _ pp dp)) },
  { obtain ⟨H1, H2, H3⟩ := H,
    simp only [dvd_div_iff dk] at H2 H3,
    exact ⟨H1, dvd_trans (dvd_mul_left _ _) H2, λ p pp dp, H3 _ pp (this _ pp dp)⟩ }
end

theorem min_sq_fac_aux_has_prop : ∀ {n : ℕ} k, 0 < n → ∀ i, k = 2*i+3 →
  (∀ m, prime m → m ∣ n → k ≤ m) → min_sq_fac_prop n (min_sq_fac_aux n k)
| n k := λ n0 i e ih, begin
  rw min_sq_fac_aux,
  by_cases h : n < k*k; simp [h],
  { refine squarefree_iff_prime_squarefree.2 (λ p pp d, _),
    have := ih p pp (dvd_trans ⟨_, rfl⟩ d),
    have := nat.mul_le_mul this this,
    exact not_le_of_lt h (le_trans this (le_of_dvd n0 d)) },
  have k2 : 2 ≤ k, { subst e, exact dec_trivial },
  have k0 : 0 < k := lt_of_lt_of_le dec_trivial k2,
  have IH : ∀ n', n' ∣ n → ¬ k ∣ n' → min_sq_fac_prop n' (n'.min_sq_fac_aux (k + 2)),
  { intros n' nd' nk,
    have hn' := le_of_dvd n0 nd',
    refine
      have nat.sqrt n' - k < nat.sqrt n + 2 - k, from
        lt_of_le_of_lt (nat.sub_le_sub_right (nat.sqrt_le_sqrt hn') _) (nat.min_fac_lemma n k h),
      @min_sq_fac_aux_has_prop n' (k+2) (pos_of_dvd_of_pos nd' n0)
        (i+1) (by simp [e, left_distrib]) (λ m m2 d, _),
    cases nat.eq_or_lt_of_le (ih m m2 (dvd_trans d nd')) with me ml,
    { subst me, contradiction },
    apply (nat.eq_or_lt_of_le ml).resolve_left, intro me,
    rw [← me, e] at d, change 2 * (i + 2) ∣ n' at d,
    have := ih _ prime_two (dvd_trans (dvd_of_mul_right_dvd d) nd'),
    rw e at this, exact absurd this dec_trivial },
  have pk : k ∣ n → prime k,
  { refine λ dk, prime_def_min_fac.2 ⟨k2, le_antisymm (min_fac_le k0) _⟩,
    exact ih _ (min_fac_prime (ne_of_gt k2)) (dvd_trans (min_fac_dvd _) dk) },
  split_ifs with dk dkk,
  { exact ⟨pk dk, (nat.dvd_div_iff dk).1 dkk, λ p pp d, ih p pp (dvd_trans ⟨_, rfl⟩ d)⟩ },
  { specialize IH (n/k) (div_dvd_of_dvd dk) dkk,
    exact min_sq_fac_prop_div _ (pk dk) dk (mt (nat.dvd_div_iff dk).2 dkk) IH },
  { exact IH n (dvd_refl _) dk }
end
using_well_founded {rel_tac :=
  λ _ _, `[exact ⟨_, measure_wf (λ ⟨n, k⟩, nat.sqrt n + 2 - k)⟩]}

theorem min_sq_fac_has_prop (n : ℕ) : min_sq_fac_prop n (min_sq_fac n) :=
begin
  dunfold min_sq_fac, split_ifs with d2 d4,
  { exact ⟨prime_two, (dvd_div_iff d2).1 d4, λ p pp _, pp.two_le⟩ },
  { cases nat.eq_zero_or_pos n with n0 n0, { subst n0, cases d4 dec_trivial },
    refine min_sq_fac_prop_div _ prime_two d2 (mt (dvd_div_iff d2).2 d4) _,
    refine min_sq_fac_aux_has_prop 3 (nat.div_pos (le_of_dvd n0 d2) dec_trivial) 0 rfl _,
    refine λ p pp dp, succ_le_of_lt (lt_of_le_of_ne pp.two_le _),
    rintro rfl, contradiction },
  { cases nat.eq_zero_or_pos n with n0 n0, { subst n0, cases d2 dec_trivial },
    refine min_sq_fac_aux_has_prop _ n0 0 rfl _,
    refine λ p pp dp, succ_le_of_lt (lt_of_le_of_ne pp.two_le _),
    rintro rfl, contradiction },
end

theorem min_sq_fac_prime {n d : ℕ} (h : n.min_sq_fac = some d) : prime d :=
by { have := min_sq_fac_has_prop n, rw h at this, exact this.1 }

theorem min_sq_fac_dvd {n d : ℕ} (h : n.min_sq_fac = some d) : d * d ∣ n :=
by { have := min_sq_fac_has_prop n, rw h at this, exact this.2.1 }

theorem min_sq_fac_le_of_dvd {n d : ℕ} (h : n.min_sq_fac = some d)
  {m} (m2 : 2 ≤ m) (md : m * m ∣ n) : d ≤ m :=
begin
  have := min_sq_fac_has_prop n, rw h at this,
  have fd := min_fac_dvd m,
  exact le_trans
    (this.2.2 _ (min_fac_prime $ ne_of_gt m2) (dvd_trans (mul_dvd_mul fd fd) md))
    (min_fac_le $ lt_of_lt_of_le dec_trivial m2),
end

lemma squarefree_iff_min_sq_fac {n : ℕ} :
  squarefree n ↔ n.min_sq_fac = none :=
begin
  have := min_sq_fac_has_prop n,
  split; intro H,
  { cases n.min_sq_fac with d, {refl},
    cases squarefree_iff_prime_squarefree.1 H _ this.1 this.2.1 },
  { rwa H at this }
end

instance : decidable_pred (squarefree : ℕ → Prop) :=
λ n, decidable_of_iff' _ squarefree_iff_min_sq_fac

theorem squarefree_two : squarefree 2 := by rw squarefree_iff_nodup_factors; norm_num

open unique_factorization_monoid

lemma divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0) :
  (n.divisors.filter squarefree).val =
    (unique_factorization_monoid.normalized_factors n).to_finset.powerset.val.map
      (λ x, x.val.prod) :=
begin
  rw (finset.nodup _).ext ((finset.nodup _).map_on _),
  { intro a,
    simp only [multiset.mem_filter, id.def, multiset.mem_map, finset.filter_val, ← finset.mem_def,
      mem_divisors],
    split,
    { rintro ⟨⟨an, h0⟩, hsq⟩,
      use (unique_factorization_monoid.normalized_factors a).to_finset,
      simp only [id.def, finset.mem_powerset],
      rcases an with ⟨b, rfl⟩,
      rw mul_ne_zero_iff at h0,
      rw unique_factorization_monoid.squarefree_iff_nodup_normalized_factors h0.1 at hsq,
      rw [multiset.to_finset_subset, multiset.to_finset_val, hsq.dedup, ← associated_iff_eq,
        normalized_factors_mul h0.1 h0.2],
      exact ⟨multiset.subset_of_le (multiset.le_add_right _ _), normalized_factors_prod h0.1⟩ },
    { rintro ⟨s, hs, rfl⟩,
      rw [finset.mem_powerset, ← finset.val_le_iff, multiset.to_finset_val] at hs,
      have hs0 : s.val.prod ≠ 0,
      { rw [ne.def, multiset.prod_eq_zero_iff],
        simp only [exists_prop, id.def, exists_eq_right],
        intro con,
        apply not_irreducible_zero (irreducible_of_normalized_factor 0
            (multiset.mem_dedup.1 (multiset.mem_of_le hs con))) },
      rw (normalized_factors_prod h0).symm.dvd_iff_dvd_right,
      refine ⟨⟨multiset.prod_dvd_prod_of_le (le_trans hs (multiset.dedup_le _)), h0⟩, _⟩,
      have h := unique_factorization_monoid.factors_unique irreducible_of_normalized_factor
        (λ x hx, irreducible_of_normalized_factor x (multiset.mem_of_le
          (le_trans hs (multiset.dedup_le _)) hx)) (normalized_factors_prod hs0),
      rw [associated_eq_eq, multiset.rel_eq] at h,
      rw [unique_factorization_monoid.squarefree_iff_nodup_normalized_factors hs0, h],
      apply s.nodup } },
  { intros x hx y hy h,
    rw [← finset.val_inj, ← multiset.rel_eq, ← associated_eq_eq],
    rw [← finset.mem_def, finset.mem_powerset] at hx hy,
    apply unique_factorization_monoid.factors_unique _ _ (associated_iff_eq.2 h),
    { intros z hz,
      apply irreducible_of_normalized_factor z,
      rw ← multiset.mem_to_finset,
      apply hx hz },
    { intros z hz,
      apply irreducible_of_normalized_factor z,
      rw ← multiset.mem_to_finset,
      apply hy hz } }
end

open_locale big_operators

lemma sum_divisors_filter_squarefree {n : ℕ} (h0 : n ≠ 0)
  {α : Type*} [add_comm_monoid α] {f : ℕ → α} :
  ∑ i in (n.divisors.filter squarefree), f i =
    ∑ i in (unique_factorization_monoid.normalized_factors n).to_finset.powerset, f (i.val.prod) :=
by rw [finset.sum_eq_multiset_sum, divisors_filter_squarefree h0, multiset.map_map,
    finset.sum_eq_multiset_sum]

lemma sq_mul_squarefree_of_pos {n : ℕ} (hn : 0 < n) :
  ∃ a b : ℕ, 0 < a ∧ 0 < b ∧ b ^ 2 * a = n ∧ squarefree a :=
begin
  let S := {s ∈ finset.range (n + 1) | s ∣ n ∧ ∃ x, s = x ^ 2},
  have hSne : S.nonempty,
  { use 1,
    have h1 : 0 < n ∧ ∃ (x : ℕ), 1 = x ^ 2 := ⟨hn, ⟨1, (one_pow 2).symm⟩⟩,
    simpa [S] },
  let s := finset.max' S hSne,
  have hs : s ∈ S := finset.max'_mem S hSne,
  simp only [finset.sep_def, S, finset.mem_filter, finset.mem_range] at hs,
  obtain ⟨hsn1, ⟨a, hsa⟩, ⟨b, hsb⟩⟩ := hs,
  rw hsa at hn,
  obtain ⟨hlts, hlta⟩ := canonically_ordered_comm_semiring.mul_pos.mp hn,
  rw hsb at hsa hn hlts,
  refine ⟨a, b, hlta, (pow_pos_iff zero_lt_two).mp hlts, hsa.symm, _⟩,
  rintro x ⟨y, hy⟩,
  rw nat.is_unit_iff,
  by_contra hx,
  refine lt_le_antisymm _ (finset.le_max' S ((b * x) ^ 2) _),
  { simp_rw [S, hsa, finset.sep_def, finset.mem_filter, finset.mem_range],
    refine ⟨lt_succ_iff.mpr (le_of_dvd hn _), _, ⟨b * x, rfl⟩⟩; use y; rw hy; ring },
  { convert lt_mul_of_one_lt_right hlts
      (one_lt_pow 2 x zero_lt_two (one_lt_iff_ne_zero_and_ne_one.mpr ⟨λ h, by simp * at *, hx⟩)),
    rw mul_pow },
end

lemma sq_mul_squarefree_of_pos' {n : ℕ} (h : 0 < n) :
  ∃ a b : ℕ, (b + 1) ^ 2 * (a + 1) = n ∧ squarefree (a + 1) :=
begin
  obtain ⟨a₁, b₁, ha₁, hb₁, hab₁, hab₂⟩ := sq_mul_squarefree_of_pos h,
  refine ⟨a₁.pred, b₁.pred, _, _⟩;
  simpa only [add_one, succ_pred_eq_of_pos, ha₁, hb₁],
end

lemma sq_mul_squarefree (n : ℕ) : ∃ a b : ℕ, b ^ 2 * a = n ∧ squarefree a :=
begin
  cases n,
  { exact ⟨1, 0, (by simp), squarefree_one⟩ },
  { obtain ⟨a, b, -, -, h₁, h₂⟩ := sq_mul_squarefree_of_pos (succ_pos n),
    exact ⟨a, b, h₁, h₂⟩ },
end

lemma squarefree_iff_prime_sq_not_dvd (n : ℕ) :
  squarefree n ↔ ∀ x : ℕ, x.prime → ¬ x * x ∣ n :=
squarefree_iff_irreducible_sq_not_dvd_of_exists_irreducible
  ⟨2, (irreducible_iff_nat_prime _).2 prime_two⟩

/-- `squarefree` is multiplicative. Note that the → direction does not require `hmn`
and generalizes to arbitrary commutative monoids. See `squarefree.of_mul_left` and
`squarefree.of_mul_right` above for auxiliary lemmas. -/
lemma squarefree_mul {m n : ℕ} (hmn : m.coprime n) :
  squarefree (m * n) ↔ squarefree m ∧ squarefree n :=
begin
  simp only [squarefree_iff_prime_squarefree, ←sq, ←forall_and_distrib],
  refine ball_congr (λ p hp, _),
  simp only [hmn.is_prime_pow_dvd_mul (hp.is_prime_pow.pow two_ne_zero), not_or_distrib],
end

end nat

/-! ### Square-free prover -/

open norm_num

namespace tactic
namespace norm_num

/-- A predicate representing partial progress in a proof of `squarefree`. -/
def squarefree_helper (n k : ℕ) : Prop :=
0 < k → (∀ m, nat.prime m → m ∣ bit1 n → bit1 k ≤ m) → squarefree (bit1 n)

lemma squarefree_bit10 (n : ℕ) (h : squarefree_helper n 1) :
  squarefree (bit0 (bit1 n)) :=
begin
  refine @nat.min_sq_fac_prop_div _ _ nat.prime_two two_dvd_bit0 _ none _,
  { rw [bit0_eq_two_mul (bit1 n), mul_dvd_mul_iff_left (@two_ne_zero ℕ _ _)],
    exact nat.not_two_dvd_bit1 _ },
  { rw [bit0_eq_two_mul, nat.mul_div_right _ (dec_trivial:0<2)],
    refine h dec_trivial (λ p pp dp, nat.succ_le_of_lt (lt_of_le_of_ne pp.two_le _)),
    rintro rfl, exact nat.not_two_dvd_bit1 _ dp }
end

lemma squarefree_bit1 (n : ℕ) (h : squarefree_helper n 1) :
  squarefree (bit1 n) :=
begin
  refine h dec_trivial (λ p pp dp, nat.succ_le_of_lt (lt_of_le_of_ne pp.two_le _)),
  rintro rfl, exact nat.not_two_dvd_bit1 _ dp
end

lemma squarefree_helper_0 {k} (k0 : 0 < k)
  {p : ℕ} (pp : nat.prime p) (h : bit1 k ≤ p) : bit1 (k + 1) ≤ p ∨ bit1 k = p :=
begin
  rcases lt_or_eq_of_le h with (hp:_+1≤_) | hp,
  { rw [bit1, bit0_eq_two_mul] at hp, change 2*(_+1) ≤ _ at hp,
    rw [bit1, bit0_eq_two_mul],
    refine or.inl (lt_of_le_of_ne hp _), unfreezingI { rintro rfl },
    exact nat.not_prime_mul dec_trivial (lt_add_of_pos_left _ k0) pp },
  { exact or.inr hp }
end

lemma squarefree_helper_1 (n k k' : ℕ) (e : k + 1 = k')
  (hk : nat.prime (bit1 k) → ¬ bit1 k ∣ bit1 n)
  (H : squarefree_helper n k') : squarefree_helper n k :=
λ k0 ih, begin
  subst e,
  refine H (nat.succ_pos _) (λ p pp dp, _),
  refine (squarefree_helper_0 k0 pp (ih p pp dp)).resolve_right (λ hp, _),
  subst hp, cases hk pp dp
end

lemma squarefree_helper_2 (n k k' c : ℕ) (e : k + 1 = k')
  (hc : bit1 n % bit1 k = c) (c0 : 0 < c)
  (h : squarefree_helper n k') : squarefree_helper n k :=
begin
  refine squarefree_helper_1 _ _ _ e (λ _, _) h,
  refine mt _ (ne_of_gt c0), intro e₁,
  rwa [← hc, ← nat.dvd_iff_mod_eq_zero],
end

lemma squarefree_helper_3 (n n' k k' c : ℕ) (e : k + 1 = k')
  (hn' : bit1 n' * bit1 k = bit1 n)
  (hc : bit1 n' % bit1 k = c) (c0 : 0 < c)
  (H : squarefree_helper n' k') : squarefree_helper n k :=
λ k0 ih, begin
  subst e,
  have k0' : 0 < bit1 k := bit1_pos (nat.zero_le _),
  have dn' : bit1 n' ∣ bit1 n := ⟨_, hn'.symm⟩,
  have dk : bit1 k ∣ bit1 n := ⟨_, ((mul_comm _ _).trans hn').symm⟩,
  have : bit1 n / bit1 k = bit1 n',
  { rw [← hn', nat.mul_div_cancel _ k0'] },
  have k2 : 2 ≤ bit1 k := nat.succ_le_succ (bit0_pos k0),
  have pk : (bit1 k).prime,
  { refine nat.prime_def_min_fac.2 ⟨k2, le_antisymm (nat.min_fac_le k0') _⟩,
    exact ih _ (nat.min_fac_prime (ne_of_gt k2)) (dvd_trans (nat.min_fac_dvd _) dk) },
  have dkk' : ¬ bit1 k ∣ bit1 n', {rw [nat.dvd_iff_mod_eq_zero, hc], exact ne_of_gt c0},
  have dkk : ¬ bit1 k * bit1 k ∣ bit1 n, {rwa [← nat.dvd_div_iff dk, this]},
  refine @nat.min_sq_fac_prop_div _ _ pk dk dkk none _,
  rw this, refine H (nat.succ_pos _) (λ p pp dp, _),
  refine (squarefree_helper_0 k0 pp (ih p pp $ dvd_trans dp dn')).resolve_right (λ e, _),
  subst e, contradiction
end

lemma squarefree_helper_4 (n k k' : ℕ) (e : bit1 k * bit1 k = k')
  (hd : bit1 n < k') : squarefree_helper n k :=
begin
  cases nat.eq_zero_or_pos n with h h,
  { subst n, exact λ _ _, squarefree_one },
  subst e,
  refine λ k0 ih, irreducible.squarefree (nat.prime_def_le_sqrt.2 ⟨bit1_lt_bit1.2 h, _⟩),
  intros m m2 hm md,
  obtain ⟨p, pp, hp⟩ := nat.exists_prime_and_dvd (ne_of_gt m2),
  have := (ih p pp (dvd_trans hp md)).trans
    (le_trans (nat.le_of_dvd (lt_of_lt_of_le dec_trivial m2) hp) hm),
  rw nat.le_sqrt at this,
  exact not_le_of_lt hd this
end

lemma not_squarefree_mul (a aa b n : ℕ) (ha : a * a = aa) (hb : aa * b = n)
  (h₁ : 1 < a) : ¬ squarefree n :=
by { rw [← hb, ← ha], exact λ H, ne_of_gt h₁ (nat.is_unit_iff.1 $ H _ ⟨_, rfl⟩) }

/-- Given `e` a natural numeral and `a : nat` with `a^2 ∣ n`, return `⊢ ¬ squarefree e`. -/
meta def prove_non_squarefree (e : expr) (n a : ℕ) : tactic expr := do
  let ea := reflect a,
  let eaa := reflect (a*a),
  c ← mk_instance_cache `(nat),
  (c, p₁) ← prove_lt_nat c `(1) ea,
  let b := n / (a*a), let eb := reflect b,
  (c, eaa, pa) ← prove_mul_nat c ea ea,
  (c, e', pb) ← prove_mul_nat c eaa eb,
  guard (e' =ₐ e),
  return $ `(@not_squarefree_mul).mk_app [ea, eaa, eb, e, pa, pb, p₁]

/-- Given `en`,`en1 := bit1 en`, `n1` the value of `en1`, `ek`,
  returns `⊢ squarefree_helper en ek`. -/
meta def prove_squarefree_aux : ∀ (ic : instance_cache) (en en1 : expr) (n1 : ℕ)
  (ek : expr) (k : ℕ), tactic expr
| ic en en1 n1 ek k := do
  let k1 := bit1 k,
  let ek1 := `(bit1:ℕ→ℕ).mk_app [ek],
  if n1 < k1*k1 then do
    (ic, ek', p₁) ← prove_mul_nat ic ek1 ek1,
    (ic, p₂) ← prove_lt_nat ic en1 ek',
    pure $ `(squarefree_helper_4).mk_app [en, ek, ek', p₁, p₂]
  else do
    let c := n1 % k1,
    let k' := k+1, let ek' := reflect k',
    (ic, p₁) ← prove_succ ic ek ek',
    if c = 0 then do
      let n1' := n1 / k1,
      let n' := n1' / 2, let en' := reflect n',
      let en1' := `(bit1:ℕ→ℕ).mk_app [en'],
      (ic, _, pn') ← prove_mul_nat ic en1' ek1,
      let c := n1' % k1,
      guard (c ≠ 0),
      (ic, ec, pc) ← prove_div_mod ic en1' ek1 tt,
      (ic, p₀) ← prove_pos ic ec,
      p₂ ← prove_squarefree_aux ic en' en1' n1' ek' k',
      pure $ `(squarefree_helper_3).mk_app [en, en', ek, ek', ec, p₁, pn', pc, p₀, p₂]
    else do
      (ic, ec, pc) ← prove_div_mod ic en1 ek1 tt,
      (ic, p₀) ← prove_pos ic ec,
      p₂ ← prove_squarefree_aux ic en en1 n1 ek' k',
      pure $ `(squarefree_helper_2).mk_app [en, ek, ek', ec, p₁, pc, p₀, p₂]

/-- Given `n > 0` a squarefree natural numeral, returns `⊢ squarefree n`. -/
meta def prove_squarefree (en : expr) (n : ℕ) : tactic expr :=
match match_numeral en with
| match_numeral_result.one := pure `(@squarefree_one ℕ _)
| match_numeral_result.bit0 en1 := match match_numeral en1 with
  | match_numeral_result.one := pure `(nat.squarefree_two)
  | match_numeral_result.bit1 en := do
    ic ← mk_instance_cache `(ℕ),
    p ← prove_squarefree_aux ic en en1 (n / 2) `(1:ℕ) 1,
    pure $ `(squarefree_bit10).mk_app [en, p]
  | _ := failed
  end
| match_numeral_result.bit1 en' := do
  ic ← mk_instance_cache `(ℕ),
  p ← prove_squarefree_aux ic en' en n `(1:ℕ) 1,
  pure $ `(squarefree_bit1).mk_app [en', p]
| _ := failed
end

/-- Evaluates the `prime` and `min_fac` functions. -/
@[norm_num] meta def eval_squarefree : expr → tactic (expr × expr)
| `(squarefree (%%e : ℕ)) := do
  n ← e.to_nat,
  match n with
  | 0 := false_intro `(@not_squarefree_zero ℕ _ _)
  | 1 := true_intro `(@squarefree_one ℕ _)
  | _ := match n.min_sq_fac with
    | some d := prove_non_squarefree e n d >>= false_intro
    | none := prove_squarefree e n >>= true_intro
    end
  end
| _ := failed

end norm_num
end tactic