import group_theory.order_of_element .Zmod algebra.pi_instances
open equiv fintype finset function
universes u v w
variables {G : Type u} {α : Type v} {β : Type w} [group G]

namespace finset

lemma filter_insert_of_pos [decidable_eq α] (s : finset α) {P : α → Prop}
  [decidable_pred P] (a : α) (h : P a) : (insert a s).filter P = insert a (s.filter P) :=
ext.2 (λ x, by rw [mem_filter, mem_insert, mem_insert, mem_filter, eq_comm];
  exact ⟨λ h₁, by cases h₁.1; simp * at *, λ h₁, by cases h₁; simp * at *⟩)

lemma filter_insert_of_neg [decidable_eq α] (s : finset α) {P : α → Prop}
  [decidable_pred P] (a : α) (h : ¬P a) : (insert a s).filter P = s.filter P :=
ext.2 (λ x, by rw [mem_filter, mem_insert, mem_filter, eq_comm];
  exact ⟨λ h₁, by cases h₁.1; simp * at *, by finish⟩)

lemma prod_const [comm_monoid β] (s : finset α) (b : β)
  [decidable_eq α] : s.prod (λ x, b) = b ^ s.card :=
finset.induction_on s rfl (by simp [pow_add, mul_comm] {contextual := tt})

lemma sum_const [add_comm_monoid β] (s : finset α) (b : β)
  [decidable_eq α] : s.sum (λ x, b) = add_monoid.smul s.card b :=
finset.induction_on s rfl (by simp [add_monoid.add_smul] {contextual := tt})

lemma card_pi {δ : α → Type*} [decidable_eq α]
  (s : finset α) (t : Π a, finset (δ a)) : (s.pi t).card = s.prod (λ a, card (t a)) :=
multiset.card_pi _ _

end finset

lemma nat.sum_mod [decidable_eq α] (s : finset α) (f : α → ℕ) (n : ℕ) :
  s.sum f ≡ (s.filter (λ x, f x % n ≠ 0)).sum f [MOD n] :=
finset.induction_on s rfl begin
  assume a s has ih,
  by_cases ha : f a % n ≠ 0,
  { rw [finset.sum_insert has, finset.filter_insert_of_pos s a ha, finset.sum_insert],
    exact nat.modeq.modeq_add rfl ih,
    { finish [finset.mem_filter] } },
  { rw [finset.sum_insert has, finset.filter_insert_of_neg s a ha,
      ← zero_add (finset.sum (finset.filter _ _) _)],
    rw [ne.def, ← nat.zero_mod n] at ha,
    exact nat.modeq.modeq_add (not_not.1 ha) ih }
end

namespace fintype

instance quotient_fintype {α : Type*} [fintype α] (s : setoid α)
  [decidable_eq (quotient s)] : fintype (quotient s) :=
fintype.of_surjective quotient.mk (λ x, quotient.induction_on x (λ x, ⟨x, rfl⟩))

instance finset_fintype [fintype α] : fintype (finset α) :=
⟨finset.univ.powerset, λ x, finset.mem_powerset.2 (finset.subset_univ _)⟩

instance set.fintype (α : Type u) [fintype α] [decidable_eq α] : fintype (set α) :=
pi.fintype

