/-
Copyright (c) 2020 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro, Yury G. Kudryashov
-/
import order.basic

/-!
# Unbundled relation classes

In this file we prove some properties of `is_*` classes defined in `init.algebra.classes`. The main
difference between these classes and the usual order classes (`preorder` etc) is that usual classes
extend `has_le` and/or `has_lt` while these classes take a relation as an explicit argument.

-/

universes u v

variables {α : Type u} {β : Type v} {r : α → α → Prop} {s : β → β → Prop}

open function

theorem is_refl.swap (r) [is_refl α r] : is_refl α (swap r) := ⟨refl_of r⟩
theorem is_irrefl.swap (r) [is_irrefl α r] : is_irrefl α (swap r) := ⟨irrefl_of r⟩
theorem is_trans.swap (r) [is_trans α r] : is_trans α (swap r) :=
⟨λ a b c h₁ h₂, trans_of r h₂ h₁⟩
theorem is_antisymm.swap (r) [is_antisymm α r] : is_antisymm α (swap r) :=
⟨λ a b h₁ h₂, antisymm h₂ h₁⟩
theorem is_asymm.swap (r) [is_asymm α r] : is_asymm α (swap r) :=
⟨λ a b h₁ h₂, asymm_of r h₂ h₁⟩
theorem is_total.swap (r) [is_total α r] : is_total α (swap r) :=
⟨λ a b, (total_of r a b).swap⟩
theorem is_trichotomous.swap (r) [is_trichotomous α r] : is_trichotomous α (swap r) :=
⟨λ a b, by simpa [swap, or.comm, or.left_comm] using trichotomous_of r a b⟩
theorem is_preorder.swap (r) [is_preorder α r] : is_preorder α (swap r) :=
{..@is_refl.swap α r _, ..@is_trans.swap α r _}
theorem is_strict_order.swap (r) [is_strict_order α r] : is_strict_order α (swap r) :=
{..@is_irrefl.swap α r _, ..@is_trans.swap α r _}
theorem is_partial_order.swap (r) [is_partial_order α r] : is_partial_order α (swap r) :=
{..@is_preorder.swap α r _, ..@is_antisymm.swap α r _}
theorem is_total_preorder.swap (r) [is_total_preorder α r] : is_total_preorder α (swap r) :=
{..@is_preorder.swap α r _, ..@is_total.swap α r _}
theorem is_linear_order.swap (r) [is_linear_order α r] : is_linear_order α (swap r) :=
{..@is_partial_order.swap α r _, ..@is_total.swap α r _}

protected theorem is_asymm.is_antisymm (r) [is_asymm α r] : is_antisymm α r :=
⟨λ x y h₁ h₂, (asymm h₁ h₂).elim⟩
protected theorem is_asymm.is_irrefl [is_asymm α r] : is_irrefl α r :=
⟨λ a h, asymm h h⟩

/- Convert algebraic structure style to explicit relation style typeclasses -/
instance [preorder α] : is_refl α (≤) := ⟨le_refl⟩
instance [preorder α] : is_refl α (≥) := is_refl.swap _
instance [preorder α] : is_trans α (≤) := ⟨@le_trans _ _⟩
instance [preorder α] : is_trans α (≥) := is_trans.swap _
instance [preorder α] : is_preorder α (≤) := {}
instance [preorder α] : is_preorder α (≥) := {}
instance [preorder α] : is_irrefl α (<) := ⟨lt_irrefl⟩
instance [preorder α] : is_irrefl α (>) := is_irrefl.swap _
instance [preorder α] : is_trans α (<) := ⟨@lt_trans _ _⟩
instance [preorder α] : is_trans α (>) := is_trans.swap _
instance [preorder α] : is_asymm α (<) := ⟨@lt_asymm _ _⟩
instance [preorder α] : is_asymm α (>) := is_asymm.swap _
instance [preorder α] : is_antisymm α (<) := is_asymm.is_antisymm _
instance [preorder α] : is_antisymm α (>) := is_asymm.is_antisymm _
instance [preorder α] : is_strict_order α (<) := {}
instance [preorder α] : is_strict_order α (>) := {}
instance preorder.is_total_preorder [preorder α] [is_total α (≤)] : is_total_preorder α (≤) := {}
instance [partial_order α] : is_antisymm α (≤) := ⟨@le_antisymm _ _⟩
instance [partial_order α] : is_antisymm α (≥) := is_antisymm.swap _
instance [partial_order α] : is_partial_order α (≤) := {}
instance [partial_order α] : is_partial_order α (≥) := {}
instance [linear_order α] : is_total α (≤) := ⟨le_total⟩
instance [linear_order α] : is_total α (≥) := is_total.swap _
instance linear_order.is_total_preorder [linear_order α] : is_total_preorder α (≤) :=
  by apply_instance
instance [linear_order α] : is_total_preorder α (≥) := {}
instance [linear_order α] : is_linear_order α (≤) := {}
instance [linear_order α] : is_linear_order α (≥) := {}
instance [linear_order α] : is_trichotomous α (<) := ⟨lt_trichotomy⟩
instance [linear_order α] : is_trichotomous α (>) := is_trichotomous.swap _

instance order_dual.is_total_le [has_le α] [is_total α (≤)] : is_total (order_dual α) (≤) :=
@is_total.swap α _ _

lemma ne_of_irrefl {r} [is_irrefl α r] : ∀ {x y : α}, r x y → x ≠ y
| _ _ h rfl := irrefl _ h

lemma trans_trichotomous_left [is_trans α r] [is_trichotomous α r] {a b c : α} :
  ¬r b a → r b c → r a c :=
begin
  intros h₁ h₂, rcases trichotomous_of r a b with h₃|h₃|h₃,
  exact trans h₃ h₂, rw h₃, exact h₂, exfalso, exact h₁ h₃
end

lemma trans_trichotomous_right [is_trans α r] [is_trichotomous α r] {a b c : α} :
  r a b → ¬r c b → r a c :=
begin
  intros h₁ h₂, rcases trichotomous_of r b c with h₃|h₃|h₃,
  exact trans h₁ h₃, rw ←h₃, exact h₁, exfalso, exact h₂ h₃
end

/-- Construct a partial order from a `is_strict_order` relation -/
def partial_order_of_SO (r) [is_strict_order α r] : partial_order α :=
{ le := λ x y, x = y ∨ r x y,
  lt := r,
  le_refl := λ x, or.inl rfl,
  le_trans := λ x y z h₁ h₂,
    match y, z, h₁, h₂ with
    | _, _, or.inl rfl, h₂ := h₂
    | _, _, h₁, or.inl rfl := h₁
    | _, _, or.inr h₁, or.inr h₂ := or.inr (trans h₁ h₂)
    end,
  le_antisymm := λ x y h₁ h₂,
    match y, h₁, h₂ with
    | _, or.inl rfl, h₂ := rfl
    | _, h₁, or.inl rfl := rfl
    | _, or.inr h₁, or.inr h₂ := (asymm h₁ h₂).elim
    end,
  lt_iff_le_not_le := λ x y,
    ⟨λ h, ⟨or.inr h, not_or
      (λ e, by rw e at h; exact irrefl _ h)
      (asymm h)⟩,
    λ ⟨h₁, h₂⟩, h₁.resolve_left (λ e, h₂ $ e ▸ or.inl rfl)⟩ }

/-- This is basically the same as `is_strict_total_order`, but that definition is
  in Type (probably by mistake) and also has redundant assumptions. -/
@[algebra] class is_strict_total_order' (α : Type u) (lt : α → α → Prop)
  extends is_trichotomous α lt, is_strict_order α lt : Prop.

