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

import data.nat.factorization
import data.set_like.fintype
import group_theory.group_action.conj_act
import group_theory.p_group
import group_theory.noncomm_pi_coprod

/-!
# Sylow theorems

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

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

## Main definitions

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

## Main statements

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

open fintype mul_action subgroup

section infinite_sylow

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

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

variables {p} {G}

namespace sylow

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

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

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

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

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

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

end sylow

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

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

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

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

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

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

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

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

/-- If `H` is a subgroup of `G`, then `fintype (sylow p G)` implies `fintype (sylow p H)`. -/
noncomputable instance (H : subgroup G) [fintype (sylow p G)] : fintype (sylow p H) :=
sylow.fintype_of_injective (show function.injective H.subtype, from subtype.coe_injective)

open_locale pointwise

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

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

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

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

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

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

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

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

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

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

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

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

variables (p) (G)

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

variables {p} {G}

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

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

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

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

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

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

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

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

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

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

end infinite_sylow

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

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

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

namespace sylow

open subgroup submonoid mul_action

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

def fixed_points_mul_left_cosets_equiv_quotient (H : subgroup G) [fintype (H : set G)] :
  mul_action.fixed_points H (G ⧸ H) ≃
  normalizer H ⧸ (subgroup.comap ((normalizer H).subtype : normalizer H →* G) H) :=
@subtype_quotient_equiv_quotient_subtype G (normalizer H : set G) (id _) (id _) (fixed_points _ _)
  (λ a, (@mem_fixed_points_mul_left_cosets_iff_mem_normalizer _ _ _ _inst_2 _).symm)
  (by intros; refl)

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

/-- If `H` is a subgroup of `G` of cardinality `p ^ n`, then the cardinality of the
  normalizer of `H` is congruent mod `p ^ (n + 1)` to the cardinality of `G`.  -/
lemma card_normalizer_modeq_card [fintype G] {p : ℕ} {n : ℕ} [hp : fact p.prime]
  {H : subgroup G} (hH : fintype.card H = p ^ n) :
  card (normalizer H) ≡ card G [MOD p ^ (n + 1)] :=
have subgroup.comap ((normalizer H).subtype : normalizer H →* G) H ≃ H,
  from set.bij_on.equiv (normalizer H).subtype
    ⟨λ _, id, λ _ _ _ _ h, subtype.val_injective h,
      λ x hx, ⟨⟨x, le_normalizer hx⟩, hx, rfl⟩⟩,
begin
  rw [card_eq_card_quotient_mul_card_subgroup H,
      card_eq_card_quotient_mul_card_subgroup
        (subgroup.comap ((normalizer H).subtype : normalizer H →* G) H),
      fintype.card_congr this, hH, pow_succ],
  exact (card_quotient_normalizer_modeq_card_quotient hH).mul_right' _
end

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

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

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

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

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

lemma pow_dvd_card_of_pow_dvd_card [fintype G] {p n : ℕ} [fact p.prime] (P : sylow p G)
  (hdvd : p ^ n ∣ card G) : p ^ n ∣ card P :=
begin
  obtain ⟨Q, hQ⟩ := exists_subgroup_card_pow_prime p hdvd,
  obtain ⟨R, hR⟩ := (is_p_group.of_card hQ).exists_le_sylow,
  obtain ⟨g, rfl⟩ := exists_smul_eq G R P,
  calc p ^ n = card Q : hQ.symm
  ... ∣ card R : card_dvd_of_le hR
  ... = card (g • R) : card_congr (R.equiv_smul g).to_equiv
end

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

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

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

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

section pointwise

open_locale pointwise

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

end pointwise

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

@[simp]
lemma coe_comap_of_ker_is_p_group {p : ℕ} {P : sylow p G}
  {K : Type*} [group K] (ϕ : K →* G) (hϕ : is_p_group p ϕ.ker) (h : P.1 ≤ ϕ.range) :
  ↑(P.comap_of_ker_is_p_group ϕ hϕ h) = subgroup.comap ϕ ↑P := rfl

/-- The preimage of a Sylow subgroup under an injective homomorphism is a Sylow subgroup -/
def comap_of_injective {p : ℕ} (P : sylow p G)
  {K : Type*} [group K] (ϕ : K →* G) (hϕ : function.injective ϕ) (h : P.1 ≤ ϕ.range) :
  sylow p K :=
P.comap_of_ker_is_p_group ϕ (is_p_group.ker_is_p_group_of_injective hϕ) h

@[simp]
lemma coe_comap_of_injective {p : ℕ} {P : sylow p G}
  {K : Type*} [group K] (ϕ : K →* G) (hϕ : function.injective ϕ) (h : P.1 ≤ ϕ.range)  :
  ↑(P.comap_of_injective ϕ hϕ h) = subgroup.comap ϕ ↑P := rfl

/-- A sylow subgroup in G is also a sylow subgroup in a subgroup of G. -/
def subtype {p : ℕ} (P : sylow p G) (N : subgroup G) (h : ↑P ≤ N) : sylow p N :=
P.comap_of_injective N.subtype subtype.coe_injective (by simp [h])

@[simp]
lemma coe_subtype {p : ℕ} {P : sylow p G} {N : subgroup G} {h : P.1 ≤ N} :
  ↑(P.subtype N h) = subgroup.comap N.subtype ↑P := rfl

lemma normal_of_normalizer_normal {p : ℕ} [fact p.prime] [fintype (sylow p G)]
  (P : sylow p G) (hn : (↑P : subgroup G).normalizer.normal) :
  (↑P : subgroup G).normal :=
by rw [←normalizer_eq_top, ←normalizer_sup_eq_top (P.subtype _ le_normalizer), coe_subtype,
  map_comap_eq_self (le_normalizer.trans (ge_of_eq (subtype_range _))), sup_idem]

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

lemma normal_of_all_max_subgroups_normal [fintype G]
  (hnc : ∀ (H : subgroup G), is_coatom H → H.normal)
  {p : ℕ} [fact p.prime] [fintype (sylow p G)] (P : sylow p G) :
  (↑P : subgroup G).normal :=