def subtype_fintype [fintype α] (p : α → Prop) [decidable_pred p] : fintype {x // p x} :=
set_fintype _

lemma card_eq_one_iff [fintype α] : card α = 1 ↔ (∃ x : α, ∀ y : α, y = x) :=
by rw [← card_unit, card_eq]; exact
⟨λ ⟨a⟩, ⟨a.symm unit.star, λ y, a.bijective.1 (subsingleton.elim _ _)⟩,
λ ⟨x, hx⟩, ⟨⟨λ _, unit.star, λ _, x, λ _, (hx _).trans (hx _).symm,
    λ _, subsingleton.elim _ _⟩⟩⟩

lemma card_eq_zero_iff [fintype α] : card α = 0 ↔ (α → false) :=
⟨λ h a, have e : α ≃ empty := classical.choice (card_eq.1 (by simp [h])),
  (e a).elim,
λ h, have e : α ≃ empty := ⟨λ a, (h a).elim, λ a, a.elim, λ a, (h a).elim, λ a, a.elim⟩,
  by simp [card_congr e]⟩

lemma card_pos_iff [fintype α] : 0 < card α ↔ nonempty α :=
⟨λ h, classical.by_contradiction (λ h₁,
  have card α = 0 := card_eq_zero_iff.2 (λ a, h₁ ⟨a⟩),
  lt_irrefl 0 $ by rwa this at h),
λ ⟨a⟩, nat.pos_of_ne_zero (mt card_eq_zero_iff.1 (λ h, h a))⟩

lemma card_le_of_injective [fintype α] [fintype β] (f : α → β)
  (hf : injective f) : card α ≤ card β :=
by haveI := classical.prop_decidable; exact
finset.card_le_card_of_inj_on f (λ _ _, finset.mem_univ _) (λ _ _ _ _ h, hf h)

lemma card_le_one_iff [fintype α] : card α ≤ 1 ↔ (∀ a b : α, a = b) :=
let n := card α in
have hn : n = card α := rfl,
match n, hn with
| 0 := λ ha, ⟨λ h, λ a, (card_eq_zero_iff.1 ha.symm a).elim, λ _, ha ▸ nat.le_succ _⟩
| 1 := λ ha, ⟨λ h, λ a b, let ⟨x, hx⟩ := card_eq_one_iff.1 ha.symm in
  by rw [hx a, hx b],
    λ _, ha ▸ le_refl _⟩
| (n+2) := λ ha, ⟨λ h, by rw ← ha at h; exact absurd h dec_trivial,
  (λ h, card_unit ▸ card_le_of_injective (λ _, ())
    (λ _ _ _, h _ _))⟩
end

open finset

lemma card_pi {β : α → Type*} [fintype α] [decidable_eq α]
  [f : Π a, fintype (β a)] :
  card (Π a, β a) = univ.prod (λ a, card (β a)) :=
by letI f : fintype (Πa∈univ, β a) :=
  ⟨(univ.pi $ λa, univ), assume f, finset.mem_pi.2 $ assume a ha, mem_univ _⟩;
exact calc card (Π a, β a) = card (Π a ∈ univ, β a) : card_congr
  ⟨λ f a ha, f a, λ f a, f a (mem_univ a), λ _, rfl, λ _, rfl⟩
... = univ.prod (λ a, card (β a)) : finset.card_pi _ _

lemma card_fun [fintype α] [decidable_eq α] [fintype β] :
  card (α → β) = card β ^ card α :=
by rw [card_pi, prod_const, nat.pow_eq_pow]; refl

end fintype

namespace set

lemma card_eq_of_eq {s t : set α} [fintype s] [fintype t] (h : s = t) :
  card s = card t :=
by congr; assumption

lemma card_image_of_inj_on {s : set α} [fintype s]
  {f : α → β} [fintype (f '' s)] (H : ∀x∈s, ∀y∈s, f x = f y → x = y) :
  fintype.card (f '' s) = fintype.card s :=
by haveI := classical.prop_decidable; exact
calc fintype.card (f '' s) = (s.to_finset.image f).card : card_fintype_of_finset' _ (by simp)
... = s.to_finset.card : card_image_of_inj_on
    (λ x hx y hy hxy, H x (mem_to_finset.1 hx) y (mem_to_finset.1 hy) hxy)
... = card s : (card_fintype_of_finset' _ (λ a, mem_to_finset)).symm

lemma card_image_of_injective (s : set α) [fintype s]
  {f : α → β} [fintype (f '' s)] (H : injective f) :
  fintype.card (f '' s) = fintype.card s :=
card_image_of_inj_on $ λ _ _ _ _ h, H h

lemma coe_to_finset' [decidable_eq α] (s : set α) [fintype s] : (↑s.to_finset : set α) = s :=
set.ext (by simp)

lemma ssubset_iff_subset_not_subset {s t : set α} : s ⊂ t ↔ s ⊆ t ∧ ¬ t ⊆ s :=
by split; simp [set.ssubset_def, ne.def, set.subset.antisymm_iff] {contextual := tt}

lemma coe_ssubset [decidable_eq α] {s t : finset α} : (↑s : set α) ⊂ ↑t ↔ s ⊂ t :=
show ↑s ⊆ ↑t ∧ ↑s ≠ ↑t ↔ s ⊆ t ∧ ¬t ⊆ s,
  by split; simp [ssubset_iff_subset_not_subset, set.subset.antisymm_iff] {contextual := tt}

lemma card_lt_card {s t : set α} [fintype s] [fintype t] (h : s ⊂ t) : card s < card t :=
begin
  haveI := classical.prop_decidable,
  rw [card_fintype_of_finset' _ (λ x, mem_to_finset), card_fintype_of_finset' _ (λ x, mem_to_finset)],
  rw [← coe_to_finset' s, ← coe_to_finset' t, coe_ssubset] at h,
  exact finset.card_lt_card h,
end

def equiv_univ (α : Type u) : α ≃ (set.univ : set α) :=
{ to_fun := λ a, ⟨a, mem_univ _⟩,
  inv_fun := λ a, a.1,
  left_inv := λ a, rfl,
  right_inv := λ ⟨a, ha⟩, rfl }

@[simp] lemma card_univ (α : Type u) [fintype α] [fintype.{u} (set.univ : set α)] :
  fintype.card (set.univ : set α) = fintype.card α :=
eq.symm (card_congr (equiv_univ α))

lemma eq_of_card_eq_of_subset {s t : set α} [fintype s] [fintype t]
  (hcard : card s = card t) (hsub : s ⊆ t) : s = t :=
classical.by_contradiction (λ h, lt_irrefl (card t)
  (have card s < card t := set.card_lt_card ⟨hsub, h⟩,
    by rwa hcard at this))

end set

local attribute [instance, priority 0]
  fintype.subtype_fintype set_fintype classical.prop_decidable

section should_be_in_group_theory

noncomputable instance [fintype G] (H : set G) [is_subgroup H] :
fintype (left_cosets H) := fintype.quotient_fintype (left_rel H)

lemma card_eq_card_cosets_mul_card_subgroup [fintype G] (H : set G) [is_subgroup H] :
  card G = card (left_cosets H) * card H :=
by rw ← card_prod;
  exact card_congr (is_subgroup.group_equiv_left_cosets_times_subgroup _)

lemma order_of_dvd_of_pow_eq_one [fintype G] {a : G} {n : ℕ} (h : a ^ n = 1) :
  order_of a ∣ n :=
by_contradiction
(λ h₁, nat.find_min _ (show n % order_of a < order_of a,
  from nat.mod_lt _ (nat.pos_of_ne_zero (order_of_ne_zero _)))
    ⟨mt nat.dvd_of_mod_eq_zero h₁, by rwa ← pow_eq_mod_order_of⟩)

lemma eq_one_of_order_of_eq_one [fintype G] {a : G} (h : order_of a = 1) : a = 1 :=
by conv { to_lhs, rw [← pow_one a, ← h, pow_order_of_eq_one] }

lemma order_eq_card_gpowers [fintype G] {a : G} : order_of a = card (gpowers a) :=
begin
  refine (finset.card_eq_of_bijective _ _ _ _).symm,
  { exact λn hn, ⟨gpow a n, ⟨n, rfl⟩⟩ },
  { exact assume ⟨_, i, rfl⟩ _,
    have pos: (0:int) < order_of a,
      from int.coe_nat_lt.mpr $ nat.pos_iff_ne_zero.mpr $ order_of_ne_zero a,
    have 0 ≤ i % (order_of a),
      from int.mod_nonneg _ $ ne_of_gt pos,
    ⟨int.to_nat (i % order_of a),
      by rw [← int.coe_nat_lt, int.to_nat_of_nonneg this];
        exact ⟨int.mod_lt_of_pos _ pos, subtype.eq gpow_eq_mod_order_of.symm⟩⟩ },
  { intros, exact finset.mem_univ _ },
  { exact assume i j hi hj eq, pow_injective_of_lt_order_of a hi hj $ by simpa using eq }
end

@[simp] lemma card_trivial [fintype (is_subgroup.trivial G)] :
  fintype.card (is_subgroup.trivial G) = 1 := fintype.card_eq_one_iff.2
  ⟨⟨(1 : G), by simp⟩, λ ⟨y, hy⟩, subtype.eq $ is_subgroup.mem_trivial.1 hy⟩

local attribute [instance] left_rel normal_subgroup.to_is_subgroup

instance quotient.mk.is_group_hom (H : set G) [normal_subgroup H] : @is_group_hom G (left_cosets H) _ _
  quotient.mk :=
⟨λ _ _, rfl⟩

instance subtype.val.is_group_hom (H : set G) [is_subgroup H] : is_group_hom (subtype.val : H → G) :=
⟨λ _ _, rfl⟩

def normalizer (H : set G) : set G :=
{ g : G | ∀ n, n ∈ H ↔ g * n * g⁻¹ ∈ H }

instance (H : set G) [is_subgroup H] : is_subgroup (normalizer H) :=
{ one_mem := by simp [normalizer],
  mul_mem := λ a b (ha : ∀ n, n ∈ H ↔ a * n * a⁻¹ ∈ H)
    (hb : ∀ n, n ∈ H ↔ b * n * b⁻¹ ∈ H) n,
    by rw [mul_inv_rev, ← mul_assoc, mul_assoc a, mul_assoc a, ← ha, ← hb],
  inv_mem := λ a (ha : ∀ n, n ∈ H ↔ a * n * a⁻¹ ∈ H) n,
    by rw [ha (a⁻¹ * n * a⁻¹⁻¹)];
    simp [mul_assoc] }

lemma subset_normalizer (H : set G) [is_subgroup H] : H ⊆ normalizer H :=
λ g hg n, by rw [is_subgroup.mul_mem_cancel_left _ ((is_subgroup.inv_mem_iff _).2 hg),
  is_subgroup.mul_mem_cancel_right _ hg]

instance (H : set G) [is_subgroup H] : normal_subgroup { x : normalizer H | ↑x ∈ H } :=
{ one_mem := show (1 : G) ∈ H, from is_submonoid.one_mem _,
  mul_mem := λ a b ha hb, show (a * b : G) ∈ H, from is_submonoid.mul_mem ha hb,
  inv_mem := λ a ha, show (a⁻¹ : G) ∈ H, from is_subgroup.inv_mem ha,
  normal := λ a ha ⟨m, hm⟩, (hm a).1 ha }

lemma conj_inj_left {x : G} : injective (λ (n : G), x * n * x⁻¹) :=
λ a b h, (mul_left_inj x).1 $ (mul_right_inj (x⁻¹)).1 h

lemma mem_normalizer_fintype {H : set G} [fintype H] {x : G} :
  (∀ n, n ∈ H → x * n * x⁻¹ ∈ H) → x ∈ normalizer H :=
λ h n, ⟨h n, λ h₁,
have heq : (λ n, x * n * x⁻¹) '' H = H := set.eq_of_card_eq_of_subset
  (set.card_image_of_injective _ conj_inj_left) (λ n ⟨y, hy⟩, hy.2 ▸ h y hy.1),
have x * n * x⁻¹ ∈ (λ n, x * n * x⁻¹) '' H := heq.symm ▸ h₁,
let ⟨y, hy⟩ := this in conj_inj_left hy.2 ▸ hy.1⟩

noncomputable lemma preimage_quotient_mk_equiv_subgroup_times_set (H : set G) [is_subgroup H]
  (s : set (left_cosets H)) : quotient.mk ⁻¹' s ≃ (H × s) :=
have h : ∀ {x : left_cosets H} {a : G}, x ∈ s → a ∈ H →
  ⟦quotient.out x * a⟧ = ⟦quotient.out x⟧ := λ x a hx ha,
      quotient.sound (show (quotient.out x * a)⁻¹ * quotient.out x ∈ H,
      from (is_subgroup.inv_mem_iff _).1 $
        by rwa [mul_inv_rev, inv_inv, ← mul_assoc, inv_mul_self, one_mul]),
{ to_fun := λ ⟨a, ha⟩, ⟨⟨(quotient.out ⟦a⟧)⁻¹ * a,
    @quotient.exact _ (left_rel H) _ _ $ by simp⟩, ⟨⟦a⟧, ha⟩⟩,
  inv_fun := λ ⟨⟨a, ha⟩, ⟨x, hx⟩⟩, ⟨(quotient.out x) * a,
    show _ ∈ s, by simpa [h hx ha]⟩,
  left_inv := λ ⟨a, ha⟩, by simp,
  right_inv := λ ⟨⟨a, ha⟩, ⟨x, hx⟩⟩, by simp [h hx ha] }

end should_be_in_group_theory

class is_group_action (f : G → α → α) : Prop :=
(one : ∀ a : α, f (1 : G) a = a)
(mul : ∀ (x y : G) (a : α), f (x * y) a = f x (f y a))

namespace group_action

variables (f : G → α → α) [is_group_action f]

@[simp] lemma one_apply (a : α) : f 1 a = a := is_group_action.one f a

lemma mul_apply (x y : G) (a : α) : f (x * y) a = f x (f y a) := is_group_action.mul _ _ _ _

lemma bijective (g : G) : bijective (f g) :=
bijective_iff_has_inverse.2 ⟨f (g⁻¹),
  λ a, by rw [← mul_apply f, inv_mul_self, one_apply f],
  λ a, by rw [← mul_apply f, mul_inv_self, one_apply f]⟩

def orbit (a : α) := set.range (λ x : G, f x a)

lemma mem_orbit_iff {f : G → α → α} [is_group_action f] {a b : α} :
  b ∈ orbit f a ↔ ∃ x : G, f x a = b :=
by finish [orbit]

@[simp] lemma mem_orbit (a : α) (x : G) :
  f x a ∈ orbit f a :=
⟨x, rfl⟩

@[simp] lemma mem_orbit_self (a : α) :
  a ∈ orbit f a :=
⟨1, show f 1 a = a, by simp [one_apply f]⟩

lemma orbit_eq {f : G → α → α} [is_group_action f] {a b : α} : a ∈ orbit f b → orbit f a = orbit f b :=
λ ⟨x, (hx : f x b = a)⟩, set.ext (λ c, ⟨λ ⟨y, (hy : f y a = c)⟩, ⟨y * x,
  show f (y * x) b = c, by rwa [mul_apply f, hx]⟩,
λ ⟨y, (hy : f y b = c)⟩, ⟨y * x⁻¹,
  show f (y * x⁻¹) a = c, by
    conv {to_rhs, rw [← hy, ← mul_one y, ← inv_mul_self x, ← mul_assoc,
      mul_apply f, hx]}⟩⟩)

instance orbit_fintype (a : α) [decidable_eq α] [fintype G] :
fintype (orbit f a) := set.fintype_range _

def stabilizer (a : α) : set G :=
{x : G | f x a = a}

lemma mem_stabilizer_iff {f : G → α → α} [is_group_action f] {a : α} {x : G} :
  x ∈ stabilizer f a ↔ f x a = a :=
iff.rfl

instance (a : α) : is_subgroup (stabilizer f a) :=
{ one_mem := one_apply _ _,
  mul_mem := λ x y (hx : f x a = a) (hy : f y a = a),
    show f (x * y) a = a, by rw mul_apply f; simp *,
  inv_mem := λ x (hx : f x a = a), show f x⁻¹ a = a,
    by rw [← hx, ← mul_apply f, inv_mul_self, one_apply f, hx] }

noncomputable lemma orbit_equiv_left_cosets (a : α) :
  orbit f a ≃ left_cosets (stabilizer f a) :=
by letI := left_rel (stabilizer f a); exact
equiv.symm (@equiv.of_bijective _ _
  (λ x : left_cosets (stabilizer f a), quotient.lift_on x
    (λ x, (⟨f x a, mem_orbit _ _ _⟩ : orbit f a))
    (λ g h (H : _ = _), subtype.eq $ (group_action.bijective f (g⁻¹)).1
      $ show f g⁻¹ (f g a) = f g⁻¹ (f h a),
      by rw [← mul_apply f, ← mul_apply f, H, inv_mul_self, one_apply f]))
⟨λ g h, quotient.induction_on₂ g h (λ g h H, quotient.sound $
  have H : f g a = f h a := subtype.mk.inj H,
  show f (g⁻¹ * h) a = a,
  by rw [mul_apply f, ← H, ← mul_apply f, inv_mul_self, one_apply f]),
  λ ⟨b, ⟨g, hgb⟩⟩, ⟨⟦g⟧, subtype.eq hgb⟩⟩)

def fixed_points : set α := {a : α | ∀ x, x ∈ stabilizer f a}

lemma mem_fixed_points {f : G → α → α} [is_group_action f] {a : α} :
  a ∈ fixed_points f ↔ ∀ x : G, f x a = a := iff.rfl

lemma mem_fixed_points' {f : G → α → α} [is_group_action f] {a : α} : a ∈ fixed_points f ↔
  (∀ b, b ∈ orbit f a → b = a) :=
⟨λ h b h₁, let ⟨x, hx⟩ := mem_orbit_iff.1 h₁ in hx ▸ h x,
λ h b, mem_stabilizer_iff.2 (h _ (mem_orbit _ _ _))⟩

lemma card_orbit_of_mem_fixed_points {f : G → α → α} [is_group_action f]  {a : α} [fintype (orbit f a)] :
  a ∈ fixed_points f ↔ card (orbit f a) = 1 :=
begin
  rw [fintype.card_eq_one_iff, mem_fixed_points],
  split,
  { exact λ h, ⟨⟨a, mem_orbit_self _ _⟩, λ ⟨b, ⟨x, hx⟩⟩, subtype.eq $ by simp [h x, hx.symm]⟩ },
  { assume h x,
    rcases h with ⟨⟨z, hz⟩, hz₁⟩,
    exact calc f x a = z : subtype.mk.inj (hz₁ ⟨f x a, mem_orbit _ _ _⟩)
      ... = a : (subtype.mk.inj (hz₁ ⟨a, mem_orbit_self _ _⟩)).symm }
end

lemma card_modeq_card_fixed_points [fintype α] [fintype G] [fintype (fixed_points f)]
  {p n : ℕ} (hp : nat.prime p) (h : card G = p ^ n) : card α ≡ card (fixed_points f) [MOD p] :=
have hcard : ∀ s : set α, card ↥{x : α | orbit f x = s} % p ≠ 0
    ↔ card ↥{x : α | orbit f x = s} = 1 :=
  λ s, ⟨λ hs, begin
    have h : ∃ y, orbit f y = s := by_contradiction (λ h, begin
      rw not_exists at h,
      have : {x | orbit f x = s} = ∅ := set.eq_empty_iff_forall_not_mem.2 h,
      rw [set.card_eq_of_eq this, set.empty_card', nat.zero_mod] at hs,
      contradiction
    end),
    cases h with y hy,
    have hseq : {x | orbit f x = s} = orbit f y := set.ext (λ z,
      ⟨λ h : orbit f z = s, hy.symm ▸ h ▸ mem_orbit_self _ _,
      λ h, show orbit f z = s, by rwa orbit_eq h⟩),
    rw [card_eq_card_cosets_mul_card_subgroup (stabilizer f y),
      ← card_congr (orbit_equiv_left_cosets f y)] at h,
    have : ∃ k ≤ n, card (orbit f y) = p ^ k := (nat.dvd_prime_pow hp).1
      (h ▸ dvd_mul_right _ _),
    rcases this with ⟨k, hk₁, hk₂⟩,
    rw [set.card_eq_of_eq hseq, hk₂] at hs ⊢,
    have : ¬p ∣ p ^ k := mt nat.mod_eq_zero_of_dvd hs,
    cases k,
    { refl },
    { simpa [nat.pow_succ] using this }
  end,
  λ hs, hs.symm ▸ (nat.mod_eq_of_lt hp.gt_one).symm ▸ λ h, nat.no_confusion h⟩,
have h : (finset.univ.filter (λ a, card {x | orbit f x = a} % p ≠ 0)).sum
  (λ a : set α, card {x | orbit f x = a}) = card (fixed_points f),
  from calc _ = (finset.univ.filter (λ a, card {x | orbit f x = a} % p ≠ 0)).sum
    (λ a : set α, 1) : finset.sum_congr rfl (λ s hs, (hcard s).1 (finset.mem_filter.1 hs).2)
  ... = card {a : set α | card ↥{x : α | orbit f x = a} % p ≠ 0} :
  begin
    rw [finset.sum_const, nat.smul_eq_mul, mul_one],
    refine eq.symm (set.card_fintype_of_finset' _ _),
    simp [finset.mem_filter],
  end
  ... = card (fixed_points f) : fintype.card_congr
    (@equiv.of_bijective _ _
      (show fixed_points f → {a : set α // card ↥{x : α | orbit f x = a} % p ≠ 0},
      from λ x, ⟨orbit f x.1, begin
        rw [hcard, fintype.card_eq_one_iff],
        exact ⟨⟨x, rfl⟩, λ ⟨y, hy⟩,
          have hy : y ∈ orbit f x := (show orbit f y = orbit f x, from hy) ▸ mem_orbit_self _ _,
          subtype.eq (mem_fixed_points'.1 x.2 _ hy)⟩
      end⟩)
      ⟨λ x y hxy,
        have hxy : orbit f x.1 = orbit f y.1 := subtype.mk.inj hxy,
        have hxo : x.1 ∈ orbit f y.1 := hxy ▸ mem_orbit_self _ _,
        subtype.eq (mem_fixed_points'.1 y.2 _ hxo),
      λ ⟨s, hs⟩, begin
        rw [hcard, fintype.card_eq_one_iff] at hs,
        rcases hs with ⟨⟨x, hx₁⟩, hx₂⟩,
        exact ⟨⟨x, mem_fixed_points'.2 (λ y hy,
          subtype.mk.inj (hx₂ ⟨y, by have := orbit_eq hy; simpa [this, hx₁] using hx₁⟩))⟩,
            by simpa using hx₁⟩
      end⟩).symm,
calc card α % p = finset.sum finset.univ (λ a : set α, card {x // orbit f x = a}) % p :
  by rw [card_congr (equiv_fib (orbit f)), fintype.card_sigma]
... = _ : nat.sum_mod _ _ _
... = fintype.card ↥(fixed_points f) % p : by rw ← h; congr

end group_action

namespace sylow
open group_action

def mk_vector_prod_eq_one (n : ℕ) [Zmod.pos n] (v : Zmod n → G) : Zmod (n+1) → G :=
λ m, if h : m.1 < n then v m.1 else ((list.range n).map (λ m : ℕ, v (m : Zmod n))).prod⁻¹

lemma mk_vector_prod_eq_one_injective {p : ℕ} [h0 : Zmod.pos p] :
  injective (@mk_vector_prod_eq_one G _ p _) :=
λ x y hxy, funext (λ ⟨a, ha⟩, begin
  have : dite _ _ _ = dite _ _ _ := congr_fun hxy a,
  rw [Zmod.cast_val, nat.mod_eq_of_lt (nat.lt_succ_of_lt ha),
    dif_pos ha, dif_pos ha] at this,
  rwa Zmod.mk_eq_cast
end)

/-- set of elements of G^n such that the product of the
  list of elements of the vector is one -/
def vectors_prod_eq_one (G : Type*) [group G] (n : ℕ) [Zmod.pos n] : set (Zmod n → G) :=
{v | ((list.range n).map (λ m : ℕ, v (↑m : Zmod n))).prod = 1 }

lemma mem_vectors_prod_eq_one_iff {n : ℕ} [Zmod.pos n] (v : Zmod (n + 1) → G) :
  v ∈ vectors_prod_eq_one G (n + 1) ↔ v ∈ mk_vector_prod_eq_one n '' (set.univ : set (Zmod n → G)) :=
have prod_lemma : ((list.range (n + 1)).map (λ m : ℕ, v (m : Zmod (n + 1)))).prod =
  list.prod (list.map (λ (m : ℕ), v ↑m) (list.range n)) * v ↑n :=
by rw [list.range_concat, list.map_append, list.prod_append,
  list.map_singleton, list.prod_cons, list.prod_nil, mul_one],
⟨λ h : list.prod (list.map (λ (m : ℕ), v ↑m) (list.range (n + 1))) = 1,
  have h₁ : list.map (λ (m : ℕ), v ((m : Zmod n).val : Zmod (n+1))) (list.range n)
    = list.map (λ (m : ℕ), v m) (list.range n) := list.map_congr (λ m hm,
  have hm' : m < n := list.mem_range.1 hm,
    by simp [Zmod.cast_val, nat.mod_eq_of_lt hm']),
  ⟨λ m, v m.val, set.mem_univ _, funext (λ i, show dite _ _ _ = _, begin
    split_ifs,
    { refine congr_arg _ (fin.eq_of_veq _),
      simp [Zmod.cast_val, nat.mod_eq_of_lt h_1, nat.mod_eq_of_lt (nat.lt_succ_of_lt h_1)] },
    { have hi : i = n := fin.eq_of_veq begin
        rw [Zmod.cast_val, nat.mod_eq_of_lt (nat.lt_succ_self _)],
        exact le_antisymm (nat.le_of_lt_succ i.2) (le_of_not_gt h_1),
      end,
      rw [h₁, hi, inv_eq_iff_mul_eq_one, ← prod_lemma, h] }
  end)⟩,
λ ⟨w, hw⟩,
  have h : list.map (λ m : ℕ, w m) (list.range n) = list.map (λ m : ℕ, v m) (list.range n) :=
  list.map_congr (λ k hk,
    have hk' : k < n := list.mem_range.1 hk,
    hw.2 ▸ (show _ = dite _ _ _,
      by rw [Zmod.cast_val, nat.mod_eq_of_lt (nat.lt_succ_of_lt hk'), dif_pos hk'])),
  begin
    show list.prod (list.map (λ (m : ℕ), v ↑m) (list.range (n + 1))) = 1,
    rw [prod_lemma, ← h, ← hw.2],
    show _ * dite _ _ _ = (1 : G),
    rw [Zmod.cast_val, nat.mod_eq_of_lt (nat.lt_succ_self _), dif_neg (lt_irrefl _),
      mul_inv_self],
  end⟩

def rotate (α : Type v) (n : ℕ) (i : multiplicative (Zmod n)) (v : multiplicative (Zmod n) → α)
  (m : multiplicative (Zmod n)) := v (m * i)

instance rotate.is_group_action (n : ℕ) [Zmod.pos n] :
  is_group_action (rotate α n) :=
{ mul := λ x y v, funext (λ i, show v (i * (x * y)) = v (i * x * y), by rw mul_assoc),
  one := λ v, funext (λ i, show v (i * 1) = v i, by rw mul_one) }

lemma fixed_points_rotate_eq_const {n : ℕ} [h0 : Zmod.pos n] {v : multiplicative (Zmod n) → G}
  (h : v ∈ fixed_points (rotate G n)) (i j : multiplicative (Zmod n)) : v i = v j :=
calc v i = v (j * i) : mul_comm i j ▸ (congr_fun ((mem_fixed_points'.1 h _) (mem_orbit (rotate G n) v j)) i).symm
... = v j : congr_fun ((mem_fixed_points'.1 h _) (mem_orbit (rotate G n) v i)) j

lemma map_succ_range : ∀ n : ℕ, list.range (nat.succ n) = 0 :: (list.range n).map nat.succ
| 0 := rfl
| (n+1) := by rw [list.range_concat, list.range_concat, list.map_append,
  ← list.cons_append, ← map_succ_range, list.range_concat, list.map_singleton]

open nat

lemma list.prod_const [monoid α] : ∀ {l : list α} {a : α}, (∀ b ∈ l, b = a) → l.prod = a ^ l.length
| [] := λ _ _, rfl
| (b::l) := λ a ha,
have h : ∀ b ∈ l, b = a := λ b hb, ha b (list.mem_cons_of_mem _ hb),
have hb : b = a := ha b (list.mem_cons_self _ _),
by simp [_root_.pow_add, list.prod_const h, hb]

lemma rotate_on_vectors_prod_eq_one {n : ℕ} [h0 : Zmod.pos n] {v : Zmod n → G}
  (hv : v ∈ vectors_prod_eq_one G n) (i : Zmod n) :
  (rotate G n) (i : Zmod n) v ∈ vectors_prod_eq_one G n :=
begin
  cases i with i hi,
  rw Zmod.mk_eq_cast,
  clear hi,
  induction i with i ih,
  { show list.prod (list.map (λ (m : ℕ), v (m + 0)) (list.range n)) = 1,
    simpa },
  { show list.prod (list.map (λ (m : ℕ), v (m + (i + 1))) (list.range n)) = 1,
    replace ih : list.prod (list.map (λ (m : ℕ), v (m + i)) (list.range n)) = 1 := ih,
    resetI,
    cases n,
    { simp [list.range, list.range_core] },
    { rw [list.range_concat, list.map_append, list.prod_append, list.map_singleton,
        list.prod_cons, list.prod_nil, mul_one] at ⊢ ih,
      have h : list.map (λ m : ℕ, v (↑m + (i + 1))) (list.range n) =
        list.map (λ m : ℕ, v (m + i)) (list.map (λ m : ℕ, m + 1) (list.range n)),
      { simp [list.map_map, comp] },
      resetI,
      cases n,
      { refine eq.trans _ ih,
        simp [list.range, list.range_core]; congr },
      { have h : list.map (λ m : ℕ, v (↑m + (i + 1))) (list.range n) =
          list.map (λ m : ℕ, v (m + i)) (list.map succ (list.range n)),
        { simp [list.map_map, comp] },
        have h₁ : (succ n : Zmod (succ (succ n))) + (↑i + 1) = i,
        { rw [add_left_comm, ← nat.cast_one, ← nat.cast_add, Zmod.cast_self_eq_zero, add_zero] },
        have h₂ : (n : Zmod (succ (succ n))) + i + 1 = succ n + i := by simp [succ_eq_add_one],
        rw [map_succ_range, list.map_cons, list.prod_cons, ← h, nat.cast_zero, zero_add] at ih,
        have := eq_inv_mul_of_mul_eq ih,
        rw [list.range_concat, list.map_append, list.map_singleton, list.prod_append,
          list.prod_cons, list.prod_nil, mul_one, ← add_assoc, h₁, h₂, this],
        simp } } }
end

def rotate_vectors_prod_eq_one (G : Type u) [group G] (n : ℕ) [Zmod.pos n] (i : multiplicative (Zmod n))
  (v : vectors_prod_eq_one G n) : vectors_prod_eq_one G n := ⟨rotate _ n i v.1, rotate_on_vectors_prod_eq_one v.2 _⟩

instance (n : ℕ) [Zmod.pos n] : is_group_action (rotate_vectors_prod_eq_one G n) :=
{ one := λ ⟨a, ha⟩, subtype.eq (is_group_action.one (rotate G n) _),
  mul := λ x y ⟨a, ha⟩, subtype.eq (is_group_action.mul (rotate G n) _ _ _) }

lemma mem_fixed_points_rotate_vectors_prod_eq_one {n : ℕ} [Zmod.pos n]
  : ∀ {v : vectors_prod_eq_one G n}, v ∈ fixed_points (rotate_vectors_prod_eq_one G n) ↔ (v : Zmod n → G) ∈ fixed_points (rotate G n) :=
λ ⟨v, hv⟩, ⟨λ h x, subtype.mk.inj (h x), λ h x, subtype.eq (h x)⟩

lemma fixed_points_rotate_pow_n [fintype G] {n : ℕ} (hn : nat.prime (succ n))
  [h0 : Zmod.pos n] : ∀ {v : vectors_prod_eq_one G (succ n)}
  (hv : v ∈ fixed_points (rotate_vectors_prod_eq_one G (succ n))), (v : Zmod (succ n) → G) 0 ^ (n + 1) = 1 :=
λ ⟨v, hv₁⟩ hv,
let ⟨w, hw⟩ := (mem_vectors_prod_eq_one_iff _).1 hv₁ in
have hv' : (v : Zmod (succ n) → G) ∈ fixed_points (rotate G (succ n)) :=
  λ i, subtype.mk.inj (mem_stabilizer_iff.1 (hv i)),
begin
  have h₁ : dite _ _ _ = (v : Zmod (succ n) → G) _ := congr_fun hw.2 ⟨n, nat.lt_succ_self n⟩,
  rw dif_neg (lt_irrefl _) at h₁,
  have h₂ : ∀ b, b < n → w b = (v : Zmod (succ n) → G) b := λ b hb, begin
    have : dite _ _ _ = _ := congr_fun hw.2 b,
    rwa [Zmod.cast_val_of_lt (lt_succ_of_lt hb), dif_pos hb] at this,
  end,
  have hb : ∀ (b : G), b ∈ list.map (λ (m : ℕ), w ↑m) (list.range n) → b = w 0 := λ b hb,
    let ⟨i, hi⟩ := list.mem_map.1 hb in
    by rw [← hi.2, h₂ _ (list.mem_range.1 hi.1), fixed_points_rotate_eq_const hv' _ 1];
      exact (h₂ 0 h0.pos).symm,
  refine (@mul_left_inj _ _ (w 0 ^ (-n : ℤ)) _ _).1 _,
  rw [@list.prod_const _ _ _ (w 0) hb, list.length_map, list.length_range, ← gpow_coe_nat, ← gpow_neg] at h₁,
  conv { to_rhs, rw [h₁, fixed_points_rotate_eq_const hv' _ 1] },
  rw [← nat.cast_zero, h₂ 0 h0.pos, nat.cast_zero, subtype.coe_mk, ← gpow_coe_nat, ← _root_.gpow_add, int.coe_nat_add],
  simp, refl,
end

lemma one_mem_fixed_points_rotate [fintype G] {n : ℕ} [h0 : Zmod.pos n] :
  (1 : Zmod n → G) ∈ fixed_points (rotate G n) :=
mem_fixed_points'.2 (λ y hy, funext (λ j,
  let ⟨i, hi⟩ := mem_orbit_iff.1 hy in
  have hj : (1 : G) = y j := congr_fun hi j,
    hj ▸ rfl))

lemma one_mem_vectors_prod_eq_one (n : ℕ) [Zmod.pos n] : (1 : Zmod n → G) ∈ vectors_prod_eq_one G n :=
show list.prod (list.map (λ (m : ℕ), (1 : G)) (list.range n)) = 1,
from have h : ∀ b : G, b ∈ list.map (λ (m : ℕ), (1 : G)) (list.range n) → b = 1 :=
λ b hb, let ⟨_, h⟩ := list.mem_map.1 hb in h.2.symm,
by simp [list.prod_const h]

lemma exists_prime_order_of_dvd_card [fintype G] {p : ℕ} (hp : nat.prime p)
  (hdvd : p ∣ card G) : ∃ x : G, order_of x = p :=
let n := p - 1 in
have hn : p = n + 1 := nat.succ_sub hp.pos,
have hnp : nat.prime (n + 1) := hn ▸ hp,
have hn0 : Zmod.pos n := ⟨nat.lt_of_succ_lt_succ hnp.gt_one⟩,
have hlt : ¬(n : Zmod (n + 1)).val < n :=
  not_lt_of_ge (by rw [Zmod.cast_val, nat.mod_eq_of_lt (nat.lt_succ_self _)];
    exact le_refl _),
have hcard1 : card (vectors_prod_eq_one G (n + 1)) = card (Zmod n → G) :=
  by rw [← set.card_univ (Zmod n → G), set.ext (@mem_vectors_prod_eq_one_iff _ _ _ hn0),
    set.card_image_of_injective _ mk_vector_prod_eq_one_injective],
have hcard : card (vectors_prod_eq_one G (n + 1)) = card G ^ n :=
  by conv { rw hcard1, to_rhs, rw ← card_fin n };
    exact fintype.card_fun,
have fintype (multiplicative (Zmod (succ n))) := fin.fintype _,
have Zmod.pos (succ n) := ⟨succ_pos _⟩,
have hZmod : @fintype.card (multiplicative (Zmod (succ n))) (fin.fintype _) =
  (n+1) ^ 1 := (nat.pow_one (n + 1)).symm ▸ card_fin _,
by exactI
have hmodeq : _ = _ := @card_modeq_card_fixed_points _ _ _ (rotate_vectors_prod_eq_one G (succ n)) _ _ _ _ _ 1 hnp hZmod,
have hdvdcard : (n + 1) ∣ card (vectors_prod_eq_one G (n + 1)) :=
  calc (n + 1) = p : hn.symm
  ... ∣ card G ^ 1 : by rwa nat.pow_one
  ... ∣ card G ^ n : nat.pow_dvd_pow _ hn0.pos
  ... = card (vectors_prod_eq_one G (n + 1)) : hcard.symm,
have hdvdcard₂ : (n + 1) ∣ card (fixed_points (rotate_vectors_prod_eq_one G (succ n))) :=
  nat.dvd_of_mod_eq_zero (hmodeq ▸ (nat.mod_eq_zero_of_dvd hdvdcard)),
have hcard_pos : 0 < card (fixed_points (rotate_vectors_prod_eq_one G (succ n))) :=
  fintype.card_pos_iff.2 ⟨⟨⟨(1 : Zmod (succ n) → G), one_mem_vectors_prod_eq_one _⟩,
    λ x, subtype.eq (one_mem_fixed_points_rotate x)⟩⟩,
have hle : 1 < card (fixed_points (rotate_vectors_prod_eq_one G (succ n))) :=
  calc 1 < n + 1 : hnp.gt_one
  ... ≤ _ : nat.le_of_dvd hcard_pos hdvdcard₂,
let ⟨⟨x, hx₁⟩, hx₂⟩ := classical.not_forall.1 (mt fintype.card_le_one_iff.2 (not_le_of_gt hle)) in
let ⟨⟨y, hy₁⟩, hy₂⟩ := classical.not_forall.1 hx₂ in
have hxy : (x : Zmod (succ n) → G) 0 ≠ 1 ∨ (y : Zmod (succ n) → G) 0 ≠ 1 :=
  or_iff_not_imp_left.2
  (λ hx1 hy1, hy₂ $ subtype.eq $ subtype.eq $ funext $ λ i,
  show (x : Zmod (succ n) → G) i = (y : Zmod (succ n) → G) i,
  by rw [fixed_points_rotate_eq_const ((mem_fixed_points_rotate_vectors_prod_eq_one).1 hx₁) _ (0 : Zmod (succ n)),
    fixed_points_rotate_eq_const ((mem_fixed_points_rotate_vectors_prod_eq_one).1 hy₁) _ (0 : Zmod (succ n)),
    not_not.1 hx1, hy1]),
have hxp : (x : Zmod (succ n) → G) 0 ^ (n + 1) = 1 := @fixed_points_rotate_pow_n _ _ _ _ hnp hn0 _ hx₁,
have hyp : (y : Zmod (succ n) → G) 0 ^ (n + 1) = 1 := @fixed_points_rotate_pow_n _ _ _ _ hnp hn0 _ hy₁,
begin
  rw hn,
  cases hxy with hx hy,
  { existsi (x : Zmod (succ n) → G) 0,
    exact or.resolve_left (hnp.2 _ (order_of_dvd_of_pow_eq_one hxp))
      (λ h, hx (eq_one_of_order_of_eq_one h)) },
  { existsi (y : Zmod (succ n) → G) 0,
    exact or.resolve_left (hnp.2 _ (order_of_dvd_of_pow_eq_one hyp))
      (λ h, hy (eq_one_of_order_of_eq_one h)) }
end

local attribute [instance] left_rel set_fintype
open is_subgroup is_submonoid is_group_hom

def mul_left_cosets (L₁ L₂ : set G) [is_subgroup L₂] [is_subgroup L₁]
  (x : L₂) (y : left_cosets L₁) : left_cosets L₁ :=
quotient.lift_on y (λ y, ⟦(x : G) * y⟧)
  (λ a b (hab : _ ∈ L₁), quotient.sound
    (show _ ∈ L₁, by rwa [mul_inv_rev, ← mul_assoc, mul_assoc (a⁻¹), inv_mul_self, mul_one]))

instance mul_left_cosets.is_group_action (L₁ L₂ : set G) [is_subgroup L₂] [is_subgroup L₁] :
  is_group_action (mul_left_cosets L₁ L₂) :=
{ one := λ a, quotient.induction_on a (λ a, quotient.sound (show (1 : G) * a ≈ a, by simp)),
  mul := λ x y a, quotient.induction_on a (λ a, quotient.sound (by rw ← mul_assoc; refl)) }

lemma mem_fixed_points_mul_left_cosets_iff_mem_normalizer {H : set G} [is_subgroup H] [fintype H]
  {x : G} : ⟦x⟧ ∈ fixed_points (mul_left_cosets H H) ↔ x ∈ normalizer H :=
⟨λ hx, have ha : ∀ {y : left_cosets H}, y ∈ orbit (mul_left_cosets H H) ⟦x⟧ → y = ⟦x⟧ := λ _,
    (mem_fixed_points'.1 hx _),
  (inv_mem_iff _).1 (mem_normalizer_fintype (λ n hn,
    have (n⁻¹ * x)⁻¹ * x ∈ H := quotient.exact (ha (mem_orbit (mul_left_cosets H H) _
      ⟨n⁻¹, inv_mem hn⟩)),
    by simpa only [mul_inv_rev, inv_inv] using this)),
λ (hx : ∀ (n : G), n ∈ H ↔ x * n * x⁻¹ ∈ H),
mem_fixed_points'.2 $ λ y, quotient.induction_on y $ λ y hy, quotient.sound
  (let ⟨⟨b, hb₁⟩, hb₂⟩ := hy in
  have hb₂ : (b * x)⁻¹ * y ∈ H := quotient.exact hb₂,
  (inv_mem_iff H).1 $ (hx _).2 $ (mul_mem_cancel_right H (inv_mem hb₁)).1
  $ by rw hx at hb₂;
    simpa [mul_inv_rev, mul_assoc] using hb₂)⟩

lemma fixed_points_mul_left_cosets_equiv_cosets (H : set G) [is_subgroup H] [fintype H] :
  fixed_points (mul_left_cosets H H) ≃ left_cosets {x : normalizer H | ↑x ∈ H} :=
{ to_fun := λ a, quotient.hrec_on a.1 (λ a ha, @quotient.mk _
  (left_rel {x : normalizer H | ↑x ∈ H}) ⟨a, mem_fixed_points_mul_left_cosets_iff_mem_normalizer.1 ha⟩)
    (λ x y hxy, hfunext (by rw quotient.sound hxy)
      (λ hx hy _, heq_of_eq (@quotient.sound _ (left_rel {x : normalizer H | ↑x ∈ H})
        _ _ (by exact hxy)))) a.2,
  inv_fun := λ x, ⟨@quotient.lift_on _ _ (left_rel {x : normalizer H | ↑x ∈ H}) x
     (λ x, show (↥(fixed_points (mul_left_cosets H H)) : Type u),
       from ⟨⟦x⟧, mem_fixed_points_mul_left_cosets_iff_mem_normalizer.2 x.2⟩)
     (λ ⟨x, hx⟩ ⟨y, hy⟩ (hxy : x⁻¹ * y ∈ H), subtype.eq (quotient.sound hxy)),
     (@quotient.induction_on _  (left_rel {x : normalizer H | ↑x ∈ H}) _ x
       (by intro x; cases x with x hx;
         exact mem_fixed_points_mul_left_cosets_iff_mem_normalizer.2 hx))⟩,
  left_inv := λ ⟨x, hx⟩, by revert hx;
    exact quotient.induction_on x (by intros; refl),
  right_inv := λ x, @quotient.induction_on _
    (left_rel {x : normalizer H | ↑x ∈ H}) _ x
      (by intro x; cases x; refl) }

lemma exists_subgroup_card_pow_prime [fintype G] {p : ℕ} : ∀ {n : ℕ} (hp : nat.prime p)
  (hdvd : p ^ n ∣ card G), ∃ H : set G, is_subgroup H ∧ card H = p ^ n
| 0 := λ _ _, ⟨trivial G, by apply_instance, by simp [-set.set_coe_eq_subtype]⟩
| (n+1) := λ hp hdvd,
let ⟨H, ⟨hH1, hH2⟩⟩ := exists_subgroup_card_pow_prime hp (dvd.trans (pow_dvd_pow _ (le_succ _)) hdvd) in
let ⟨s, hs⟩ := exists_eq_mul_left_of_dvd hdvd in
by exactI
have hcard : card (left_cosets H) = s * p :=
  (nat.mul_right_inj (show card H > 0, from fintype.card_pos_iff.2 ⟨⟨1, is_submonoid.one_mem H⟩⟩)).1
    (by rwa [← card_eq_card_cosets_mul_card_subgroup, hH2, hs, nat.pow_succ, mul_assoc, mul_comm p]),
have hm : s * p % p = card (left_cosets {x : normalizer H | ↑x ∈ H}) % p :=
  card_congr (fixed_points_mul_left_cosets_equiv_cosets H) ▸ hcard ▸
    card_modeq_card_fixed_points _ hp hH2,
have hm' : p ∣ card (left_cosets {x : normalizer H | ↑x ∈ H}) :=
  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 hp hm' in
have hxcard : card (gpowers x) = p := by rwa ← order_eq_card_gpowers,
let S : set ↥(normalizer H) := set.preimage (@quotient.mk _
    (left_rel {x : ↥(normalizer H) | ↑x ∈ H}))
      (@gpowers (left_cosets {x : ↥(normalizer H) | ↑x ∈ H}) _ x) in
have is_subgroup S := @is_group_hom.preimage _
  (left_cosets {x : ↥(normalizer H) | ↑x ∈ H}) _ _ _ _ _ _,
have fS : fintype S := by apply_instance,
let hequiv : {x : ↥(normalizer H) | ↑x ∈ H} ≃ H :=
  { to_fun := λ ⟨x, hx⟩, ⟨x, hx⟩,
    inv_fun := λ ⟨x, hx⟩, ⟨⟨x, subset_normalizer _ hx⟩, hx⟩,
    left_inv := λ ⟨⟨_, _⟩, _⟩, rfl,
    right_inv := λ ⟨_, _⟩, rfl } in
⟨subtype.val '' S, by apply_instance,
by dsimp only [S];
  rw [set.card_image_of_injective _ subtype.val_injective, nat.pow_succ,
    @card_congr _ _ fS _ (preimage_quotient_mk_equiv_subgroup_times_set _ _),
    card_prod, hxcard, ← hH2, card_congr hequiv]⟩

def conjugate_set (x : G) (H : set G) : set G :=
(λ n, x⁻¹ * n * x) ⁻¹' H

lemma conjugate_set_eq_image (H : set G) (x : G) :
  conjugate_set x H = (λ n, x * n * x⁻¹) '' H :=
eq.symm (congr_fun (set.image_eq_preimage_of_inverse
  (λ _, by simp [mul_assoc]) (λ _, by simp [mul_assoc])) _)

lemma conjugate_set_eq_preimage (H : set G) (x : G) :
  conjugate_set x H = (λ n, x⁻¹ * n * x) ⁻¹' H := rfl

instance conjugate_set.is_group_action : is_group_action (@conjugate_set G _) :=
{ one := λ H, by simp [conjugate_set_eq_image, set.image],
  mul := λ x y H, by simp [mul_inv_rev, mul_assoc, comp, conjugate_set_eq_preimage,
    set.preimage] }

@[simp] lemma conjugate_set_normal_subgroup (H : set G) [normal_subgroup H] (x : G) :
  conjugate_set x H = H :=
set.ext (λ n, ⟨λ h : _ ∈ H, by have := normal_subgroup.normal _ h x; simpa [mul_assoc] using this,
λ h, show _ ∈ H, by have := normal_subgroup.normal _ h (x⁻¹); by simpa using this⟩)

instance is_group_action.subgroup (H : set G) [is_subgroup H] (f : G → α → α) [is_group_action f] :
  is_group_action (λ x : H, f x) :=
{ one := λ a, is_group_action.one f a,
  mul := λ ⟨x, hx⟩ ⟨y, hy⟩ a, is_group_action.mul f x y a }

instance is_group_hom_conj (x : G) : is_group_hom (λ (n : G), x * n * x⁻¹) :=
⟨by simp [mul_assoc]⟩

instance is_subgroup_conj (x : G) (H : set G) [is_subgroup H] :
  is_subgroup (conjugate_set x H) :=
by rw conjugate_set_eq_image; apply_instance

/-- `dlogn p a` gives the maximum value of `n` such that `p ^ n ∣ a` -/
def dlogn (p : ℕ) : ℕ → ℕ
| 0     := 0
| (a+1) := if h : p > 1 then
  have (a + 1) / p < a + 1, from div_lt_self dec_trivial h,
    if p ∣ (a + 1) then dlogn ((a + 1) / p) + 1 else 0
  else 0

lemma dlogn_dvd {p : ℕ} : ∀ a, p > 1 → p ^ dlogn p a ∣ a
| 0     := λ _, dvd_zero _
| (a+1) := λ h,
have (a + 1) / p < a + 1, from div_lt_self dec_trivial h,
begin
  rw [dlogn, if_pos h],
  split_ifs with hd,
  { rw nat.pow_succ,
    conv { to_rhs, rw ← nat.div_mul_cancel hd },
    exact mul_dvd_mul (dlogn_dvd _ h) (dvd_refl _) },
  { simp }
end

lemma not_dvd_of_gt_dlogn {p : ℕ} : ∀ {a m}, a > 0 → p > 1 → m > dlogn p a → ¬p ^ m ∣ a
| 0     := λ m h, (lt_irrefl _ h).elim
| (a+1) := λ m h hp hm ,
have (a + 1) / p < a + 1, from div_lt_self dec_trivial hp,
begin
  rw [dlogn, if_pos hp] at hm,
  split_ifs at hm with hd,
  { have hmsub : succ (m - 1) = m :=
      succ_sub (show 1 ≤ m, from (lt_of_le_of_lt (nat.zero_le _) hm)) ▸
      (succ_sub_one m).symm,
    have := @not_dvd_of_gt_dlogn ((a + 1) / p) (m - 1)
      (pos_of_mul_pos_left (by rw nat.mul_div_cancel' hd; exact nat.succ_pos _) (nat.zero_le p))
      hp (lt_of_succ_lt_succ (hmsub.symm ▸ hm)),
    rwa [← nat.mul_dvd_mul_iff_right (lt_trans dec_trivial hp), nat.div_mul_cancel hd,
      ← nat.pow_succ, hmsub] at this },
  { assume h,
    exact hd (calc p = p ^ 1 : (nat.pow_one _).symm
      ... ∣ p ^ m : nat.pow_dvd_pow p hm
      ... ∣ a + 1 : h) }
end

lemma pow_dvd_of_dvd_mul {p : ℕ} : ∀ {m n k : ℕ} (hp : prime p) (hd : p ^ m ∣ n * k) (hk : ¬p ∣ k),
  p ^ m ∣ n
| 0     := by simp
| (m+1) := λ n k hp hd hk,
have hpnk : p ∣ n * k := calc p = p ^ 1 : by rw nat.pow_one
  ... ∣ p ^ (m + 1) : nat.pow_dvd_pow _ (succ_pos _)
  ... ∣ n * k : by assumption,
have hpn : p ∣ n := or.resolve_right (hp.dvd_mul.1 hpnk) hk,
have p ^ m ∣ (n / p) * k := dvd_of_mul_dvd_mul_right hp.pos $
  by rwa [mul_right_comm, nat.div_mul_cancel hpn, ← nat.pow_succ],
by rw [nat.pow_succ, ← nat.div_mul_cancel hpn];
  exact mul_dvd_mul_right (pow_dvd_of_dvd_mul hp this hk) _

lemma eq_dlogn_of_dvd_of_succ_not_dvd {a p n : ℕ} (hp : 1 < p) (h₁ : p ^ n ∣ a) (h₂ : ¬p ^ succ n ∣ a) :
  n = dlogn p a :=
have ha : 0 < a := nat.pos_of_ne_zero (λ h, by simpa [h] using h₂),
le_antisymm (le_of_not_gt $ λ h, not_dvd_of_gt_dlogn ha hp h h₁)
  (le_of_not_gt $ λ h, h₂ $ calc p ^ succ n ∣ p ^ dlogn p a : nat.pow_dvd_pow _ h
    ... ∣ _ : dlogn_dvd _ hp)

lemma dlogn_eq_of_not_dvd {a b p  : ℕ} (hp : prime p) (hpb : ¬p ∣ b) : dlogn p a = dlogn p (a * b) :=
if ha : a = 0 then by simp [ha, dlogn] else
eq_dlogn_of_dvd_of_succ_not_dvd hp.gt_one (dvd.trans (dlogn_dvd _ hp.gt_one) (dvd_mul_right _ _))
  (λ h, not_dvd_of_gt_dlogn (nat.pos_of_ne_zero ha)
  hp.gt_one (lt_succ_self _) (pow_dvd_of_dvd_mul hp h hpb))

lemma not_dvd_div_dlogn {p a : ℕ} (ha : a > 0) (hp : p > 1) : ¬p ∣ a / (p ^ dlogn p a) :=
by rw [← nat.mul_dvd_mul_iff_left (nat.pos_pow_of_pos (dlogn p a) (lt_trans dec_trivial hp)),
    nat.mul_div_cancel' (dlogn_dvd _ hp), ← nat.pow_succ];
  exact not_dvd_of_gt_dlogn ha hp (lt_succ_self _)

class is_sylow [fintype G] (H : set G) {p : ℕ} (hp : prime p) extends is_subgroup H : Prop :=
(card_eq : card H = p ^ dlogn p (card G))

instance is_subgroup_in_subgroup (H K : set G) [is_subgroup H] [is_subgroup K] :
  is_subgroup {x : K | (x : G) ∈ H} :=
{ one_mem := show _ ∈ H, from one_mem _,
  mul_mem := λ x y hx hy, show x.1 * y.1 ∈ H, from mul_mem hx hy,
  inv_mem := λ x hx, show x.1⁻¹ ∈ H, from inv_mem hx }

lemma exists_sylow_subgroup (G : Type u) [group G] [fintype G] {p : ℕ} (hp : prime p) :
  ∃ H : set G, is_sylow H hp :=
let ⟨H, ⟨hH₁, hH₂⟩⟩ := exists_subgroup_card_pow_prime hp (dlogn_dvd (card G) hp.gt_one) in
by exactI ⟨H, by split; assumption⟩

lemma card_sylow [fintype G] (H : set G) [f : fintype H] {p : ℕ} (hp : prime p) [is_sylow H hp] :
  card H = p ^ dlogn p (card G) :=
by rw ← is_sylow.card_eq H hp; congr

lemma is_sylow_in_subgroup [fintype G] (H K : set G) {p : ℕ} (hp : prime p) [is_sylow H hp] (hsub : H ⊆ K)
  [is_subgroup K] : is_sylow {x : K | (x : G) ∈ H} hp :=
{ card_eq :=
  have h₁ : H = subtype.val '' {x : K | (x : G) ∈ H},
    from set.ext $ λ x, ⟨λ h, ⟨⟨x, hsub h⟩, ⟨h, rfl⟩⟩, λ ⟨y, hy⟩, hy.2 ▸ hy.1⟩,
  have h₂ : card K * (card G / card K) = card G := nat.mul_div_cancel'
    ((card_eq_card_cosets_mul_card_subgroup K).symm ▸ dvd_mul_left _ _),
  have h₃ : ∀ {f : fintype {x : K | (x : G) ∈ H}}, @fintype.card {x : K | (x : G) ∈ H} f
    = card H := λ f, by exactI
    calc @fintype.card {x : K | (x : G) ∈ H} f = card (subtype.val '' {x : K | (x : G) ∈ H}) :
      by exact (set.card_image_of_injective _ subtype.val_injective).symm
    ... = card H : set.card_eq_of_eq h₁.symm,
  calc _ = _ : h₃
  ... = p ^ dlogn p (card G) : card_sylow H hp
  ... = p ^ dlogn p (card K) : congr_arg _ (h₂ ▸ eq.symm begin
    refine dlogn_eq_of_not_dvd hp (λ h, _),
    have h₄ := mul_dvd_mul_left (card K) h,
    rw [h₂, card_eq_card_cosets_mul_card_subgroup {x : K | (x : G) ∈ H}, h₃, card_sylow H hp,
      mul_assoc, ← nat.pow_succ] at h₄,
    exact not_dvd_of_gt_dlogn (fintype.card_pos_iff.2 ⟨(1 : G)⟩) hp.gt_one (lt_succ_self _)
      (dvd_of_mul_left_dvd h₄),
  end),
  ..sylow.is_subgroup_in_subgroup H K }

lemma sylow_conjugate [fintype G] {p : ℕ} (hp : prime p)
  (H K : set G) [is_sylow H hp] [is_sylow K hp] :
  ∃ g : G, H = conjugate_set g K :=
have hs : card (left_cosets K) = card G / (p ^ dlogn p (card G)) :=
  (nat.mul_right_inj (pos_pow_of_pos (dlogn p (card G)) hp.pos)).1
  $ by rw [← card_sylow K hp, ← card_eq_card_cosets_mul_card_subgroup, card_sylow K hp,
    nat.div_mul_cancel (dlogn_dvd _ hp.gt_one)],
have hmodeq : card G / (p ^ dlogn p (card G)) ≡ card (fixed_points (mul_left_cosets K H)) [MOD p] :=
  hs ▸ card_modeq_card_fixed_points (mul_left_cosets K H) hp (card_sylow H hp),
have hfixed : 0 < card (fixed_points (mul_left_cosets K H)) := nat.pos_of_ne_zero
  (λ h, (not_dvd_div_dlogn (fintype.card_pos_iff.2 ⟨(1 : G)⟩) hp.gt_one)
    $ by rwa [h, nat.modeq.modeq_zero_iff] at hmodeq),
let ⟨⟨x, hx⟩⟩ := fintype.card_pos_iff.1 hfixed in
begin
  haveI : is_subgroup K := by apply_instance,
  revert hx,
  refine quotient.induction_on x
    (λ x hx, ⟨x, set.eq_of_card_eq_of_subset _ _⟩),
  { rw [conjugate_set_eq_image, set.card_image_of_injective _ conj_inj_left,
    card_sylow K hp, card_sylow H hp] },
  { assume y hy,
    have : (y⁻¹ * x)⁻¹ * x ∈ K := quotient.exact
      (mem_fixed_points'.1 hx ⟦y⁻¹ * x⟧ ⟨⟨y⁻¹, inv_mem hy⟩, rfl⟩),
    simp [conjugate_set_eq_preimage, set.preimage, mul_inv_rev, *, mul_assoc] at * }
end

def conj_on_sylow [fintype G] {p : ℕ} (hp : nat.prime p)
  : Π (x : G) (H : {H : set G // is_sylow H hp}), {H : set G // is_sylow H hp} :=
λ x ⟨H, hH⟩, ⟨conjugate_set x H, by exactI
have h : is_subgroup (conjugate_set x H) := @sylow.is_subgroup_conj _ _ _ _ _,
{ card_eq := by exactI by
  rw [← card_sylow H hp, conjugate_set_eq_image, set.card_image_of_injective _ conj_inj_left],
  ..h }⟩

instance conj_on_sylow.is_group_action [fintype G] {p : ℕ} (hp : prime p) :
  is_group_action (@conj_on_sylow G _ _ _ hp) :=
{ one := λ ⟨H, hH⟩, by simp [conj_on_sylow, conjugate_set_eq_preimage, set.preimage],
  mul := λ x y ⟨H, hH⟩, by simp! [mul_inv_rev, mul_assoc, comp,
      conjugate_set_eq_image, (set.image_comp _ _ _).symm, conj_on_sylow] }

lemma card_sylow_dvd [fintype G] {p : ℕ} (hp : prime p) :
  card {H : set G // is_sylow H hp} ∣ card G :=
let ⟨H, hH⟩ := exists_sylow_subgroup G hp in
have h : orbit (conj_on_sylow hp) ⟨H, hH⟩ = set.univ :=
  set.eq_univ_iff_forall.2 (λ S, mem_orbit_iff.2 $
  let ⟨x, (hx : S.val = _)⟩ := @sylow_conjugate _ _ _ _ hp S.1 H S.2 hH in
  ⟨x, subtype.eq (hx.symm ▸ rfl)⟩),
have is_subgroup (stabilizer (conj_on_sylow hp) ⟨H, hH⟩) := group_action.is_subgroup _ _,
by exactI
have orbit_equiv : card (orbit (conj_on_sylow hp) ⟨H, hH⟩) =
  fintype.card (left_cosets (stabilizer (conj_on_sylow hp) ⟨H, hH⟩)) :=
   card_congr (orbit_equiv_left_cosets (conj_on_sylow hp) (⟨H, hH⟩ : {H : set G // is_sylow H hp})),
by exactI begin
  rw [h, ← card_congr (set.equiv_univ _)] at orbit_equiv,
  rw [orbit_equiv, card_congr (@group_equiv_left_cosets_times_subgroup _ _
    (stabilizer (conj_on_sylow hp) ⟨H, hH⟩) (by apply_instance)), card_prod],
  exact dvd_mul_right _ _
end

lemma card_sylow_modeq_one [fintype G] {p : ℕ} (hp : prime p) :
  card {H : set G // is_sylow H hp} ≡ 1 [MOD p] :=
let ⟨H, hH⟩ := exists_sylow_subgroup G hp in
by exactI
eq.trans
(card_modeq_card_fixed_points (λ x : H, conj_on_sylow hp (x : G)) hp (card_sylow H hp))
begin
  refine congr_fun (show (%) _ = (%) 1,
    from congr_arg _ (fintype.card_eq_one_iff.2 _)) p,
  refine ⟨(⟨(⟨H, hH⟩ :  {H // is_sylow H hp}), λ ⟨x, hx⟩, subtype.eq $
    set.ext (λ i, by simp [conj_on_sylow, conjugate_set_eq_preimage, mul_mem_cancel_left _ hx,
      mul_mem_cancel_right _ (inv_mem hx)])⟩ :
        subtype (fixed_points (λ (x : ↥H), conj_on_sylow hp ↑x))), _⟩,
  refine λ L, subtype.eq (subtype.eq _),
  rcases L with ⟨⟨L, hL₁⟩, hL₂⟩,
  have Hsub : H ⊆ normalizer L,
  { assume x hx n,
    conv {to_rhs, rw ← subtype.mk.inj (hL₂ ⟨x, hx⟩)},
    simp [conjugate_set, mul_assoc] },
  suffices : ∀ x, x ∈ {x : normalizer L | (x : G) ∈ L} ↔ x ∈ {x : normalizer L | (x : G) ∈ H},
  { exact set.ext (λ x, ⟨λ h, (this ⟨x, subset_normalizer _ h⟩).1 h, λ h, (this ⟨x, Hsub h⟩).2 h⟩) },
  assume x,
  haveI := is_sylow_in_subgroup L (normalizer L) hp (subset_normalizer L),
  haveI := is_sylow_in_subgroup H (normalizer L) hp Hsub,
  cases sylow_conjugate hp {x : normalizer L | (x : G) ∈ H} {x | (x : G) ∈ L} with x hx,
  simp [hx]
end

end sylow


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Jeremy Avigad

Prime numbers.
-/
import data.nat logic.identities
open bool subtype

namespace nat
open decidable

definition prime [reducible] (p : nat) := p ≥ 2 ∧ ∀ m, m ∣ p → m = 1 ∨ m = p

definition prime_ext (p : nat) := p ≥ 2 ∧ ∀ m, m ≤ p → m ∣ p → m = 1 ∨ m = p
local attribute prime_ext [reducible]

lemma prime_ext_iff_prime (p : nat) : prime_ext p ↔ prime p :=
iff.intro
  begin
    intro h, cases h with h₁ h₂, constructor, assumption,
    intro m d, exact h₂ m (le_of_dvd (lt_of_succ_le (le_of_succ_le h₁)) d) d
  end
  begin
    intro h, cases h with h₁ h₂, constructor, assumption,
    intro m l d, exact h₂ m d
  end

definition decidable_prime [instance] (p : nat) : decidable (prime p) :=
decidable_of_decidable_of_iff _ (prime_ext_iff_prime p)

lemma ge_two_of_prime {p : nat} : prime p → p ≥ 2 :=
suppose prime p, obtain h₁ h₂, from this,
h₁

theorem gt_one_of_prime {p : ℕ} (primep : prime p) : p > 1 :=
lt_of_succ_le (ge_two_of_prime primep)

theorem pos_of_prime {p : ℕ} (primep : prime p) : p > 0 :=
lt.trans zero_lt_one (gt_one_of_prime primep)

lemma not_prime_zero : ¬ prime 0 :=
λ h, absurd (ge_two_of_prime h) dec_trivial

lemma not_prime_one : ¬ prime 1 :=
λ h, absurd (ge_two_of_prime h) dec_trivial

lemma prime_two : prime 2 :=
dec_trivial

lemma prime_three : prime 3 :=
dec_trivial

lemma pred_prime_pos {p : nat} : prime p → pred p > 0 :=
suppose prime p,
have p ≥ 2,      from ge_two_of_prime this,
show pred p > 0, from lt_of_succ_le (pred_le_pred this)

lemma succ_pred_prime {p : nat} : prime p → succ (pred p) = p :=
assume h, succ_pred_of_pos (pos_of_prime h)

lemma eq_one_or_eq_self_of_prime_of_dvd {p m : nat} : prime p → m ∣ p → m = 1 ∨ m = p :=
assume h d, obtain h₁ h₂, from h, h₂ m d

lemma gt_one_of_pos_of_prime_dvd {i p : nat} : prime p → 0 < i → i % p = 0 → 1 < i :=
assume ipp pos h,
have p ≥ 2,  from ge_two_of_prime ipp,
have p ∣ i,  from dvd_of_mod_eq_zero h,
have p ≤ i,  from le_of_dvd pos this,
lt_of_succ_le (le.trans `2 ≤ p` this)

definition sub_dvd_of_not_prime {n : nat} : n ≥ 2 → ¬ prime n → {m | m ∣ n ∧ m ≠ 1 ∧ m ≠ n} :=
assume h₁ h₂,
have ¬ prime_ext n, from iff.mpr (not_iff_not_of_iff !prime_ext_iff_prime) h₂,
have ¬ n ≥ 2 ∨ ¬ (∀ m, m ≤ n → m ∣ n → m = 1 ∨ m = n), from iff.mp !not_and_iff_not_or_not this,
have ¬ (∀ m, m ≤ n → m ∣ n → m = 1 ∨ m = n), from or_resolve_right this (not_not_intro h₁),
have ¬ (∀ m, m < succ n → m ∣ n → m = 1 ∨ m = n), from
  assume h, absurd (λ m hl hd, h m (lt_succ_of_le hl) hd) this,
have {m | m < succ n ∧ ¬(m ∣ n → m = 1 ∨ m = n)}, from bsub_not_of_not_ball this,
obtain m hlt (h₃ : ¬(m ∣ n → m = 1 ∨ m = n)), from this,
obtain `m ∣ n` (h₅ : ¬ (m = 1 ∨ m = n)), from iff.mp !not_implies_iff_and_not h₃,
have ¬ m = 1 ∧ ¬ m = n,  from iff.mp !not_or_iff_not_and_not h₅,
subtype.tag m (and.intro `m ∣ n` this)

theorem exists_dvd_of_not_prime {n : nat} : n ≥ 2 → ¬ prime n → ∃ m, m ∣ n ∧ m ≠ 1 ∧ m ≠ n :=
assume h₁ h₂, exists_of_subtype (sub_dvd_of_not_prime h₁ h₂)

definition sub_dvd_of_not_prime2 {n : nat} : n ≥ 2 → ¬ prime n → {m | m ∣ n ∧ m ≥ 2 ∧ m < n} :=
assume h₁ h₂,
have n ≠ 0, from assume h, begin subst n, exact absurd h₁ dec_trivial end,
obtain m m_dvd_n m_ne_1 m_ne_n, from sub_dvd_of_not_prime h₁ h₂,
have m_ne_0 : m ≠ 0, from assume h, begin subst m, exact absurd (eq_zero_of_zero_dvd m_dvd_n) `n ≠ 0` end,
begin
  existsi m, split, assumption,
  split,
    {cases m with m, exact absurd rfl m_ne_0,
    cases m with m, exact absurd rfl m_ne_1, exact succ_le_succ (succ_le_succ (zero_le _))},
    {have m_le_n : m ≤ n, from le_of_dvd (pos_of_ne_zero `n ≠ 0`) m_dvd_n,
     exact lt_of_le_of_ne m_le_n m_ne_n}
end

theorem exists_dvd_of_not_prime2 {n : nat} : n ≥ 2 → ¬ prime n → ∃ m, m ∣ n ∧ m ≥ 2 ∧ m < n :=
assume h₁ h₂, exists_of_subtype (sub_dvd_of_not_prime2 h₁ h₂)

definition sub_prime_and_dvd {n : nat} : n ≥ 2 → {p | prime p ∧ p ∣ n} :=
nat.strong_rec_on n
  (take n,
   assume ih : ∀ m, m < n → m ≥ 2 → {p | prime p ∧ p ∣ m},
   suppose n ≥ 2,
   by_cases
    (suppose prime n, subtype.tag n (and.intro this (dvd.refl n)))
    (suppose ¬ prime n,
      obtain m m_dvd_n m_ge_2 m_lt_n, from sub_dvd_of_not_prime2 `n ≥ 2` this,
      obtain p (hp : prime p) (p_dvd_m : p ∣ m), from ih m m_lt_n m_ge_2,
      have p ∣ n, from dvd.trans p_dvd_m m_dvd_n,
      subtype.tag p (and.intro hp this)))

lemma exists_prime_and_dvd {n : nat} : n ≥ 2 → ∃ p, prime p ∧ p ∣ n :=
assume h, exists_of_subtype (sub_prime_and_dvd h)

open eq.ops

definition infinite_primes (n : nat) : {p | p ≥ n ∧ prime p} :=
let m := fact (n + 1) in
have m ≥ 1,     from le_of_lt_succ (succ_lt_succ (fact_pos _)),
have m + 1 ≥ 2, from succ_le_succ this,
obtain p `prime p` `p ∣ m + 1`, from sub_prime_and_dvd this,
have p ≥ 2, from ge_two_of_prime `prime p`,
have p > 0, from lt_of_succ_lt (lt_of_succ_le `p ≥ 2`),
have p ≥ n, from by_contradiction
  (suppose ¬ p ≥ n,
    have p < n,     from lt_of_not_ge this,
    have p ≤ n + 1, from le_of_lt (lt.step this),
    have p ∣ m,     from dvd_fact `p > 0` this,
    have p ∣ 1,     from dvd_of_dvd_add_right (!add.comm ▸ `p ∣ m + 1`) this,
    have p ≤ 1,     from le_of_dvd zero_lt_one this,
    show false,     from absurd (le.trans `2 ≤ p` `p ≤ 1`) dec_trivial),
subtype.tag p (and.intro this `prime p`)

lemma exists_infinite_primes (n : nat) : ∃ p, p ≥ n ∧ prime p :=
exists_of_subtype (infinite_primes n)

lemma odd_of_prime {p : nat} : prime p → p > 2 → odd p :=
λ pp p_gt_2, by_contradiction (λ hn,
  have even p, from even_of_not_odd hn,
  obtain k `p = 2*k`, from exists_of_even this,
  have 2 ∣ p, by rewrite [`p = 2*k`]; apply dvd_mul_right,
  or.elim (eq_one_or_eq_self_of_prime_of_dvd pp this)
    (suppose 2 = 1, absurd this dec_trivial)
    (suppose 2 = p, by subst this; exact absurd p_gt_2 !lt.irrefl))

theorem dvd_of_prime_of_not_coprime {p n : ℕ} (primep : prime p) (nc : ¬ coprime p n) : p ∣ n :=
have H : gcd p n = 1 ∨ gcd p n = p, from eq_one_or_eq_self_of_prime_of_dvd primep !gcd_dvd_left,
or_resolve_right H nc ▸ !gcd_dvd_right

theorem coprime_of_prime_of_not_dvd {p n : ℕ} (primep : prime p) (npdvdn : ¬ p ∣ n) :
  coprime p n :=
by_contradiction (suppose ¬ coprime p n, npdvdn (dvd_of_prime_of_not_coprime primep this))

theorem not_dvd_of_prime_of_coprime {p n : ℕ} (primep : prime p) (cop : coprime p n) : ¬ p ∣ n :=
suppose p ∣ n,
have p ∣ gcd p n,  from dvd_gcd !dvd.refl this,
have p ≤ gcd p n, from le_of_dvd (!gcd_pos_of_pos_left (pos_of_prime primep)) this,
have 2 ≤ 1,       from le.trans (ge_two_of_prime primep) (cop ▸ this),
show false,       from !not_succ_le_self this

theorem not_coprime_of_prime_dvd {p n : ℕ} (primep : prime p) (pdvdn : p ∣ n) : ¬ coprime p n :=
assume cop, not_dvd_of_prime_of_coprime primep cop pdvdn

theorem dvd_of_prime_of_dvd_mul_left {p m n : ℕ} (primep : prime p)
    (Hmn : p ∣ m * n) (Hm : ¬ p ∣ m) :
  p ∣ n :=
have coprime p m, from coprime_of_prime_of_not_dvd primep Hm,
show p ∣ n, from dvd_of_coprime_of_dvd_mul_left this Hmn

theorem dvd_of_prime_of_dvd_mul_right {p m n : ℕ} (primep : prime p)
    (Hmn : p ∣ m * n) (Hn : ¬ p ∣ n) :
  p ∣ m :=
dvd_of_prime_of_dvd_mul_left primep (!mul.comm ▸ Hmn) Hn

theorem not_dvd_mul_of_prime {p m n : ℕ} (primep : prime p) (Hm : ¬ p ∣ m) (Hn : ¬ p ∣ n) :
  ¬ p ∣ m * n :=
assume Hmn, Hm (dvd_of_prime_of_dvd_mul_right primep Hmn Hn)

lemma dvd_or_dvd_of_prime_of_dvd_mul {p m n : nat} : prime p → p ∣ m * n → p ∣ m ∨ p ∣ n :=
λ h₁ h₂, by_cases
  (suppose p ∣ m, or.inl this)
  (suppose ¬ p ∣ m, or.inr (dvd_of_prime_of_dvd_mul_left h₁ h₂ this))

lemma dvd_of_prime_of_dvd_pow {p m : nat} : ∀ {n}, prime p → p ∣ m^n → p ∣ m
| 0 hp hd :=
  have p = 1,       from eq_one_of_dvd_one hd,
  have (1:nat) ≥ 2, begin rewrite -this at {1}, apply ge_two_of_prime hp end,
  absurd this dec_trivial
| (succ n) hp hd :=
  have p ∣ (m^n)*m, by rewrite [pow_succ' at hd]; exact hd,
  or.elim (dvd_or_dvd_of_prime_of_dvd_mul hp this)
    (suppose p ∣ m^n, dvd_of_prime_of_dvd_pow hp this)
    (suppose p ∣ m, this)

lemma coprime_pow_of_prime_of_not_dvd {p m a : nat} : prime p → ¬ p ∣ a → coprime a (p^m) :=
λ h₁ h₂, coprime_pow_right m (coprime_swap (coprime_of_prime_of_not_dvd h₁ h₂))

lemma coprime_primes {p q : nat} : prime p → prime q → p ≠ q → coprime p q :=
λ hp hq hn,
  have gcd p q ∣ p, from !gcd_dvd_left,
  or.elim (eq_one_or_eq_self_of_prime_of_dvd hp this)
    (suppose gcd p q = 1, this)
    (assume h : gcd p q = p,
      have gcd p q ∣ q, from !gcd_dvd_right,
      have p ∣ q, by rewrite -h; exact this,
      or.elim (eq_one_or_eq_self_of_prime_of_dvd hq this)
        (suppose p = 1, by subst p; exact absurd hp not_prime_one)
        (suppose p = q, by contradiction))

lemma coprime_pow_primes {p q : nat} (n m : nat) : prime p → prime q → p ≠ q → coprime (p^n) (q^m) :=
λ hp hq hn, coprime_pow_right m (coprime_pow_left n (coprime_primes hp hq hn))

lemma coprime_or_dvd_of_prime {p} (Pp : prime p) (i : nat) : coprime p i ∨ p ∣ i :=
by_cases
 (suppose p ∣ i, or.inr this)
 (suppose ¬ p ∣ i, or.inl (coprime_of_prime_of_not_dvd Pp this))

lemma eq_one_or_dvd_of_dvd_prime_pow {p : nat} : ∀ {m i : nat}, prime p → i ∣ (p^m) → i = 1 ∨ p ∣ i
| 0        := take i, assume Pp, begin rewrite [pow_zero], intro Pdvd, apply or.inl (eq_one_of_dvd_one Pdvd) end
| (succ m) := take i, assume Pp, or.elim (coprime_or_dvd_of_prime Pp i)
  (λ Pcp, begin
    rewrite [pow_succ'], intro Pdvd,
    apply eq_one_or_dvd_of_dvd_prime_pow Pp,
    apply dvd_of_coprime_of_dvd_mul_right,
      apply coprime_swap Pcp, exact Pdvd
  end)
  (λ Pdvd, assume P, or.inr Pdvd)
end nat


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Yaël Dillies
-/
import order.locally_finite

/-!
# Intervals as finsets

This file provides basic results about all the `finset.Ixx`, which are defined in
`order.locally_finite`.

## TODO

This file was originally only about `finset.Ico a b` where `a b : ℕ`. No care has yet been taken to
generalize these lemmas properly and many lemmas about `Icc`, `Ioc`, `Ioo` are missing. In general,
what's to do is taking the lemmas in `data.x.intervals` and abstract away the concrete structure.
-/

variables {α : Type*}

namespace finset
section preorder
variables [preorder α] [locally_finite_order α] {a b : α}

@[simp] lemma nonempty_Icc : (Icc a b).nonempty ↔ a ≤ b :=
by rw [←coe_nonempty, coe_Icc, set.nonempty_Icc]

@[simp] lemma nonempty_Ico : (Ico a b).nonempty ↔ a < b :=
by rw [←coe_nonempty, coe_Ico, set.nonempty_Ico]

@[simp] lemma nonempty_Ioc : (Ioc a b).nonempty ↔ a < b :=
by rw [←coe_nonempty, coe_Ioc, set.nonempty_Ioc]

@[simp] lemma nonempty_Ioo [densely_ordered α] : (Ioo a b).nonempty ↔ a < b :=
by rw [←coe_nonempty, coe_Ioo, set.nonempty_Ioo]

@[simp] lemma Icc_eq_empty_iff : Icc a b = ∅ ↔ ¬a ≤ b :=
by rw [←coe_eq_empty, coe_Icc, set.Icc_eq_empty_iff]

@[simp] lemma Ico_eq_empty_iff : Ico a b = ∅ ↔ ¬a < b :=
by rw [←coe_eq_empty, coe_Ico, set.Ico_eq_empty_iff]

@[simp] lemma Ioc_eq_empty_iff : Ioc a b = ∅ ↔ ¬a < b :=
by rw [←coe_eq_empty, coe_Ioc, set.Ioc_eq_empty_iff]

@[simp] lemma Ioo_eq_empty_iff [densely_ordered α] : Ioo a b = ∅ ↔ ¬a < b :=
by rw [←coe_eq_empty, coe_Ioo, set.Ioo_eq_empty_iff]

alias Icc_eq_empty_iff ↔ _ finset.Icc_eq_empty
alias Ico_eq_empty_iff ↔ _ finset.Ico_eq_empty
alias Ioc_eq_empty_iff ↔ _ finset.Ioc_eq_empty

@[simp] lemma Ioo_eq_empty (h : ¬a < b) : Ioo a b = ∅ :=
eq_empty_iff_forall_not_mem.2 $ λ x hx, h ((mem_Ioo.1 hx).1.trans (mem_Ioo.1 hx).2)

@[simp] lemma Icc_eq_empty_of_lt (h : b < a) : Icc a b = ∅ := Icc_eq_empty h.not_le
@[simp] lemma Ico_eq_empty_of_le (h : b ≤ a) : Ico a b = ∅ := Ico_eq_empty h.not_lt
@[simp] lemma Ioc_eq_empty_of_le (h : b ≤ a) : Ioc a b = ∅ := Ioc_eq_empty h.not_lt
@[simp] lemma Ioo_eq_empty_of_le (h : b ≤ a) : Ioo a b = ∅ := Ioo_eq_empty h.not_lt

variables (a)

@[simp] lemma Ico_self : Ico a a = ∅ := by rw [←coe_eq_empty, coe_Ico, set.Ico_self]
@[simp] lemma Ioc_self : Ioc a a = ∅ := by rw [←coe_eq_empty, coe_Ioc, set.Ioc_self]
@[simp] lemma Ioo_self : Ioo a a = ∅ := by rw [←coe_eq_empty, coe_Ioo, set.Ioo_self]

variables {a b}

lemma left_mem_Icc : a ∈ Icc a b ↔ a ≤ b := by simp only [mem_Icc, true_and, le_refl]
lemma left_mem_Ico : a ∈ Ico a b ↔ a < b := by simp only [mem_Ico, true_and, le_refl]
lemma right_mem_Icc : b ∈ Icc a b ↔ a ≤ b := by simp only [mem_Icc, and_true, le_refl]
lemma right_mem_Ioc : b ∈ Ioc a b ↔ a < b := by simp only [mem_Ioc, and_true, le_refl]

@[simp] lemma left_not_mem_Ioc : a ∉ Ioc a b := λ h, lt_irrefl _ (mem_Ioc.1 h).1
@[simp] lemma left_not_mem_Ioo : a ∉ Ioo a b := λ h, lt_irrefl _ (mem_Ioo.1 h).1
@[simp] lemma right_not_mem_Ico : b ∉ Ico a b := λ h, lt_irrefl _ (mem_Ico.1 h).2
@[simp] lemma right_not_mem_Ioo : b ∉ Ioo a b := λ h, lt_irrefl _ (mem_Ioo.1 h).2

lemma Ico_filter_lt_of_le_left {a b c : α} [decidable_pred (< c)] (hca : c ≤ a) :
  (Ico a b).filter (λ x, x < c) = ∅ :=
finset.filter_false_of_mem (λ x hx, (hca.trans (mem_Ico.1 hx).1).not_lt)

lemma Ico_filter_lt_of_right_le {a b c : α} [decidable_pred (< c)] (hbc : b ≤ c) :
  (Ico a b).filter (λ x, x < c) = Ico a b :=
finset.filter_true_of_mem (λ x hx, (mem_Ico.1 hx).2.trans_le hbc)

lemma Ico_filter_lt_of_le_right {a b c : α} [decidable_pred (< c)] (hcb : c ≤ b) :
  (Ico a b).filter (λ x, x < c) = Ico a c :=
begin
  ext x,
  rw [mem_filter, mem_Ico, mem_Ico, and.right_comm],
  exact and_iff_left_of_imp (λ h, h.2.trans_le hcb),
end

lemma Ico_filter_le_of_le_left {a b c : α} [decidable_pred ((≤) c)] (hca : c ≤ a) :
  (Ico a b).filter (λ x, c ≤ x) = Ico a b :=
finset.filter_true_of_mem (λ x hx, hca.trans (mem_Ico.1 hx).1)

lemma Ico_filter_le_of_right_le {a b : α} [decidable_pred ((≤) b)] :
  (Ico a b).filter (λ x, b ≤ x) = ∅ :=
finset.filter_false_of_mem (λ x hx, (mem_Ico.1 hx).2.not_le)

lemma Ico_filter_le_of_left_le {a b c : α} [decidable_pred ((≤) c)] (hac : a ≤ c) :
  (Ico a b).filter (λ x, c ≤ x) = Ico c b :=
begin
  ext x,
  rw [mem_filter, mem_Ico, mem_Ico, and_comm, and.left_comm],
  exact and_iff_right_of_imp (λ h, hac.trans h.1),
end

/-- A set with upper and lower bounds in a locally finite order is a fintype -/
def _root_.set.fintype_of_mem_bounds {a b} {s : set α} [decidable_pred (∈ s)]
  (ha : a ∈ lower_bounds s) (hb : b ∈ upper_bounds s) : fintype s :=
set.fintype_subset (set.Icc a b) $ λ x hx, ⟨ha hx, hb hx⟩

lemma _root_.bdd_below.finite_of_bdd_above {s : set α} (h₀ : bdd_below s) (h₁ : bdd_above s) :
  s.finite :=
let ⟨a, ha⟩ := h₀, ⟨b, hb⟩ := h₁ in by { classical, exact ⟨set.fintype_of_mem_bounds ha hb⟩ }

end preorder

section partial_order
variables [partial_order α] [locally_finite_order α] {a b : α}

@[simp] lemma Icc_self (a : α) : Icc a a = {a} := by rw [←coe_eq_singleton, coe_Icc, set.Icc_self]

section decidable_eq
variables [decidable_eq α]

lemma Icc_erase_left : (Icc a b).erase a = Ioc a b :=
by rw [←coe_inj, coe_erase, coe_Icc, coe_Ioc, set.Icc_diff_left]

lemma Icc_erase_right : (Icc a b).erase b = Ico a b :=
by rw [←coe_inj, coe_erase, coe_Icc, coe_Ico, set.Icc_diff_right]

lemma Ico_insert_right (h : a ≤ b) : insert b (Ico a b) = Icc a b :=
by rw [←coe_inj, coe_insert, coe_Icc, coe_Ico, set.insert_eq, set.union_comm, set.Ico_union_right h]

lemma Ioo_insert_left (h : a < b) : insert a (Ioo a b) = Ico a b :=
by rw [←coe_inj, coe_insert, coe_Ioo, coe_Ico, set.insert_eq, set.union_comm, set.Ioo_union_left h]

@[simp] lemma Ico_inter_Ico_consecutive (a b c : α) : Ico a b ∩ Ico b c = ∅ :=
begin
  refine eq_empty_of_forall_not_mem (λ x hx, _),
  rw [mem_inter, mem_Ico, mem_Ico] at hx,
  exact hx.1.2.not_le hx.2.1,
end

lemma Ico_disjoint_Ico_consecutive (a b c : α) : disjoint (Ico a b) (Ico b c) :=
le_of_eq $ Ico_inter_Ico_consecutive a b c

end decidable_eq

lemma Ico_filter_le_left {a b : α} [decidable_pred (≤ a)] (hab : a < b) :
  (Ico a b).filter (λ x, x ≤ a) = {a} :=
begin
  ext x,
  rw [mem_filter, mem_Ico, mem_singleton, and.right_comm, ←le_antisymm_iff, eq_comm],
  exact and_iff_left_of_imp (λ h, h.le.trans_lt hab),
end

lemma card_Ico_eq_card_Icc_sub_one (h : a ≤ b) : (Ico a b).card = (Icc a b).card - 1 :=
begin
  classical,
  rw [←Ico_insert_right h, card_insert_of_not_mem right_not_mem_Ico],
  exact (nat.add_sub_cancel _ _).symm,
end

lemma card_Ioc_eq_card_Icc_sub_one (h : a ≤ b) : (Ioc a b).card = (Icc a b).card - 1 :=
@card_Ico_eq_card_Icc_sub_one (order_dual α) _ _ _ _ h

lemma card_Ioo_eq_card_Ico_sub_one (h : a ≤ b) : (Ioo a b).card = (Ico a b).card - 1 :=
begin
  obtain rfl | h' := h.eq_or_lt,
  { rw [Ioo_self, Ico_self, card_empty] },
  classical,
  rw [←Ioo_insert_left h', card_insert_of_not_mem left_not_mem_Ioo],
  exact (nat.add_sub_cancel _ _).symm,
end

lemma card_Ioo_eq_card_Icc_sub_two (h : a ≤ b) : (Ioo a b).card = (Icc a b).card - 2 :=
by { rw [card_Ioo_eq_card_Ico_sub_one h, card_Ico_eq_card_Icc_sub_one h], refl }

end partial_order

section linear_order
variables [linear_order α] [locally_finite_order α] {a b : α}

lemma Ico_subset_Ico_iff {a₁ b₁ a₂ b₂ : α} (h : a₁ < b₁) :
  Ico a₁ b₁ ⊆ Ico a₂ b₂ ↔ a₂ ≤ a₁ ∧ b₁ ≤ b₂ :=
by rw [←coe_subset, coe_Ico, coe_Ico, set.Ico_subset_Ico_iff h]

lemma Ico_union_Ico_eq_Ico {a b c : α} (hab : a ≤ b) (hbc : b ≤ c) :
  Ico a b ∪ Ico b c = Ico a c :=
by rw [←coe_inj, coe_union, coe_Ico, coe_Ico, coe_Ico, set.Ico_union_Ico_eq_Ico hab hbc]

lemma Ico_union_Ico' {a b c d : α} (hcb : c ≤ b) (had : a ≤ d) :
  Ico a b ∪ Ico c d = Ico (min a c) (max b d) :=
by rw [←coe_inj, coe_union, coe_Ico, coe_Ico, coe_Ico, set.Ico_union_Ico' hcb had]

lemma Ico_union_Ico {a b c d : α} (h₁ : min a b ≤ max c d) (h₂ : min c d ≤ max a b) :
  Ico a b ∪ Ico c d = Ico (min a c) (max b d) :=
by rw [←coe_inj, coe_union, coe_Ico, coe_Ico, coe_Ico, set.Ico_union_Ico h₁ h₂]

lemma Ico_inter_Ico {a b c d : α} : Ico a b ∩ Ico c d = Ico (max a c) (min b d) :=
by rw [←coe_inj, coe_inter, coe_Ico, coe_Ico, coe_Ico, ←inf_eq_min, ←sup_eq_max, set.Ico_inter_Ico]

@[simp] lemma Ico_filter_lt (a b c : α) : (Ico a b).filter (λ x, x < c) = Ico a (min b c) :=
begin
  cases le_total b c,
  { rw [Ico_filter_lt_of_right_le h, min_eq_left h] },
  { rw [Ico_filter_lt_of_le_right h, min_eq_right h] }
end

@[simp] lemma Ico_filter_le (a b c : α) : (Ico a b).filter (λ x, c ≤ x) = Ico (max a c) b :=
begin
  cases le_total a c,
  { rw [Ico_filter_le_of_left_le h, max_eq_right h] },
  { rw [Ico_filter_le_of_le_left h, max_eq_left h] }
end

@[simp] lemma Ico_diff_Ico_left (a b c : α) : (Ico a b) \ (Ico a c) = Ico (max a c) b :=
begin
  cases le_total a c,
  { ext x,
    rw [mem_sdiff, mem_Ico, mem_Ico, mem_Ico, max_eq_right h, and.right_comm, not_and, not_lt],
    exact and_congr_left' ⟨λ hx, hx.2 hx.1, λ hx, ⟨h.trans hx, λ _, hx⟩⟩ },
  { rw [Ico_eq_empty_of_le h, sdiff_empty, max_eq_left h] }
end

@[simp] lemma Ico_diff_Ico_right (a b c : α) : (Ico a b) \ (Ico c b) = Ico a (min b c) :=
begin
  cases le_total b c,
  { rw [Ico_eq_empty_of_le h, sdiff_empty, min_eq_left h] },
  { ext x,
    rw [mem_sdiff, mem_Ico, mem_Ico, mem_Ico, min_eq_right h, and_assoc, not_and', not_le],
    exact and_congr_right' ⟨λ hx, hx.2 hx.1, λ hx, ⟨hx.trans_le h, λ _, hx⟩⟩ }
end

end linear_order

section order_top
variables [preorder α] [order_top α] [locally_finite_order α]

lemma _root_.bdd_below.finite {s : set α} (hs : bdd_below s) : s.finite :=
hs.finite_of_bdd_above $ order_top.bdd_above s

end order_top

section order_bot
variables [preorder α] [order_bot α] [locally_finite_order α]

lemma _root_.bdd_above.finite {s : set α} (hs : bdd_above s) : s.finite := hs.dual.finite

end order_bot

section ordered_cancel_add_comm_monoid
variables [ordered_cancel_add_comm_monoid α] [has_exists_add_of_le α] [decidable_eq α]
  [locally_finite_order α]

lemma image_add_left_Icc (a b c : α) : (Icc a b).image ((+) c) = Icc (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Icc],
  split,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Icc at hy,
    exact ⟨add_le_add_left hy.1 c, add_le_add_left hy.2 c⟩ },
  { intro hx,
    obtain ⟨y, hy⟩ := exists_add_of_le hx.1,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Icc.2 ⟨le_of_add_le_add_left hx.1, le_of_add_le_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_left_Ico (a b c : α) : (Ico a b).image ((+) c) = Ico (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Ico],
  split,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Ico at hy,
    exact ⟨add_le_add_left hy.1 c, add_lt_add_left hy.2 c⟩ },
  { intro hx,
    obtain ⟨y, hy⟩ := exists_add_of_le hx.1,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Ico.2 ⟨le_of_add_le_add_left hx.1, lt_of_add_lt_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_left_Ioc (a b c : α) : (Ioc a b).image ((+) c) = Ioc (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Ioc],
  refine ⟨_, λ hx, _⟩,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Ioc at hy,
    exact ⟨add_lt_add_left hy.1 c, add_le_add_left hy.2 c⟩ },
  { obtain ⟨y, hy⟩ := exists_add_of_le hx.1.le,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Ioc.2 ⟨lt_of_add_lt_add_left hx.1, le_of_add_le_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_left_Ioo (a b c : α) : (Ioo a b).image ((+) c) = Ioo (c + a) (c + b) :=
begin
  ext x,
  rw [mem_image, mem_Ioo],
  refine ⟨_, λ hx, _⟩,
  { rintro ⟨y, hy, rfl⟩,
    rw mem_Ioo at hy,
    exact ⟨add_lt_add_left hy.1 c, add_lt_add_left hy.2 c⟩ },
  { obtain ⟨y, hy⟩ := exists_add_of_le hx.1.le,
    rw add_assoc at hy,
    rw hy at hx,
    exact ⟨a + y, mem_Ioo.2 ⟨lt_of_add_lt_add_left hx.1, lt_of_add_lt_add_left hx.2⟩, hy.symm⟩ }
end

lemma image_add_right_Icc (a b c : α) : (Icc a b).image (λ x, x + c) = Icc (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Icc a b c }

lemma image_add_right_Ico (a b c : α) : (Ico a b).image (λ x, x + c) = Ico (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Ico a b c }

lemma image_add_right_Ioc (a b c : α) : (Ioc a b).image (λ x, x + c) = Ioc (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Ioc a b c }

lemma image_add_right_Ioo (a b c : α) : (Ioo a b).image (λ x, x + c) = Ioo (a + c) (b + c) :=
by { simp_rw add_comm _ c, exact image_add_left_Ioo a b c }

end ordered_cancel_add_comm_monoid
end finset


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import data.set.basic
import tactic.interactive

open set

variables {α β : Type}
@[simp] lemma singleton_inter_singleton_eq_empty {x y : α} :
  ({x} ∩ {y} = (∅ : set α)) ↔ x ≠ y :=
by simp [singleton_inter_eq_empty]

example {f : β → α} {x y : α} (h : x ≠ y) : f ⁻¹' {x} ∩ f ⁻¹' {y} = ∅ :=
begin
  have : {x} ∩ {y} = (∅ : set α) := by simpa using h,
  convert preimage_empty,
  rw [←preimage_inter,this],
end

example (P : Prop) (h : P) : P := by convert h


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Alena Gusakov
-/
import data.fintype.basic
import algebra.geom_sum

/-!
# Colex

We define the colex ordering for finite sets, and give a couple of important
lemmas and properties relating to it.

The colex ordering likes to avoid large values - it can be thought of on
`finset ℕ` as the "binary" ordering. That is, order A based on
`∑_{i ∈ A} 2^i`.
It's defined here in a slightly more general way, requiring only `has_lt α` in
the definition of colex on `finset α`. In the context of the Kruskal-Katona
theorem, we are interested in particular on how colex behaves for sets of a
fixed size. If the size is 3, colex on ℕ starts
123, 124, 134, 234, 125, 135, 235, 145, 245, 345, ...

## Main statements
* `colex.hom_lt_iff`: strictly monotone functions preserve colex
* Colex order properties - linearity, decidability and so on.
* `forall_lt_of_colex_lt_of_forall_lt`: if A < B in colex, and everything
  in B is < t, then everything in A is < t. This confirms the idea that
  an enumeration under colex will exhaust all sets using elements < t before
  allowing t to be included.
* `sum_two_pow_le_iff_lt`: colex for α = ℕ is the same as binary
  (this also proves binary expansions are unique)

## See also

Related files are:
* `data.list.lex`: Lexicographic order on lists.
* `data.pi.lex`: Lexicographic order on `Πₗ i, α i`.
* `data.psigma.order`: Lexicographic order on `Σ' i, α i`.
* `data.sigma.order`: Lexicographic order on `Σ i, α i`.
* `data.prod.lex`: Lexicographic order on `α × β`.

## Tags
colex, colexicographic, binary

## References
* https://github.com/b-mehta/maths-notes/blob/master/iii/mich/combinatorics.pdf

-/

variable {α : Type*}

open finset
open_locale big_operators

/--
We define this type synonym to refer to the colexicographic ordering on finsets
rather than the natural subset ordering.
-/
@[derive inhabited]
def finset.colex (α) := finset α

/--
A convenience constructor to turn a `finset α` into a `finset.colex α`, useful in order to
use the colex ordering rather than the subset ordering.
-/
def finset.to_colex {α} (s : finset α) : finset.colex α := s

@[simp]
lemma colex.eq_iff (A B : finset α) :
  A.to_colex = B.to_colex ↔ A = B := iff.rfl

/--
`A` is less than `B` in the colex ordering if the largest thing that's not in both sets is in B.
In other words, `max (A ∆ B) ∈ B` (if the maximum exists).
-/
instance [has_lt α] : has_lt (finset.colex α) :=
⟨λ (A B : finset α), ∃ (k : α), (∀ {x}, k < x → (x ∈ A ↔ x ∈ B)) ∧ k ∉ A ∧ k ∈ B⟩

/-- We can define (≤) in the obvious way. -/
instance [has_lt α] : has_le (finset.colex α) :=
⟨λ A B, A < B ∨ A = B⟩

lemma colex.lt_def [has_lt α] (A B : finset α) :
  A.to_colex < B.to_colex ↔ ∃ k, (∀ {x}, k < x → (x ∈ A ↔ x ∈ B)) ∧ k ∉ A ∧ k ∈ B :=
iff.rfl
lemma colex.le_def [has_lt α] (A B : finset α) :
  A.to_colex ≤ B.to_colex ↔ A.to_colex < B.to_colex ∨ A = B :=
iff.rfl

/-- If everything in `A` is less than `k`, we can bound the sum of powers. -/
lemma nat.sum_two_pow_lt {k : ℕ} {A : finset ℕ} (h₁ : ∀ {x}, x ∈ A → x < k) :
  A.sum (pow 2) < 2^k :=
begin
  apply lt_of_le_of_lt (sum_le_sum_of_subset (λ t, mem_range.2 ∘ h₁)),
  have z := geom_sum_mul_add 1 k,
  rw [mul_one, one_add_one_eq_two] at z,
  rw ← z,
  apply nat.lt_succ_self,
end

namespace colex

/-- Strictly monotone functions preserve the colex ordering. -/
lemma hom_lt_iff {β : Type*} [linear_order α] [decidable_eq β] [preorder β]
  {f : α → β} (h₁ : strict_mono f) (A B : finset α) :
  (A.image f).to_colex < (B.image f).to_colex ↔ A.to_colex < B.to_colex :=
begin
  simp only [colex.lt_def, not_exists, mem_image, exists_prop, not_and],
  split,
  { rintro ⟨k, z, q, k', _, rfl⟩,
    exact ⟨k', λ x hx, by simpa [h₁.injective.eq_iff] using z (h₁ hx), λ t, q _ t rfl, ‹k' ∈ B›⟩ },
  rintro ⟨k, z, ka, _⟩,
  refine ⟨f k, λ x hx, _, _, k, ‹k ∈ B›, rfl⟩,
  { split,
    any_goals
    { rintro ⟨x', hx', rfl⟩,
      refine ⟨x', _, rfl⟩,
      rwa ← z _ <|> rwa z _,
      rwa strict_mono.lt_iff_lt h₁ at hx } },
  { simp only [h₁.injective, function.injective.eq_iff],
    exact λ x hx, ne_of_mem_of_not_mem hx ka }
end

/-- A special case of `colex.hom_lt_iff` which is sometimes useful. -/
@[simp] lemma hom_fin_lt_iff {n : ℕ} (A B : finset (fin n)) :
  (A.image (λ i : fin n, (i : ℕ))).to_colex < (B.image (λ i : fin n, (i : ℕ))).to_colex
   ↔ A.to_colex < B.to_colex :=
colex.hom_lt_iff (λ x y k, k) _ _

instance [has_lt α] : is_irrefl (finset.colex α) (<) :=
⟨λ A h, exists.elim h (λ _ ⟨_,a,b⟩, a b)⟩

@[trans]
lemma lt_trans [linear_order α] {a b c : finset.colex α} : a < b → b < c → a < c :=
begin
  rintros ⟨k₁, k₁z, notinA, inB⟩ ⟨k₂, k₂z, notinB, inC⟩,
  cases lt_or_gt_of_ne (ne_of_mem_of_not_mem inB notinB),
  { refine ⟨k₂, λ x hx, _, by rwa k₁z h, inC⟩,
    rw ← k₂z hx,
    apply k₁z (trans h hx) },
  { refine ⟨k₁, λ x hx, _, notinA, by rwa ← k₂z h⟩,
    rw k₁z hx,
    apply k₂z (trans h hx) }
end

@[trans]
lemma le_trans [linear_order α] (a b c : finset.colex α) : a ≤ b → b ≤ c → a ≤ c :=
λ AB BC, AB.elim (λ k, BC.elim (λ t, or.inl (lt_trans k t)) (λ t, t ▸ AB)) (λ k, k.symm ▸ BC)

instance [linear_order α] : is_trans (finset.colex α) (<) := ⟨λ _ _ _, colex.lt_trans⟩

lemma lt_trichotomy [linear_order α] (A B : finset.colex α) :
  A < B ∨ A = B ∨ B < A :=
begin
  by_cases h₁ : (A = B),
  { tauto },
  rcases (exists_max_image (A \ B ∪ B \ A) id _) with ⟨k, hk, z⟩,
  { simp only [mem_union, mem_sdiff] at hk,
    cases hk,
    { right,
      right,
      refine ⟨k, λ t th, _, hk.2, hk.1⟩,
      specialize z t,
      by_contra h₂,
      simp only [mem_union, mem_sdiff, id.def] at z,
      rw [not_iff, iff_iff_and_or_not_and_not, not_not, and_comm] at h₂,
      apply not_le_of_lt th (z h₂) },
    { left,
      refine ⟨k, λ t th, _, hk.2, hk.1⟩,
      specialize z t,
      by_contra h₃,
      simp only [mem_union, mem_sdiff, id.def] at z,
      rw [not_iff, iff_iff_and_or_not_and_not, not_not, and_comm, or_comm] at h₃,
      apply not_le_of_lt th (z h₃) }, },
  rw nonempty_iff_ne_empty,
  intro a,
  simp only [union_eq_empty_iff, sdiff_eq_empty_iff_subset] at a,
  apply h₁ (subset.antisymm a.1 a.2)
end

instance [linear_order α] : is_trichotomous (finset.colex α) (<) := ⟨lt_trichotomy⟩

instance decidable_lt [linear_order α] : ∀ {A B : finset.colex α}, decidable (A < B) :=
show ∀ A B : finset α, decidable (A.to_colex < B.to_colex),
from λ A B, decidable_of_iff'
  (∃ (k ∈ B), (∀ x ∈ A ∪ B, k < x → (x ∈ A ↔ x ∈ B)) ∧ k ∉ A)
  begin
    rw colex.lt_def,
    apply exists_congr,
    simp only [mem_union, exists_prop, or_imp_distrib, and_comm (_ ∈ B), and_assoc],
    intro k,
    refine and_congr_left' (forall_congr _),
    tauto,
  end

instance [linear_order α] : linear_order (finset.colex α) :=
{ le_refl := λ A, or.inr rfl,
  le_trans := le_trans,
  le_antisymm := λ A B AB BA, AB.elim (λ k, BA.elim (λ t, (asymm k t).elim) (λ t, t.symm)) id,
  le_total := λ A B,
          (lt_trichotomy A B).elim3 (or.inl ∘ or.inl) (or.inl ∘ or.inr) (or.inr ∘ or.inl),
  decidable_le := λ A B, by apply_instance,
  decidable_lt := λ A B, by apply_instance,
  decidable_eq := λ A B, by apply_instance,
  lt_iff_le_not_le := λ A B,
  begin
    split,
    { intro t,
      refine ⟨or.inl t, _⟩,
      rintro (i | rfl),
      { apply asymm_of _ t i },
      { apply irrefl _ t } },
    rintro ⟨h₁ | rfl, h₂⟩,
    { apply h₁ },
    apply h₂.elim (or.inr rfl),
  end,
  ..finset.colex.has_lt,
  ..finset.colex.has_le }

/-- The instances set up let us infer that `colex.lt` is a strict total order. -/
example [linear_order α] : is_strict_total_order (finset.colex α) (<) := infer_instance

/-- Strictly monotone functions preserve the colex ordering. -/
lemma hom_le_iff {β : Type*} [linear_order α] [linear_order β]
  {f : α → β} (h₁ : strict_mono f) (A B : finset α) :
  (A.image f).to_colex ≤ (B.image f).to_colex ↔ A.to_colex ≤ B.to_colex :=
by rw [le_iff_le_iff_lt_iff_lt, hom_lt_iff h₁]

/-- A special case of `colex_hom` which is sometimes useful. -/
@[simp] lemma hom_fin_le_iff {n : ℕ} (A B : finset (fin n)) :
  (A.image (λ i : fin n, (i : ℕ))).to_colex ≤ (B.image (λ i : fin n, (i : ℕ))).to_colex
   ↔ A.to_colex ≤ B.to_colex :=
colex.hom_le_iff (λ x y k, k) _ _

/--
If `A` is before `B` in colex, and everything in `B` is small, then everything in `A` is small.
-/
lemma forall_lt_of_colex_lt_of_forall_lt [linear_order α] {A B : finset α}
  (t : α) (h₁ : A.to_colex < B.to_colex) (h₂ : ∀ x ∈ B, x < t) :
  ∀ x ∈ A, x < t :=
begin
  rw colex.lt_def at h₁,
  rcases h₁ with ⟨k, z, _, _⟩,
  intros x hx,
  apply lt_of_not_ge,
  intro a,
  refine not_lt_of_ge a (h₂ x _),
  rwa ← z,
  apply lt_of_lt_of_le (h₂ k ‹_›) a,
end

/-- `s.to_colex < {r}.to_colex` iff all elements of `s` are less than `r`. -/
lemma lt_singleton_iff_mem_lt [linear_order α] {r : α} {s : finset α} :
  s.to_colex < ({r} : finset α).to_colex ↔ ∀ x ∈ s, x < r :=
begin
  simp only [lt_def, mem_singleton, ←and_assoc, exists_eq_right],
  split,
  { intros t x hx,
    rw ←not_le,
    intro h,
    rcases lt_or_eq_of_le h with h₁ | rfl,
    { exact ne_of_irrefl h₁ ((t.1 h₁).1 hx).symm },
    { exact t.2 hx } },
  { exact λ h, ⟨λ z hz, ⟨λ i, (asymm hz (h _ i)).elim, λ i, (hz.ne' i).elim⟩, by simpa using h r⟩ }
end

/-- If {r} is less than or equal to s in the colexicographical sense,
  then s contains an element greater than or equal to r. -/
lemma mem_le_of_singleton_le [linear_order α] {r : α} {s : finset α}:
  ({r} : finset α).to_colex ≤ s.to_colex ↔ ∃ x ∈ s, r ≤ x :=
by { rw ←not_lt, simp [lt_singleton_iff_mem_lt] }

/-- Colex is an extension of the base ordering on α. -/
lemma singleton_lt_iff_lt [linear_order α] {r s : α} :
  ({r} : finset α).to_colex < ({s} : finset α).to_colex ↔ r < s :=
by simp [lt_singleton_iff_mem_lt]

/-- Colex is an extension of the base ordering on α. -/
lemma singleton_le_iff_le [linear_order α] {r s : α} :
  ({r} : finset α).to_colex ≤ ({s} : finset α).to_colex ↔ r ≤ s :=
by rw [le_iff_le_iff_lt_iff_lt, singleton_lt_iff_lt]

/-- Colex doesn't care if you remove the other set -/
@[simp] lemma sdiff_lt_sdiff_iff_lt [has_lt α] [decidable_eq α] (A B : finset α) :
  (A \ B).to_colex < (B \ A).to_colex ↔ A.to_colex < B.to_colex :=
begin
  rw [colex.lt_def, colex.lt_def],
  apply exists_congr,
  intro k,
  simp only [mem_sdiff, not_and, not_not],
  split,
  { rintro ⟨z, kAB, kB, kA⟩,
    refine ⟨_, kA, kB⟩,
    { intros x hx,
      specialize z hx,
      tauto } },
  { rintro ⟨z, kA, kB⟩,
    refine ⟨_, λ _, kB, kB, kA⟩,
    intros x hx,
    rw z hx },
end

/-- Colex doesn't care if you remove the other set -/
@[simp]

lemma empty_to_colex_lt [linear_order α] {A : finset α} (hA : A.nonempty) :
  (∅ : finset α).to_colex < A.to_colex :=
begin
  rw [colex.lt_def],
  refine ⟨max' _ hA, _, by simp, max'_mem _ _⟩,
  simp only [false_iff, not_mem_empty],
  intros x hx t,
  apply not_le_of_lt hx (le_max' _ _ t),
end

/-- If `A ⊂ B`, then `A` is less than `B` in the colex order. Note the converse does not hold, as
`⊆` is not a linear order. -/
lemma colex_lt_of_ssubset [linear_order α] {A B : finset α} (h : A ⊂ B) :
  A.to_colex < B.to_colex :=
begin
  rw [←sdiff_lt_sdiff_iff_lt, sdiff_eq_empty_iff_subset.2 h.1],
  exact empty_to_colex_lt (by simpa [finset.nonempty] using exists_of_ssubset h),
end

@[simp] lemma empty_to_colex_le [linear_order α] {A : finset α} :
  (∅ : finset α).to_colex ≤ A.to_colex :=
begin
  rcases A.eq_empty_or_nonempty with rfl | hA,
  { simp },
  { apply (empty_to_colex_lt hA).le },
end

/-- If `A ⊆ B`, then `A ≤ B` in the colex order. Note the converse does not hold, as `⊆` is not a
linear order. -/
lemma colex_le_of_subset [linear_order α] {A B : finset α} (h : A ⊆ B) :
  A.to_colex ≤ B.to_colex :=
begin
  rw [←sdiff_le_sdiff_iff_le, sdiff_eq_empty_iff_subset.2 h],
  apply empty_to_colex_le
end

/-- The function from finsets to finsets with the colex order is a relation homomorphism. -/
@[simps]
def to_colex_rel_hom [linear_order α] :
  ((⊆) : finset α → finset α → Prop) →r ((≤) : finset.colex α → finset.colex α → Prop) :=
{ to_fun := finset.to_colex,
  map_rel' := λ A B, colex_le_of_subset }

instance [linear_order α] : order_bot (finset.colex α) :=
{ bot := (∅ : finset α).to_colex,
  bot_le := λ x, empty_to_colex_le }

instance [linear_order α] [fintype α] : order_top (finset.colex α) :=
{ top := finset.univ.to_colex,
  le_top := λ x, colex_le_of_subset (subset_univ _) }

instance [linear_order α] : lattice (finset.colex α) :=
{ ..(by apply_instance : semilattice_sup (finset.colex α)),
  ..(by apply_instance : semilattice_inf (finset.colex α)) }

instance [linear_order α] [fintype α] : bounded_order (finset.colex α) :=
{ ..(by apply_instance : order_top (finset.colex α)),
  ..(by apply_instance : order_bot (finset.colex α)) }

/-- For subsets of ℕ, we can show that colex is equivalent to binary. -/
lemma sum_two_pow_lt_iff_lt (A B : finset ℕ) :
  ∑ i in A, 2^i < ∑ i in B, 2^i ↔ A.to_colex < B.to_colex :=
begin
  have z : ∀ (A B : finset ℕ), A.to_colex < B.to_colex → ∑ i in A, 2^i < ∑ i in B, 2^i,
  { intros A B,
    rw [← sdiff_lt_sdiff_iff_lt, colex.lt_def],
    rintro ⟨k, z, kA, kB⟩,
    rw ← sdiff_union_inter A B,
    conv_rhs { rw ← sdiff_union_inter B A },
    rw [sum_union (disjoint_sdiff_inter _ _), sum_union (disjoint_sdiff_inter _ _),
        inter_comm, add_lt_add_iff_right],
    apply lt_of_lt_of_le (@nat.sum_two_pow_lt k (A \ B) _),
    { apply single_le_sum (λ _ _, nat.zero_le _) kB },
    intros x hx,
    apply lt_of_le_of_ne (le_of_not_lt (λ kx, _)),
    { apply (ne_of_mem_of_not_mem hx kA) },
    have := (z kx).1 hx,
    rw mem_sdiff at this hx,
    exact hx.2 this.1 },
  refine ⟨λ h, (lt_trichotomy A B).resolve_right (λ h₁, h₁.elim _ (not_lt_of_gt h ∘ z _ _)), z A B⟩,
  rintro rfl,
  apply irrefl _ h
end

/-- For subsets of ℕ, we can show that colex is equivalent to binary. -/
lemma sum_two_pow_le_iff_lt (A B : finset ℕ) :
  ∑ i in A, 2^i ≤ ∑ i in B, 2^i ↔ A.to_colex ≤ B.to_colex :=
by rw [le_iff_le_iff_lt_iff_lt, sum_two_pow_lt_iff_lt]

end colex


/-
Copyright (c) 2017 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Robert Y. Lewis
-/

import mathematica
import analysis.calculus.deriv
open tactic

/-!
This demo shows how we can axiomatically accept results from Mathematica.
Bessel functions <https://en.wikipedia.org/wiki/Bessel_function> are not defined in mathlib,
but we can add a constant with the right type,
and import properties from Mathematica as axioms.
-/

open real

/-
`deriv` is the single variable Frechet derivative.
In the case of `ℝ`, it specializes to the familiar derivative.
-/
#check (deriv : (ℝ → ℝ) → (ℝ → ℝ))

/-
We add a constant representing Bessel functions and an axiom with their defining property.
-/
constant BesselJ (n : ℝ) (z : ℝ) : ℝ

axiom BesselJ_def (n : ℝ) (z : ℝ) :
  z*z*(deriv (deriv (BesselJ n)) z) + z*(deriv (BesselJ n) z) + (z*z-n*n)*(BesselJ n z) = 0

section
open mathematica

/-
We translate Mathematica's Bessel functions to our new type.
-/
@[sym_to_pexpr]
meta def BesselJ_trans : sym_trans_pexpr_rule :=
⟨"BesselJ", ``(BesselJ)⟩

end

/--
`make_bessel_fn_eq` takes an expression,
simplifies it in Mathematica,
translates it back to Lean,
and axiomatizes the equality of the input and output.

Note that this has nothing specific to do with Bessel functions besides the translation rules used.
-/
meta def make_bessel_fn_eq (e : expr) : tactic (expr × expr) :=
do pe ← mathematica.run_command_on_using
     (λ t, t ++ "// LeanForm // Activate // FullSimplify") e "bessel.m",
   val ← to_expr ``(%%pe : ℝ),
   tp ← to_expr ``(%%e = %%val),
   nm ← (++) `mathematica_axiom <$> new_aux_decl_name,
   l ← local_context,
   l' ← mfilter (kdepends_on tp) l,
   gls ← get_goals,
   m ← mk_meta_var tp,
   set_goals [m],
   generalizes l',
   tp' ← target,
   set_goals gls,
   let dcl := declaration.ax nm [] tp',
   add_decl dcl,
   prf ← mk_const nm,
   return (val, prf)

/--
`approx e q` axiomatizes a numeric approximation of `e` to precision `q`,
where `e` and `q` have type `ℝ`.
-/
meta def approx (e q : expr) : tactic (expr × expr) :=
do pe ← mathematica.run_command_on_2
     (λ e q, "Rationalize[" ++ e ++ " // LeanForm // Activate // N, " ++ q ++ "// LeanForm // Activate]")
     e q,
   val ← to_expr ```(%%pe : ℝ),
   (lb, _) ← to_expr ```(%%val - %%q) >>= norm_num.derive,
   (ub, _) ← to_expr ```(%%val + %%q) >>= norm_num.derive,
   tgt ← to_expr ```(%%lb < %%e ∧ %%e < %%ub),
   nm ← new_aux_decl_name,
   let nm' := `approx_axiom ++ nm,
   let dcl := declaration.ax nm' [] tgt,
   add_decl dcl,
   prf ← mk_const nm',
   return (val, prf)

namespace tactic
namespace interactive

setup_tactic_parser

meta def simplify_target : itactic :=
do (t, _) ← target >>= match_eq,
   (_, prf) ← make_bessel_fn_eq t,
   tactic.apply prf $> ()

meta def approx (e : parse parser.pexpr) (q : parse parser.pexpr) : itactic :=
do e' ← i_to_expr e,
   q' ← i_to_expr q,
   (_, prf) ← _root_.approx e' q',
   n ← get_unused_name `approx none,
   tactic.note n none prf, skip

end interactive
end tactic

variable x : ℝ

/-
This example proves an equality between Bessel functions
by checking in Mathematica that the left hand side simplifies to the right hand side.

Below we can see the axiom generated by Mathematica.
-/
def f1 : x*BesselJ 2 x + x*BesselJ 0 x = 2*BesselJ 1 x :=
by simplify_target

/-
In this example we axiomatically add an approximation to a numeric value to the context.
Below we look at all axioms currently in the environment.
Because this approximation was not actually used in the proof,
it doesn't appear in the list of axioms.
-/

theorem apr : true :=
begin
  approx (100*BesselJ 2 0.52) (0.00001 : ℝ),
  trace_state,
  triv
end

#print axioms


/-
Copyright (c) 2023 Christopher Hoskin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Christopher Hoskin

! This file was ported from Lean 3 source module topology.order.lower_topology
! leanprover-community/mathlib commit 98e83c3d541c77cdb7da20d79611a780ff8e7d90
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Homeomorph
import Mathlib.Topology.Order.Lattice
import Mathlib.Order.Hom.CompleteLattice

/-!
# Lower topology

This file introduces the lower topology on a preorder as the topology generated by the complements
of the closed intervals to infinity.

## Main statements

- `LowerTopology.t0Space` - the lower topology on a partial order is T₀
- `LowerTopology.isTopologicalBasis` - the complements of the upper closures of finite
  subsets form a basis for the lower topology
- `LowerTopology.continuousInf` - the inf map is continuous with respect to the lower topology

## Implementation notes

A type synonym `WithLowerTopology` is introduced and for a preorder `α`, `WithLowerTopology α`
is made an instance of `TopologicalSpace` by the topology generated by the complements of the
closed intervals to infinity.

We define a mixin class `LowerTopology` for the class of types which are both a preorder and a
topology and where the topology is generated by the complements of the closed intervals to infinity.
It is shown that `WithLowerTopology α` is an instance of `LowerTopology`.

## Motivation

The lower topology is used with the `Scott` topology to define the Lawson topology. The restriction
of the lower topology to the spectrum of a complete lattice coincides with the hull-kernel topology.

## References

* [Gierz et al, *A Compendium of Continuous Lattices*][GierzEtAl1980]

## Tags

lower topology, preorder
-/

variable (α β : Type _)

open Set TopologicalSpace

/-- Type synonym for a preorder equipped with the lower topology. -/
def WithLowerTopology := α
#align with_lower_topology WithLowerTopology

variable {α β}

namespace WithLowerTopology

/-- `toLower` is the identity function to the `WithLowerTopology` of a type.  -/
@[match_pattern]
def toLower : α ≃ WithLowerTopology α := Equiv.refl _
#align with_lower_topology.to_lower WithLowerTopology.toLower

/-- `ofLower` is the identity function from the `WithLowerTopology` of a type.  -/
@[match_pattern]
def ofLower : WithLowerTopology α ≃ α := Equiv.refl _
#align with_lower_topology.of_lower WithLowerTopology.ofLower

@[simp]
theorem to_withLowerTopology_symm_eq : (@toLower α).symm = ofLower :=
  rfl
#align with_lower_topology.to_with_lower_topology_symm_eq WithLowerTopology.to_withLowerTopology_symm_eq

@[simp]
theorem of_withLowerTopology_symm_eq : (@ofLower α).symm = toLower :=
  rfl
#align with_lower_topology.of_with_lower_topology_symm_eq WithLowerTopology.of_withLowerTopology_symm_eq

@[simp]
theorem toLower_ofLower (a : WithLowerTopology α) : toLower (ofLower a) = a :=
  rfl
#align with_lower_topology.to_lower_of_lower WithLowerTopology.toLower_ofLower

@[simp]
theorem ofLower_toLower (a : α) : ofLower (toLower a) = a :=
  rfl
#align with_lower_topology.of_lower_to_lower WithLowerTopology.ofLower_toLower

-- porting note: removed @[simp] to make linter happy
theorem toLower_inj {a b : α} : toLower a = toLower b ↔ a = b :=
  Iff.rfl
#align with_lower_topology.to_lower_inj WithLowerTopology.toLower_inj

-- porting note: removed @[simp] to make linter happy
theorem ofLower_inj {a b : WithLowerTopology α} : ofLower a = ofLower b ↔ a = b :=
  Iff.rfl
#align with_lower_topology.of_lower_inj WithLowerTopology.ofLower_inj

/-- A recursor for `WithLowerTopology`. Use as `induction x using WithLowerTopology.rec`. -/
protected def rec {β : WithLowerTopology α → Sort _} (h : ∀ a, β (toLower a)) : ∀ a, β a := fun a =>
  h (ofLower a)
#align with_lower_topology.rec WithLowerTopology.rec

instance [Nonempty α] : Nonempty (WithLowerTopology α) :=
  ‹Nonempty α›

instance [Inhabited α] : Inhabited (WithLowerTopology α) :=
  ‹Inhabited α›

variable [Preorder α]

instance : Preorder (WithLowerTopology α) :=
  ‹Preorder α›

instance : TopologicalSpace (WithLowerTopology α) :=
  generateFrom { s | ∃ a, Ici aᶜ = s }

theorem isOpen_preimage_ofLower (S : Set α) :
    IsOpen (WithLowerTopology.ofLower ⁻¹' S) ↔
      (generateFrom { s : Set α | ∃ a : α, Ici aᶜ = s }).IsOpen S :=
  Iff.rfl
#align with_lower_topology.is_open_preimage_of_lower WithLowerTopology.isOpen_preimage_ofLower

theorem isOpen_def (T : Set (WithLowerTopology α)) :
    IsOpen T ↔
      (generateFrom { s : Set α | ∃ a : α, Ici aᶜ = s }).IsOpen (WithLowerTopology.toLower ⁻¹' T) :=
  Iff.rfl
#align with_lower_topology.is_open_def WithLowerTopology.isOpen_def

end WithLowerTopology

/--
The lower topology is the topology generated by the complements of the closed intervals to infinity.
-/
class LowerTopology (α : Type _) [t : TopologicalSpace α] [Preorder α] : Prop where
  topology_eq_lowerTopology : t = generateFrom { s | ∃ a, Ici aᶜ = s }
#align lower_topology LowerTopology

instance [Preorder α] : LowerTopology (WithLowerTopology α) :=
  ⟨rfl⟩

namespace LowerTopology

/-- The complements of the upper closures of finite sets are a collection of lower sets
which form a basis for the lower topology. -/
def lowerBasis (α : Type _) [Preorder α] :=
  { s : Set α | ∃ t : Set α, t.Finite ∧ (upperClosure t : Set α)ᶜ = s }
#align lower_topology.lower_basis LowerTopology.lowerBasis

section Preorder

variable (α)
variable [Preorder α] [TopologicalSpace α] [LowerTopology α] {s : Set α}

lemma topology_eq : ‹_› = generateFrom { s | ∃ a : α, (Ici a)ᶜ = s } := topology_eq_lowerTopology

variable {α}

/-- If `α` is equipped with the lower topology, then it is homeomorphic to `WithLowerTopology α`.
-/
def withLowerTopologyHomeomorph : WithLowerTopology α ≃ₜ α :=
  WithLowerTopology.ofLower.toHomeomorphOfInducing ⟨by erw [topology_eq α, induced_id]; rfl⟩
#align lower_topology.with_lower_topology_homeomorph LowerTopology.withLowerTopologyHomeomorph

theorem isOpen_iff_generate_Ici_compl : IsOpen s ↔ GenerateOpen { t | ∃ a, Ici aᶜ = t } s := by
  rw [topology_eq α]; rfl
#align lower_topology.is_open_iff_generate_Ici_compl LowerTopology.isOpen_iff_generate_Ici_compl

/-- Left-closed right-infinite intervals [a, ∞) are closed in the lower topology. -/
theorem isClosed_Ici (a : α) : IsClosed (Ici a) :=
  isOpen_compl_iff.1 <| isOpen_iff_generate_Ici_compl.2 <| GenerateOpen.basic _ ⟨a, rfl⟩
#align lower_topology.is_closed_Ici LowerTopology.isClosed_Ici

/-- The upper closure of a finite set is closed in the lower topology. -/
theorem isClosed_upperClosure (h : s.Finite) : IsClosed (upperClosure s : Set α) := by
  simp only [← UpperSet.infᵢ_Ici, UpperSet.coe_infᵢ]
  exact isClosed_bunionᵢ h fun a _ => isClosed_Ici a
#align lower_topology.is_closed_upper_closure LowerTopology.isClosed_upperClosure

/-- Every set open in the lower topology is a lower set. -/
theorem isLowerSet_of_isOpen (h : IsOpen s) : IsLowerSet s := by
  -- porting note: `rw` leaves a shadowed assumption
  replace h := isOpen_iff_generate_Ici_compl.1 h
  induction h
  case basic u h' => obtain ⟨a, rfl⟩ := h'; exact (isUpperSet_Ici a).compl
  case univ => exact isLowerSet_univ
  case inter u v _ _ hu2 hv2 => exact hu2.inter hv2
  case unionₛ _ _ ih => exact isLowerSet_unionₛ ih
#align lower_topology.is_lower_set_of_is_open LowerTopology.isLowerSet_of_isOpen

theorem isUpperSet_of_isClosed (h : IsClosed s) : IsUpperSet s :=
  isLowerSet_compl.1 <| isLowerSet_of_isOpen h.isOpen_compl
#align lower_topology.is_upper_set_of_is_closed LowerTopology.isUpperSet_of_isClosed

/--
The closure of a singleton `{a}` in the lower topology is the left-closed right-infinite interval
[a, ∞).
-/
@[simp]
theorem closure_singleton (a : α) : closure {a} = Ici a :=
  Subset.antisymm ((closure_minimal fun _ h => h.ge) <| isClosed_Ici a) <|
    (isUpperSet_of_isClosed isClosed_closure).Ici_subset <| subset_closure rfl
#align lower_topology.closure_singleton LowerTopology.closure_singleton

protected theorem isTopologicalBasis : IsTopologicalBasis (lowerBasis α) := by
  convert isTopologicalBasis_of_subbasis (topology_eq α)
  simp_rw [lowerBasis, coe_upperClosure, compl_unionᵢ]
  ext s
  constructor
  · rintro ⟨F, hF, rfl⟩
    refine' ⟨(fun a => Ici aᶜ) '' F, ⟨hF.image _, image_subset_iff.2 fun _ _ => ⟨_, rfl⟩⟩, _⟩
    simp only [interₛ_image]
  · rintro ⟨F, ⟨hF, hs⟩, rfl⟩
    haveI := hF.to_subtype
    rw [subset_def, Subtype.forall'] at hs
    choose f hf using hs
    exact ⟨_, finite_range f, by simp_rw [binterᵢ_range, hf, interₛ_eq_interᵢ]⟩
#align lower_topology.is_topological_basis LowerTopology.isTopologicalBasis

/-- A function `f : β → α` with lower topology in the codomain is continuous provided that the
preimage of every interval `Set.Ici a` is a closed set.

TODO: upgrade to an `iff`. -/
lemma continuous_of_Ici [TopologicalSpace β] {f : β → α} (h : ∀ a, IsClosed (f ⁻¹' (Ici a))) :
    Continuous f := by
  obtain rfl := LowerTopology.topology_eq α
  refine continuous_generateFrom ?_
  rintro _ ⟨a, rfl⟩
  exact (h a).isOpen_compl

end Preorder

section PartialOrder

variable [PartialOrder α] [TopologicalSpace α] [LowerTopology α]

-- see Note [lower instance priority]
/-- The lower topology on a partial order is T₀. -/
instance (priority := 90) t0Space : T0Space α :=
  (t0Space_iff_inseparable α).2 fun x y h =>
    Ici_injective <| by simpa only [inseparable_iff_closure_eq, closure_singleton] using h

end PartialOrder

end LowerTopology

instance [Preorder α] [TopologicalSpace α] [LowerTopology α] [OrderBot α] [Preorder β]
    [TopologicalSpace β] [LowerTopology β] [OrderBot β] : LowerTopology (α × β) where
  topology_eq_lowerTopology := by
    refine' le_antisymm (le_generateFrom _) _
    · rintro _ ⟨x, rfl⟩
      exact ((LowerTopology.isClosed_Ici _).prod <| LowerTopology.isClosed_Ici _).isOpen_compl
    rw [(LowerTopology.isTopologicalBasis.prod LowerTopology.isTopologicalBasis).eq_generateFrom,
      le_generateFrom_iff_subset_isOpen, image2_subset_iff]
    rintro _ ⟨s, hs, rfl⟩ _ ⟨t, ht, rfl⟩
    dsimp
    simp_rw [coe_upperClosure, compl_unionᵢ, prod_eq, preimage_interᵢ, preimage_compl]
    -- without `let`, `refine` tries to use the product topology and fails
    let _ : TopologicalSpace (α × β) := generateFrom { s | ∃ a, Ici aᶜ = s }
    refine (isOpen_binterᵢ hs fun a _ => ?_).inter (isOpen_binterᵢ ht fun b _ => ?_)
    · exact GenerateOpen.basic _ ⟨(a, ⊥), by simp [Ici_prod_eq, prod_univ]⟩
    · exact GenerateOpen.basic _ ⟨(⊥, b), by simp [Ici_prod_eq, univ_prod]⟩

section CompleteLattice

variable [CompleteLattice α] [CompleteLattice β] [TopologicalSpace α] [LowerTopology α]
  [TopologicalSpace β] [LowerTopology β]

protected theorem InfₛHom.continuous (f : InfₛHom α β) : Continuous f := by
  refine LowerTopology.continuous_of_Ici fun b => ?_
  convert LowerTopology.isClosed_Ici (infₛ <| f ⁻¹' Ici b)
  refine' Subset.antisymm (fun a => infₛ_le) fun a ha => le_trans _ <|
    OrderHomClass.mono (f : α →o β) ha
  refine' LE.le.trans _ (map_infₛ f _).ge
  simp
#align Inf_hom.continuous InfₛHom.continuous

-- see Note [lower instance priority]
instance (priority := 90) LowerTopology.continuousInf : ContinuousInf α :=
  ⟨(infInfₛHom : InfₛHom (α × α) α).continuous⟩
#align lower_topology.to_has_continuous_inf LowerTopology.continuousInf

end CompleteLattice