/-- Construct a linear order from an `is_strict_total_order'` relation -/
def linear_order_of_STO' (r) [is_strict_total_order' α r] [Π x y, decidable (¬ r x y)] :
  linear_order α :=
{ le_total := λ x y,
    match y, trichotomous_of r x y with
    | y, or.inl h := or.inl (or.inr h)
    | _, or.inr (or.inl rfl) := or.inl (or.inl rfl)
    | _, or.inr (or.inr h) := or.inr (or.inr h)
    end,
  decidable_le := λ x y, decidable_of_iff (¬ r y x)
    ⟨λ h, ((trichotomous_of r y x).resolve_left h).imp eq.symm id,
      λ h, h.elim (λ h, h ▸ irrefl_of _ _) (asymm_of r)⟩,
  ..partial_order_of_SO r }

theorem is_strict_total_order'.swap (r) [is_strict_total_order' α r] :
  is_strict_total_order' α (swap r) :=
{..is_trichotomous.swap r, ..is_strict_order.swap r}

instance [linear_order α] : is_strict_total_order' α (<) := {}

/-- A connected order is one satisfying the condition `a < c → a < b ∨ b < c`.
  This is recognizable as an intuitionistic substitute for `a ≤ b ∨ b ≤ a` on
  the constructive reals, and is also known as negative transitivity,
  since the contrapositive asserts transitivity of the relation `¬ a < b`.  -/
@[algebra] class is_order_connected (α : Type u) (lt : α → α → Prop) : Prop :=
(conn : ∀ a b c, lt a c → lt a b ∨ lt b c)

theorem is_order_connected.neg_trans {r : α → α → Prop} [is_order_connected α r]
  {a b c} (h₁ : ¬ r a b) (h₂ : ¬ r b c) : ¬ r a c :=
mt (is_order_connected.conn a b c) $ by simp [h₁, h₂]

theorem is_strict_weak_order_of_is_order_connected [is_asymm α r]
  [is_order_connected α r] : is_strict_weak_order α r :=
{ trans := λ a b c h₁ h₂, (is_order_connected.conn _ c _ h₁).resolve_right (asymm h₂),
  incomp_trans := λ a b c ⟨h₁, h₂⟩ ⟨h₃, h₄⟩,
    ⟨is_order_connected.neg_trans h₁ h₃, is_order_connected.neg_trans h₄ h₂⟩,
  ..@is_asymm.is_irrefl α r _ }