normalizer_eq_top.mp begin
  rcases eq_top_or_exists_le_coatom ((↑P : subgroup G).normalizer) with heq | ⟨K, hK, hNK⟩,
  { exact heq },
  { haveI := hnc _ hK,
    have hPK := le_trans le_normalizer hNK,
    let P' := P.subtype K hPK,
    exfalso,
    apply hK.1,
    calc K = (↑P : subgroup G).normalizer ⊔ K : by { rw sup_eq_right.mpr, exact hNK }
    ... = (map K.subtype (↑P' : subgroup K)).normalizer ⊔ K : by simp [map_comap_eq_self, hPK]
    ... = ⊤ : normalizer_sup_eq_top P' },
end

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

open_locale big_operators

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

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

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

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

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

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

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

end sylow


-- Copyright 2022-2023 VMware, Inc.
-- SPDX-License-Identifier: BSD-2-Clause

import .zset
import .linear

open zset

variables {A B C: Type}.
variables [decidable_eq A] [decidable_eq B] [decidable_eq C].

lemma distinct_is_set (m: Z[A]) : is_set (distinct m) :=
begin
  intros a, rw elem_mp, simp,
  intros, linarith,
end

lemma distinct_is_bag (m: Z[A]) : is_bag (distinct m) :=
begin
  apply set_is_bag, apply distinct_is_set,
end

lemma distinct_set_id (m: Z[A]) : is_set m → m.distinct = m :=
begin
  intros h,
  ext a, simp,
  cases (is_set_or _).mp h a with hma hma; rw hma,
  { rw if_neg, omega, },
  { rw if_pos, omega, },
end

@[simp]
lemma distinct_set_simp (m: Z[A]) : is_set (distinct m) ↔ true :=
  by { simp, apply distinct_is_set }.

@[simp]
lemma distinct_bag_simp (m: Z[A]) : is_bag (distinct m) ↔ true :=
  by { simp, apply distinct_is_bag }.

lemma distinct_elem {m: Z[A]} {a: A} :
  is_bag m →
  (a ∈ m.distinct ↔ a ∈ m) :=
begin
  intros hpos,
  rw [elem_mp, elem_mp],
  rw distinct_apply,
  have h := hpos a, simp at h,
  split_ifs; simp,
  omega, omega,
end

lemma distinct_pos : fun_positive (@distinct A _) :=
begin
  intros f hp, simp,
end

@[simp]
lemma distinct_0 : distinct (0 : Z[A]) = 0 := rfl.

def query (A B: Type) := operator Z[A] Z[B].

def union (m1 m2: Z[A]) := distinct (m1 + m2).
instance zset_union : has_union Z[A] := ⟨union⟩.
lemma union_eq (m1 m2: Z[A]) : m1 ∪ m2 = union m1 m2 := rfl.

lemma union_apply (m1 m2: Z[A]) (a: A) :
  union m1 m2 a = if 0 < m1 a + m2 a then 1 else 0 :=
begin
  unfold union distinct; simp,
  apply if_congr; try { refl },
  simp, omega,
end

theorem union_ok (s1 s2: finset A) :
  zset.to_set (zset.from_set s1 ∪ zset.from_set s2) = s1 ∪ s2 :=
begin
  ext a,
  rw finset.mem_union,
  rw union_eq, unfold union,
  unfold distinct zset.from_set zset.to_set; simp,
  split_ifs; ring_nf; simp; tauto,
end

theorem union_pos : fun_positive2 (@union A _) :=
begin
  intros m1 m2 h1 h2,
  intros a, simp,
  rw union_apply,
  split_ifs; omega,
end

theorem map_ok (f: A → B) (s: finset A) :
  (zset.map f (zset.from_set s)).support = s.image f :=
begin
  ext b, simp, rw map_is_card,
  simp,
  tauto,
end

theorem map_pos (f: A → B) : fun_positive (zset.map f) :=
begin
  intros m h,
  intros a, simp,
  unfold zset.map, rw flatmap_apply,
  apply map_at_nonneg, assumption,
end

section filter.
  variables (p: A → Prop) [decidable_pred p].

  def filter (m: Z[A]) : Z[A] :=
    dfinsupp.mk (m.support.filter p) (λ a, m a).

  lemma filter_support (m: Z[A]) :
    dfinsupp.support (filter p m) = m.support.filter p :=
  begin
    unfold filter, ext a, simp,
    tauto,
  end

  @[simp]
  lemma filter_apply (m: Z[A]) (a: A) :
    filter p m a = if p a then m a else 0 :=
  begin
    unfold filter, simp,
    split_ifs; tauto,
  end

  theorem filter_ok (s: finset A) :
    zset.to_set (filter p (zset.from_set s)) = s.filter p :=
  begin
    ext a, simp,
    rw [elem_mp, filter_apply],
    simp, tauto,
  end

  lemma filter_linear :
    ∀ (m1 m2: Z[A]), filter p (m1 + m2) = filter p m1 + filter p m2 :=
  begin
    intros,
    ext a, simp,
    split_ifs,
    { simp },
    { finish },
  end

  theorem filter_pos : fun_positive (filter p) :=
  begin
    intros m h, intros a, simp,
    split_ifs,
    { apply h, },
    { linarith, }
  end

  lemma filter_0 : filter p 0 = 0 := rfl.

end filter.

section product.
  def product (m1: Z[A]) (m2: Z[B]) : Z[A × B] :=
    -- the unusual binder is because dfinupp.mk actually supplies a proof that
    -- the input is in the support, which is being ignored here
    dfinsupp.mk
      (finset.product m1.support m2.support)
      (λ ⟨(a, b), _⟩, m1 a * m2 b).

  @[simp]
  lemma product_apply (m1: Z[A]) (m2: Z[B]) (ab: A × B) :
    product m1 m2 ab = m1 ab.1 * m2 ab.2 :=
  begin
    unfold product, cases ab with a b, simp,
    split_ifs,
    { refl },
    { finish },
  end

  theorem product_ok (s1: finset A) (s2: finset B) :
    zset.to_set (product (zset.from_set s1) (zset.from_set s2)) = finset.product s1 s2 :=
  begin
    ext ab, cases ab with a b, simp,
    rw elem_eq, simp,
  end

  theorem product_bilinear : bilinear (@product A B _ _) :=
  begin
    split,
    { intros x1 x2 y,
      ext ab, cases ab with a b, simp,
      omega, },
    { intros x y1 y2,
      ext ab, cases ab with a b, simp,
      omega, }
  end

  theorem product_pos : fun_positive2 (@product A B _ _) :=
  begin
    intros m1 m2 h1 h2,
    intros ab, cases ab with a b, simp,
    have h1a := h1 a,
    have h2a := h2 b,
    simp at h1a h2a,
    nlinarith,
  end

  @[simp]
  lemma product_0 : @product A B _ _ 0 0 = 0 := rfl.

  section equi_join.

  variables (π1: A → C) (π2: B → C).

  def equi_join (m1: Z[A]) (m2: Z[B]) : Z[A × B]
    := filter (λ t, π1 t.1 = π2 t.2) (product m1 m2).

  @[simp]
  lemma equi_join_apply (m1: Z[A]) (m2: Z[B]) (t: A × B) :
    equi_join π1 π2 m1 m2 t = if π1 t.1 = π2 t.2 then m1 t.1 * m2 t.2 else 0 :=
    by { unfold equi_join, simp, }.

  theorem equi_join_bilinear : bilinear (equi_join π1 π2) :=
  begin
    split; intros,
    { unfold equi_join, rw [product_bilinear.1, filter_linear], },
    { unfold equi_join, rw [product_bilinear.2, filter_linear], },
  end

  theorem equi_join_pos : fun_positive2 (equi_join π1 π2) :=
  begin
    intros m1 m2 h1 h2,
    apply filter_pos, apply product_pos; assumption,
  end

  @[simp]
  lemma equi_join_0_l (b: Z[B]) : equi_join π1 π2 0 b = 0 := rfl.

  @[simp]
  lemma equi_join_0_r (a: Z[A]) : equi_join π1 π2 a 0 = 0 :=
  begin
    ext a, simp,
  end

  end equi_join.

end product.

-- TODO: paper says intersection can be defined as a special case of an
-- equijoin, but this construction required projecting A × A → A (where both are
-- equal due to the filter), and it's not obvious that project preserves
-- bilinearity. In any case the direct definition is straightforward.

def intersect (m1 m2: Z[A]) : Z[A] :=
  dfinsupp.mk (m1.support ∩ m2.support) (λ a, m1 a * m2 a).
instance : has_inter (Z[A]) := ⟨intersect⟩.

@[simp]
lemma intersect_apply (m1 m2: Z[A]) (a: A) :
  (m1 ∩ m2) a = m1 a * m2 a :=
begin
  change (m1 ∩ m2) with (intersect m1 m2),
  unfold intersect, simp,
  tauto,
end

@[simp]
lemma intersect_0 : (0: Z[A]) ∩ 0 = 0 := rfl.

@[simp]
lemma intersect_support (m1 m2: Z[A]) :
  (m1 ∩ m2).support = m1.support ∩ m2.support :=
begin
  ext a,
  change (m1 ∩ m2) with (intersect m1 m2),
  unfold intersect, simp,
  tauto,
end

theorem intersect_ok (s1 s2: finset A) :
  zset.to_set (zset.from_set s1 ∩ zset.from_set s2) = s1 ∩ s2 :=
begin
  ext a, simp,
   rw elem_mp, simp,
end

theorem intersect_pos : fun_positive2 ((∩) : Z[A] → Z[A] → Z[A]) :=
begin
  intros m1 m2 hpos1 hpos2,
  intros a, simp,
  have h1 := hpos1 a, have h2 := hpos2 a, simp at h1 h2,
  nlinarith,
end

theorem intersect_bilinear : bilinear ((∩) : Z[A] → Z[A] → Z[A]) :=
begin
  split; introv; ext a; simp; nlinarith,
end

def difference (m1 m2: Z[A]) : Z[A] := distinct (m1 - m2).

theorem difference_ok (s1 s2: finset A) :
  zset.to_set (difference (zset.from_set s1) (zset.from_set s2)) = s1 \ s2 :=
begin
  ext a, simp,
  rw elem_mp, unfold difference, simp,
  split_ifs; try { simp }; clarify,
end

section group_by.

variables {K: Type} [decidable_eq K] (p: A → K).

def group_by : Z[A] → Π₀ (_: K), Z[A] :=
  λ m, dfinsupp.mk (m.support.image p)
    (λ k, dfinsupp.mk (m.support.filter (λ a, p a = k))
      (λ a, if p a = k then m a else 0)).

@[simp]
lemma group_by_apply (m: Z[A]) (k: K) (a: A) :
  group_by p m k a = if p a = k then m a else 0 :=
begin
  unfold group_by, simp,
  split_ifs with hk hp; simp at hk |-,
  { split_ifs; try { tauto }, },
  { tauto, },
  { by_contra, apply (hk a); tauto, },
end

lemma group_by_support (m: Z[A]) (k: K) :
  (group_by p m k).support = m.support.filter (λ a, p a = k) :=
begin
  ext a, simp, tauto,
end

lemma elem_group_by (m: Z[A]) (k: K) (a: A) :
  a ∈ group_by p m k ↔ p a = k ∧ a ∈ m :=
begin
  rw [elem_mp, elem_mp], simp,
end

lemma group_by_linear (m1 m2: Z[A]) :
  group_by p (m1 + m2) = group_by p m1 + group_by p m2 :=
begin
  ext k a, simp,
  split_ifs; refl
end

end group_by.

/- A few properties about [distinct] -/

@[simp]
lemma ite_ite {A: Type} {c1: Prop} [decidable c1] {c2: Prop} [decidable c2] (x z: A) :
  ite c1 (ite c2 x z) z = ite (c1 ∧ c2) x z :=
begin
  split_ifs; clarify,
end

-- this doesn't require is_bag i
lemma filter_distinct_comm (p: A → Prop) [decidable_pred p] (i: Z[A]) :
  filter p (distinct i) = distinct (filter p i) :=
begin
  ext a, simp,
  apply if_congr; try { refl },
  split_ifs; clarify,
end

theorem product_distinct_comm (i1: Z[A]) (i2: Z[B]) :
  is_bag i1 → is_bag i2 →
  product (distinct i1) (distinct i2) = distinct (product i1 i2) :=
begin
  intros hpos1 hpos2,
  ext ab, cases ab with a b, simp,
  have h1 := hpos1 a, have h2 := hpos2 b,
  simp at h1 h2,
  apply if_congr; try { refl },
  tauto { closer := `[nlinarith] },
end

theorem join_distinct_comm (π1: A → C) (π2: B → C) (i1: Z[A]) (i2: Z[B]) :
  is_bag i1 → is_bag i2 →
  equi_join π1 π2 (distinct i1) (distinct i2) = distinct (equi_join π1 π2 i1 i2) :=
begin
  intros hpos1 hpos2,
  unfold equi_join,
  rw <- filter_distinct_comm,
  { rw<- product_distinct_comm; assumption },
end

theorem intersect_distinct_comm (i1 i2: Z[A]) :
  is_bag i1 → is_bag i2 →
  distinct i1 ∩ distinct i2 = distinct (i1 ∩ i2) :=
begin
  intros hpos1 hpos2,
  ext a, simp,
  apply if_congr; try { refl },
  have h1 := hpos1 a, have h2 := hpos2 a, simp at h1 h2,
  tauto { closer := `[nlinarith] },
end

private lemma map_at_distinct_none (f: A → B) (i: Z[A]) (b: B) :
  is_bag i →
  (∀ a, a ∈ i → f a ≠ b) →
  flatmap_at (λ a, {f a}) i.distinct b = 0 :=
begin
  intros hpos h,
  unfold flatmap_at,
  rw finset.sum_eq_zero,
  intros x ix_pos, simp at ix_pos,
  simp, intros hfx,
  suffices hne : f x ≠ b, { tauto },
  apply h, rw elem_mp, linarith,
end

theorem map_inj_distinct_comm (f: A → B) [f_inj: function.injective f] (i: Z[A]) :
  is_bag i →
  distinct (zset.map f i) = zset.map f (distinct i) :=
begin
  intros hpos,
  ext b, simp,
  unfold zset.map,
  rw [flatmap_apply, flatmap_apply],
  split_ifs with h h; rw (map_at_pos _ _ _ hpos) at h,
  { cases h with a h, cases h with hel hf,
    have ha := hpos a, simp at ha,
    rw flatmap_map_at,
    -- split sum into a and everything else; intuition is that "everything else"
    -- can't include any matching elements because f is injective
    rw<- (@finset.sum_erase_add _ _ _ _ _ _ a),
    { rw finset.sum_eq_zero,
      { rw distinct_apply,
        rw elem_mp at hel,
        rw if_pos, swap, assumption,
        rw if_pos, swap, omega,
        refl, },
      introv hel_erase,
      split_ifs, swap, refl,
      simp at hel_erase |-,
      suffices hxa : (x = a), { exfalso, tauto, },
      apply f_inj, cc,
    },
    simp, { rw elem_mp at hel, omega },
  },
  { push_neg at h,
    rw map_at_distinct_none,
    assumption,
    assumption,
  }
end

@[simp]
lemma distinct_idem (i: Z[A]) :
  distinct (distinct i) = distinct i :=
begin
  ext a, simp,
  split_ifs; refl <|> linarith,
end

theorem filter_distinct_dedup (p: A → Prop) [decidable_pred p] (i: Z[A]) :
  distinct (filter p (distinct i)) = distinct (filter p i) :=
begin
  rw [filter_distinct_comm, distinct_idem],
end

theorem map_distinct_dedup (f: A → B) (i: Z[A]) :
  is_bag i →
  distinct (zset.map f (distinct i)) = distinct (zset.map f i) :=
begin
  intros hpos,
  ext b, simp,
  apply if_congr; try { refl },
  unfold zset.map,
  rw [flatmap_apply, flatmap_apply],
  rw [map_at_pos, map_at_pos],
  { conv_lhs {
      congr,
      funext,
      rw (distinct_elem hpos),
      skip,
    },
   },
  { assumption, },
  { simp, },
end

theorem add_distinct_dedup (i1 i2: Z[A]) :
  is_bag i1 → is_bag i2 →
  distinct (i1.distinct + i2.distinct) = distinct (i1 + i2) :=
begin
  intros hpos1 hpos2,
  ext a, simp,
  have h1 := hpos1 a, have h2 := hpos2 a, simp at h1 h2,
  split_ifs; refl <|> linarith,
end

theorem product_distinct_dedup (i1: Z[A]) (i2: Z[B]) :
  is_bag i1 → is_bag i2 →
  distinct (product (distinct i1) (distinct i2)) = distinct (product i1 i2) :=
begin
  intros hpos1 hpos2,
  rw [product_distinct_comm, distinct_idem];
  assumption
end

theorem join_distinct_dedup (π1: A → C) (π2: B → C) (i1: Z[A]) (i2: Z[B]) :
  is_bag i1 → is_bag i2 →
  distinct (equi_join π1 π2 (distinct i1) (distinct i2)) = distinct (equi_join π1 π2 i1 i2) :=
begin
  intros hpos1 hpos2,
  rw [join_distinct_comm, distinct_idem];
  assumption,
end

theorem intersect_distinct_dedup (i1 i2: Z[A]) :
  is_bag i1 → is_bag i2 →
  distinct (distinct i1 ∩ distinct i2) = distinct (i1 ∩ i2) :=
begin
  intros hpos1 hpos2,
  rw [intersect_distinct_comm, distinct_idem];
  assumption,
end


/-
Copyright (c) 2020 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import algebra.associated
import algebra.big_operators.basic
/-!
# Prime elements in rings
This file contains lemmas about prime elements of commutative rings.
-/

section cancel_comm_monoid_with_zero

variables {R : Type*} [cancel_comm_monoid_with_zero R]
open finset

open_locale big_operators

/-- If `x * y = a * ∏ i in s, p i` where `p i` is always prime, then
  `x` and `y` can both be written as a divisor of `a` multiplied by
  a product over a subset of `s`  -/
lemma mul_eq_mul_prime_prod {α : Type*} [decidable_eq α] {x y a : R} {s : finset α}
  {p : α → R} (hp : ∀ i ∈ s, prime (p i)) (hx : x * y = a * ∏ i in s, p i) :
  ∃ (t u : finset α) (b c : R),
      t ∪ u = s
    ∧ disjoint t u
    ∧ a = b * c
    ∧ x = b * ∏ i in t, p i
    ∧ y = c * ∏ i in u, p i :=
begin
  induction s using finset.induction with i s his ih generalizing x y a,
  { exact ⟨∅, ∅, x, y, by simp [hx]⟩ },
  { rw [prod_insert his, ← mul_assoc] at hx,
    have hpi : prime (p i), { exact hp i (mem_insert_self _ _) },
    rcases ih (λ i hi, hp i (mem_insert_of_mem hi)) hx with
      ⟨t, u, b, c, htus, htu, hbc, rfl, rfl⟩,
    have hit : i ∉ t, from λ hit, his (htus ▸ mem_union_left _ hit),
    have hiu : i ∉ u, from λ hiu, his (htus ▸ mem_union_right _ hiu),
    obtain ⟨d, rfl⟩ | ⟨d, rfl⟩ : p i ∣ b ∨ p i ∣ c,
      from hpi.dvd_or_dvd ⟨a, by rw [← hbc, mul_comm]⟩,
    { rw [mul_assoc, mul_comm a, mul_right_inj' hpi.ne_zero] at hbc,
      exact ⟨insert i t, u, d, c, by rw [insert_union, htus],
        disjoint_insert_left.2 ⟨hiu, htu⟩,
          by simp [hbc, prod_insert hit, mul_assoc, mul_comm, mul_left_comm]⟩ },
    { rw [← mul_assoc, mul_right_comm b, mul_left_inj' hpi.ne_zero] at hbc,
      exact ⟨t, insert i u, b, d, by rw [union_insert, htus],
        disjoint_insert_right.2 ⟨hit, htu⟩,
          by simp [← hbc, prod_insert hiu, mul_assoc, mul_comm, mul_left_comm]⟩ } }
end

/-- If ` x * y = a * p ^ n` where `p` is prime, then `x` and `y` can both be written
  as the product of a power of `p` and a divisor of `a`. -/
lemma mul_eq_mul_prime_pow {x y a p : R} {n : ℕ} (hp : prime p) (hx : x * y = a * p ^ n) :
  ∃ (i j : ℕ) (b c : R),
    i + j = n
  ∧ a = b * c
  ∧ x = b * p ^ i
  ∧ y = c * p ^ j :=
begin
  rcases mul_eq_mul_prime_prod (λ _ _, hp)
    (show x * y = a * (range n).prod (λ _, p), by simpa) with
    ⟨t, u, b, c, htus, htu, rfl, rfl, rfl⟩,
  exact ⟨t.card, u.card, b, c, by rw [← card_disjoint_union htu, htus, card_range], by simp⟩,
end

end cancel_comm_monoid_with_zero

section comm_ring

variables {α : Type*} [comm_ring α]

lemma prime.neg {p : α} (hp : prime p) : prime (-p) :=
begin
  obtain ⟨h1, h2, h3⟩ := hp,
  exact ⟨neg_ne_zero.mpr h1, by rwa is_unit.neg_iff, by simpa [neg_dvd] using h3⟩
end

lemma prime.abs [linear_order α] {p : α} (hp : prime p) : prime (abs p) :=
begin
  obtain h|h := abs_choice p; rw h,
  { exact hp },
  { exact hp.neg }
end

end comm_ring


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Sean Leather

Functions on lists of sigma types.
-/
import data.list.perm
import data.list.range
import data.sigma

universes u v

namespace list
variables {α : Type u} {β : α → Type v}

/- keys -/

/-- List of keys from a list of key-value pairs -/
def keys : list (sigma β) → list α :=
map sigma.fst

@[simp] theorem keys_nil : @keys α β [] = [] :=
rfl

@[simp] theorem keys_cons {s} {l : list (sigma β)} : (s :: l).keys = s.1 :: l.keys :=
rfl

theorem mem_keys_of_mem {s : sigma β} {l : list (sigma β)} : s ∈ l → s.1 ∈ l.keys :=
mem_map_of_mem sigma.fst

theorem exists_of_mem_keys {a} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a), sigma.mk a b ∈ l :=
let ⟨⟨a', b'⟩, m, e⟩ := exists_of_mem_map h in
eq.rec_on e (exists.intro b' m)

theorem mem_keys {a} {l : list (sigma β)} : a ∈ l.keys ↔ ∃ (b : β a), sigma.mk a b ∈ l :=
⟨exists_of_mem_keys, λ ⟨b, h⟩, mem_keys_of_mem h⟩

theorem not_mem_keys {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ b : β a, sigma.mk a b ∉ l :=
(not_iff_not_of_iff mem_keys).trans not_exists

theorem not_eq_key {a} {l : list (sigma β)} : a ∉ l.keys ↔ ∀ s : sigma β, s ∈ l → a ≠ s.1 :=
iff.intro
  (λ h₁ s h₂ e, absurd (mem_keys_of_mem h₂) (by rwa e at h₁))
  (λ f h₁, let ⟨b, h₂⟩ := exists_of_mem_keys h₁ in f _ h₂ rfl)

/- nodupkeys -/

def nodupkeys (l : list (sigma β)) : Prop :=
l.keys.nodup

theorem nodupkeys_iff_pairwise {l} : nodupkeys l ↔
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l := pairwise_map _

theorem nodupkeys.pairwise_ne {l} (h : nodupkeys l) :
  pairwise (λ s s' : sigma β, s.1 ≠ s'.1) l :=
nodupkeys_iff_pairwise.1 h

@[simp] theorem nodupkeys_nil : @nodupkeys α β [] := pairwise.nil

@[simp] theorem nodupkeys_cons {s : sigma β} {l : list (sigma β)} :
  nodupkeys (s::l) ↔ s.1 ∉ l.keys ∧ nodupkeys l :=
by simp [keys, nodupkeys]

theorem nodupkeys.eq_of_fst_eq {l : list (sigma β)}
  (nd : nodupkeys l) {s s' : sigma β} (h : s ∈ l) (h' : s' ∈ l) :
  s.1 = s'.1 → s = s' :=
@forall_of_forall_of_pairwise _
  (λ s s' : sigma β, s.1 = s'.1 → s = s')
  (λ s s' H h, (H h.symm).symm) _ (λ x h _, rfl)
  ((nodupkeys_iff_pairwise.1 nd).imp (λ s s' h h', (h h').elim)) _ h _ h'

theorem nodupkeys.eq_of_mk_mem {a : α} {b b' : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) (h' : sigma.mk a b' ∈ l) : b = b' :=
by cases nd.eq_of_fst_eq h h' rfl; refl

theorem nodupkeys_singleton (s : sigma β) : nodupkeys [s] := nodup_singleton _

theorem nodupkeys_of_sublist {l₁ l₂ : list (sigma β)} (h : l₁ <+ l₂) :
  nodupkeys l₂ → nodupkeys l₁ :=
nodup_of_sublist (h.map _)

theorem nodup_of_nodupkeys {l : list (sigma β)} : nodupkeys l → nodup l :=
nodup_of_nodup_map _

theorem perm_nodupkeys {l₁ l₂ : list (sigma β)} (h : l₁ ~ l₂) : nodupkeys l₁ ↔ nodupkeys l₂ :=
(h.map _).nodup_iff

theorem nodupkeys_join {L : list (list (sigma β))} :
  nodupkeys (join L) ↔ (∀ l ∈ L, nodupkeys l) ∧ pairwise disjoint (L.map keys) :=
begin
  rw [nodupkeys_iff_pairwise, pairwise_join, pairwise_map],
  refine and_congr (ball_congr $ λ l h, by simp [nodupkeys_iff_pairwise]) _,
  apply iff_of_eq, congr' with l₁ l₂,
  simp [keys, disjoint_iff_ne]
end

theorem nodup_enum_map_fst (l : list α) : (l.enum.map prod.fst).nodup :=
by simp [list.nodup_range]

lemma mem_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodup) (nd₁ : l₁.nodup)
  (h : ∀ x, x ∈ l₀ ↔ x ∈ l₁) : l₀ ~ l₁ :=
begin
  induction l₀ with x xs generalizing l₁; cases l₁ with y ys,
  { constructor },
  iterate 2
  { specialize h x <|> specialize h y, simp at h,
    cases h },
  simp at nd₀ nd₁, classical,
  cases nd₀, cases nd₁,
  by_cases h' : x = y,
  { subst y, constructor, apply l₀_ih ‹ _ › ‹ nodup ys ›,
    intro a, specialize h a, simp at h,
    by_cases h' : a = x,
    { subst a, rw ← not_iff_not, split; intro; assumption },
    { simp [h'] at h, exact h } },
  { transitivity x :: y :: ys.erase x,
    { constructor, apply l₀_ih ‹ _ ›,
      { simp, split, { intro, apply nd₁_left, apply mem_of_mem_erase ‹_› },
        apply nodup_erase_of_nodup; assumption },
      { intro a, specialize h a, simp at h,
        by_cases h' : a = x,
        { subst a, rw ← not_iff_not, split; intro, simp [mem_erase_of_nodup,*], assumption },
        { simp [h'] at h, simp [h], apply or_congr, refl,
          simp [mem_erase_of_ne,*] } } },
    transitivity y :: x :: ys.erase x,
    { constructor },
    { constructor, symmetry, apply perm_cons_erase,
      specialize h x, simp [h'] at h, exact h } }
end

variables [decidable_eq α]

/- lookup -/

/-- `lookup a l` is the first value in `l` corresponding to the key `a`,
  or `none` if no such element exists. -/
def lookup (a : α) : list (sigma β) → option (β a)
| []             := none
| (⟨a', b⟩ :: l) := if h : a' = a then some (eq.rec_on h b) else lookup l

@[simp] theorem lookup_nil (a : α) : lookup a [] = @none (β a) := rfl

@[simp] theorem lookup_cons_eq (l) (a : α) (b : β a) : lookup a (⟨a, b⟩::l) = some b :=
dif_pos rfl

@[simp] theorem lookup_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup a (s::l) = lookup a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_is_some {a : α} : ∀ {l : list (sigma β)},
  (lookup a l).is_some ↔ a ∈ l.keys
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_is_some] },
end

theorem lookup_eq_none {a : α} {l : list (sigma β)} :
  lookup a l = none ↔ a ∉ l.keys :=
by simp [← lookup_is_some, option.is_none_iff_eq_none]

theorem of_mem_lookup
  {a : α} {b : β a} : ∀ {l : list (sigma β)}, b ∈ lookup a l → sigma.mk a b ∈ l
| (⟨a', b'⟩ :: l) H := begin
  by_cases h : a = a',
  { subst a', simp at H, simp [H] },
  { simp [h] at H, exact or.inr (of_mem_lookup H) }
end

theorem mem_lookup {a} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys)
  (h : sigma.mk a b ∈ l) : b ∈ lookup a l :=
begin
  cases option.is_some_iff_exists.mp (lookup_is_some.mpr (mem_keys_of_mem h)) with b' h',
  cases nd.eq_of_mk_mem h (of_mem_lookup h'),
  exact h'
end

theorem map_lookup_eq_find (a : α) : ∀ l : list (sigma β),
  (lookup a l).map (sigma.mk a) = find (λ s, a = s.1) l
| [] := rfl
| (⟨a', b'⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, map_lookup_eq_find] }
end

theorem mem_lookup_iff {a : α} {b : β a} {l : list (sigma β)} (nd : l.nodupkeys) :
  b ∈ lookup a l ↔ sigma.mk a b ∈ l :=
⟨of_mem_lookup, mem_lookup nd⟩

theorem perm_lookup (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup a l₁ = lookup a l₂ :=
by ext b; simp [mem_lookup_iff, nd₁, nd₂]; exact p.mem_iff

lemma lookup_ext {l₀ l₁ : list (sigma β)}
  (nd₀ : l₀.nodupkeys) (nd₁ : l₁.nodupkeys)
  (h : ∀ x y, y ∈ l₀.lookup x ↔ y ∈ l₁.lookup x) : l₀ ~ l₁ :=
mem_ext (nodup_of_nodupkeys nd₀) (nodup_of_nodupkeys nd₁)
  (λ ⟨a,b⟩, by rw [← mem_lookup_iff, ← mem_lookup_iff, h]; assumption)

/- lookup_all -/

/-- `lookup_all a l` is the list of all values in `l` corresponding to the key `a`. -/
def lookup_all (a : α) : list (sigma β) → list (β a)
| []             := []
| (⟨a', b⟩ :: l) := if h : a' = a then eq.rec_on h b :: lookup_all l else lookup_all l

@[simp]

@[simp] theorem lookup_all_cons_eq (l) (a : α) (b : β a) :
  lookup_all a (⟨a, b⟩::l) = b :: lookup_all a l :=
dif_pos rfl

@[simp] theorem lookup_all_cons_ne (l) {a} :
  ∀ s : sigma β, a ≠ s.1 → lookup_all a (s::l) = lookup_all a l
| ⟨a', b⟩ h := dif_neg h.symm

theorem lookup_all_eq_nil {a : α} : ∀ {l : list (sigma β)},
  lookup_all a l = [] ↔ ∀ b : β a, sigma.mk a b ∉ l
| []             := by simp
| (⟨a', b⟩ :: l) := begin
  by_cases h : a = a',
  { subst a', simp },
  { simp [h, lookup_all_eq_nil] },
end

theorem head_lookup_all (a : α) : ∀ l : list (sigma β),
  head' (lookup_all a l) = lookup a l
| []             := by simp
| (⟨a', b⟩ :: l) := by by_cases h : a = a'; [{subst h, simp}, simp *]

theorem mem_lookup_all {a : α} {b : β a} :
  ∀ {l : list (sigma β)}, b ∈ lookup_all a l ↔ sigma.mk a b ∈ l
| []              := by simp
| (⟨a', b'⟩ :: l) := by by_cases h : a = a'; [{subst h, simp *}, simp *]

theorem lookup_all_sublist (a : α) :
  ∀ l : list (sigma β), (lookup_all a l).map (sigma.mk a) <+ l
| []              := by simp
| (⟨a', b'⟩ :: l) := begin
    by_cases h : a = a',
    { subst h, simp, exact (lookup_all_sublist l).cons2 _ _ _ },
    { simp [h], exact (lookup_all_sublist l).cons _ _ _ }
  end

theorem lookup_all_length_le_one (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  length (lookup_all a l) ≤ 1 :=
by have := nodup_of_sublist ((lookup_all_sublist a l).map _) h;
   rw map_map at this; rwa [← nodup_repeat, ← map_const _ a]

theorem lookup_all_eq_lookup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  lookup_all a l = (lookup a l).to_list :=
begin
  rw ← head_lookup_all,
  have := lookup_all_length_le_one a h, revert this,
  rcases lookup_all a l with _|⟨b, _|⟨c, l⟩⟩; intro; try {refl},
  exact absurd this dec_trivial
end

theorem lookup_all_nodup (a : α) {l : list (sigma β)} (h : l.nodupkeys) :
  (lookup_all a l).nodup :=
by rw lookup_all_eq_lookup a h; apply option.to_list_nodup

theorem perm_lookup_all (a : α) {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) (p : l₁ ~ l₂) : lookup_all a l₁ = lookup_all a l₂ :=
by simp [lookup_all_eq_lookup, nd₁, nd₂, perm_lookup a nd₁ nd₂ p]

/- kreplace -/

def kreplace (a : α) (b : β a) : list (sigma β) → list (sigma β) :=
lookmap $ λ s, if h : a = s.1 then some ⟨a, b⟩ else none

theorem kreplace_of_forall_not (a : α) (b : β a) {l : list (sigma β)}
  (H : ∀ b : β a, sigma.mk a b ∉ l) : kreplace a b l = l :=
lookmap_of_forall_not _ $ begin
  rintro ⟨a', b'⟩ h, dsimp, split_ifs,
  { subst a', exact H _ h }, {refl}
end

theorem kreplace_self {a : α} {b : β a} {l : list (sigma β)}
  (nd : nodupkeys l) (h : sigma.mk a b ∈ l) : kreplace a b l = l :=
begin
  refine (lookmap_congr _).trans
    (lookmap_id' (option.guard (λ s, a = s.1)) _ _),
  { rintro ⟨a', b'⟩ h', dsimp [option.guard], split_ifs,
    { subst a', exact ⟨rfl, heq_of_eq $ nd.eq_of_mk_mem h h'⟩ },
    { refl } },
  { rintro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩, dsimp [option.guard], split_ifs,
    { subst a₁, rintro ⟨⟩, simp }, { rintro ⟨⟩ } },
end

theorem keys_kreplace (a : α) (b : β a) : ∀ l : list (sigma β),
  (kreplace a b l).keys = l.keys :=
lookmap_map_eq _ _ $ by rintro ⟨a₁, b₂⟩ ⟨a₂, b₂⟩;
  dsimp; split_ifs; simp [h] {contextual := tt}

theorem kreplace_nodupkeys (a : α) (b : β a) {l : list (sigma β)} :
  (kreplace a b l).nodupkeys ↔ l.nodupkeys :=
by simp [nodupkeys, keys_kreplace]

theorem perm.kreplace {a : α} {b : β a} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ →
  kreplace a b l₁ ~ kreplace a b l₂ :=
perm_lookmap _ $ begin
  refine nd.pairwise_ne.imp _,
  intros x y h z h₁ w h₂,
  split_ifs at h₁ h₂; cases h₁; cases h₂,
  exact (h (h_2.symm.trans h_1)).elim
end

/- kerase -/

/-- Remove the first pair with the key `a`. -/
def kerase (a : α) : list (sigma β) → list (sigma β) :=
erasep $ λ s, a = s.1

@[simp] theorem kerase_nil {a} : @kerase _ β _ a [] = [] :=
rfl

@[simp, priority 990]
theorem kerase_cons_eq {a} {s : sigma β} {l : list (sigma β)} (h : a = s.1) :
  kerase a (s :: l) = l :=
by simp [kerase, h]

@[simp, priority 990]
theorem kerase_cons_ne {a} {s : sigma β} {l : list (sigma β)} (h : a ≠ s.1) :
  kerase a (s :: l) = s :: kerase a l :=
by simp [kerase, h]

@[simp, priority 980]
theorem kerase_of_not_mem_keys {a} {l : list (sigma β)} (h : a ∉ l.keys) :
  kerase a l = l :=
by induction l with _ _ ih;
   [refl, { simp [not_or_distrib] at h, simp [h.1, ih h.2] }]

theorem kerase_sublist (a : α) (l : list (sigma β)) : kerase a l <+ l :=
erasep_sublist _

theorem kerase_keys_subset (a) (l : list (sigma β)) :
  (kerase a l).keys ⊆ l.keys :=
((kerase_sublist a l).map _).subset

theorem mem_keys_of_mem_keys_kerase {a₁ a₂} {l : list (sigma β)} :
  a₁ ∈ (kerase a₂ l).keys → a₁ ∈ l.keys :=
@kerase_keys_subset _ _ _ _ _ _

theorem exists_of_kerase {a : α} {l : list (sigma β)} (h : a ∈ l.keys) :
  ∃ (b : β a) (l₁ l₂ : list (sigma β)),
    a ∉ l₁.keys ∧
    l = l₁ ++ ⟨a, b⟩ :: l₂ ∧
    kerase a l = l₁ ++ l₂ :=
begin
  induction l,
  case list.nil { cases h },
  case list.cons : hd tl ih {
    by_cases e : a = hd.1,
    { subst e,
      exact ⟨hd.2, [], tl, by simp, by cases hd; refl, by simp⟩ },
    { simp at h,
      cases h,
      case or.inl : h { exact absurd h e },
      case or.inr : h {
        rcases ih h with ⟨b, tl₁, tl₂, h₁, h₂, h₃⟩,
        exact ⟨b, hd :: tl₁, tl₂, not_mem_cons_of_ne_of_not_mem e h₁,
               by rw h₂; refl, by simp [e, h₃]⟩ } } }
end

@[simp, priority 990]
theorem mem_keys_kerase_of_ne {a₁ a₂} {l : list (sigma β)} (h : a₁ ≠ a₂) :
  a₁ ∈ (kerase a₂ l).keys ↔ a₁ ∈ l.keys :=
iff.intro mem_keys_of_mem_keys_kerase $ λ p,
  if q : a₂ ∈ l.keys then
    match l, kerase a₂ l, exists_of_kerase q, p with
    | _, _, ⟨_, _, _, _, rfl, rfl⟩, p := by simpa [keys, h] using p
    end
  else
    by simp [q, p]

theorem keys_kerase {a} {l : list (sigma β)} : (kerase a l).keys = l.keys.erase a :=
by rw [keys, kerase, ←erasep_map sigma.fst l, erase_eq_erasep]

theorem kerase_kerase {a a'} {l : list (sigma β)} :
  (kerase a' l).kerase a = (kerase a l).kerase a' :=
begin
  by_cases a = a',
  { subst a' },
  induction l with x xs, { refl },
  { by_cases a' = x.1,
    { subst a', simp [kerase_cons_ne h,kerase_cons_eq rfl] },
    by_cases h' : a = x.1,
    { subst a, simp [kerase_cons_eq rfl,kerase_cons_ne (ne.symm h)] },
    { simp [kerase_cons_ne,*] } }
end

theorem kerase_nodupkeys (a : α) {l : list (sigma β)} : nodupkeys l → (kerase a l).nodupkeys :=
nodupkeys_of_sublist $ kerase_sublist _ _

theorem perm.kerase {a : α} {l₁ l₂ : list (sigma β)}
  (nd : l₁.nodupkeys) : l₁ ~ l₂ → kerase a l₁ ~ kerase a l₂ :=
perm.erasep _ $ (nodupkeys_iff_pairwise.1 nd).imp $
by rintro x y h rfl; exact h

@[simp] theorem not_mem_keys_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  a ∉ (kerase a l).keys :=
begin
  induction l,
  case list.nil { simp },
  case list.cons : hd tl ih {
    simp at nd,
    by_cases h : a = hd.1,
    { subst h, simp [nd.1] },
    { simp [h, ih nd.2] } }
end

@[simp] theorem lookup_kerase (a) {l : list (sigma β)} (nd : l.nodupkeys) :
  lookup a (kerase a l) = none :=
lookup_eq_none.mpr (not_mem_keys_kerase a nd)

@[simp] theorem lookup_kerase_ne {a a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kerase a' l) = lookup a l :=
begin
  induction l,
  case list.nil { refl },
  case list.cons : hd tl ih {
    cases hd with ah bh,
    by_cases h₁ : a = ah; by_cases h₂ : a' = ah,
    { substs h₁ h₂, cases ne.irrefl h },
    { subst h₁, simp [h₂] },
    { subst h₂, simp [h] },
    { simp [h₁, h₂, ih] }
  }
end

theorem kerase_append_left {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∈ l₁.keys → kerase a (l₁ ++ l₂) = kerase a l₁ ++ l₂
| []        _  h  := by cases h
| (s :: l₁) l₂ h₁ :=
  if h₂ : a = s.1 then
    by simp [h₂]
  else
    by simp at h₁;
       cases h₁;
       [exact absurd h₁ h₂, simp [h₂, kerase_append_left h₁]]

theorem kerase_append_right {a} : ∀ {l₁ l₂ : list (sigma β)},
  a ∉ l₁.keys → kerase a (l₁ ++ l₂) = l₁ ++ kerase a l₂
| []        _  h := rfl
| (_ :: l₁) l₂ h := by simp [not_or_distrib] at h;
                       simp [h.1, kerase_append_right h.2]

theorem kerase_comm (a₁ a₂) (l : list (sigma β)) :
  kerase a₂ (kerase a₁ l) = kerase a₁ (kerase a₂ l) :=
if h : a₁ = a₂ then
  by simp [h]
else if ha₁ : a₁ ∈ l.keys then
  if ha₂ : a₂ ∈ l.keys then
    match l, kerase a₁ l, exists_of_kerase ha₁, ha₂ with
    | _, _, ⟨b₁, l₁, l₂, a₁_nin_l₁, rfl, rfl⟩, a₂_in_l₁_app_l₂ :=
      if h' : a₂ ∈ l₁.keys then
        by simp [kerase_append_left h',
                 kerase_append_right (mt (mem_keys_kerase_of_ne h).mp a₁_nin_l₁)]
      else
        by simp [kerase_append_right h', kerase_append_right a₁_nin_l₁,
                 @kerase_cons_ne _ _ _ a₂ ⟨a₁, b₁⟩ _ (ne.symm h)]
    end
  else
    by simp [ha₂, mt mem_keys_of_mem_keys_kerase ha₂]
else
  by simp [ha₁, mt mem_keys_of_mem_keys_kerase ha₁]

lemma sizeof_kerase {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)] (x : α)
  (xs : list (sigma β)) :
  sizeof (list.kerase x xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with y ys,
  { simp },
  { by_cases x = y.1; simp [*, list.sizeof] },
end

/- kinsert -/

/-- Insert the pair `⟨a, b⟩` and erase the first pair with the key `a`. -/
def kinsert (a : α) (b : β a) (l : list (sigma β)) : list (sigma β) :=
⟨a, b⟩ :: kerase a l

@[simp] theorem kinsert_def {a} {b : β a} {l : list (sigma β)} :
  kinsert a b l = ⟨a, b⟩ :: kerase a l := rfl

theorem mem_keys_kinsert {a a'} {b' : β a'} {l : list (sigma β)} :
  a ∈ (kinsert a' b' l).keys ↔ a = a' ∨ a ∈ l.keys :=
by by_cases h : a = a'; simp [h]

theorem kinsert_nodupkeys (a) (b : β a) {l : list (sigma β)} (nd : l.nodupkeys) :
  (kinsert a b l).nodupkeys :=
nodupkeys_cons.mpr ⟨not_mem_keys_kerase a nd, kerase_nodupkeys a nd⟩

theorem perm.kinsert {a} {b : β a} {l₁ l₂ : list (sigma β)} (nd₁ : l₁.nodupkeys)
  (p : l₁ ~ l₂) : kinsert a b l₁ ~ kinsert a b l₂ :=
(p.kerase nd₁).cons _

theorem lookup_kinsert {a} {b : β a} (l : list (sigma β)) :
  lookup a (kinsert a b l) = some b :=
by simp only [kinsert, lookup_cons_eq]

theorem lookup_kinsert_ne {a a'} {b' : β a'} {l : list (sigma β)} (h : a ≠ a') :
  lookup a (kinsert a' b' l) = lookup a l :=
by simp [h]

/- kextract -/

def kextract (a : α) : list (sigma β) → option (β a) × list (sigma β)
| []     := (none, [])
| (s::l) := if h : s.1 = a then (some (eq.rec_on h s.2), l) else
  let (b', l') := kextract l in (b', s :: l')

@[simp] theorem kextract_eq_lookup_kerase (a : α) :
  ∀ l : list (sigma β), kextract a l = (lookup a l, kerase a l)
| []     := rfl
| (⟨a', b⟩::l) := begin
    simp [kextract], dsimp, split_ifs,
    { subst a', simp [kerase] },
    { simp [kextract, ne.symm h, kextract_eq_lookup_kerase l, kerase] }
  end

/- erase_dupkeys -/

/-- Remove entries with duplicate keys from `l : list (sigma β)`. -/
def erase_dupkeys : list (sigma β) → list (sigma β) :=
list.foldr (λ x, kinsert x.1 x.2) []

lemma erase_dupkeys_cons {x : sigma β} (l : list (sigma β)) :
  erase_dupkeys (x :: l) = kinsert x.1 x.2 (erase_dupkeys l) := rfl

lemma nodupkeys_erase_dupkeys (l : list (sigma β)) : nodupkeys (erase_dupkeys l) :=
begin
  dsimp [erase_dupkeys], generalize hl : nil = l',
  have : nodupkeys l', { rw ← hl, apply nodup_nil },
  clear hl,
  induction l with x xs,
  { apply this },
  { cases x, simp [erase_dupkeys], split,
    { simp [keys_kerase], apply mem_erase_of_nodup l_ih },
    apply kerase_nodupkeys _ l_ih, }
end

lemma lookup_erase_dupkeys (a : α) (l : list (sigma β)) : lookup a (erase_dupkeys l) = lookup a l :=
begin
  induction l, refl,
  cases l_hd with a' b,
  by_cases a = a',
  { subst a', rw [erase_dupkeys_cons,lookup_kinsert,lookup_cons_eq] },
  { rw [erase_dupkeys_cons,lookup_kinsert_ne h,l_ih,lookup_cons_ne], exact h },
end

lemma sizeof_erase_dupkeys {α} {β : α → Type*} [decidable_eq α] [has_sizeof (sigma β)]
  (xs : list (sigma β)) :
  sizeof (list.erase_dupkeys xs) ≤ sizeof xs :=
begin
  unfold_wf,
  induction xs with x xs,
  { simp [list.erase_dupkeys] },
  { simp only [erase_dupkeys_cons, list.sizeof, kinsert_def, add_le_add_iff_left, sigma.eta],
    transitivity, apply sizeof_kerase,
    assumption }
end

/- kunion -/

/-- `kunion l₁ l₂` is the append to l₁ of l₂ after, for each key in l₁, the
first matching pair in l₂ is erased. -/
def kunion : list (sigma β) → list (sigma β) → list (sigma β)
| []        l₂ := l₂
| (s :: l₁) l₂ := s :: kunion l₁ (kerase s.1 l₂)

@[simp] theorem nil_kunion {l : list (sigma β)} : kunion [] l = l :=
rfl

@[simp] theorem kunion_nil : ∀ {l : list (sigma β)}, kunion l [] = l
| []       := rfl
| (_ :: l) := by rw [kunion, kerase_nil, kunion_nil]

@[simp] theorem kunion_cons {s} {l₁ l₂ : list (sigma β)} :
  kunion (s :: l₁) l₂ = s :: kunion l₁ (kerase s.1 l₂) :=
rfl

@[simp] theorem mem_keys_kunion {a} {l₁ l₂ : list (sigma β)} :
  a ∈ (kunion l₁ l₂).keys ↔ a ∈ l₁.keys ∨ a ∈ l₂.keys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s l₁ ih { by_cases h : a = s.1; [simp [h], simp [h, ih]] }
end

@[simp] theorem kunion_kerase {a} : ∀ {l₁ l₂ : list (sigma β)},
  kunion (kerase a l₁) (kerase a l₂) = kerase a (kunion l₁ l₂)
| []       _ := rfl
| (s :: _) l := by by_cases h : a = s.1;
                   simp [h, kerase_comm a s.1 l, kunion_kerase]

theorem kunion_nodupkeys {l₁ l₂ : list (sigma β)}
  (nd₁ : l₁.nodupkeys) (nd₂ : l₂.nodupkeys) : (kunion l₁ l₂).nodupkeys :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp only [nil_kunion, nd₂] },
  case list.cons : s l₁ ih {
    simp at nd₁,
    simp [not_or_distrib, nd₁.1, nd₂, ih nd₁.2 (kerase_nodupkeys s.1 nd₂)] }
end

theorem perm.kunion_right {l₁ l₂ : list (sigma β)} (p : l₁ ~ l₂) (l) :
  kunion l₁ l ~ kunion l₂ l :=
begin
  induction p generalizing l,
  case list.perm.nil { refl },
  case list.perm.cons : hd tl₁ tl₂ p ih {
    simp [ih (kerase hd.1 l), perm.cons] },
  case list.perm.swap : s₁ s₂ l {
    simp [kerase_comm, perm.swap] },
  case list.perm.trans : l₁ l₂ l₃ p₁₂ p₂₃ ih₁₂ ih₂₃ {
    exact perm.trans (ih₁₂ l) (ih₂₃ l) }
end

theorem perm.kunion_left : ∀ l {l₁ l₂ : list (sigma β)},
  l₁.nodupkeys → l₁ ~ l₂ → kunion l l₁ ~ kunion l l₂
| []       _  _  _   p := p
| (s :: l) l₁ l₂ nd₁ p :=
  by simp [((p.kerase nd₁).kunion_left l (kerase_nodupkeys s.1 nd₁)).cons s]

theorem perm.kunion {l₁ l₂ l₃ l₄ : list (sigma β)} (nd₃ : l₃.nodupkeys)
  (p₁₂ : l₁ ~ l₂) (p₃₄ : l₃ ~ l₄) : kunion l₁ l₃ ~ kunion l₂ l₄ :=
(p₁₂.kunion_right l₃).trans (p₃₄.kunion_left l₂ nd₃)

@[simp] theorem lookup_kunion_left {a} {l₁ l₂ : list (sigma β)} (h : a ∈ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₁ :=
begin
  induction l₁ with s _ ih generalizing l₂; simp at h; cases h; cases s with a',
  { subst h, simp },
  { rw kunion_cons,
    by_cases h' : a = a',
    { subst h', simp },
    { simp [h', ih h] } }
end

@[simp] theorem lookup_kunion_right {a} {l₁ l₂ : list (sigma β)} (h : a ∉ l₁.keys) :
  lookup a (kunion l₁ l₂) = lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : _ _ ih { simp [not_or_distrib] at h, simp [h.1, ih h.2] }
end

@[simp] theorem mem_lookup_kunion {a} {b : β a} {l₁ l₂ : list (sigma β)} :
  b ∈ lookup a (kunion l₁ l₂) ↔ b ∈ lookup a l₁ ∨ a ∉ l₁.keys ∧ b ∈ lookup a l₂ :=
begin
  induction l₁ generalizing l₂,
  case list.nil { simp },
  case list.cons : s _ ih {
    cases s with a',
    by_cases h₁ : a = a',
    { subst h₁, simp },
    { let h₂ := @ih (kerase a' l₂), simp [h₁] at h₂, simp [h₁, h₂] } }
end

theorem mem_lookup_kunion_middle {a} {b : β a} {l₁ l₂ l₃ : list (sigma β)}
  (h₁ : b ∈ lookup a (kunion l₁ l₃)) (h₂ : a ∉ keys l₂) :
  b ∈ lookup a (kunion (kunion l₁ l₂) l₃) :=
match mem_lookup_kunion.mp h₁ with
| or.inl h := mem_lookup_kunion.mpr (or.inl (mem_lookup_kunion.mpr (or.inl h)))
| or.inr h := mem_lookup_kunion.mpr $
  or.inr ⟨mt mem_keys_kunion.mp (not_or_distrib.mpr ⟨h.1, h₂⟩), h.2⟩
end

end list


/-
Copyright (c) 2020 Kevin Kappelmann. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Kappelmann
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.continued_fractions.computation.translations
import Mathlib.algebra.continued_fractions.continuants_recurrence
import Mathlib.algebra.continued_fractions.terminated_stable
import Mathlib.data.nat.fib
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Approximations for Continued Fraction Computations (`gcf.of`)

## Summary

Let us write `gcf` for `generalized_continued_fraction`. This file contains useful approximations
for the values involved in the continued fractions computation `gcf.of`.

## Main Theorems

- `gcf.of_part_num_eq_one`: shows that all partial numerators `aᵢ` are equal to one.
- `gcf.exists_int_eq_of_part_denom`: shows that all partial denominators `bᵢ` correspond to an integer.
- `gcf.one_le_of_nth_part_denom`: shows that `1 ≤ bᵢ`.
- `gcf.succ_nth_fib_le_of_nth_denom`: shows that the `n`th denominator `Bₙ` is greater than or equal to
  the `n + 1`th fibonacci number `nat.fib (n + 1)`.
- `gcf.le_of_succ_nth_denom`: shows that `Bₙ₊₁ ≥ bₙ * Bₙ`, where `bₙ` is the `n`th partial denominator
  of the continued fraction.

## References

- [*Hardy, GH and Wright, EM and Heath-Brown, Roger and Silverman, Joseph*][hardy2008introduction]
-/

namespace generalized_continued_fraction

/-
We begin with some lemmas about the stream of `int_fract_pair`s, which presumably are not
of great interest for the end user.
-/

namespace int_fract_pair

/-- Shows that the fractional parts of the stream are in `[0,1)`. -/
theorem nth_stream_fr_nonneg_lt_one {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {ifp_n : int_fract_pair K}
    (nth_stream_eq : int_fract_pair.stream v n = some ifp_n) : 0 ≤ fr ifp_n ∧ fr ifp_n < 1 :=
  sorry

/-- Shows that the fractional parts of the stream are nonnegative. -/
theorem nth_stream_fr_nonneg {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {ifp_n : int_fract_pair K} (nth_stream_eq : int_fract_pair.stream v n = some ifp_n) :
    0 ≤ fr ifp_n :=
  and.left (nth_stream_fr_nonneg_lt_one nth_stream_eq)

/-- Shows that the fractional parts of the stream smaller than one. -/
theorem nth_stream_fr_lt_one {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {ifp_n : int_fract_pair K} (nth_stream_eq : int_fract_pair.stream v n = some ifp_n) :
    fr ifp_n < 1 :=
  and.right (nth_stream_fr_nonneg_lt_one nth_stream_eq)

/-- Shows that the integer parts of the stream are at least one. -/
theorem one_le_succ_nth_stream_b {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {ifp_succ_n : int_fract_pair K}
    (succ_nth_stream_eq : int_fract_pair.stream v (n + 1) = some ifp_succ_n) : 1 ≤ b ifp_succ_n :=
  sorry

/--
Shows that the `n + 1`th integer part `bₙ₊₁` of the stream is smaller or equal than the inverse of
the `n`th fractional part `frₙ` of the stream.
This result is straight-forward as `bₙ₊₁` is defined as the floor of `1 / frₙ`
-/
theorem succ_nth_stream_b_le_nth_stream_fr_inv {K : Type u_1} {v : K} {n : ℕ}
    [linear_ordered_field K] [floor_ring K] {ifp_n : int_fract_pair K}
    {ifp_succ_n : int_fract_pair K} (nth_stream_eq : int_fract_pair.stream v n = some ifp_n)
    (succ_nth_stream_eq : int_fract_pair.stream v (n + 1) = some ifp_succ_n) :
    ↑(b ifp_succ_n) ≤ (fr ifp_n⁻¹) :=
  sorry

end int_fract_pair

/-
Next we translate above results about the stream of `int_fract_pair`s to the computed continued
fraction `gcf.of`.
-/

/-- Shows that the integer parts of the continued fraction are at least one. -/
theorem of_one_le_nth_part_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    1 ≤ b :=
  sorry

/--
Shows that the partial numerators `aᵢ` of the continued fraction are equal to one and the partial
denominators `bᵢ` correspond to integers.
-/
theorem of_part_num_eq_one_and_exists_int_part_denom_eq {K : Type u_1} {v : K} {n : ℕ}
    [linear_ordered_field K] [floor_ring K] {gp : pair K}
    (nth_s_eq : seq.nth (s (generalized_continued_fraction.of v)) n = some gp) :
    pair.a gp = 1 ∧ ∃ (z : ℤ), pair.b gp = ↑z :=
  sorry

/-- Shows that the partial numerators `aᵢ` are equal to one. -/
theorem of_part_num_eq_one {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {a : K}
    (nth_part_num_eq :
      seq.nth (partial_numerators (generalized_continued_fraction.of v)) n = some a) :
    a = 1 :=
  sorry

/-- Shows that the partial denominators `bᵢ` correspond to an integer. -/
theorem exists_int_eq_of_part_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    ∃ (z : ℤ), b = ↑z :=
  sorry

/-
One of our next goals is to show that `Bₙ₊₁ ≥ bₙ * Bₙ`. For this, we first show that the partial
denominators `Bₙ` are bounded from below by the fibonacci sequence `nat.fib`. This then implies that
`0 ≤ Bₙ` and hence `Bₙ₊₂ = bₙ₊₁ * Bₙ₊₁ + Bₙ ≥ bₙ₊₁ * Bₙ₊₁ + 0 = bₙ₊₁ * Bₙ₊₁`.
-/

-- open `nat` as we will make use of fibonacci numbers.

theorem fib_le_of_continuants_aux_b {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] :
    n ≤ 1 ∨ ¬terminated_at (generalized_continued_fraction.of v) (n - bit0 1) →
        ↑(nat.fib n) ≤ pair.b (continuants_aux (generalized_continued_fraction.of v) n) :=
  sorry

/-- Shows that the `n`th denominator is greater than or equal to the `n + 1`th fibonacci number,
that is `nat.fib (n + 1) ≤ Bₙ`. -/
theorem succ_nth_fib_le_of_nth_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] (hyp : n = 0 ∨ ¬terminated_at (generalized_continued_fraction.of v) (n - 1)) :
    ↑(nat.fib (n + 1)) ≤ denominators (generalized_continued_fraction.of v) n :=
  sorry

/- As a simple consequence, we can now derive that all denominators are nonnegative. -/

theorem zero_le_of_continuants_aux_b {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K]
    [floor_ring K] : 0 ≤ pair.b (continuants_aux (generalized_continued_fraction.of v) n) :=
  sorry

/-- Shows that all denominators are nonnegative. -/
theorem zero_le_of_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K] :
    0 ≤ denominators (generalized_continued_fraction.of v) n :=
  sorry

theorem le_of_succ_succ_nth_continuants_aux_b {K : Type u_1} {v : K} {n : ℕ}
    [linear_ordered_field K] [floor_ring K] {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    b * pair.b (continuants_aux (generalized_continued_fraction.of v) (n + 1)) ≤
        pair.b (continuants_aux (generalized_continued_fraction.of v) (n + bit0 1)) :=
  sorry

/-- Shows that `Bₙ₊₁ ≥ bₙ * Bₙ`, where `bₙ` is the `n`th partial denominator and `Bₙ₊₁` and `Bₙ` are
the `n + 1`th and `n`th denominator of the continued fraction. -/
theorem le_of_succ_nth_denom {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K]
    {b : K}
    (nth_part_denom_eq :
      seq.nth (partial_denominators (generalized_continued_fraction.of v)) n = some b) :
    b * denominators (generalized_continued_fraction.of v) n ≤
        denominators (generalized_continued_fraction.of v) (n + 1) :=
  sorry

/-- Shows that the sequence of denominators is monotonically increasing, that is `Bₙ ≤ Bₙ₊₁`. -/
theorem of_denom_mono {K : Type u_1} {v : K} {n : ℕ} [linear_ordered_field K] [floor_ring K] :
    denominators (generalized_continued_fraction.of v) n ≤
        denominators (generalized_continued_fraction.of v) (n + 1) :=
  sorry

end Mathlib


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies
-/
import algebra.category.CommRing.basic
import algebra.ring.boolean_ring
import order.category.BoolAlg

/-!
# The category of Boolean rings

This file defines `BoolRing`, the category of Boolean rings.

## TODO

Finish the equivalence with `BoolAlg`.
-/

universes u

open category_theory order

/-- The category of Boolean rings. -/
def BoolRing := bundled boolean_ring

namespace BoolRing

instance : has_coe_to_sort BoolRing Type* := bundled.has_coe_to_sort
instance (X : BoolRing) : boolean_ring X := X.str

/-- Construct a bundled `BoolRing` from a `boolean_ring`. -/
def of (α : Type*) [boolean_ring α] : BoolRing := bundled.of α

@[simp] lemma coe_of (α : Type*) [boolean_ring α] : ↥(of α) = α := rfl

instance : inhabited BoolRing := ⟨of punit⟩

instance : bundled_hom.parent_projection @boolean_ring.to_comm_ring := ⟨⟩

attribute [derive [large_category, concrete_category]] BoolRing

@[simps] instance has_forget_to_CommRing : has_forget₂ BoolRing CommRing := bundled_hom.forget₂ _ _

/-- Constructs an isomorphism of Boolean rings from a ring isomorphism between them. -/
@[simps] def iso.mk {α β : BoolRing.{u}} (e : α ≃+* β) : α ≅ β :=
{ hom := e,
  inv := e.symm,
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

end BoolRing

/-! ### Equivalence between `BoolAlg` and `BoolRing` -/

@[simps] instance BoolRing.has_forget_to_BoolAlg : has_forget₂ BoolRing BoolAlg :=
{ forget₂ := { obj := λ X, BoolAlg.of (as_boolalg X), map := λ X Y, ring_hom.as_boolalg } }