@[priority 100] -- see Note [lower instance priority]
instance is_order_connected_of_is_strict_total_order'
  [is_strict_total_order' α r] : is_order_connected α r :=
⟨λ a b c h, (trichotomous _ _).imp_right (λ o,
  o.elim (λ e, e ▸ h) (λ h', trans h' h))⟩

@[priority 100] -- see Note [lower instance priority]
instance is_strict_total_order_of_is_strict_total_order'
  [is_strict_total_order' α r] : is_strict_total_order α r :=
{..is_strict_weak_order_of_is_order_connected}

instance [linear_order α] : is_strict_total_order α (<) := by apply_instance
instance [linear_order α] : is_order_connected α (<) := by apply_instance
instance [linear_order α] : is_incomp_trans α (<) := by apply_instance
instance [linear_order α] : is_strict_weak_order α (<) := by apply_instance

/-- An extensional relation is one in which an element is determined by its set
  of predecessors. It is named for the `x ∈ y` relation in set theory, whose
  extensionality is one of the first axioms of ZFC. -/
@[algebra] class is_extensional (α : Type u) (r : α → α → Prop) : Prop :=
(ext : ∀ a b, (∀ x, r x a ↔ r x b) → a = b)

@[priority 100] -- see Note [lower instance priority]
instance is_extensional_of_is_strict_total_order'
  [is_strict_total_order' α r] : is_extensional α r :=
⟨λ a b H, ((@trichotomous _ r _ a b)
  .resolve_left $ mt (H _).2 (irrefl a))
  .resolve_right $ mt (H _).1 (irrefl b)⟩

/-- A well order is a well-founded linear order. -/
@[algebra] class is_well_order (α : Type u) (r : α → α → Prop)
  extends is_strict_total_order' α r : Prop :=
(wf : well_founded r)

@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_strict_total_order {α} (r : α → α → Prop) [is_well_order α r] :
  is_strict_total_order α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_extensional {α} (r : α → α → Prop) [is_well_order α r] :
  is_extensional α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_trichotomous {α} (r : α → α → Prop) [is_well_order α r] :
  is_trichotomous α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_trans {α} (r : α → α → Prop) [is_well_order α r] :
  is_trans α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_irrefl {α} (r : α → α → Prop) [is_well_order α r] :
  is_irrefl α r := by apply_instance
@[priority 100] -- see Note [lower instance priority]
instance is_well_order.is_asymm {α} (r : α → α → Prop) [is_well_order α r] :
  is_asymm α r := by apply_instance

/-- Construct a decidable linear order from a well-founded linear order. -/
noncomputable def is_well_order.linear_order (r : α → α → Prop) [is_well_order α r] :
  linear_order α :=
by { letI := λ x y, classical.dec (¬r x y), exact linear_order_of_STO' r }

instance empty_relation.is_well_order [subsingleton α] : is_well_order α empty_relation :=
{ trichotomous := λ a b, or.inr $ or.inl $ subsingleton.elim _ _,
  irrefl       := λ a, id,
  trans        := λ a b c, false.elim,
  wf           := ⟨λ a, ⟨_, λ y, false.elim⟩⟩ }

instance nat.lt.is_well_order : is_well_order ℕ (<) := ⟨nat.lt_wf⟩

instance sum.lex.is_well_order [is_well_order α r] [is_well_order β s] :
  is_well_order (α ⊕ β) (sum.lex r s) :=
{ trichotomous := λ a b, by cases a; cases b; simp; apply trichotomous,
  irrefl       := λ a, by cases a; simp; apply irrefl,
  trans        := λ a b c, by cases a; cases b; simp; cases c; simp; apply trans,
  wf           := sum.lex_wf is_well_order.wf is_well_order.wf }

instance prod.lex.is_well_order [is_well_order α r] [is_well_order β s] :
  is_well_order (α × β) (prod.lex r s) :=
{ trichotomous := λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩,
    match @trichotomous _ r _ a₁ b₁ with
    | or.inl h₁ := or.inl $ prod.lex.left _ _ h₁
    | or.inr (or.inr h₁) := or.inr $ or.inr $ prod.lex.left _ _ h₁
    | or.inr (or.inl e) := e ▸  match @trichotomous _ s _ a₂ b₂ with
      | or.inl h := or.inl $ prod.lex.right _ h
      | or.inr (or.inr h) := or.inr $ or.inr $ prod.lex.right _ h
      | or.inr (or.inl e) := e ▸ or.inr $ or.inl rfl
      end
    end,
  irrefl := λ ⟨a₁, a₂⟩ h, by cases h with _ _ _ _ h _ _ _ h;
     [exact irrefl _ h, exact irrefl _ h],
  trans := λ a b c h₁ h₂, begin
    cases h₁ with a₁ a₂ b₁ b₂ ab a₁ b₁ b₂ ab;
    cases h₂ with _ _ c₁ c₂ bc _ _ c₂ bc,
    { exact prod.lex.left _ _ (trans ab bc) },
    { exact prod.lex.left _ _ ab },
    { exact prod.lex.left _ _ bc },
    { exact prod.lex.right _ (trans ab bc) }
  end,
  wf := prod.lex_wf is_well_order.wf is_well_order.wf }

/-- An unbounded or cofinal set -/
def unbounded (r : α → α → Prop) (s : set α) : Prop := ∀ a, ∃ b ∈ s, ¬ r b a
/-- A bounded or final set -/
def bounded (r : α → α → Prop) (s : set α) : Prop := ∃a, ∀ b ∈ s, r b a

@[simp] lemma not_bounded_iff {r : α → α → Prop} (s : set α) : ¬bounded r s ↔ unbounded r s :=
begin
  classical,
  simp only [bounded, unbounded, not_forall, not_exists, exists_prop, not_and, not_not]
end

@[simp] lemma not_unbounded_iff {r : α → α → Prop} (s : set α) : ¬unbounded r s ↔ bounded r s :=
by { classical, rw [not_iff_comm, not_bounded_iff] }

namespace prod

instance is_refl_preimage_fst {r : α → α → Prop} [h : is_refl α r] :
  is_refl (α × α) (prod.fst ⁻¹'o r) := ⟨λ a, refl_of r a.1⟩

instance is_refl_preimage_snd {r : α → α → Prop} [h : is_refl α r] :
  is_refl (α × α) (prod.snd ⁻¹'o r) := ⟨λ a, refl_of r a.2⟩

instance is_trans_preimage_fst {r : α → α → Prop} [h : is_trans α r] :
  is_trans (α × α) (prod.fst ⁻¹'o r) := ⟨λ _ _ _, trans_of r⟩

instance is_trans_preimage_snd {r : α → α → Prop} [h : is_trans α r] :
  is_trans (α × α) (prod.snd ⁻¹'o r) := ⟨λ _ _ _, trans_of r⟩

end prod


import .definitions
import data.bool
import data.int.gcd
import tactic

@[simp]
theorem rdiv_cons (a: ℤ) (as: list ℤ) (f: ℤ): rdiv (a :: as) f = ((a / f) :: rdiv as f) :=
by simp [rdiv]

@[simp]
theorem rdiv_length (as: list ℤ) (f: ℤ): (rdiv as f).length = as.length :=
by simp [rdiv]

@[simp]
theorem rmul_cons (a: ℤ) (as: list ℤ) (f: ℤ): rmul (a :: as) f = ((a * f) :: rmul as f) :=
by simp [rmul]

@[simp]
theorem rmul_length (as: list ℤ) (f: ℤ): (rmul as f).length = as.length :=
by simp [rmul]

@[simp]
theorem smul_cons (a b: ℤ) (as bs: list ℤ): smul (a::as) (b::bs) = a * b + smul as bs :=
by simp [smul, list.zip_cons_cons]

@[simp]
theorem smul_rmul_right (as bs: list ℤ) (f: ℤ): smul as (rmul bs f) = (smul as bs) * f := begin
	induction bs generalizing as,
	{ simp [smul, rmul], },
	{
		cases as,
		{ simp [smul], },
		simp only [bs_ih, smul_cons, rmul_cons],
		linarith,
	},
end

@[simp]
theorem smul_rmul_left (as bs: list ℤ) (f: ℤ): smul (rmul as f) bs = (smul as bs) * f := begin
	induction as generalizing bs,
	{ simp [smul, rmul], },
	{
		cases bs,
		{ simp [smul], },
		simp only [as_ih, smul_cons, rmul_cons],
		linarith,
	},
end

theorem dvd_dvd_smul_left (as bs: list ℤ) (d: ℤ) (h: ∀ a ∈ as, d ∣ a): d ∣ smul as bs :=
begin
	induction as generalizing bs,
	{ simp [smul], },
	{
		cases bs, { simp [smul], },
		{
			simp,
			have := h as_hd (list.mem_cons_self _ _),
			replace this := dvd_mul_of_dvd_left this bs_hd,
			replace as_ih := as_ih _ bs_tl,
			exact dvd_add this as_ih,

			assume a ah,
			simp [list.mem_cons_of_mem, *],
		}
	},
end

@[simp]
theorem gcd_list_gcd (a: ℤ) (as: list ℤ): gcd_list (a::as) = a.nat_abs.gcd (gcd_list as) :=
begin
	cases as,
	{ simp [gcd_list], },
	{ simp [gcd_list], },
end

theorem gcd_list_dvd (as: list ℤ) (a: ℤ) (h: a ∈ as): gcd_list as ∣ a.nat_abs :=
begin
	induction as,
	{ finish, },
	simp at h,
	cases h,
	{
		cases as_tl,
		{ simp [gcd_list, *], },
		{ simp [gcd_list, h, (int.nat_abs as_hd).gcd_dvd_left], }
	},
	{
		replace as_ih := as_ih h,
		simp,
		have := (nat.gcd_dvd (as_hd.nat_abs) (gcd_list as_tl)).2,
		exact dvd.trans this as_ih,
	}
end

@[simp]
theorem xgcd_list_length (as: list ℤ): (xgcd_list as).length = as.length :=
begin
	induction as,
	simp [xgcd_list],
	cases as_tl;
	simp [xgcd_list, *],
end

theorem xgcd_list_smul (xs: list ℤ): smul xs (xgcd_list xs) = gcd_list xs :=
begin
	induction xs,
	{ refl, },

	cases xs_tl, {
		by_cases h: xs_hd < 0,
		{
			have : xs_hd ≤ 0 := by linarith,
			simp [xgcd_list, smul, gcd_list, h, int.of_nat_nat_abs_of_nonpos this],
		},

		{
			have : xs_hd ≥ 0 := by linarith,
			simp [xgcd_list, smul, gcd_list, h],
			unfold_coes,
			rw int.of_nat_nat_abs_eq_of_nonneg this,
		}
	},

	by_cases c: xs_hd < 0,
	{
		have : xs_hd ≤ 0 := by linarith,
		simp [xgcd_list, smul_cons, xgcd_list, xs_ih, gcd_list, c, nat.gcd_eq_gcd_ab, int.of_nat_nat_abs_of_nonpos this],
	},
	{
		have : xs_hd ≥ 0 := by linarith,
		simp [xgcd_list, smul_cons, xgcd_list, xs_ih, gcd_list, c, nat.gcd_eq_gcd_ab],
		unfold_coes,
		rw int.of_nat_nat_abs_eq_of_nonneg this,
		simp,
	},
end

theorem Eq.has_mem_iff (eq: Eq) (xs: list ℤ) : xs ∈ eq ↔ xs.length = eq.as.length ∧ smul eq.as xs = eq.c :=
by simp [has_mem.mem, Eq.is_solution]

theorem Eq.get_solution_mem { eq: Eq } { s: list ℤ } (h: s ∈ eq.get_solution): s ∈ eq :=
begin
	unfold Eq.get_solution at h,
	cases c: eq.has_solution,
	case bool.ff { finish, },
	case bool.tt {
		simp only [c, if_true, bool.coe_sort_tt, option.mem_def] at h,
		simp only [Eq.has_solution, to_bool_iff] at c,
		replace c : ((gcd_list eq.as) : ℤ) ∣ eq.c := int.coe_nat_dvd_left.mpr c,
		cases c with f c,
		by_cases x: eq.c = 0, {
			simp [x] at h,
			simp [Eq.has_mem_iff, ←h, x],
		},
		simp [x] at h,

		have : (gcd_list eq.as : ℤ)  ≠ 0 := begin
			rw c at x,
			exact left_ne_zero_of_mul x,
		end,

		rw int.div_eq_of_eq_mul_right this c at h,
		simp [Eq.has_mem_iff, ←h, xgcd_list_smul, c],
	},
end

theorem Eq.get_solution_neq_none_iff (eq: Eq): eq.get_solution ≠ none ↔ eq.has_solution :=
begin
	unfold Eq.get_solution,
	cases eq.has_solution;
	finish,
end

theorem Eq.has_solution_iff (eq: Eq) : eq.has_solution ↔ ∃ xs, xs ∈ eq :=
begin
	split, {
		assume h,
		have := eq.get_solution_neq_none_iff.2 h,
		cases s: eq.get_solution,
		{ finish, },
		use val,
		exact Eq.get_solution_mem s,
	}, {
		assume h,
		cases h with s h,
		rw Eq.has_mem_iff at h,
		simp [Eq.has_solution],

		have := dvd_dvd_smul_left eq.as s (gcd_list eq.as) _,
		rw h.2 at this,
		exact int.coe_nat_dvd_left.mp this,

		assume a ah,
		have := gcd_list_dvd eq.as a ah,
		exact int.coe_nat_dvd_left.mpr this,
	}
end

theorem Eq.equiv_mul (eq: Eq) (f: ℤ) (f_neq_z: f ≠ 0): eq.equiv (Eq.mk (rmul eq.as f) (eq.c * f)) :=
begin
	unfold Eq.equiv,
	assume xs,
	split, {
		assume h,
		rw Eq.has_mem_iff at h,
		rw Eq.has_mem_iff,
		unfold_projs,
		simp [h],
	}, {
		assume h,
		rw Eq.has_mem_iff at h,
		rw Eq.has_mem_iff,
		unfold_projs at h,
		simp at h,
		finish,
	}
end

/-
theorem Eq.equiv_div (eq: Eq) (h: eq.has_solution): eq.equiv (Eq.mk (rdiv eq.as (gcd_list eq.as)) (eq.c / (gcd_list eq.as))) :=
begin
	unfold Eq.equiv,
	assume xs,
	split, {
		assume h,
		rw Eq.has_mem_iff at h,
		rw Eq.has_mem_iff,
		unfold_projs,
		simp [h],
		sorry,
	},
	sorry,
end
-/

theorem Eqs.has_mem_iff (e: Eqs) (xs: list ℤ) : xs ∈ e ↔ xs.length = e.dim ∧ e.eqs.all (λ eq, eq.is_solution xs) :=
by simp [has_mem.mem, Eqs.is_solution]


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import tactic.basic
import logic.is_empty

/-!
# Types with a unique term

In this file we define a typeclass `unique`,
which expresses that a type has a unique term.
In other words, a type that is `inhabited` and a `subsingleton`.

## Main declaration

* `unique`: a typeclass that expresses that a type has a unique term.

## Main statements

* `unique.mk'`: an inhabited subsingleton type is `unique`. This can not be an instance because it
  would lead to loops in typeclass inference.

* `function.surjective.unique`: if the domain of a surjective function is `unique`, then its
  codomain is `unique` as well.

* `function.injective.subsingleton`: if the codomain of an injective function is `subsingleton`,
  then its domain is `subsingleton` as well.

* `function.injective.unique`: if the codomain of an injective function is `subsingleton` and its
  domain is `inhabited`, then its domain is `unique`.

## Implementation details

The typeclass `unique α` is implemented as a type,
rather than a `Prop`-valued predicate,
for good definitional properties of the default term.

-/

universes u v w

variables {α : Sort u} {β : Sort v} {γ : Sort w}

/-- `unique α` expresses that `α` is a type with a unique term `default α`.

This is implemented as a type, rather than a `Prop`-valued predicate,
for good definitional properties of the default term. -/
@[ext]
structure unique (α : Sort u) extends inhabited α :=
(uniq : ∀ a:α, a = default)

attribute [class] unique

/-- Given an explicit `a : α` with `[subsingleton α]`, we can construct
a `[unique α]` instance. This is a def because the typeclass search cannot
arbitrarily invent the `a : α` term. Nevertheless, these instances are all
equivalent by `unique.subsingleton.unique`.

See note [reducible non-instances]. -/
@[reducible] def unique_of_subsingleton {α : Sort*} [subsingleton α] (a : α) : unique α :=
{ default := a,
  uniq := λ _, subsingleton.elim _ _ }

instance punit.unique : unique punit.{u} :=
{ default := punit.star,
  uniq := λ x, punit_eq x _ }

/-- Every provable proposition is unique, as all proofs are equal. -/
def unique_prop {p : Prop} (h : p) : unique p :=
{ default := h, uniq := λ x, rfl }

instance : unique true := unique_prop trivial

lemma fin.eq_zero : ∀ n : fin 1, n = 0
| ⟨n, hn⟩ := fin.eq_of_veq (nat.eq_zero_of_le_zero (nat.le_of_lt_succ hn))

instance {n : ℕ} : inhabited (fin n.succ) := ⟨0⟩
instance inhabited_fin_one_add (n : ℕ) : inhabited (fin (1 + n)) := ⟨⟨0, nat.zero_lt_one_add n⟩⟩

@[simp] lemma fin.default_eq_zero (n : ℕ) : default (fin n.succ) = 0 := rfl

instance fin.unique : unique (fin 1) :=
{ uniq := fin.eq_zero, .. fin.inhabited }

namespace unique
open function

section

variables [unique α]

@[priority 100] -- see Note [lower instance priority]
instance : inhabited α := to_inhabited ‹unique α›

lemma eq_default (a : α) : a = default α := uniq _ a

lemma default_eq (a : α) : default α = a := (uniq _ a).symm

@[priority 100] -- see Note [lower instance priority]
instance : subsingleton α := subsingleton_of_forall_eq _ eq_default

lemma forall_iff {p : α → Prop} : (∀ a, p a) ↔ p (default α) :=
⟨λ h, h _, λ h x, by rwa [unique.eq_default x]⟩

lemma exists_iff {p : α → Prop} : Exists p ↔ p (default α) :=
⟨λ ⟨a, ha⟩, eq_default a ▸ ha, exists.intro (default α)⟩

end

@[ext] protected lemma subsingleton_unique' : ∀ (h₁ h₂ : unique α), h₁ = h₂
| ⟨⟨x⟩, h⟩ ⟨⟨y⟩, _⟩ := by congr; rw [h x, h y]

instance subsingleton_unique : subsingleton (unique α) :=
⟨unique.subsingleton_unique'⟩

/-- Construct `unique` from `inhabited` and `subsingleton`. Making this an instance would create
a loop in the class inheritance graph. -/
@[reducible] def mk' (α : Sort u) [h₁ : inhabited α] [subsingleton α] : unique α :=
{ uniq := λ x, subsingleton.elim _ _, .. h₁ }

end unique

@[simp] lemma pi.default_def {β : Π a : α, Sort v} [Π a, inhabited (β a)] :
  default (Π a, β a) = λ a, default (β a) :=
rfl

lemma pi.default_apply {β : Π a : α, Sort v} [Π a, inhabited (β a)] (a : α) :
  default (Π a, β a) a = default (β a) :=
rfl

instance pi.unique {β : Π a : α, Sort v} [Π a, unique (β a)] : unique (Π a, β a) :=
{ uniq := λ f, funext $ λ x, unique.eq_default _,
  .. pi.inhabited α }

/-- There is a unique function on an empty domain. -/
instance pi.unique_of_is_empty [is_empty α] (β : Π a : α, Sort v) :
  unique (Π a, β a) :=
{ default := is_empty_elim,
  uniq := λ f, funext is_empty_elim }

namespace function

variable {f : α → β}

/-- If the domain of a surjective function is a singleton,
then the codomain is a singleton as well. -/
protected def surjective.unique (hf : surjective f) [unique α] : unique β :=
{ default := f (default _),
  uniq := λ b, let ⟨a, ha⟩ := hf b in ha ▸ congr_arg f (unique.eq_default _) }

/-- If the codomain of an injective function is a subsingleton, then the domain
is a subsingleton as well. -/
protected lemma injective.subsingleton (hf : injective f) [subsingleton β] :
  subsingleton α :=
⟨λ x y, hf $ subsingleton.elim _ _⟩

/-- If `α` is inhabited and admits an injective map to a subsingleton type, then `α` is `unique`. -/
protected def injective.unique [inhabited α] [subsingleton β] (hf : injective f) : unique α :=
@unique.mk' _ _ hf.subsingleton

end function

namespace option

/-- `option α` is a `subsingleton` if and only if `α` is empty. -/
lemma subsingleton_iff_is_empty {α} : subsingleton (option α) ↔ is_empty α :=
⟨λ h, ⟨λ x, option.no_confusion $ @subsingleton.elim _ h x none⟩,
  λ h, ⟨λ x y, option.cases_on x (option.cases_on y rfl (λ x, h.elim x)) (λ x, h.elim x)⟩⟩

instance {α} [is_empty α] : unique (option α) := @unique.mk' _ _ (subsingleton_iff_is_empty.2 ‹_›)

end option

section subtype

instance unique.subtype_eq (y : α) : unique {x // x = y} :=
{ default := ⟨y, rfl⟩,
  uniq := λ ⟨x, hx⟩, by simpa using hx }

instance unique.subtype_eq' (y : α) : unique {x // y = x} :=
{ default := ⟨y, rfl⟩,
  uniq := λ ⟨x, hx⟩, by simpa using hx.symm }

end subtype


/-
Author: Jeremy Avigad

This is a makeshift theory of the cardinality of a list. Any list can be taken to represent the
finite set of its elements. Cardinality counts the number of distinct elements. Cardinality
respects equivalence and is preserved by any mapping that is injective on its elements.

It might make sense to remove this when we have a proper theory of finite sets.
-/
import Mathlib.Data.List.Basic

namespace List

def inj_on (f : α → β) (as : List α) := ∀ {x y}, x ∈ as → y ∈ as → f x = f y → x = y

theorem inj_on_of_subset {f : α → β} {as bs : List α} (h : inj_on f bs) (hsub : as ⊆ bs) :
  inj_on f as := fun xas yas heq => h (hsub xas) (hsub yas) heq

protected def equiv (as bs : List α) := ∀ x, x ∈ as ↔ x ∈ bs

theorem equiv_iff_subset_and_subset {as bs : List α} : as.equiv bs ↔ as ⊆ bs ∧ bs ⊆ as :=
Iff.intro
  (fun h => ⟨fun _ xas => (h _).1 xas, fun _ xbs => (h _).2 xbs⟩)
  (fun ⟨h1, h2⟩ x => ⟨@h1 x, @h2 x⟩)

theorem insert_equiv_cons [DecidableEq α] (a : α) (as : List α) : (insert a as).equiv (a :: as) :=
  fun x => by simp

theorem union_equiv_append [DecidableEq α] (as bs : List α) : (as.union bs).equiv (as ++ bs) :=
  fun x => by simp

section decidable_eq
variable [DecidableEq α] [DecidableEq β]

/- remove -/

def remove (a : α) : List α → List α
  | [] => []
  | (b :: bs) => if a = b then remove a bs else b :: remove a bs

theorem mem_remove_iff {a b : α} {as : List α} : b ∈ remove a as ↔ b ∈ as ∧ b ≠ a := by
  induction as with
  | nil => simp [remove]
  | cons a' as ih =>
    simp [remove]
    cases Decidable.em (a = a') with
    | inl h =>
      simp only [if_pos h, ih]
      exact ⟨fun ⟨h1, h2⟩ => ⟨Or.inr h1, h2⟩, fun ⟨h1, h2⟩ => ⟨Or.resolve_left h1 (h ▸ h2), h2⟩⟩
    | inr h =>
      simp [if_neg h, ih]
      constructor
      { focus
        intro h'
        cases h' with
        | inl h₁ => exact ⟨Or.inl h₁, h₁.symm ▸ (Ne.symm h)⟩
        | inr h₁ => exact ⟨Or.inr h₁.1, h₁.2⟩ }
      intro ⟨h1, h2⟩
      cases h1 with
      | inl h1' => exact Or.inl h1'
      | inr h1' => exact Or.inr ⟨h1', h2⟩

theorem remove_eq_of_not_mem {a : α} : ∀ {as : List α}, (a ∉ as) → remove a as = as
  | [], _ => by simp [remove]
  | a' :: as, h => by
    have h1 : a ≠ a' := fun h' => h (by rw [h']; apply mem_cons_self)
    have h2 : a ∉ as := fun h' => h (mem_cons_of_mem _ h')
    simp [remove, h1, remove_eq_of_not_mem h2]

theorem mem_of_mem_remove {a b : α} {as : List α} (h : b ∈ remove a as) : b ∈ as := by
  rw [mem_remove_iff] at h; exact h.1

/- card -/

def card : List α → Nat
  | [] => 0
  | a :: as => if a ∈ as then card as else card as + 1

@[simp] theorem card_nil : card ([] : List α) = 0 := rfl

@[simp] theorem card_cons_of_mem {a : α} {as : List α} (h : a ∈ as) :
    card (a :: as) = card as := by simp [card]; rw [if_pos h]

@[simp] theorem card_cons_of_not_mem {a : α} {as : List α} (h : a ∉ as) :
    card (a :: as) = card as + 1 := by simp [card]; rw [if_neg h]

theorem card_le_card_cons (a : α) (as : List α) : card as ≤ card (a :: as) := by
  cases Decidable.em (a ∈ as) with
  | inl h => simp [h, Nat.le_refl]
  | inr h => simp [h, Nat.le_succ]

@[simp] theorem card_insert_of_mem {a : α} {as : List α} (h : a ∈ as) :
    card (insert a as) = card as := by simp [h]

@[simp] theorem card_insert_of_not_mem {a : α} {as : List α} (h : a ∉ as) :
    card (insert a as) = card as + 1 := by simp [h]

theorem card_remove_of_mem {a : α} : ∀ {as : List α}, a ∈ as → card as = card (remove a as) + 1
  | [], h => False.elim (not_mem_nil _ h)
  | (a' :: as), h => by
    cases Decidable.em (a = a') with
    | inl h' =>
      simp [remove, if_pos h']
      cases Decidable.em (a ∈ as) with
      | inl h'' =>
        have h₃ : a' ∈ as := h' ▸ h''
        simp [card_remove_of_mem h'', h₃]
      | inr h'' =>
        have h₃ : a' ∉ as := h' ▸ h''
        simp [card_cons_of_not_mem h₃, remove_eq_of_not_mem h'']
    | inr h' =>
        have h₃ : a ∈ as := (mem_cons.1 h).resolve_left h'
        simp [remove, h']
        cases Decidable.em (a' ∈ as) with
        | inl h'' =>
          have : a' ∈ remove a as := by rw [mem_remove_iff]; exact ⟨h'', Ne.symm h'⟩
          simp [h'', this, card_remove_of_mem h₃]
        | inr h'' =>
          have : a' ∉ remove a as := fun h => h'' (mem_of_mem_remove h)
          simp [h'', this, card_remove_of_mem h₃]

theorem card_subset_le : ∀ {as bs : List α}, as ⊆ bs → card as ≤ card bs
  | [], bs, _ => by simp
  | (a :: as), bs, hsub => by
    cases Decidable.em (a ∈ as) with
    | inl h' =>
      have hsub' : as ⊆ bs := fun _ xmem => hsub (mem_cons_of_mem a xmem)
      simp [h', card_subset_le hsub']
    | inr h' =>
      have : a ∈ bs := hsub (Mem.head ..)
      simp [h', card_remove_of_mem this]
      apply Nat.add_le_add_right
      apply card_subset_le
      intro x xmem
      rw [mem_remove_iff]
      exact ⟨hsub (mem_cons_of_mem _ xmem), fun h => h' (h ▸ xmem)⟩

theorem card_map_le (f : α → β) (as : List α) : card (as.map f) ≤ card as := by
  induction as with
  | nil => simp
  | cons a as ih =>
    cases Decidable.em (f a ∈ map f as) with
    | inl h => simp [h]; apply Nat.le_trans ih (card_le_card_cons ..)
    | inr h =>
      have : a ∉ as := fun h'' => h (mem_map_of_mem _ h'')
      simp [h, this]
      exact Nat.add_le_add_right ih _

theorem card_map_eq_of_inj_on {f : α → β} {as : List α} :
    inj_on f as →  card (as.map f) = card as := by
  induction as with
  | nil => simp
  | cons a as ih =>
    cases Decidable.em (f a ∈ map f as) with
    | inl h =>
      intro inj_on'
      cases (exists_of_mem_map h) with
      | intro x hx =>
        have : x = a := inj_on' (mem_cons_of_mem _ hx.1) (mem_cons_self ..) hx.2
        have h1 : a ∈ as := this ▸ hx.1
        have h2 : inj_on f as := inj_on_of_subset inj_on' (subset_cons _ _)
        simp  [h1, mem_map_of_mem f h1, ih h2]
    | inr h =>
      intro inj_on'
      have h1 : a ∉ as := fun h'' => h (mem_map_of_mem _ h'')
      have h2 : inj_on f as := inj_on_of_subset inj_on' (subset_cons _ _)
      simp [h, h1, ih h2]

theorem card_eq_of_equiv {as bs : List α} (h : as.equiv bs) : card as = card bs :=
  let sub_and_sub := equiv_iff_subset_and_subset.1 h
  Nat.le_antisymm (card_subset_le sub_and_sub.1) (card_subset_le sub_and_sub.2)

theorem card_append_disjoint : ∀ {as bs : List α},
    disjoint as bs → card (as ++ bs) = card as + card bs
  | [], bs, disj => by simp
  | a :: as, bs, disj => by
    have disj' : disjoint as bs := fun _ h1 h2 => disj (mem_cons_of_mem a h1) h2
    cases Decidable.em (a ∈ as) with
    | inl h =>
      simp [h, card_append_disjoint disj']
    | inr h =>
      have h1 : a ∉ bs := fun h' => disj (mem_cons_self a as) h'
      simp [h, h1, card_append_disjoint disj']
      rw [Nat.add_right_comm]

theorem card_union_disjoint {as bs : List α} (h : disjoint as bs) :
    card (as.union bs) = card as + card bs := by
  rw [card_eq_of_equiv (union_equiv_append as bs), card_append_disjoint h]

end decidable_eq

end List


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Kevin Buzzard
-/
import algebra.big_operators.nat_antidiagonal
import algebra.geom_sum
import data.fintype.big_operators
import ring_theory.power_series.well_known
import tactic.field_simp

/-!
# Bernoulli numbers

The Bernoulli numbers are a sequence of rational numbers that frequently show up in
number theory.

## Mathematical overview

The Bernoulli numbers $(B_0, B_1, B_2, \ldots)=(1, -1/2, 1/6, 0, -1/30, \ldots)$ are
a sequence of rational numbers. They show up in the formula for the sums of $k$th
powers. They are related to the Taylor series expansions of $x/\tan(x)$ and
of $\coth(x)$, and also show up in the values that the Riemann Zeta function
takes both at both negative and positive integers (and hence in the
theory of modular forms). For example, if $1 \leq n$ is even then

$$\zeta(2n)=\sum_{t\geq1}t^{-2n}=(-1)^{n+1}\frac{(2\pi)^{2n}B_{2n}}{2(2n)!}.$$

Note however that this result is not yet formalised in Lean.

The Bernoulli numbers can be formally defined using the power series

$$\sum B_n\frac{t^n}{n!}=\frac{t}{1-e^{-t}}$$

although that happens to not be the definition in mathlib (this is an *implementation
detail* and need not concern the mathematician).

Note that $B_1=-1/2$, meaning that we are using the $B_n^-$ of
[from Wikipedia](https://en.wikipedia.org/wiki/Bernoulli_number).

## Implementation detail

The Bernoulli numbers are defined using well-founded induction, by the formula
$$B_n=1-\sum_{k\lt n}\frac{\binom{n}{k}}{n-k+1}B_k.$$
This formula is true for all $n$ and in particular $B_0=1$. Note that this is the definition
for positive Bernoulli numbers, which we call `bernoulli'`. The negative Bernoulli numbers are
then defined as `bernoulli := (-1)^n * bernoulli'`.

## Main theorems

`sum_bernoulli : ∑ k in finset.range n, (n.choose k : ℚ) * bernoulli k = 0`
-/

open_locale nat big_operators
open finset nat finset.nat power_series
variables (A : Type*) [comm_ring A] [algebra ℚ A]

/-! ### Definitions -/

/-- The Bernoulli numbers:
the $n$-th Bernoulli number $B_n$ is defined recursively via
$$B_n = 1 - \sum_{k < n} \binom{n}{k}\frac{B_k}{n+1-k}$$ -/
def bernoulli' : ℕ → ℚ :=
well_founded.fix lt_wf $
  λ n bernoulli', 1 - ∑ k : fin n, n.choose k / (n - k + 1) * bernoulli' k k.2

lemma bernoulli'_def' (n : ℕ) :
  bernoulli' n = 1 - ∑ k : fin n, n.choose k / (n - k + 1) * bernoulli' k :=
well_founded.fix_eq _ _ _

lemma bernoulli'_def (n : ℕ) :
  bernoulli' n = 1 - ∑ k in range n, n.choose k / (n - k + 1) * bernoulli' k :=
by { rw [bernoulli'_def', ← fin.sum_univ_eq_sum_range], refl }

lemma bernoulli'_spec (n : ℕ) :
  ∑ k in range n.succ, (n.choose (n - k) : ℚ) / (n - k + 1) * bernoulli' k = 1 :=
begin
  rw [sum_range_succ_comm, bernoulli'_def n, tsub_self],
  conv in (n.choose (_ - _)) { rw choose_symm (mem_range.1 H).le },
  simp only [one_mul, cast_one, sub_self, sub_add_cancel, choose_zero_right, zero_add, div_one],
end

lemma bernoulli'_spec' (n : ℕ) :
  ∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli' k.1 = 1 :=
begin
  refine ((sum_antidiagonal_eq_sum_range_succ_mk _ n).trans _).trans (bernoulli'_spec n),
  refine sum_congr rfl (λ x hx, _),
  simp only [add_tsub_cancel_of_le, mem_range_succ_iff.mp hx, cast_sub],
end

/-! ### Examples -/

section examples

@[simp] lemma bernoulli'_zero : bernoulli' 0 = 1 :=
by { rw bernoulli'_def, norm_num }

@[simp] lemma bernoulli'_one : bernoulli' 1 = 1/2 :=
by { rw bernoulli'_def, norm_num }

@[simp] lemma bernoulli'_two : bernoulli' 2 = 1/6 :=
by { rw bernoulli'_def, norm_num [sum_range_succ] }

@[simp] lemma bernoulli'_three : bernoulli' 3 = 0 :=
by { rw bernoulli'_def, norm_num [sum_range_succ] }

@[simp] lemma bernoulli'_four : bernoulli' 4 = -1/30 :=
have nat.choose 4 2 = 6 := dec_trivial, -- shrug
by { rw bernoulli'_def, norm_num [sum_range_succ, this] }

end examples

@[simp] lemma sum_bernoulli' (n : ℕ) :
  ∑ k in range n, (n.choose k : ℚ) * bernoulli' k = n :=
begin
  cases n, { simp },
  suffices : (n + 1 : ℚ) * ∑ k in range n, ↑(n.choose k) / (n - k + 1) * bernoulli' k =
    ∑ x in range n, ↑(n.succ.choose x) * bernoulli' x,
  { rw_mod_cast [sum_range_succ, bernoulli'_def, ← this, choose_succ_self_right], ring },
  simp_rw [mul_sum, ← mul_assoc],
  refine sum_congr rfl (λ k hk, _),
  congr',
  have : ((n - k : ℕ) : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero,
  field_simp [← cast_sub (mem_range.1 hk).le, mul_comm],
  rw_mod_cast [tsub_add_eq_add_tsub (mem_range.1 hk).le, choose_mul_succ_eq],
end

/-- The exponential generating function for the Bernoulli numbers `bernoulli' n`. -/
def bernoulli'_power_series := mk $ λ n, algebra_map ℚ A (bernoulli' n / n!)

theorem bernoulli'_power_series_mul_exp_sub_one :
  bernoulli'_power_series A * (exp A - 1) = X * exp A :=
begin
  ext n,
  -- constant coefficient is a special case
  cases n, { simp },
  rw [bernoulli'_power_series, coeff_mul, mul_comm X, sum_antidiagonal_succ'],
  suffices : ∑ p in antidiagonal n, (bernoulli' p.1 / p.1!) * ((p.2 + 1) * p.2!)⁻¹ = n!⁻¹,
  { simpa [ring_hom.map_sum] using congr_arg (algebra_map ℚ A) this },
  apply eq_inv_of_mul_eq_one_left,
  rw sum_mul,
  convert bernoulli'_spec' n using 1,
  apply sum_congr rfl,
  simp_rw [mem_antidiagonal],
  rintro ⟨i, j⟩ rfl,
  have : (j + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero j,
  have : (j + 1 : ℚ) * j! * i! ≠ 0 := by simpa [factorial_ne_zero],
  have := factorial_mul_factorial_dvd_factorial_add i j,
  field_simp [mul_comm _ (bernoulli' i), mul_assoc, add_choose],
  rw_mod_cast [mul_comm (j + 1), mul_div_assoc, ← mul_assoc],
  rw [cast_mul, cast_mul, mul_div_mul_right, cast_div_char_zero, cast_mul],
  assumption, rwa nat.cast_succ,
end

/-- Odd Bernoulli numbers (greater than 1) are zero. -/
theorem bernoulli'_odd_eq_zero {n : ℕ} (h_odd : odd n) (hlt : 1 < n) : bernoulli' n = 0 :=
begin
  let B := mk (λ n, bernoulli' n / n!),
  suffices : (B - eval_neg_hom B) * (exp ℚ - 1) = X * (exp ℚ - 1),
  { cases mul_eq_mul_right_iff.mp this;
    simp only [power_series.ext_iff, eval_neg_hom, coeff_X] at h,
    { apply eq_zero_of_neg_eq,
      specialize h n,
      split_ifs at h;
      simp [h_odd.neg_one_pow, factorial_ne_zero, *] at * },
    { simpa using h 1 } },
  have h : B * (exp ℚ - 1) = X * exp ℚ,
  { simpa [bernoulli'_power_series] using bernoulli'_power_series_mul_exp_sub_one ℚ },
  rw [sub_mul, h, mul_sub X, sub_right_inj, ← neg_sub, mul_neg, neg_eq_iff_eq_neg],
  suffices : eval_neg_hom (B * (exp ℚ - 1)) * exp ℚ = eval_neg_hom (X * exp ℚ) * exp ℚ,
  { simpa [mul_assoc, sub_mul, mul_comm (eval_neg_hom (exp ℚ)), exp_mul_exp_neg_eq_one] },
  congr',
end

/-- The Bernoulli numbers are defined to be `bernoulli'` with a parity sign. -/
def bernoulli (n : ℕ) : ℚ := (-1)^n * bernoulli' n

lemma bernoulli'_eq_bernoulli (n : ℕ) : bernoulli' n = (-1)^n * bernoulli n :=
by simp [bernoulli, ← mul_assoc, ← sq, ← pow_mul, mul_comm n 2, pow_mul]

@[simp] lemma bernoulli_zero : bernoulli 0 = 1 := by simp [bernoulli]

@[simp] lemma bernoulli_one : bernoulli 1 = -1/2 :=
by norm_num [bernoulli]

theorem bernoulli_eq_bernoulli'_of_ne_one {n : ℕ} (hn : n ≠ 1) : bernoulli n = bernoulli' n :=
begin
  by_cases h0 : n = 0, { simp [h0] },
  rw [bernoulli, neg_one_pow_eq_pow_mod_two],
  cases mod_two_eq_zero_or_one n, { simp [h] },
  simp [bernoulli'_odd_eq_zero (odd_iff.mpr h) (one_lt_iff_ne_zero_and_ne_one.mpr ⟨h0, hn⟩)],
end

@[simp] theorem sum_bernoulli (n : ℕ):
  ∑ k in range n, (n.choose k : ℚ) * bernoulli k = if n = 1 then 1 else 0 :=
begin
  cases n, { simp },
  cases n, { simp },
  suffices : ∑ i in range n, ↑((n + 2).choose (i + 2)) * bernoulli (i + 2) = n / 2,
  { simp only [this, sum_range_succ', cast_succ, bernoulli_one, bernoulli_zero, choose_one_right,
    mul_one, choose_zero_right, cast_zero, if_false, zero_add, succ_succ_ne_one], ring },
  have f := sum_bernoulli' n.succ.succ,
  simp_rw [sum_range_succ', bernoulli'_one, choose_one_right, cast_succ, ← eq_sub_iff_add_eq] at f,
  convert f,
  { funext x, rw bernoulli_eq_bernoulli'_of_ne_one (succ_ne_zero x ∘ succ.inj) },
  { simp only [one_div, mul_one, bernoulli'_zero, cast_one, choose_zero_right, add_sub_cancel],
    ring },
end

lemma bernoulli_spec' (n : ℕ) :
  ∑ k in antidiagonal n, ((k.1 + k.2).choose k.2 : ℚ) / (k.2 + 1) * bernoulli k.1 =
    if n = 0 then 1 else 0 :=
begin
  cases n, { simp },
  rw if_neg (succ_ne_zero _),
  -- algebra facts
  have h₁ : (1, n) ∈ antidiagonal n.succ := by simp [mem_antidiagonal, add_comm],
  have h₂ : (n : ℚ) + 1 ≠ 0 := by apply_mod_cast succ_ne_zero,
  have h₃ : (1 + n).choose n = n + 1 := by simp [add_comm],
  -- key equation: the corresponding fact for `bernoulli'`
  have H := bernoulli'_spec' n.succ,
  -- massage it to match the structure of the goal, then convert piece by piece
  rw sum_eq_add_sum_diff_singleton h₁ at H ⊢,
  apply add_eq_of_eq_sub',
  convert eq_sub_of_add_eq' H using 1,
  { refine sum_congr rfl (λ p h, _),
    obtain ⟨h', h''⟩ : p ∈ _ ∧ p ≠ _ := by rwa [mem_sdiff, mem_singleton] at h,
    simp [bernoulli_eq_bernoulli'_of_ne_one ((not_congr (antidiagonal_congr h' h₁)).mp h'')] },
  { field_simp [h₃],
    norm_num },
end

/-- The exponential generating function for the Bernoulli numbers `bernoulli n`. -/
def bernoulli_power_series := mk $ λ n, algebra_map ℚ A (bernoulli n / n!)

theorem bernoulli_power_series_mul_exp_sub_one :
  bernoulli_power_series A * (exp A - 1) = X :=
begin
  ext n,
  -- constant coefficient is a special case
  cases n, { simp },
  simp only [bernoulli_power_series, coeff_mul, coeff_X, sum_antidiagonal_succ', one_div, coeff_mk,
    coeff_one, coeff_exp, linear_map.map_sub, factorial, if_pos, cast_succ, cast_one, cast_mul,
    sub_zero, ring_hom.map_one, add_eq_zero_iff, if_false, _root_.inv_one, zero_add, one_ne_zero,
    mul_zero, and_false, sub_self, ← ring_hom.map_mul, ← ring_hom.map_sum],
  cases n, { simp },
  rw if_neg n.succ_succ_ne_one,
  have hfact : ∀ m, (m! : ℚ) ≠ 0 := λ m, by exact_mod_cast factorial_ne_zero m,
  have hite2 : ite (n.succ = 0) 1 0 = (0 : ℚ) := if_neg n.succ_ne_zero,
  rw [←map_zero (algebra_map ℚ A), ←zero_div (n.succ! : ℚ), ←hite2, ← bernoulli_spec', sum_div],
  refine congr_arg (algebra_map ℚ A) (sum_congr rfl $ λ x h, eq_div_of_mul_eq (hfact n.succ) _),
  rw mem_antidiagonal at h,
  have hj : (x.2 + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero _,
  field_simp [← h, mul_ne_zero hj (hfact x.2), hfact x.1, mul_comm _ (bernoulli x.1), mul_assoc,
    add_choose, cast_div_char_zero (factorial_mul_factorial_dvd_factorial_add _ _),
    nat.factorial_ne_zero, hj],
  cc,
end

section faulhaber

/-- **Faulhaber's theorem** relating the **sum of of p-th powers** to the Bernoulli numbers:
$$\sum_{k=0}^{n-1} k^p = \sum_{i=0}^p B_i\binom{p+1}{i}\frac{n^{p+1-i}}{p+1}.$$
See https://proofwiki.org/wiki/Faulhaber%27s_Formula and [orosi2018faulhaber] for
the proof provided here. -/
theorem sum_range_pow (n p : ℕ) :
  ∑ k in range n, (k : ℚ) ^ p =
    ∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
begin
  have hne : ∀ m : ℕ, (m! : ℚ) ≠ 0 := λ m, by exact_mod_cast factorial_ne_zero m,
  -- compute the Cauchy product of two power series
  have h_cauchy : mk (λ p, bernoulli p / p!) * mk (λ q, coeff ℚ (q + 1) (exp ℚ ^ n))
                = mk (λ p, ∑ i in range (p + 1),
                      bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!),
  { ext q : 1,
    let f := λ a b, bernoulli a / a! * coeff ℚ (b + 1) (exp ℚ ^ n),
    -- key step: use `power_series.coeff_mul` and then rewrite sums
    simp only [coeff_mul, coeff_mk, cast_mul, sum_antidiagonal_eq_sum_range_succ f],
    apply sum_congr rfl,
    simp_intros m h only [finset.mem_range],
    simp only [f, exp_pow_eq_rescale_exp, rescale, one_div, coeff_mk, ring_hom.coe_mk, coeff_exp,
              ring_hom.id_apply, cast_mul, algebra_map_rat_rat],
    -- manipulate factorials and binomial coefficients
    rw [choose_eq_factorial_div_factorial h.le, eq_comm, div_eq_iff (hne q.succ), succ_eq_add_one,
        mul_assoc _ _ ↑q.succ!, mul_comm _ ↑q.succ!, ← mul_assoc, div_mul_eq_mul_div,
        mul_comm (↑n ^ (q - m + 1)), ← mul_assoc _ _ (↑n ^ (q - m + 1)), ← one_div, mul_one_div,
        div_div, tsub_add_eq_add_tsub (le_of_lt_succ h), cast_div, cast_mul],
    { ring },
    { exact factorial_mul_factorial_dvd_factorial h.le },
    { simp [hne] } },
  -- same as our goal except we pull out `p!` for convenience
  have hps : ∑ k in range n, ↑k ^ p
          = (∑ i in range (p + 1), bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!)
            * p!,
  { suffices : mk (λ p, ∑ k in range n, ↑k ^ p * algebra_map ℚ ℚ p!⁻¹)
             = mk (λ p, ∑ i in range (p + 1),
                    bernoulli i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1)!),
    { rw [← div_eq_iff (hne p), div_eq_mul_inv, sum_mul],
      rw power_series.ext_iff at this,
      simpa using this p },
    -- the power series `exp ℚ - 1` is non-zero, a fact we need in order to use `mul_right_inj'`
    have hexp : exp ℚ - 1 ≠ 0,
    { simp only [exp, power_series.ext_iff, ne, not_forall],
      use 1,
      simp },
    have h_r : exp ℚ ^ n - 1 = X * mk (λ p, coeff ℚ (p + 1) (exp ℚ ^ n)),
    { have h_const : C ℚ (constant_coeff ℚ (exp ℚ ^ n)) = 1 := by simp,
      rw [← h_const, sub_const_eq_X_mul_shift] },
    -- key step: a chain of equalities of power series
    rw [← mul_right_inj' hexp, mul_comm, ← exp_pow_sum, geom_sum_mul, h_r,
        ← bernoulli_power_series_mul_exp_sub_one, bernoulli_power_series, mul_right_comm],
    simp [h_cauchy, mul_comm] },
  -- massage `hps` into our goal
  rw [hps, sum_mul],
  refine sum_congr rfl (λ x hx, _),
  field_simp [mul_right_comm _ ↑p!, ← mul_assoc _ _ ↑p!, cast_add_one_ne_zero, hne],
end

/-- Alternate form of **Faulhaber's theorem**, relating the sum of p-th powers to the Bernoulli
numbers: $$\sum_{k=1}^{n} k^p = \sum_{i=0}^p (-1)^iB_i\binom{p+1}{i}\frac{n^{p+1-i}}{p+1}.$$
Deduced from `sum_range_pow`. -/
theorem sum_Ico_pow (n p : ℕ) :
  ∑ k in Ico 1 (n + 1), (k : ℚ) ^ p =
    ∑ i in range (p + 1), bernoulli' i * (p + 1).choose i * n ^ (p + 1 - i) / (p + 1) :=
begin
  rw ← nat.cast_succ,
  -- dispose of the trivial case
  cases p, { simp },
  let f := λ i, bernoulli i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ,
  let f' := λ i, bernoulli' i * p.succ.succ.choose i * n ^ (p.succ.succ - i) / p.succ.succ,
  suffices : ∑ k in Ico 1 n.succ, ↑k ^ p.succ = ∑ i in range p.succ.succ, f' i, { convert this },
  -- prove some algebraic facts that will make things easier for us later on
  have hle := nat.le_add_left 1 n,
  have hne : (p + 1 + 1 : ℚ) ≠ 0 := by exact_mod_cast succ_ne_zero p.succ,
  have h1 : ∀ r : ℚ, r * (p + 1 + 1) * n ^ p.succ / (p + 1 + 1 : ℚ) = r * n ^ p.succ :=
    λ r, by rw [mul_div_right_comm, mul_div_cancel _ hne],
  have h2 : f 1 + n ^ p.succ = 1 / 2 * n ^ p.succ,
  { simp_rw [f, bernoulli_one, choose_one_right, succ_sub_succ_eq_sub, cast_succ, tsub_zero, h1],
    ring },
  have : ∑ i in range p, bernoulli (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2)
       = ∑ i in range p, bernoulli' (i + 2) * (p + 2).choose (i + 2) * n ^ (p - i) / ↑(p + 2) :=
    sum_congr rfl (λ i h, by rw bernoulli_eq_bernoulli'_of_ne_one (succ_succ_ne_one i)),
  calc  ∑ k in Ico 1 n.succ, ↑k ^ p.succ
        -- replace sum over `Ico` with sum over `range` and simplify
      = ∑ k in range n.succ, ↑k ^ p.succ : by simp [sum_Ico_eq_sub _ hle, succ_ne_zero]
        -- extract the last term of the sum
  ... = ∑ k in range n, (k : ℚ) ^ p.succ + n ^ p.succ : by rw sum_range_succ
        -- apply the key lemma, `sum_range_pow`
  ... = ∑ i in range p.succ.succ, f i + n ^ p.succ : by simp [f, sum_range_pow]
        -- extract the first two terms of the sum
  ... = ∑ i in range p, f i.succ.succ + f 1 + f 0 + n ^ p.succ : by simp_rw [sum_range_succ']
  ... = ∑ i in range p, f i.succ.succ + (f 1 + n ^ p.succ) + f 0 : by ring
  ... = ∑ i in range p, f i.succ.succ + 1 / 2 * n ^ p.succ + f 0 : by rw h2
        -- convert from `bernoulli` to `bernoulli'`
  ... = ∑ i in range p, f' i.succ.succ + f' 1 + f' 0 :
        by { simp only [f, f'], simpa [h1, λ i, show i + 2 = i + 1 + 1, from rfl] }
        -- rejoin the first two terms of the sum
  ... = ∑ i in range p.succ.succ, f' i : by simp_rw [sum_range_succ'],
end

end faulhaber