/-
Copyright (c) 2021 Henry Swanson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Henry Swanson, Patrick Massot
-/
import analysis.special_functions.exponential
import combinatorics.derangements.finite
import order.filter.basic

/-!
# Derangement exponential series

This file proves that the probability of a permutation on n elements being a derangement is 1/e.
The specific lemma is `num_derangements_tendsto_inv_e`.
-/
open filter

open_locale big_operators
open_locale topological_space

theorem num_derangements_tendsto_inv_e :
  tendsto (λ n, (num_derangements n : ℝ) / n.factorial) at_top
  (𝓝 (real.exp (-1))) :=
begin
  -- we show that d(n)/n! is the partial sum of exp(-1), but offset by 1.
  -- this isn't entirely obvious, since we have to ensure that asc_factorial and
  -- factorial interact in the right way, e.g., that k ≤ n always
  let s : ℕ → ℝ := λ n, ∑ k in finset.range n, (-1 : ℝ)^k / k.factorial,
  suffices : ∀ n : ℕ, (num_derangements n : ℝ) / n.factorial = s(n+1),
  { simp_rw this,
    -- shift the function by 1, and then use the fact that the partial sums
    -- converge to the infinite sum
    rw tendsto_add_at_top_iff_nat 1,
    apply has_sum.tendsto_sum_nat,
    -- there's no specific lemma for ℝ that ∑ x^k/k! sums to exp(x), but it's
    -- true in more general fields, so use that lemma
    rw real.exp_eq_exp_ℝ_ℝ,
    exact exp_series_field_has_sum_exp (-1 : ℝ) },
  intro n,
  rw [← int.cast_coe_nat, num_derangements_sum],
  push_cast,
  rw finset.sum_div,
  -- get down to individual terms
  refine finset.sum_congr (refl _) _,
  intros k hk,
  have h_le : k ≤ n := finset.mem_range_succ_iff.mp hk,
  rw [nat.asc_factorial_eq_div, add_tsub_cancel_of_le h_le],
  push_cast [nat.factorial_dvd_factorial h_le],
  field_simp [nat.factorial_ne_zero],
  ring,
end


import data.nat.digits

open nat

-- Los dígitos de n en base b son menores que b.
lemma digits_lt_base
  (b : ℕ)
  (hb : 2 ≤ b)
  (n : ℕ)
  : ∀ d ∈ digits b n, d < b :=
begin
  cases b with b,
  { linarith },
  { cases b with b,
    { linarith },
    { clear hb,
      apply nat.strong_induction_on n,
      clear n,
      intro n,
      intro IH,
      intro d,
      intro hd,
      unfold digits at hd IH,
      have h := digits_aux_def (b+2) (by linarith) n,
      cases n with n,
      { finish },
      { replace h := h (nat.zero_lt_succ n),
        rw h at hd,
        cases hd,
        { rw hd,
          exact n.succ.mod_lt (by linarith) },
        { apply IH _ _ d hd,
          apply nat.div_lt_self (nat.succ_pos _),
          linarith }}}},
end

-- Los dígitos de la expresión decimal de un número son menores o
-- iguales que 9.
lemma digits_le_9
  (n : ℕ)
  : ∀ (d ∈ (digits 10 n)), d ≤ 9 :=
λ d hd, nat.le_of_lt_succ $ digits_lt_base 10 (by norm_num) n _ hd


import data.finset
import data.fintype
import data.fin
import data.rat

open function
open finset

variables {α : Type*} {β : Type*}
variables [fintype α] [fintype β]

namespace fintype

theorem card_image_of_injective [decidable_eq β] {f : α → β}: injective f → finset.card ((elems α).image f) = card α :=
  finset.card_image_of_injective (elems α)

end fintype

section surj

open fintype

-- for fintypes (where we can define the image), surjection is equivalent to the image being everything

lemma univ_eq_image_of_surj [decidable_eq β] (f : α → β): surjective f → elems β = image f (elems α) :=
begin
  intro,
  ext b, rw mem_image, apply iff_of_true (complete _),
  cases ‹surjective f› b with a ha,
  exact ⟨a, complete _, ha⟩,
end

lemma surj_of_univ_eq_image [decidable_eq β] (f : α → β): elems β = image f (elems α) → surjective f :=
begin
  intros h b,
  have q: b ∈ elems β := complete b,
  rw h at q,
  simp at q,
  rcases q with ⟨a, _, r⟩,
  exact ⟨a, r⟩
end

lemma univ_eq_image_iff_surj [decidable_eq β] (f : α → β): elems β = image f (elems α) ↔ surjective f :=
⟨surj_of_univ_eq_image _, univ_eq_image_of_surj _⟩

-- ed's proof
-- idea: show f is injective as well, so it's bijective, so α and β have the same cardinality: contradiction
lemma fintype.not_surjective_of_card_lt {f : α → β}
  (hcard : fintype.card α < fintype.card β) (h_surj : surjective f) : false :=
  begin
    have h_inj : injective f,
      intros a1 a2 h,
      refine @finset.inj_on_of_surj_on_of_card_le _ _ (fintype.elems α) (fintype.elems β) (λ a ha, f a)
        (λ a ha, fintype.complete _) _ (le_of_lt hcard) _ _ (fintype.complete _) (fintype.complete _) h,
      refine λ b hb, let ⟨a,ha⟩ := h_surj b in ⟨a,fintype.complete _, eq.symm ha⟩,
    apply ne_of_lt hcard,
    apply fintype.card_congr,
    apply equiv.of_bijective ⟨h_inj, h_surj⟩,
  end

-- my proof 1
-- idea: show f is injective as well, so its image is the same size as α, but it's surjective: contradiction
lemma no_surj_to_smaller_set [decidable_eq β] (hst : card α < card β) (f : α → β) : ¬ surjective f :=
begin
  intro,
  have: injective f,
    intros a1 a2 h,
    refine inj_on_of_surj_on_of_card_le (λ a _, f a) (λ _ _, mem_univ _) (λ b _, _) (le_of_lt hst) (complete _) (complete _) h,
    cases ‹surjective f› b with a _,
    exact ⟨a, complete _, ‹f a = b›.symm⟩,
  apply not_le_of_gt hst,
  rw [← card_image_of_injective ‹injective f›, ← univ_eq_image_of_surj f ‹surjective f›],
  trivial
end

-- my proof 2
-- idea: show f has an injective inverse, so the image of f⁻¹ is the same size as β, but the image is a subset of α, so card α ≥ card β
lemma ge_card_of_surj [decidable_eq α] {f : α → β} : surjective f → card β ≤ card α :=
begin
  intro,
  let f_inv := surj_inv ‹surjective f›,
  have: injective f_inv := injective_surj_inv _,
  rw ← card_image_of_injective ‹injective f_inv›,
  apply card_le_of_subset,
  apply subset_univ
end

-- apply my proof 1 to fins
lemma no_surj_to_smaller_fin (n m : ℕ) (H : n < m) (f : fin n → fin m) : ¬ surjective f :=
begin
  apply no_surj_to_smaller_set,
  repeat {rwa fintype.card_fin},
end

-- apply my proof 2 to fins
lemma no_surj_to_smaller_fin' (n m : ℕ) (H : n < m) (f : fin n → fin m) : ¬ surjective f :=
begin
  intro f_surj,
  apply not_le_of_gt H,
  rw [← fintype.card_fin m, ← fintype.card_fin n],
  apply ge_card_of_surj f_surj,
end

-- a lemma which might want to belong somewhere (effectively used in my proof 2)
lemma no_inj_to_smaller_set [decidable_eq β] (H : card β < card α) (f : α → β) : ¬ injective f :=
begin
  intro f_inj,
  have := card_image_of_injective f_inj,
  apply not_le_of_gt H,
  rw ← this,
  apply card_le_of_subset,
  apply subset_univ
end

end surj


/-
Copyright (c) 2022 Violeta Hernández Palacios. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Violeta Hernández Palacios
-/

import order.succ_pred.basic

/-!
# Successor and predecessor limits

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

We define the predicate `order.is_succ_limit` for "successor limits", values that don't cover any
others. They are so named since they can't be the successors of anything smaller. We define
`order.is_pred_limit` analogously, and prove basic results.

## Todo

The plan is to eventually replace `ordinal.is_limit` and `cardinal.is_limit` with the common
predicate `order.is_succ_limit`.
-/

variables {α : Type*}

namespace order
open function set order_dual

/-! ### Successor limits -/

section has_lt
variables [has_lt α]

/-- A successor limit is a value that doesn't cover any other.

It's so named because in a successor order, a successor limit can't be the successor of anything
smaller. -/
def is_succ_limit (a : α) : Prop := ∀ b, ¬ b ⋖ a

lemma not_is_succ_limit_iff_exists_covby (a : α) : ¬ is_succ_limit a ↔ ∃ b, b ⋖ a :=
by simp [is_succ_limit]

@[simp] lemma is_succ_limit_of_dense [densely_ordered α] (a : α) : is_succ_limit a := λ b, not_covby

end has_lt

section preorder
variables [preorder α] {a : α}

protected lemma _root_.is_min.is_succ_limit : is_min a → is_succ_limit a :=
λ h b hab, not_is_min_of_lt hab.lt h

lemma is_succ_limit_bot [order_bot α] : is_succ_limit (⊥ : α) := is_min_bot.is_succ_limit

variables [succ_order α]

protected lemma is_succ_limit.is_max (h : is_succ_limit (succ a)) : is_max a :=
by { by_contra H, exact h a (covby_succ_of_not_is_max H) }

lemma not_is_succ_limit_succ_of_not_is_max (ha : ¬ is_max a) : ¬ is_succ_limit (succ a) :=
by { contrapose! ha, exact ha.is_max }

section no_max_order
variables [no_max_order α]

lemma is_succ_limit.succ_ne (h : is_succ_limit a) (b : α) : succ b ≠ a :=
by { rintro rfl, exact not_is_max _ h.is_max }

@[simp] lemma not_is_succ_limit_succ (a : α) : ¬ is_succ_limit (succ a) := λ h, h.succ_ne _ rfl

end no_max_order

section is_succ_archimedean
variable [is_succ_archimedean α]

lemma is_succ_limit.is_min_of_no_max [no_max_order α] (h : is_succ_limit a) : is_min a :=
λ b hb, begin
  rcases hb.exists_succ_iterate with ⟨_ | n, rfl⟩,
  { exact le_rfl },
  { rw iterate_succ_apply' at h,
    exact (not_is_succ_limit_succ _ h).elim }
end

@[simp] lemma is_succ_limit_iff_of_no_max [no_max_order α] : is_succ_limit a ↔ is_min a :=
⟨is_succ_limit.is_min_of_no_max, is_min.is_succ_limit⟩

lemma not_is_succ_limit_of_no_max [no_min_order α] [no_max_order α] : ¬ is_succ_limit a := by simp

end is_succ_archimedean
end preorder

section partial_order
variables [partial_order α] [succ_order α] {a b : α} {C : α → Sort*}

lemma is_succ_limit_of_succ_ne (h : ∀ b, succ b ≠ a) : is_succ_limit a := λ b hba, h b hba.succ_eq

lemma not_is_succ_limit_iff : ¬ is_succ_limit a ↔ ∃ b, ¬ is_max b ∧ succ b = a :=
begin
  rw not_is_succ_limit_iff_exists_covby,
  refine exists_congr (λ b, ⟨λ hba, ⟨hba.lt.not_is_max, hba.succ_eq⟩, _⟩),
  rintro ⟨h, rfl⟩,
  exact covby_succ_of_not_is_max h
end

/-- See `not_is_succ_limit_iff` for a version that states that `a` is a successor of a value other
than itself. -/
lemma mem_range_succ_of_not_is_succ_limit (h : ¬ is_succ_limit a) : a ∈ range (@succ α _ _) :=
by { cases not_is_succ_limit_iff.1 h with b hb, exact ⟨b, hb.2⟩ }

lemma is_succ_limit_of_succ_lt (H : ∀ a < b, succ a < b) : is_succ_limit b :=
λ a hab, (H a hab.lt).ne hab.succ_eq

lemma is_succ_limit.succ_lt (hb : is_succ_limit b) (ha : a < b) : succ a < b :=
begin
  by_cases h : is_max a,
  { rwa h.succ_eq },
  { rw [lt_iff_le_and_ne, succ_le_iff_of_not_is_max h],
    refine ⟨ha, λ hab, _⟩,
    subst hab,
    exact (h hb.is_max).elim }
end

lemma is_succ_limit.succ_lt_iff (hb : is_succ_limit b) : succ a < b ↔ a < b :=
⟨λ h, (le_succ a).trans_lt h, hb.succ_lt⟩

lemma is_succ_limit_iff_succ_lt : is_succ_limit b ↔ ∀ a < b, succ a < b :=
⟨λ hb a, hb.succ_lt, is_succ_limit_of_succ_lt⟩

/-- A value can be built by building it on successors and successor limits. -/
@[elab_as_eliminator] noncomputable def is_succ_limit_rec_on (b : α)
  (hs : Π a, ¬ is_max a → C (succ a)) (hl : Π a, is_succ_limit a → C a) : C b :=
begin
  by_cases hb : is_succ_limit b,
  { exact hl b hb },
  { have H := classical.some_spec (not_is_succ_limit_iff.1 hb),
    rw ←H.2,
    exact hs _ H.1 }
end

lemma is_succ_limit_rec_on_limit (hs : Π a, ¬ is_max a → C (succ a))
  (hl : Π a, is_succ_limit a → C a) (hb : is_succ_limit b) :
  @is_succ_limit_rec_on α _ _ C b hs hl = hl b hb :=
by { classical, exact dif_pos hb }

lemma is_succ_limit_rec_on_succ' (hs : Π a, ¬ is_max a → C (succ a))
  (hl : Π a, is_succ_limit a → C a) {b : α} (hb : ¬ is_max b) :
  @is_succ_limit_rec_on α _ _ C (succ b) hs hl = hs b hb :=
begin
  have hb' := not_is_succ_limit_succ_of_not_is_max hb,
  have H := classical.some_spec (not_is_succ_limit_iff.1 hb'),
  rw is_succ_limit_rec_on,
  simp only [cast_eq_iff_heq, hb', not_false_iff, eq_mpr_eq_cast, dif_neg],
  congr,
  { exact (succ_eq_succ_iff_of_not_is_max H.1 hb).1 H.2 },
  { apply proof_irrel_heq }
end

section no_max_order
variables [no_max_order α]

@[simp] lemma is_succ_limit_rec_on_succ (hs : Π a, ¬ is_max a → C (succ a))
  (hl : Π a, is_succ_limit a → C a) (b : α) :
  @is_succ_limit_rec_on α _ _ C (succ b) hs hl = hs b (not_is_max b) :=
is_succ_limit_rec_on_succ' _ _ _

lemma is_succ_limit_iff_succ_ne : is_succ_limit a ↔ ∀ b, succ b ≠ a :=
⟨is_succ_limit.succ_ne, is_succ_limit_of_succ_ne⟩

lemma not_is_succ_limit_iff' : ¬ is_succ_limit a ↔ a ∈ range (@succ α _ _) :=
by { simp_rw [is_succ_limit_iff_succ_ne, not_forall, not_ne_iff], refl }

end no_max_order

section is_succ_archimedean
variable [is_succ_archimedean α]

protected lemma is_succ_limit.is_min (h : is_succ_limit a) : is_min a :=
λ b hb, begin
  revert h,
  refine succ.rec (λ _, le_rfl) (λ c hbc H hc, _) hb,
  have := hc.is_max.succ_eq,
  rw this at hc ⊢,
  exact H hc
end

@[simp] lemma is_succ_limit_iff : is_succ_limit a ↔ is_min a :=
⟨is_succ_limit.is_min, is_min.is_succ_limit⟩

lemma not_is_succ_limit [no_min_order α] : ¬ is_succ_limit a := by simp

end is_succ_archimedean
end partial_order

/-! ### Predecessor limits -/

section has_lt
variables [has_lt α] {a : α}

/-- A predecessor limit is a value that isn't covered by any other.

It's so named because in a predecessor order, a predecessor limit can't be the predecessor of
anything greater. -/
def is_pred_limit (a : α) : Prop := ∀ b, ¬ a ⋖ b

lemma not_is_pred_limit_iff_exists_covby (a : α) : ¬ is_pred_limit a ↔ ∃ b, a ⋖ b :=
by simp [is_pred_limit]

lemma is_pred_limit_of_dense [densely_ordered α] (a : α) : is_pred_limit a := λ b, not_covby

@[simp] lemma is_succ_limit_to_dual_iff : is_succ_limit (to_dual a) ↔ is_pred_limit a :=
by simp [is_succ_limit, is_pred_limit]

@[simp] lemma is_pred_limit_to_dual_iff : is_pred_limit (to_dual a) ↔ is_succ_limit a :=
by simp [is_succ_limit, is_pred_limit]

alias is_succ_limit_to_dual_iff ↔ _ is_pred_limit.dual
alias is_pred_limit_to_dual_iff ↔ _ is_succ_limit.dual

end has_lt

section preorder
variables [preorder α] {a : α}

protected lemma _root_.is_max.is_pred_limit : is_max a → is_pred_limit a :=
λ h b hab, not_is_max_of_lt hab.lt h

lemma is_pred_limit_top [order_top α] : is_pred_limit (⊤ : α) := is_max_top.is_pred_limit

variables [pred_order α]

protected lemma is_pred_limit.is_min (h : is_pred_limit (pred a)) : is_min a :=
by { by_contra H, exact h a (pred_covby_of_not_is_min H) }

section no_min_order
variables [no_min_order α]

lemma is_pred_limit.pred_ne (h : is_pred_limit a) (b : α) : pred b ≠ a :=
by { rintro rfl, exact not_is_min _ h.is_min }

@[simp] lemma not_is_pred_limit_pred (a : α) : ¬ is_pred_limit (pred a) := λ h, h.pred_ne _ rfl

end no_min_order

section is_pred_archimedean
variables [is_pred_archimedean α]

protected lemma is_pred_limit.is_max_of_no_min [no_min_order α] (h : is_pred_limit a) : is_max a :=
h.dual.is_min_of_no_max

@[simp] lemma is_pred_limit_iff_of_no_min [no_min_order α] : is_pred_limit a ↔ is_max a :=
is_succ_limit_to_dual_iff.symm.trans is_succ_limit_iff_of_no_max

lemma not_is_pred_limit_of_no_min [no_min_order α] [no_max_order α] : ¬ is_pred_limit a :=
by simp

end is_pred_archimedean
end preorder

section partial_order
variables [partial_order α] [pred_order α] {a b : α} {C : α → Sort*}

lemma is_pred_limit_of_pred_ne (h : ∀ b, pred b ≠ a) : is_pred_limit a := λ b hba, h b hba.pred_eq

lemma not_is_pred_limit_iff : ¬ is_pred_limit a ↔ ∃ b, ¬ is_min b ∧ pred b = a :=
by { rw ←is_succ_limit_to_dual_iff, exact not_is_succ_limit_iff }

/-- See `not_is_pred_limit_iff` for a version that states that `a` is a successor of a value other
than itself. -/
lemma mem_range_pred_of_not_is_pred_limit (h : ¬ is_pred_limit a) : a ∈ range (@pred α _ _) :=
by { cases not_is_pred_limit_iff.1 h with b hb, exact ⟨b, hb.2⟩ }

lemma is_pred_limit_of_pred_lt (H : ∀ a > b, pred a < b) : is_pred_limit b :=
λ a hab, (H a hab.lt).ne hab.pred_eq

lemma is_pred_limit.lt_pred (h : is_pred_limit a) : a < b → a < pred b := h.dual.succ_lt
lemma is_pred_limit.lt_pred_iff (h : is_pred_limit a) : a < pred b ↔ a < b := h.dual.succ_lt_iff

lemma is_pred_limit_iff_lt_pred : is_pred_limit a ↔ ∀ ⦃b⦄, a < b → a < pred b :=
is_succ_limit_to_dual_iff.symm.trans is_succ_limit_iff_succ_lt

/-- A value can be built by building it on predecessors and predecessor limits. -/
@[elab_as_eliminator] noncomputable def is_pred_limit_rec_on (b : α)
  (hs : Π a, ¬ is_min a → C (pred a)) (hl : Π a, is_pred_limit a → C a) : C b :=
@is_succ_limit_rec_on αᵒᵈ _ _ _ _ hs (λ a ha, hl _ ha.dual)

lemma is_pred_limit_rec_on_limit (hs : Π a, ¬ is_min a → C (pred a))
  (hl : Π a, is_pred_limit a → C a) (hb : is_pred_limit b) :
  @is_pred_limit_rec_on α _ _ C b hs hl = hl b hb :=
is_succ_limit_rec_on_limit _ _ hb.dual

lemma is_pred_limit_rec_on_pred' (hs : Π a, ¬ is_min a → C (pred a))
  (hl : Π a, is_pred_limit a → C a) {b : α} (hb : ¬ is_min b) :
  @is_pred_limit_rec_on α _ _ C (pred b) hs hl = hs b hb :=
is_succ_limit_rec_on_succ' _ _ _

section no_min_order
variables [no_min_order α]

@[simp] theorem is_pred_limit_rec_on_pred (hs : Π a, ¬ is_min a → C (pred a))
  (hl : Π a, is_pred_limit a → C a) (b : α) :
  @is_pred_limit_rec_on α _ _ C (pred b) hs hl = hs b (not_is_min b) :=
is_succ_limit_rec_on_succ _ _ _

end no_min_order

section is_pred_archimedean
variable [is_pred_archimedean α]

protected lemma is_pred_limit.is_max (h : is_pred_limit a) : is_max a := h.dual.is_min

@[simp] lemma is_pred_limit_iff : is_pred_limit a ↔ is_max a :=
is_succ_limit_to_dual_iff.symm.trans is_succ_limit_iff

lemma not_is_pred_limit [no_max_order α] : ¬ is_pred_limit a := by simp

end is_pred_archimedean
end partial_order
end order


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import number_theory.class_number.admissible_card_pow_degree
import number_theory.class_number.finite
import number_theory.function_field

/-!
# Class numbers of function fields

This file defines the class number of a function field as the (finite) cardinality of
the class group of its ring of integers. It also proves some elementary results
on the class number.

## Main definitions
- `function_field.class_number`: the class number of a function field is the (finite)
cardinality of the class group of its ring of integers
-/

namespace function_field
open_locale polynomial

variables (Fq F : Type) [field Fq] [fintype Fq] [field F]
variables [algebra Fq[X] F] [algebra (ratfunc Fq) F]
variables [is_scalar_tower Fq[X] (ratfunc Fq) F]
variables [function_field Fq F] [is_separable (ratfunc Fq) F]

open_locale classical

namespace ring_of_integers

open function_field

noncomputable instance  : fintype (class_group (ring_of_integers Fq F)) :=
class_group.fintype_of_admissible_of_finite (ratfunc Fq) F
  (polynomial.card_pow_degree_is_admissible : absolute_value.is_admissible
    (polynomial.card_pow_degree : absolute_value Fq[X] ℤ))

end ring_of_integers

/-- The class number in a function field is the (finite) cardinality of the class group. -/
noncomputable def class_number : ℕ := fintype.card (class_group (ring_of_integers Fq F))

/-- The class number of a function field is `1` iff the ring of integers is a PID. -/
theorem class_number_eq_one_iff :
  class_number Fq F = 1 ↔ is_principal_ideal_ring (ring_of_integers Fq F) :=
card_class_group_eq_one_iff

end function_field


-- begin header

import M40001.M40001_C2

namespace numbers

variables {X Y : Type}
-- end header

/- Section
Chapter 2. Numbers
-/

/- Sub-section
Countability
-/

/-
We will be proving the Well-Ordered Principle (A non-empty set of natural numbers
has a least element) as it will be usful for proving theorems regarding countability.

In LEAN's maths library, there is a useful lemma that does the samething.
See nat.find
-/

open function M40001

/- Theorem
The Well-Ordered Principle. If $S$ is a set of natural numbers and is non-empty, then there exists an element $n ∈ S, ∀s ∈ S, n ≤ s$.
-/
theorem well_ordered_principle (S : set ℕ) (h : S ≠ ∅) : ∃ n ∈ S, ∀ s ∈ S, n ≤ s :=
begin
-- We'll prove the Well-Ordered Principle by contradiction. Suppose there exist $∅ ≠ S ⊂ ℕ$, $S$ does not have a least element.
  apply classical.by_contradiction, push_neg, intro ha,
-- Then let us create the set $B := {n ∈ ℕ | ∀ x ≤ n, x ∉ S}$. (Notice that all elements of $S$ are bigger that all elements of $B$.)
  let B := {n : ℕ | ∀ x ≤ n, x ∉ S},
-- I claim that $B = ℕ$.
  have : ∀ x : ℕ, x ∈ B,
-- We will prove this by doing an induction on $x$.
    by {intro x, induction x with k hk,
-- We first need to prove that $0 ∈ B$. As we have $∀ s ∈ S, s ∈ ℕ ⇒ s ≥ 0$, it suffices to prove that $0 ∉ S$.
      {rw set.mem_set_of_eq,
      intros x hb hc,
      replace hb : x = 0 :=
        by {revert hb, simp},
      rw hb at hc,
-- But if $0 ∈ S$ then $S$ has a minimum, $0$ can't be in $S$, implying $0 ∈ B$.
    have : ∃ (s : ℕ), s ∈ S ∧ s < 0 := by {apply ha 0, assumption},
    rcases this with ⟨y, ⟨_, he⟩⟩,
    refine not_lt_of_ge _ he, norm_num,
    },
-- Now assume $k ∈ B$ for some $k ∈ ℕ$, then we need to prove $k + 1 ∈ B$, i.e. we need to prove $∀ x ∈ ℕ, x ≤ k + 1 → x ∉ S$.
    {rw set.mem_set_of_eq at hk,
    rw set.mem_set_of_eq,
-- Let $x$ be an arbitary natural number thats less than $k + 1$. Suppose $x ∈ S$, we will show a contradiction.
    intros x hx hb,
-- As $x ≤ k ⇔ x < k + 1$, we have $x < k + 1 → x ∉ S$.
    have hl : x < k + 1 → x ∉ S := by {rwa nat.lt_succ_iff, from hk x},
-- Then as we have assumed $x ∈ S$, $x ≥ k + 1$ since $x < k + 1 → x ∉ S$.
    have : x = k + 1 :=
      by {cases lt_trichotomy x (k + 1),
        {exfalso, from (hl h_1) hb},
        {cases h_1,
          {assumption},
-- But we have $x < k + 1$, thus, by the trichotomy axiom, $x = k + 1$.
          {have : k + 1 < x ∧ x ≤ nat.succ k := ⟨h_1, hx⟩,
          revert this, simp
          } } },
-- Then, as $S$ has no least element, there is some $s ∈ S, s < k + 1$.
    rw this at hb,
    have hc : ∃ (s : ℕ), s ∈ S ∧ s < k + 1 := by {apply ha, assumption},
    rcases hc with ⟨y, ⟨hd, he⟩⟩,
-- But as $k ∈ B$, $s < k + 1 ⇒ s ∉ S$, we have a contradiction! Therefore, by mathematical induction, we have $B = ℕ$
    apply hk y,
    rwa ←nat.lt_succ_iff, assumption
    } },
-- As, by construction, we have $S$ and $B$ are disjoint. Thus, since $S ⊆ ℕ, B = ℕ ⇒ S = ∅$.
  apply h,
  have hSempty : ∀ n ∈ B, n ∉ S :=
    by {intros n hn hs,
    rw set.mem_set_of_eq at hn,
    apply hn n, refl, assumption
    },
  ext, split,
  all_goals {intro he},
  {from hSempty x (this x) he},
-- But $S = ∅$ is a contradiction as we assumed its non-empty. Thus such an $S$ does not exist!
  {simp at he, contradiction}
end

/- Definition
A set $S$ is countable if and only if there exists a bijection $f : ℕ → S$.
-/
def countable (A : set(X)) := ∃ f : ℕ → A, bijective f

/-
Intuitively, we can think of this as putting the elements of $S$ into a list with no repeates.
-/

lemma inverse_refl (f : X → Y) (g : Y → X): two_sided_inverse f g ↔ two_sided_inverse g f :=
by {split,
  all_goals {rintro ⟨ha, hb⟩, from ⟨hb, ha⟩},
}

/- Theorem
 Given a set $A$, if there exists a function $f : A → ℕ$ where $f$ is bijective then $A$ is countable.
-/
theorem countable_rev : ∀ (S : set X), countable S ↔ (∃ g : S → ℕ, bijective g) :=
begin
  intro S,
  split,
    all_goals{rintro ⟨f, hf⟩},
    {suffices : ∃ (g : S → ℕ), two_sided_inverse f g,
      by {cases this with g hg, use g,
      rw ←exist_two_sided_inverse, use f, rwa inverse_refl},
    rwa exist_two_sided_inverse,
    },

    {have : ∃ (g : ℕ → S), two_sided_inverse f g,
      by {rwa exist_two_sided_inverse},
    cases this with g hg,
    use g,
    rwa ←exist_two_sided_inverse,
    use f, rwa inverse_refl
    }
end

end numbers


theorem add_comm : ∀ (n m : Nat), n + m = m + n
  | n, 0   => Eq.symm (Nat.zero_add n)
  | n, m+1 => by
    have : Nat.succ (n + m) = Nat.succ (m + n) :=
      by apply congrArg; apply Nat.add_comm
    rw [Nat.succ_add m n]
    apply this


import data.nat.modeq
import recursions

lemma div_algo (a b: ℕ ): ∃ (q : ℕ) , a=b*q+(a%b) :=
begin
    have t1: b ∣ a-(a%b), apply nat.dvd_sub_mod,
    cases t1 with x y, use x, rw ← y,
    apply int.coe_nat_inj, push_cast, rw int.coe_nat_sub (nat.mod_le a b), ring,
end

lemma fib_pos : ∀ m: ℕ, fib(m+1) >0:=
begin
    apply nat.two_step_induction,
    {simp},
    {simp},
    {intros, simp,linarith}
end

lemma luc_pos : ∀ m: ℕ, luc(m) >0:=
begin
    apply nat.two_step_induction,
    {simp},
    {simp},
    {intros, rw luc_add, linarith}
end

lemma gcd_add (a b c: ℕ  ) (h: a = b +c): nat.gcd a b = nat.gcd b c:=
begin
    cases nat.gcd_dvd b c,
    have h1: nat.gcd b c ∣ b + c,
    {apply dvd_add, exact left, exact right},
    rw ← h at h1,
    have h2: nat.gcd b c ∣ nat.gcd a b,
    {rw nat.dvd_gcd_iff, split, exact h1, exact left},
    clear left, clear right,
    cases nat.gcd_dvd a b,
    have h3: (nat.gcd a b :ℤ ) ∣  (a - b :ℤ) ,
    {apply dvd_sub, norm_cast, exact left, norm_cast, exact right},
    nth_rewrite 1 h at h3,
    have h4: nat.gcd a b ∣ nat.gcd b c,
    {rw nat.dvd_gcd_iff, split,
    {exact right},
    {simp at h3, norm_cast at h3, assumption}},
    apply nat.dvd_antisymm h4 h2,
end

lemma fib_coprime (m: ℕ ) : nat.gcd (fib(m+1)) (fib(m+2)) = 1:=
begin
    induction m with d hd,
    {ring},
    nth_rewrite 1 fib_add, rw  nat.gcd_comm, rw gcd_add,
    {rw nat.gcd_comm, exact hd},
    {simp}
end

lemma fib_even (m : ℕ) : fib (3*m) %2 =0 ∧  fib (3*m +1) % 2 =1  ∧ fib (3*m+2)%2=1 :=
begin
    induction m with d hd,
    {simp, ring},
    {cases hd with h1 h2, cases h2 with h2 h3,
    have g1:fib (3*d+3)%2=0,
    {rw fib_add, rw nat.add_mod, simp * at *},
    have g2: fib(3*d+4)%2=1,
    {rw fib_add, rw nat.add_mod, rw g1, rw h3, ring},
    have g3: fib(3*d+5)%2=1,
    {rw fib_add, rw nat.add_mod, rw g2, rw g1, ring},
    repeat{rw nat.succ_eq_add_one}, ring, cc}
end

lemma fib_luc_gcd_div_2 (m: ℕ ) : nat.gcd (fib(m+2)) (luc(m+2)) =nat.gcd (fib(m+2)) 2:=
begin
    have h1: nat.gcd (fib(m+2)) (luc(m+2)) =nat.gcd (fib(m+2)) (2 * fib(m+1)),
    {rw  fib_luc_rec, rw fib_add, rw nat.gcd_comm, rw gcd_add, simp, ring},
    rw h1, apply nat.coprime.gcd_mul_right_cancel_right, apply fib_coprime
end

lemma fib_luc_gcd (m: ℕ ) : nat.gcd (fib(3*m)) (luc(3*m)) = 2  :=
begin
    cases nat_case_bash m 0, interval_cases m,
    {cases h with h h2, rw [show h+0+1 =h+1, from rfl] at h2, rw h2, rw mul_add, rw [show 3*1 = 1+2, by ring], rw fib_luc_gcd_div_2,
    rw [show 3*h+1+2 = 3*(h+1), by ring],
    rw ← nat.gcd_eq_right_iff_dvd, rw nat.dvd_iff_mod_eq_zero,  simp[fib_even]},
    {ring},
end

lemma fib_luc_gcd_2 (m : ℕ) (h: m%3 ≠ 0): nat.gcd (fib(m)) (luc(m))=1 :=
begin
    cases nat_case_bash m 1, interval_cases m,
    {cases h_1 with u h1, rw h1, rw fib_luc_gcd_div_2, rw nat.gcd_comm, rw ← nat.coprime,  rw nat.prime.coprime_iff_not_dvd nat.prime_two,
    by_contra,
    have h2 := nat.mod_eq_zero_of_dvd a, have h3:= nat.mod_lt m (show 3>0, by linarith),
    have h4:= div_algo m 3, cases h4 with d h4, have h5:=fib_even d, interval_cases m%3,
    {rw h_1 at h4, rw ← h1 at h2, rw h4 at h2, cc},
    {rw h_1 at h4, rw ← h1 at h2, rw h4 at h2, cc}},
    {simp at h, exfalso, exact h},
    {simp}
end


/-
Copyright (c) 2023 Mark Andrew Gerads. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mark Andrew Gerads, Junyan Xu, Eric Wieser

! This file was ported from Lean 3 source module data.nat.hyperoperation
! leanprover-community/mathlib commit f7fc89d5d5ff1db2d1242c7bb0e9062ce47ef47c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Tactic.Ring
import Mathlib.Data.Nat.Parity

/-!
# Hyperoperation sequence

This file defines the Hyperoperation sequence.
`hyperoperation 0 m k = k + 1`
`hyperoperation 1 m k = m + k`
`hyperoperation 2 m k = m * k`
`hyperoperation 3 m k = m ^ k`
`hyperoperation (n + 3) m 0 = 1`
`hyperoperation (n + 1) m (k + 1) = hyperoperation n m (hyperoperation (n + 1) m k)`

## References

* <https://en.wikipedia.org/wiki/Hyperoperation>

## Tags

hyperoperation
-/

/-- Implementation of the hyperoperation sequence
where `hyperoperation n m k` is the `n`th hyperoperation between `m` and `k`.
-/
-- porting note: termination_by was not required before port
def hyperoperation : ℕ → ℕ → ℕ → ℕ
  | 0, _, k => k + 1
  | 1, m, 0 => m
  | 2, _, 0 => 0
  | _ + 3, _, 0 => 1
  | n + 1, m, k + 1 => hyperoperation n m (hyperoperation (n + 1) m k)
  termination_by hyperoperation a b c => (a, b, c)
#align hyperoperation hyperoperation

-- Basic hyperoperation lemmas
@[simp]
theorem hyperoperation_zero (m : ℕ) : hyperoperation 0 m = Nat.succ :=
  funext fun k => by rw [hyperoperation, Nat.succ_eq_add_one]
#align hyperoperation_zero hyperoperation_zero

theorem hyperoperation_ge_three_eq_one (n m : ℕ) : hyperoperation (n + 3) m 0 = 1 := by
  rw [hyperoperation]
#align hyperoperation_ge_three_eq_one hyperoperation_ge_three_eq_one

theorem hyperoperation_recursion (n m k : ℕ) :
    hyperoperation (n + 1) m (k + 1) = hyperoperation n m (hyperoperation (n + 1) m k) := by
  rw [hyperoperation]
#align hyperoperation_recursion hyperoperation_recursion

-- Interesting hyperoperation lemmas
@[simp]
theorem hyperoperation_one : hyperoperation 1 = (· + ·) := by
  ext (m k)
  induction' k with bn bih
  · rw [Nat.add_zero m, hyperoperation]
  · rw [hyperoperation_recursion, bih, hyperoperation_zero]
    exact Nat.add_assoc m bn 1
#align hyperoperation_one hyperoperation_one

@[simp]
theorem hyperoperation_two : hyperoperation 2 = (· * ·) := by
  ext (m k)
  induction' k with bn bih
  · rw [hyperoperation]
    exact (Nat.mul_zero m).symm
  · rw [hyperoperation_recursion, hyperoperation_one, bih]
    -- porting note: was `ring`
    dsimp only
    nth_rewrite 1 [← mul_one m]
    rw [← mul_add, add_comm, Nat.succ_eq_add_one]
#align hyperoperation_two hyperoperation_two

@[simp]
theorem hyperoperation_three : hyperoperation 3 = (· ^ ·) := by
  ext (m k)
  induction' k with bn bih
  · rw [hyperoperation_ge_three_eq_one]
    exact (pow_zero m).symm
  · rw [hyperoperation_recursion, hyperoperation_two, bih]
    exact (pow_succ m bn).symm
#align hyperoperation_three hyperoperation_three

theorem hyperoperation_ge_two_eq_self (n m : ℕ) : hyperoperation (n + 2) m 1 = m := by
  induction' n with nn nih
  · rw [hyperoperation_two]
    ring
  · rw [hyperoperation_recursion, hyperoperation_ge_three_eq_one, nih]
#align hyperoperation_ge_two_eq_self hyperoperation_ge_two_eq_self

theorem hyperoperation_two_two_eq_four (n : ℕ) : hyperoperation (n + 1) 2 2 = 4 := by
  induction' n with nn nih
  · rw [hyperoperation_one]
  · rw [hyperoperation_recursion, hyperoperation_ge_two_eq_self, nih]
#align hyperoperation_two_two_eq_four hyperoperation_two_two_eq_four

theorem hyperoperation_ge_three_one (n : ℕ) : ∀ k : ℕ, hyperoperation (n + 3) 1 k = 1 := by
  induction' n with nn nih
  · intro k
    rw [hyperoperation_three]
    dsimp
    rw [one_pow]
  · intro k
    cases k
    · rw [hyperoperation_ge_three_eq_one]
    · rw [hyperoperation_recursion, nih]
#align hyperoperation_ge_three_one hyperoperation_ge_three_one

theorem hyperoperation_ge_four_zero (n k : ℕ) :
    hyperoperation (n + 4) 0 k = if Even k then 1 else 0 := by
  induction' k with kk kih
  · rw [hyperoperation_ge_three_eq_one]
    simp only [even_zero, if_true]
  · rw [hyperoperation_recursion]
    rw [kih]
    simp_rw [Nat.even_add_one]
    split_ifs
    · exact hyperoperation_ge_two_eq_self (n + 1) 0
    · exact hyperoperation_ge_three_eq_one n 0
#align hyperoperation_ge_four_zero hyperoperation_ge_four_zero


import basic

/-

In this file, we formalize a proof of Arrow's Impossibility Theorem.
We closely follow the first proof in this 2005 paper by John Geankopolos:
* https://link.springer.com/article/10.1007/s00199-004-0556-7

Arrow's Impossibility Theorem has been formalized in other languages before.

Freek Wiedijk wrote a formalization in Mizar:
* https://link.springer.com/article/10.1007/s12046-009-0005-1

Tobias Nipkow wrote a formalization in Isabelle/HOL:
* https://link.springer.com/article/10.1007/s10817-009-9147-4

At times, our formalization is a close translation of Nipkow's proof in HOL.
In particular, our definition of functions `maketop`, `makebot`, and `makeabove` are
inspired by his strategy for manipulating preferences. However, Nipkow defines preference orders
in a completely different way from our `basic` file.
-/

open relation vector finset

-- We think of social states as type `σ` and inidividuals as type `ι`
variables {σ ι : Type} {x y x' y' a b : σ} {r r' : σ → σ → Prop} {X : finset σ}

/-! ### Some basic definitions and lemmas -/

/-- A social state `b` is *strictly worst* of a finite set of social states `X` with respect to
  a ranking `p` if `b` is ranked strictly lower than every other `a ∈ X`. -/
def is_strictly_worst (b : σ) (r : σ → σ → Prop) (X : finset σ) : Prop :=
∀ a ∈ X, a ≠ b → P r a b

/-- A social state `b` is *strictly best* of a finite set of social states `X` with respect to
  a ranking `p` if `b` is ranked strictly higher than every other `a ∈ X`. -/
def is_strictly_best (b : σ) (r : σ → σ → Prop) (X : finset σ) : Prop :=
∀ a ∈ X, a ≠ b → P r b a

/-- A social state `b` is *extremal* with respect to a finite set of social states `X`
  and a ranking `p` if `b` is either strictly worst or strictly best of `X`. -/
def is_extremal (b : σ) (r : σ → σ → Prop) (X : finset σ) : Prop :=
is_strictly_worst b r X ∨ is_strictly_best b r X

lemma not_strictly_worst : ¬is_strictly_worst b r X ↔ ∃ a (h : a ∈ X) (h : a ≠ b), ¬P r a b :=
by simp only [is_strictly_worst, not_forall]

lemma not_strictly_best : ¬is_strictly_best b r X ↔ ∃ a (h : a ∈ X) (h : a ≠ b), ¬P r b a :=
by simp only [is_strictly_best, not_forall]

lemma not_extremal : ¬is_extremal b r X ↔
  (∃ a (h : a ∈ X) (h : a ≠ b), ¬P r a b) ∧ (∃ c (h : c ∈ X) (h : c ≠ b), ¬P r b c) :=
by simp only [is_extremal, not_or_distrib, not_strictly_worst, not_strictly_best]

lemma not_extremal' (hr : total r) (h : ¬ is_extremal b r X) : -- maybe make an `iff`? maybe combine with `exists_of_not_extremal`? -Ben
  ∃ a c ∈ X, a ≠ b ∧ c ≠ b ∧ r a b ∧ r b c :=
let ⟨⟨c, hc, hcb, hPc⟩, ⟨a, ha, hab, hPa⟩⟩ := not_extremal.mp h in
  ⟨a, c, ha, hc, hab, hcb, R_of_nP_total hr hPa, R_of_nP_total hr hPc⟩

lemma is_strictly_best.not_strictly_worst (htop : is_strictly_best b r X) (h : ∃ a ∈ X, a ≠ b) :
  ¬is_strictly_worst b r X :=
let ⟨a, a_in, hab⟩ := h in not_strictly_worst.mpr ⟨a, a_in, hab, nP_of_reverseP (htop a a_in hab)⟩

lemma is_strictly_best.not_strictly_worst' (htop : is_strictly_best b r X) (hX : 2 ≤ X.card) (hb : b ∈ X) :
  ¬is_strictly_worst b r X :=
htop.not_strictly_worst $ exists_second_distinct_mem hX hb

lemma is_strictly_worst.not_strictly_best (hbot : is_strictly_worst b r X) (h : ∃ a ∈ X, a ≠ b) :
  ¬is_strictly_best b r X :=
let ⟨a, a_in, hab⟩ := h in not_strictly_best.mpr ⟨a, a_in, hab, nP_of_reverseP (hbot a a_in hab)⟩

lemma is_strictly_worst.not_strictly_best' (hbot : is_strictly_worst b r X) (hX : 2 ≤ X.card) (hb : b ∈ X) :
 ¬is_strictly_best b r X :=
hbot.not_strictly_best $ exists_second_distinct_mem hX hb

lemma is_extremal.is_strictly_best (hextr : is_extremal b r X) (not_strictly_worst : ¬is_strictly_worst b r X) :
  is_strictly_best b r X :=
hextr.resolve_left not_strictly_worst

lemma is_extremal.is_strictly_worst (hextr : is_extremal b r X) (not_strictly_best : ¬is_strictly_best b r X) :
  is_strictly_worst b r X :=
hextr.resolve_right not_strictly_best

lemma is_strictly_worst.is_extremal (hbot : is_strictly_worst b r X) : is_extremal b r X :=
or.inl hbot

lemma is_strictly_best.is_extremal (hbot : is_strictly_best b r X) : is_extremal b r X :=
or.inr hbot

/-! ### "Make" functions -/

local attribute [instance] classical.prop_decidable

/-- Given an arbitary preference order `r` and a social state `b`,
  `maketop r b` updates `r` so that `b` is now ranked strictly higher
  than any other social state.
  The definition also contains a proof that this new relation is a `pref_order σ`. --/
def maketop (r : pref_order σ) (b : σ) : pref_order σ :=
begin
  use λ x y, if x = b then true else if y = b then false else r x y,
  { intro x,
    split_ifs,
    { trivial },
    { exact r.refl x } },
  { intros x y, simp only,
    split_ifs with hx _ hy,
    work_on_goal 3 { exact r.total x y },
    all_goals { simp only [or_true, true_or] } },
  { intros x y z, simp only,
    split_ifs with hx _ _ hy _ hz; intros hxy hyz,
    work_on_goal 6 { exact r.trans hxy hyz },
    all_goals { trivial } },
end

/-- Given an arbitary preference order `r` and a social state `b`,
  `makebot r b` updates `r` so that every other social state is now ranked
  strictly higher than `b`.
  The definition also contains a proof that this new relation is a `pref_order σ`. --/
def makebot (r : pref_order σ) (b : σ) : pref_order σ :=
begin
  use λ x y, if y = b then true else if x = b then false else r x y,
  { intro x,
    split_ifs,
    { trivial },
    { exact r.refl x } },
  { intros x y, simp only,
    split_ifs with hx _ hy,
    work_on_goal 3 { exact r.total x y },
    all_goals { simp only [or_true, true_or] } },
  { intros x y z, simp only,
    split_ifs with hx _ _ hy _ hz; intros hxy hyz,
    work_on_goal 6 { exact r.trans hxy hyz },
    all_goals { trivial } },
end

/-- Given an arbitary preference order `r` and two social states `a` and `b`,
  `makebot r a b` updates `r` so that:
  (1) `b` is strictly higher than `a` and any other social state `y` where `r a y`
  (2) any other social state that is strictly higher than `a` is strictly higher than `b`.
  Intuitively, we have moved `b` just above `a` in the ordering.
  The definition also contains a proof that this new relation is a `pref_order σ`. --/
def makeabove (r : pref_order σ) (a b : σ) : pref_order σ :=
begin
  use λ x y, if x = b then if y = b then true else if r a y then true else false
             else if y = b then if r a x then false else true else r x y,
  { intro x,
    split_ifs,
    { trivial },
    { exact r.refl x } },
  { intros x y, simp only,
    split_ifs,
    work_on_goal 5 { exact r.total x y },
    all_goals { simp only [or_true, true_or] } },
  { intros x y z, simp only,
    split_ifs with hx hy _ _ hay hz haz _ _ hy hax _ _ hz haz hz hay; intros hxy hyz,
    any_goals { trivial },
    { exact haz (r.trans hay hyz) },
    { exact r.trans (pref_order.reverse hax) haz },
    { exact hay (r.trans h hxy) },
    { exact r.trans hxy hyz } },
end

lemma maketop_noteq (r : pref_order σ) {a b c : σ} (ha : a ≠ b) (hc : c ≠ b) :
  (maketop r b a c ↔ r a c) ∧ (maketop r b c a ↔ r c a) :=
begin
  simp only [maketop, if_false_left_eq_and, if_true_left_eq_or],
  refine ⟨⟨_, λ h, or.inr ⟨hc, h⟩⟩, ⟨_, λ h, or.inr ⟨ha, h⟩⟩⟩; rintro (rfl | ⟨-, h⟩),
  exacts [absurd rfl ha, h, absurd rfl hc, h],
end

lemma maketop_noteq' (r : pref_order σ) {a b c : σ} (ha : a ≠ b) (hc : c ≠ b) :
  (P (maketop r b) a c ↔ P r a c) ∧ (P (maketop r b) c a ↔ P r c a) :=
let h := maketop_noteq r ha hc in P_iff_of_iff h.1 h.2

lemma makebot_noteq (r : pref_order σ) {a b c : σ} (ha : a ≠ b) (hc : c ≠ b) :
  (makebot r b a c ↔ r a c) ∧ (makebot r b c a ↔ r c a) :=
begin
  simp only [makebot, if_false_left_eq_and, if_true_left_eq_or],
  refine ⟨⟨_, λ h, or.inr ⟨ha, h⟩⟩, ⟨_, λ h, or.inr ⟨hc, h⟩⟩⟩; rintro (rfl | ⟨-, h⟩),
  exacts [absurd rfl hc, h, absurd rfl ha, h],
end

lemma makebot_noteq' (r : pref_order σ) {a b c : σ} (ha : a ≠ b) (hc : c ≠ b) :
  (P (makebot r b) a c ↔ P r a c) ∧ (P (makebot r b) c a ↔ P r c a) :=
let h := makebot_noteq r ha hc in P_iff_of_iff h.1 h.2

lemma makeabove_noteq (r : pref_order σ) (a : σ) {b c d : σ} (hc : c ≠ b) (hd : d ≠ b) :
  (makeabove r a b c d ↔ r c d) ∧ (makeabove r a b d c ↔ r d c) :=
by simp [makeabove, ← pref_order.eq_coe, hc, hd]

lemma makeabove_noteq' (r : pref_order σ) (a : σ) {b c d : σ} (hc : c ≠ b) (hd : d ≠ b) :
  (P (makeabove r a b) c d ↔ P r c d) ∧ (P (makeabove r a b) d c ↔ P r d c) :=
by simp [makeabove, P, ← pref_order.eq_coe, hc, hd]

lemma is_strictly_best_maketop (b : σ) (r : pref_order σ) (X : finset σ) :
  is_strictly_best b (maketop r b) X :=
by simp [maketop, is_strictly_best, P, ← pref_order.eq_coe]

lemma is_strictly_worst_makebot (b : σ) (r : pref_order σ) (X : finset σ) :
  is_strictly_worst b (makebot r b) X :=
by simp [is_strictly_worst, makebot, P, ← pref_order.eq_coe]

lemma makeabove_above {a b : σ} (r : pref_order σ) (ha : a ≠ b):
  P (makeabove r a b) b a :=
by simpa [P, makeabove, ← pref_order.eq_coe, not_or_distrib, ha] using r.refl a

lemma makeabove_above' {a b c : σ} {r : pref_order σ} (hc : c ≠ b) (hr : r a c) :
  P (makeabove r a b) b c :=
by simpa [P, makeabove, ← pref_order.eq_coe, hc]

lemma makeabove_below {a b c : σ} {r : pref_order σ} (hc : c ≠ b) (hr : ¬r a c) :
  P (makeabove r a b) c b :=
by simpa [P, makeabove, ← pref_order.eq_coe, not_or_distrib, hc]

/-! ### Properties -/

/-- A social welfare function satisfies the Weak Pareto criterion if, for any two social states
  `x` and `y`, every individual ranking `x` higher than `y` implies that society ranks `x` higher
  than `y`. -/
def weak_pareto (f : (ι → pref_order σ) → pref_order σ) (X : finset σ) : Prop :=
∀ (x y ∈ X) (R : ι → pref_order σ), (∀ i : ι, P (R i) x y) → P (f R) x y

/-- Suppose that for any two social states `x` and `y`, every individual's ordering of `x` and `y`
  remains unchanged between two orderings `P₁` and `P₂`. We say that a social welfare function is
  *independent of irrelevant alternatives* if society's ordering of `x` and `y` also remains
  unchanged between `P₁` and `P₂`. -/
def ind_of_irr_alts (f : (ι → pref_order σ) → pref_order σ) (X : finset σ) : Prop :=
∀ (R R' : ι → pref_order σ) (x y ∈ X),
  (∀ i : ι, same_order' (R i) (R' i) x y x y) → same_order' (f R) (f R') x y x y

/-- A social welfare function is a *dictatorship* if there exists an individual who possesses the power
   to determine society's order of any social states. -/
def is_dictatorship (f : (ι → pref_order σ) → pref_order σ) (X : finset σ) : Prop :=
∃ i : ι, ∀ (x y ∈ X) (R : ι → pref_order σ), P (R i) x y → P (f R) x y

/-- An individual `i` is *pivotal* with respect to a social welfare function and a social state `b`
  if there exist preference orderings `R` and `R'` such that:
  (1) all individuals except for `i` rank all social states exactly the same in both orderings
  (2) all individuals place `b` in an extremal position in both rankings
  (3) `i` ranks `b` bottom of their rankings in `R`, but top of their rankings in `R'`
  (4) society ranks `b` bottom of its rankings in `R`, but top of its rankings in `R'` -/
def is_pivotal (f : (ι → pref_order σ) → pref_order σ) (X : finset σ) (i : ι) (b : σ) : Prop :=
∃ (R R' : ι → pref_order σ),
  (∀ j : ι, j ≠ i → ∀ x y ∈ X, R j = R' j) ∧
    (∀ i : ι, is_extremal b (R i) X) ∧ (∀ i : ι, is_extremal b (R' i) X) ∧
      (is_strictly_worst b (R i) X) ∧ (is_strictly_best b (R' i) X) ∧
        (is_strictly_worst b (f R) X) ∧ (is_strictly_best b (f R') X)

/-- A social welfare function has a *pivot* with respect to a social state `b` if there exists an
  individual who is pivotal with respect to that function and `b`. -/
def has_pivot (f : (ι → pref_order σ) → pref_order σ) (X : finset σ) (b : σ): Prop :=
∃ i, is_pivotal f X i b

/-- An individual is a dictator over all social states in a given set *except* `b`
  if they are a dictator over every pair of distinct alternatives not equal to `b`.  -/
def is_dictator_except (f : (ι → pref_order σ) → pref_order σ)
  (X : finset σ) (i : ι) (b : σ) : Prop :=
∀ a c ∈ X, a ≠ b → c ≠ b → ∀ R : ι → pref_order σ, P (R i) c a → P (f R) c a

variables {R : ι → pref_order σ} {f : (ι → pref_order σ) → pref_order σ}

/-! ### Auxiliary lemmas -/

/-- If every individual ranks a social state `b` at the top of its rankings, then society must also
  rank `b` at the top of its rankings. -/
theorem is_strictly_best_of_forall_is_strictly_best (b_in : b ∈ X) (hwp : weak_pareto f X)
  (htop : ∀ i, is_strictly_best b (R i) X) :
  is_strictly_best b (f R) X :=
λ a a_in hab, hwp b a b_in a_in R $ λ i, htop i a a_in hab

/-- If every individual ranks a social state `b` at the bottom of its rankings, then society must
  also rank `b` at the bottom of its rankings. -/
theorem is_strictly_worst_of_forall_is_strictly_worst (b_in : b ∈ X) (hwp : weak_pareto f X)
  (hbot : ∀ i, is_strictly_worst b (R i) X) :
  is_strictly_worst b (f R) X :=
λ a a_in hab, hwp a b a_in b_in R $ λ i, hbot i a a_in hab

lemma exists_of_not_extremal (hX : 3 ≤ X.card) (hb : b ∈ X) (h : ¬ is_extremal b (f R) X) : -- it may be worth generalizing this; see `not_extremal'` above - Ben
  ∃ a c ∈ X, a ≠ b ∧ c ≠ b ∧ a ≠ c ∧ f R a b ∧ f R b c :=
begin
  obtain ⟨a, c, ha, hc, hab, hcb, hfa, hfc⟩ := not_extremal' (f R).total h,
  obtain hac | rfl := ne_or_eq a c, { exact ⟨a, c, ha, hc, hab, hcb, hac, hfa, hfc⟩ },
  obtain ⟨d, hd, hda, hdb⟩ := exists_third_distinct_mem hX ha hb hab,
  obtain hfd | hfd := (f R).total d b,
  { exact ⟨d, a, hd, hc, hdb, hcb, hda, hfd, hfc⟩ },
  { exact ⟨a, d, ha, hd, hab, hdb, hda.symm, hfa, hfd⟩ },
end

/-! ### The Proof Begins -/

/- Geankopolos (2005) calls this step the *Extremal Lemma*. If every individual
places alternative `b` in an extremal position (at the very top or bottom of her rankings),
then society must also place alternative `b` in an extremal position. -/
lemma first_step (hwp : weak_pareto f X) (hind : ind_of_irr_alts f X)
  (hX : 3 ≤ X.card) (hb : b ∈ X) (hextr : ∀ i, is_extremal b (R i) X) :
  is_extremal b (f R) X :=
begin
  by_contra hnot,
  obtain ⟨a, c, ha, hc, hab, hcb, hac, hfa, hfb⟩ := exists_of_not_extremal hX hb hnot,
  have H1 := λ {j} h, makeabove_below hcb.symm ((hextr j).is_strictly_best h a ha hab).2,
  have H2 := λ {j} h, makeabove_above' hcb.symm ((hextr j).is_strictly_worst h a ha hab).1,
  refine (hwp c a hc ha (λ j, makeabove (R j) a c) (λ j, makeabove_above (R j) hac)).2
    ((f _).trans (((same_order_iff_same_order' (f R).total (f _).total).2 -- wouldn't it be better just to do everything using `same_order'`? -Ben
      (hind R _ a b ha hb (λ j, _))).1.1.1 hfa)
        (((same_order_iff_same_order' (f R).total (f _).total).2
          (hind R _ b c hb hc (λ j, ⟨⟨λ h, H1 (not_strictly_worst.mpr ⟨c, hc, hcb, nP_of_reverseP h⟩), _⟩,
            ⟨λ h, H2 (not_strictly_best.mpr ⟨c, hc, hcb, nP_of_reverseP h⟩), _⟩⟩))).1.1.1 hfb)),
  { simp only [same_order', makeabove_noteq' _ a hcb.symm hac, iff_self, and_self] },
  all_goals { rintro ⟨-, h⟩, contrapose! h },
  { exact (H2 (not_strictly_best.mpr ⟨c, hc, hcb, h⟩)).1 },
  { exact (H1 (not_strictly_worst.mpr ⟨c, hc, hcb, h⟩)).1 },
end

/-- We define relation `r₂`, a `pref_order` we will use in `second_step`. -/
def r₂ (b : σ) : pref_order σ :=
begin
  use λ x y, if y = b then true else if x = b then false else true,
  { intro x, split_ifs; trivial },
  { intros x y, simp only, split_ifs; simp only [true_or, or_true] },
  { intros x y z, simp only, split_ifs; simp only [forall_true_left, forall_false_left] },
end

/- This is an auxiliary lemma used in the `second_step`. -/
lemma second_step_aux [fintype ι] (hwp : weak_pareto f X) (hind : ind_of_irr_alts f X)
  (hX : 2 < X.card) (b_in : b ∈ X) {D' : finset ι} :
  ∀ {R : ι → pref_order σ}, D' = {i ∈ univ | is_strictly_worst b (R i) X} →
    (∀ i, is_extremal b (R i) X) → is_strictly_worst b (f R) X → has_pivot f X b :=
begin
  refine finset.induction_on D'
    (λ R h hextr hbot, absurd (is_strictly_best_of_forall_is_strictly_best b_in hwp (λ j, (hextr j).is_strictly_best _))
                              (hbot.not_strictly_best (exists_second_distinct_mem hX.le b_in)))
    (λ i D hi IH R h_insert hextr hbot, _),
  { simpa using eq_empty_iff_forall_not_mem.mp h.symm j },
  { let R' := λ j, (ite (j = i) (maketop (R j) b) (R j)),
    have hextr' : ∀ j, is_extremal b (R' j) X,
    { intro j, simp only [R'],
      split_ifs,
      { exact (is_strictly_best_maketop b (R j) X).is_extremal },
      { exact hextr j } },
    by_cases hR' : is_strictly_best b (f R') X,
    { refine ⟨i, R, R', λ j hj x y _ _, _, hextr, hextr', _, _, hbot, hR'⟩,
      { simp only [R', if_neg hj] },
      { have : i ∈ {j ∈ univ | is_strictly_worst b (R j) X}, { rw ← h_insert, exact mem_insert_self i D },
        simpa },
      { simp only [R', is_strictly_best_maketop, if_pos] } },
    { refine IH (ext (λ j, _)) hextr' ((first_step hwp hind hX b_in hextr').is_strictly_worst hR'),
      simp only [true_and, sep_def, mem_filter, mem_univ, R'],
      split; intro hj,
      { have hji : j ≠ i, { rintro rfl, exact hi hj },
        have : j ∈ {i ∈ univ | is_strictly_worst b ⇑(R i) X}, { convert mem_insert_of_mem hj, rw h_insert },
        simpa [hji] },
      { have hji : j ≠ i,
        { rintro rfl,
          obtain ⟨a, a_in, hab⟩ := exists_second_distinct_mem hX.le b_in,
          simp only [if_pos] at hj,
          exact (is_strictly_best_maketop b (R j) X a a_in hab).2 (hj a a_in hab).1 },
        rw [← erase_insert hi, h_insert],
        simpa [hji] using hj } } },
end

/- In his second step, Geankopolos shows that for any social state `b`,
there exists an individual who is pivotal over that social state.  -/
lemma second_step [fintype ι] (hwp : weak_pareto f X) (hind : ind_of_irr_alts f X)
  (hX : 3 ≤ X.card) (b) (b_in : b ∈ X) :
  has_pivot f X b :=
have hbot : is_strictly_worst b (r₂ b) X, by simp [is_strictly_worst, r₂, P, ← pref_order.eq_coe],
second_step_aux hwp hind hX b_in rfl (λ i, hbot.is_extremal) $
  is_strictly_worst_of_forall_is_strictly_worst b_in hwp $ λ i, hbot

/- Step 3 states that if an individual `is_pivotal` over some alternative `b`, they
are also a dictator over every pair of alternatives not equal to `b`. -/
lemma third_step (hind : ind_of_irr_alts f X)
  (b_in : b ∈ X) {i : ι} (i_piv : is_pivotal f X i b) :
  is_dictator_except f X i b :=
begin
  rintros a c a_in c_in hab hcb Q ⟨-, h⟩,
  obtain ⟨R, R', i_piv⟩ := i_piv,
  let Q' := λ j, if j = i then makeabove (Q j) a b
                 else if is_strictly_worst b (R j) X then makebot (Q j) b else maketop (Q j) b,
  have Q'bot : ∀ j ≠ i, is_strictly_worst b (R j) X → Q' j = makebot (Q j) b :=
    λ j hj hbot, by simp only [Q', if_neg hj, if_pos hbot],
  have Q'top : ∀ j ≠ i, ¬is_strictly_worst b (R j) X → Q' j = maketop (Q j) b :=
    λ j hj hbot, by simp only [Q', if_neg hj, if_neg hbot],
  have Q'above : Q' i = makeabove (Q i) a b := by simp [Q'],
  have hQ' : ∀ j, same_order' (Q j) (Q' j) c a c a,
  { intro j,
    suffices : ∀ d ≠ b, ∀ e ≠ b, same_order' (Q j) (Q' j) e d e d, from this a hab c hcb,
    intros d hdb e heb,
    simp only [Q', same_order'],
    split_ifs; simp [makeabove_noteq', makebot_noteq', maketop_noteq', hdb, heb] },
  rw (hind Q Q' c a c_in a_in hQ').1,
  refine P_trans (f Q').trans ((hind R Q' c b c_in b_in _).1.1 (i_piv.2.2.2.2.2.1 c c_in hcb))
    ((hind R' Q' b a b_in a_in _).1.1 (i_piv.2.2.2.2.2.2 a a_in hab));
      intro j; split; split; intro H; rcases eq_or_ne j i with rfl | hj,
  { convert makeabove_below hcb h },
  { convert is_strictly_worst_makebot b (Q j) X c c_in hcb,
    apply Q'bot j hj,
    unfold is_strictly_worst,
    by_contra hbot, push_neg at hbot,
    rcases hbot with ⟨d, d_in, hdb, H'⟩,
    cases i_piv.2.1 j with hbot htop,
    { exact H' (hbot d d_in hdb) },
    { exact H.2 (htop c c_in hcb).1 } },
  { exact i_piv.2.2.2.1 c c_in hcb },
  { by_contra H',
    apply nP_of_reverseP ((is_strictly_best_maketop b (Q j) X) c c_in hcb),
    rwa ← Q'top j hj,
    exact not_strictly_worst.mpr ⟨c, c_in, hcb, H'⟩ },
  { exact absurd (i_piv.2.2.2.1 c c_in hcb).1 H.2 },
  { convert is_strictly_best_maketop b (Q j) X c c_in hcb,
    exact Q'top j hj (λ hbot, H.2 (hbot c c_in hcb).1) },
  { apply absurd (makeabove_below hcb h).1,
    convert ← H.2 },
  { by_contra H',
    apply absurd (is_strictly_worst_makebot b (Q j) X c c_in hcb).1,
    convert ← H.2,
    exact Q'bot j hj ((i_piv.2.1 j).is_strictly_worst (not_strictly_best.mpr ⟨c, c_in, hcb, H'⟩)) },
  { convert makeabove_above (Q j) hab },
  { convert is_strictly_best_maketop b (Q j) X a a_in hab,
    apply Q'top j hj,
    rw i_piv.1 j hj a b a_in b_in,
    exact not_strictly_worst.mpr ⟨a, a_in, hab, nP_of_reverseP H⟩ },
  { exact i_piv.2.2.2.2.1 a a_in hab },
  { rw ← i_piv.1 j hj a b a_in b_in,
    refine ((i_piv.2.1 j).is_strictly_best (λ hbot, nP_of_reverseP H _)) a a_in hab,
    convert is_strictly_worst_makebot b (Q j) X a a_in hab,
    exact Q'bot j hj hbot },
  { exact absurd (i_piv.2.2.2.2.1 a a_in hab).1 H.2 },
  { convert is_strictly_worst_makebot b (Q j) X a a_in hab,
    apply Q'bot j hj,
    rw i_piv.1 j hj a b a_in b_in,
    exact (i_piv.2.2.1 j).is_strictly_worst (not_strictly_best.mpr ⟨a, a_in, hab, nP_of_reverseP H⟩) },
  { apply absurd (makeabove_above (Q j) hab).1,
    convert ← H.2 },
  { rw ← i_piv.1 j hj a b a_in b_in,
    suffices : is_strictly_worst b (R j) X, from this a a_in hab,
    by_contra hbot,
    apply absurd (is_strictly_best_maketop b (Q j) X a a_in hab).1,
    convert ← H.2,
    exact Q'top j hj hbot },
end

/- Step 4 states that if an individual is a dictator over every pair of social states
except for `b`, they are also a dictator over all pairs (including `b`). -/
lemma fourth_step (hind : ind_of_irr_alts f X)
  (hX : 3 ≤ X.card) (hpiv : ∀ b ∈ X, has_pivot f X b) :
  is_dictatorship f X :=
begin
  obtain ⟨b, hb⟩ := (card_pos.1 (zero_lt_two.trans hX)).bex,
  obtain ⟨i, i_piv⟩ := hpiv b hb,
  have h : ∀ a ∈ X, a ≠ b → ∀ Rᵢ : ι → pref_order σ,
          (P (Rᵢ i) a b → P (f Rᵢ) a b) ∧ (P (Rᵢ i) b a → P (f Rᵢ) b a), -- is there perhaps a better way to state this? -Ben
  { intros a ha hab Rᵢ,
    obtain ⟨c, hc, hca, hcb⟩ := exists_third_distinct_mem hX ha hb hab,
    obtain ⟨hac, hbc⟩ := ⟨hca.symm, hcb.symm⟩,
    obtain ⟨j, j_piv⟩ := hpiv c hc,
    obtain hdict := third_step hind hc j_piv,
    obtain rfl : j = i,
    { by_contra hji,
      obtain ⟨R, R', hso, hextr, -, -, -, hbot, htop⟩ := i_piv,
      refine (htop a ha hab).2 (hdict b a hb ha hbc hac R' _).1,
      rw ← hso j hji a b ha hb,
      by_contra hnot,
      exact (hdict a b ha hb hac hbc R ((hextr j).is_strictly_best
        (not_strictly_worst.mpr ⟨a, ha, hab, hnot⟩) a ha hab)).2 (hbot a ha hab).1 },
    split; apply hdict; assumption },
  refine ⟨i, λ x y hx hy Rᵢ hRᵢ, _⟩,
  rcases eq_or_ne b x with rfl | hbx; rcases eq_or_ne b y with rfl | hby,
  { exact (false_of_P_self hRᵢ).elim },
  { exact (h y hy hby.symm Rᵢ).2 hRᵢ },
  { exact (h x hx hbx.symm Rᵢ).1 hRᵢ },
  { exact third_step hind hb i_piv y x hy hx hby.symm hbx.symm Rᵢ hRᵢ },
end

/-- Arrow's Impossibility Theorem: Any social welfare function involving at least three social
  states that satisfies WP and IoIA is necessarily a dictatorship. --/
theorem arrow [fintype ι] (hwp : weak_pareto f X) (hind : ind_of_irr_alts f X) (hX : 3 ≤ X.card) :
  is_dictatorship f X :=
fourth_step hind hX $ second_step hwp hind hX


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

import data.finite.basic
import data.fintype.basic
import data.fun_like.basic

/-!
# Finiteness of `fun_like` types

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

We show a type `F` with a `fun_like F α β` is finite if both `α` and `β` are finite.
This corresponds to the following two pairs of declarations:

 * `fun_like.fintype` is a definition stating all `fun_like`s are finite if their domain and
   codomain are.
 * `fun_like.finite` is a lemma stating all `fun_like`s are finite if their domain and
   codomain are.
 * `fun_like.fintype'` is a non-dependent version of `fun_like.fintype` and
 * `fun_like.finite` is a non-dependent version of `fun_like.finite`, because dependent instances
   are harder to infer.

You can use these to produce instances for specific `fun_like` types.
(Although there might be options for `fintype` instances with better definitional behaviour.)
They can't be instances themselves since they can cause loops.
-/

section type

variables (F G : Type*) {α γ : Type*} {β : α → Type*} [fun_like F α β] [fun_like G α (λ _, γ)]

/-- All `fun_like`s are finite if their domain and codomain are.

This is not an instance because specific `fun_like` types might have a better-suited definition.

See also `fun_like.finite`.
-/
noncomputable def fun_like.fintype [decidable_eq α] [fintype α] [Π i, fintype (β i)] : fintype F :=
fintype.of_injective _ fun_like.coe_injective

/-- All `fun_like`s are finite if their domain and codomain are.

Non-dependent version of `fun_like.fintype` that might be easier to infer.
This is not an instance because specific `fun_like` types might have a better-suited definition.
-/
noncomputable def fun_like.fintype' [decidable_eq α] [fintype α] [fintype γ] : fintype G :=
fun_like.fintype G

end type

section sort

variables (F G : Sort*) {α γ : Sort*} {β : α → Sort*} [fun_like F α β] [fun_like G α (λ _, γ)]

/-- All `fun_like`s are finite if their domain and codomain are.

Can't be an instance because it can cause infinite loops.
-/
lemma fun_like.finite [finite α] [∀ i, finite (β i)] : finite F :=
finite.of_injective _ fun_like.coe_injective

/-- All `fun_like`s are finite if their domain and codomain are.

Non-dependent version of `fun_like.finite` that might be easier to infer.
Can't be an instance because it can cause infinite loops.
-/
lemma fun_like.finite' [finite α] [finite γ] : finite G :=
fun_like.finite G

end sort


/- Universal quantifier -/

namespace uni_q
  example (α : Type) (p q : α → Prop) : (∀ x : α, p x ∧ q x) → (∀ y : α, q y) :=
    fun h : ∀ x : α, p x ∧ q x =>
      fun y : α =>
        show q y from (h y).right

  variable (α : Type) (r : α → α → Prop)
  variable (trans_r : ∀ x y z, r x y → r y z → r x z)
  variable (a b c : α)
  variable (hab : r a b) (hbc : r b c)

  #check trans_r
  #check trans_r a -- (∀ y z : α), r a y → r y z → r a z
  #check trans_r a b -- (∀ z : α), r a b → r b z → r a z
  #check trans_r a b c -- r a b → r b c → r a c
  #check trans_r a b c hab -- r b c → r a c
  #check trans_r a b c hab hbc -- r a c

  variable (trans_r : ∀ {x y z}, r x y → r y z → r x z)
  #check trans_r hab hbc -- r a c

  /- Equivalence relation -/
  variable (refl_r : ∀ x, r x x)
  variable (symm_r : ∀ {x y}, r x y → r y x)
  variable (trans_r : ∀ {x y z}, r x y → r y z → r x z)
  example (a b c d : α) (hab : r a b) (hcb : r c b) (hcd : r c d) : r a d :=
    trans_r (trans_r hab (symm_r hcb)) hcd
end uni_q

/- Equality -/

namespace equality
  universe u
  #check @Eq.refl.{u} -- a = a
  #check @Eq.symm.{u} -- a = b → b = a
  #check @Eq.trans.{u} -- a = b → b = c → a = c

  variable (α : Type) (a b c d : α)
  variable (hab : a = b) (hcb : c = b) (hcd : c = d)
  example : a = d :=
    Eq.trans (Eq.trans hab (Eq.symm hcb)) hcd
  example : a = d := (hab.trans hcb.symm).trans hcd

  variable (α β : Type) (a b c d : α)

  example (f : α → β) (a : α) : (fun x => f x) a = f a := Eq.refl (f a)
  example (f : α → β) (a : α) : (fun x => f x) a = f a := Eq.refl _
  example : (a, b).1 = a := Eq.refl a
  example : 2 + 3 = 5 := rfl

  -- Substitution
  example (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
    Eq.subst h1 h2

  example (a b : α) (p : α → Prop) (h1 : a = b) (h2 : p a) : p b :=
    h1 ▸ h2  -- "▸" "t"

  variable (f g : α → ℕ)
  variable (h1 : f = g) (h2 : a = b)
  example : f a = f b := congrArg f h2
  example : f a = g a := congrFun h1 a
  example : f a = g b := congr h1 h2

  variable (a b c d : Nat)
  example : a + 0 = a := a.add_zero
  example : 0 + a = a := a.zero_add
  example : a * 1 = a := a.mul_one
  example : 1 * a = a := a.one_mul
  example : a + b = b + a := a.add_comm b
  example : a + b + c = a + (b + c) := a.add_assoc b c
  example : a * b = b * a := a.mul_comm b
  example : a * b * c = a * (b * c) := a.mul_assoc b c
  example : a * (b + c) = a * b + a * c := a.mul_add b c
  example : (a + b) * c = a * c + b * c := a.add_mul b c

  example (x y : Nat) : (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
    have h1 : (x + y) * (x + y) = (x + y) * x + (x + y) * y :=
      Nat.mul_add (x + y) x y
    have h2 : (x + y) * (x + y) = (x * x + y * x) + (x * y + y * y) :=
      (Nat.add_mul x y x) ▸ (Nat.add_mul x y y) ▸ h1
    h2.trans (Nat.add_assoc (x * x + y * x) (x * y) (y * y)).symm

end equality

/- Calculation Proofs -/

namespace calc_p
  variable (a b c d e : Nat)
  variable (h1 : a = b) (h2 : b = c + 1) (h3 : c = d) (h4 : e = 1 + d)
  theorem T : a = e :=
    calc
      a = b := h1
      _ = c + 1 := h2
      _ = d + 1 := congrArg Nat.succ h3
      _ = 1 + d := Nat.add_comm d 1
      _ = e := h4.symm

  theorem T1 : a = e :=
    calc
      a = b := by rw [h1]
      _ = c + 1 := by rw [h2]
      _ = d + 1 := by rw [h3]
      _ = 1 + d := by rw [Nat.add_comm]
      _ = e := by rw [h4]

  theorem T2 : a = e :=
    calc
      a = d + 1 := by rw [h1, h2, h3]
      _ = 1 + d := by rw [Nat.add_comm]
      _ = e := by rw [h4]

  theorem T3 : a = e :=
    by rw [h1, h2, h3, Nat.add_comm, h4]

  example (a b c d : Nat) (h1 : a = b) (h2 : b ≤ c) (h3 : c + 1 < d) : a < d :=
    calc
      a = b := h1
      _ < b + 1 := Nat.lt_succ_self b
      _ ≤ c + 1 := Nat.succ_le_succ h2
      _ < d := h3

  example (x y : Nat) : (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
    calc
      (x + y) * (x + y) = (x + y) * x + (x + y) * y := by rw [Nat.mul_add]
      _ = x * x + y * x + (x + y) * y := by rw [Nat.add_mul]
      _ = x * x + y * x + (x * y + y * y) := by rw [Nat.add_mul]
      _ = x * x + y * x + x * y + y * y := by rw [←Nat.add_assoc]

  example (x y : Nat) : (x + y) * (x + y) = x * x + y * x + x * y + y * y :=
    by simp [Nat.mul_add, Nat.add_mul, Nat.add_assoc]

end calc_p

/- Existencial Quantifier -/

namespace exist
  #check @Exists.intro
  example : ∃ x : Nat, x > 0 :=
    have h : 1 > 0 := Nat.zero_lt_succ 0
    Exists.intro 1 h

  example (x : Nat) (h : x > 0) : ∃ y : Nat, y < x :=
    Exists.intro 0 h

  example (x y z : Nat) (h1 : x < y) (h2 : y < z) : ∃ w, x < w ∧ w < z :=
    Exists.intro y (And.intro h1 h2)

  variable (g : Nat → Nat → Nat)

  variable (hg : g 0 0 = 0)

  theorem gex1 : ∃ x, g x x = x := ⟨0, hg⟩
  theorem gex2 : ∃ x, g x 0 = x := ⟨0, hg⟩
  theorem gex3 : ∃ x, g 0 0 = x := ⟨0, hg⟩
  theorem gex4 : ∃ x, g x x = 0 := ⟨0, hg⟩

  set_option pp.explicit true  -- display implicit arguments
  #print gex1
  #print gex2
  #print gex3
  #print gex4

  variable (α : Type) (p q : α → Prop)
  example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
    Exists.elim h
      (fun w =>
        fun hw : p w ∧ q w =>
          show ∃ w, q w ∧ p w from Exists.intro w (And.intro hw.right hw.left))

  example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
    match h with
    | Exists.intro w hw => Exists.intro w (And.intro hw.right hw.left)

  example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
    match h with
    | Exists.intro w (And.intro hpw hqw) => Exists.intro w (And.intro hqw hpw)

  example (h : ∃ x, p x ∧ q x) : ∃ x, q x ∧ p x :=
    let (Exists.intro w (And.intro hpw hqw)) := h
    Exists.intro w (And.intro hqw hpw)

  def is_even (a : Nat) := ∃ b : Nat, a = 2 * b

  theorem even_plus_even (h1 : is_even a) (h2 : is_even b) : is_even (a + b) :=
    match h1, h2 with
    | Exists.intro w1 hw1, Exists.intro w2 hw2 =>
        Exists.intro (w1 + w2)
          (calc
            a + b = 2 * w1 + 2 * w2 := by rw [hw1, hw2]
            _ = 2 * (w1 + w2) := by simp [Nat.mul_add])

  example (h : ¬ ∀ x, ¬p x) : ∃ x, p x :=
    Classical.byContradiction
      (fun h1 : ¬ ∃ x, p x =>
        have h2 : ∀ x, ¬p x :=
          fun x =>
            fun h3 : p x =>
              have h4 : ∃ x, p x := Exists.intro x h3
              show False from h1 h4
        show False from h h2)

end exist

/- More on Proof Language -/

namespace proof_lang
  variable (f : Nat → Nat)
  variable (h : ∀ x, f x ≤ f (x + 1))

  example : (f 0 ≤ f 3) :=
    have : f 0 ≤ f 1 := h 0
    have : f 0 ≤ f 2 := Nat.le_trans this (h 1)
    show f 0 ≤ f 3 from Nat.le_trans this (h 2)

  example : f 0 ≤ f 3 :=
    have : f 0 ≤ f 1 := h 0
    have : f 0 ≤ f 2 := Nat.le_trans (by assumption) (h 1)
    show f 0 ≤ f 3 from Nat.le_trans (by assumption) (h 2)

  example : f 0 ≥ f 1 → f 1 ≥ f 2 → f 0 = f 2 :=
    fun _ : f 0 ≥ f 1 =>
    fun _ : f 1 ≥ f 2 =>
    have : f 0 ≥ f 2 := Nat.le_trans ‹f 1 ≥ f 2› ‹f 0 ≥ f 1›
    have : f 0 ≤ f 2 := Nat.le_trans (h 0) (h 1)
    show f 0 = f 2 from Nat.le_antisymm this ‹f 0 ≥ f 2›
end proof_lang


import data.real.basic
import data.matrix.notation
import linear_algebra.matrix
import linear_algebra.determinant
import group_theory.perm.fin
import tactic.norm_swap

open_locale big_operators

namespace e222

section

-- We specialize `matrix` for n × n matrices
notation `Mn[` α `]` n := matrix (fin n) (fin n) α

-- and a shortcut for Mn(ℝ)
notation `MnR ` n := Mn[ℝ]n

variables {n : ℕ}
variables (A : MnR n) (B : MnR n) (C : MnR n)

-- Call the collection of n × n matrices as Mₙ(ℝ).
-- That is a vector space over the real numbers, of dimension n².
example : finite_dimensional.finrank ℝ (MnR n) = n ^ 2 :=
by simp [pow_two]   -- rw [matrix.findim_matrix, fintype.card_fin, nat.pow_two]

-- The addition law in the vector space of n × n matrices
example : A + B = λ i j, A i j + B i j :=
by { funext i j, refl } -- matrix.add_val A B

-- Multiplication of a matrix by a real scalar, doesn't work
example (α : ℝ) : α • A = λ i j, α * (A i j) :=
by { funext i j, refl } -- matrix.smul_val α A i j

-- Matrix is a vector space, which only needs a `module`
example : module ℝ (MnR n) :=
by apply_instance
-- ... so we can use a finite dimensional vector space instance
example : finite_dimensional ℝ (MnR n) :=
by apply_instance

-- An n × n matrix has some finite basis of cardinality n ^ 2
example : ∃ (s : finset (MnR n)) (b : basis s ℝ (MnR n)),
            (finset.card s = n ^ 2) :=
begin
  letI : is_noetherian ℝ (MnR n) := is_noetherian.iff_fg.mpr (by apply_instance),
  let s_basis := is_noetherian.finset_basis ℝ (MnR n),
  refine ⟨_, s_basis, _⟩,
  rw [←finite_dimensional.finrank_eq_card_finset_basis s_basis,
      matrix.finrank_matrix, fintype.card, finset.card_fin, pow_two]
end

variables {m : ℕ}

-- An m × n matrix has some finite basis of cardinality m * n
example : ∃ (s : finset (matrix (fin m) (fin n) ℝ)) (b : basis s ℝ (matrix (fin m) (fin n) ℝ)),
            (finset.card s = m * n) :=
begin
  letI : is_noetherian ℝ (matrix (fin m) (fin n) ℝ) := is_noetherian.iff_fg.mpr (by apply_instance),
  let s_basis := is_noetherian.finset_basis ℝ (matrix (fin m) (fin n) ℝ),
  refine ⟨_, s_basis, _⟩,
  rw [←finite_dimensional.finrank_eq_card_finset_basis s_basis,
      matrix.finrank_matrix],
  repeat { rw [fintype.card, finset.card_fin] }
end

-- Multiplication is defined on n x n matrices
example : has_mul (MnR n) := by apply_instance -- show_term gives matrix.has_mul

-- Multiplication is defined by sum of row elements times column elements
example : A * B = λ i j, ∑ k , A i k * B k j := rfl

-- An n x n matrix represents a linear operator T : ℝⁿ → ℝⁿ
-- ... vectors in ℝⁿ are represented by functions of (fin n) → ℝ
-- ... linear maps are notated by →ₗ with an optional →ₗ[field R] parameter
example : ∃ (T : (fin n → ℝ) →ₗ[ℝ] fin n → ℝ), T.to_matrix' = A :=
by { use A.to_lin', exact linear_map.to_matrix'_to_lin' _ }

example : (MnR n) ≃ₗ[ℝ] ((fin n → ℝ) →ₗ[ℝ] fin n → ℝ) := matrix.to_lin'

-- Multiplication of matrices is the composition of transformations
example : A * B = (A.to_lin'.comp B.to_lin').to_matrix' :=
by rw [←matrix.to_lin'_mul, linear_map.to_matrix'_to_lin', matrix.mul_eq_mul]

-- Multiplication of 1 x 1 matrices is commutative
example (A : MnR 1) (B : MnR 1) : A * B = B * A :=
begin
  ext i j,
  rw [matrix.mul_eq_mul, matrix.mul_eq_mul, matrix.mul_apply, matrix.mul_apply,
      finset.sum_congr rfl],
  intros x _,
  rw mul_comm,
  congr
end

-- Multiplication of 2 x 2 matrices is not necessarily commutative
example : ∃ (A : MnR 2) (B : MnR 2), A * B ≠ B * A :=
begin
  use ![![0, 1], ![0, 0]],
  use ![![0, 0], ![0, 1]],
  intros h,
  replace h := congr_fun (congr_fun h 0) 1,
  norm_num at h
end

-- Zero matrix is the zero element of the vector space,
-- adding it to any element, you get the same
-- ... following examples use the monoid and semiring instances of matrices
example (A : matrix (fin m) (fin n) ℝ) : A + 0 = A := add_zero _
example (A : matrix (fin m) (fin n) ℝ) : 0 + A = A := zero_add _

-- The identity matrix
example {i j} : (1 : MnR n) i j = if i = j then 1 else 0 := matrix.one_apply

-- Multiplication by the identity matrix gets anything back
example : A * 1 = A := mul_one _
example : 1 * A = A := one_mul _

-- Matrix distributive law
example : A * (B + C) = A * B + A * C :=
mul_add _ _ _

-- Matrix associative law
example : A * (B * C) = A * B * C :=
(mul_assoc _ _ _).symm

-- Proving associativity by composition of transformation
example : (A * (B * C)) = ((A.to_lin'.comp B.to_lin').comp C.to_lin').to_matrix' :=
by { rw [linear_map.comp_assoc, ←matrix.to_lin'_mul, ←matrix.to_lin'_mul,
         linear_map.to_matrix'_to_lin'], refl }

-- A 1 x 1 matrix is invertible iff the element is nonzero
example (A : MnR 1) : A ≠ 0 ↔ is_unit A :=
begin
  have nonzero : A ≠ 0 → A 0 0 ≠ 0,
    { intros nonzeroA nz,
      refine nonzeroA _,
      ext i j,
      convert nz },
  split,
  { intros hA,
    refine ⟨⟨A, ![![1 / (A 0 0)]], _, _⟩, rfl⟩;
    { ext i j,
      rw [matrix.mul_eq_mul, matrix.mul_apply, fin.sum_univ_succ, subsingleton.elim i 0,
          subsingleton.elim j 0],
      simp [nonzero hA] } },
  { rintros ⟨⟨A, B, h, h'⟩, rfl⟩ H,
    have : A 0 0 * B 0 0 = 1,
      { convert matrix.ext_iff.mpr h 0 0,
        rw [matrix.mul_eq_mul, matrix.mul_apply, fin.sum_univ_succ, fin.sum_univ_zero, add_zero] },
    have hz : A 0 0 = 0 := matrix.ext_iff.mpr H 0 0,
    rw [hz, zero_mul] at this,
    exact zero_ne_one this }
end

-- A 2 x 2 matrix is invertible if the "determinant" is nonzero, without definition of determinants
example (A : MnR 2) {a b c d} (hA : A = ![![a, b], ![c, d]]) :
        a * d - b * c ≠ 0 ↔ is_unit A :=
begin
  split,
  { intros h,
    refine ⟨⟨A, (1 / (a * d - b * c)) • ![![d, -b], ![-c, a]], _, _⟩, rfl⟩;
    { ext i j,
      fin_cases i;
      fin_cases j;
      field_simp [hA, h];
      ring } },
  { rintros ⟨⟨A, B, hAB, hBA⟩, rfl⟩ H,
    simp only [units.coe_mk] at hA,
    rw [←matrix.ext_iff, hA, matrix.mul_eq_mul] at hBA hAB,
    classical,
    by_cases hn : a ≠ 0 ∧ b ≠ 0 ∧ c ≠ 0 ∧ d ≠ 0,
    { have ha' : a = b * c / d,
        { rwa [eq_div_iff, ←sub_eq_zero],
          simp [hn] },
      have hBA' : a * B 0 0 + c * B 0 1 = 1,
        { convert hBA 0 0 using 2;
          simp [mul_comm] },
      have hBA'' : b * B 0 0 + d * B 0 1 = 0,
        { convert hBA 0 1 using 2;
          simp [mul_comm] },
      have hBv : B 0 1 = - b / d * B 0 0,
        { field_simp [hn],
          rw ←eq_neg_iff_add_eq_zero at hBA'',
          simp [hBA'', mul_comm] },
      have hd' : d = 0,
        { field_simp [ha', hn, hBv] at hBA',
          rw ←hBA',
          ring },
      simpa [hd'] using hn },
    { simp only [not_and_distrib, not_not, ne.def] at hn,
      have v0 : ∀ x, matrix.vec_cons 0 (λ (i : fin 1), 0) x = 0,
        { intros x,
          fin_cases x;
          refl },
      have h00 := hAB 0 0,
      have h01 := hAB 0 1,
      have h11 := hAB 1 1,
      have h10 := hAB 1 0,
      have h00' := hBA 0 0,
      have h01' := hBA 0 1,
      have h11' := hBA 1 1,
      have h10' := hBA 1 0,
      rcases hn with (rfl | rfl | rfl | rfl);
      { simp only [zero_sub, sub_zero, zero_mul, mul_zero, neg_eq_zero, mul_eq_zero] at H,
        rcases H with (rfl | rfl);
        simp [matrix.mul_apply, fin.sum_univ_succ] at h00 h01 h11 h10 h00' h01' h11' h10';
        assumption } } }
end

-- determinant of a 2 x 2 matrix is a * d - b * c
lemma det_2 (A : MnR 2) {a b c d : ℝ} (hA : A = ![![a, b], ![c, d]]) :
        matrix.det A = a * d - b * c :=
begin
  simp [hA, matrix.det_succ_row_zero, fin.sum_univ_succ],
  ring
end

--  A matrix is invertible iff the determinant is nonzero
lemma is_unit_iff_det_ne_zero  {n : ℕ} (A : MnR n) : is_unit A ↔ A.det ≠ 0 :=
begin
  rw matrix.is_unit_iff_is_unit_det,
  exact is_unit_iff_ne_zero
end

-- The general linear group, as a subtype of matrices
abbreviation GLₙ (n : ℕ) (α : Type*) [comm_ring α] : Type* := units (matrix (fin n) (fin n) α)

lemma GLₙ.is_unit_det {n : ℕ} (A : GLₙ n ℝ) : is_unit (matrix.det (A : MnR n)) :=
begin
  rw ←matrix.is_unit_iff_is_unit_det,
  exact units.is_unit _
end

lemma GLₙ.det_ne_zero {n : ℕ} (A : GLₙ n ℝ) : matrix.det (A : MnR n) ≠ 0 :=
begin
  rw ←is_unit_iff_det_ne_zero,
  exact units.is_unit _
end

-- For GL₁(ℝ) matrices, everything but 0
example (A : GLₙ 1 ℝ) : (A : MnR 1) ≠ 0 :=
begin
  intro H,
  simpa [H] using A.det_ne_zero
end

-- For M₂(ℝ) matrices, there are nonzero examples that are not GL₂(ℝ)
example (A : GLₙ 2 ℝ) : ![![(0 : ℝ), 1], ![0, 0]] ≠ (A : MnR 2) :=
begin
  intro H,
  apply A.det_ne_zero,
  rw [←H, det_2 _ rfl],
  simp
end

-- If the inverse exists, it is unique
example {n : ℕ} (A : MnR n) (h : ∃ B, A * B = 1 ∧ B * A = 1) : ∃! B, (A * B = 1 ∧ B * A = 1) :=
begin
  refine exists_unique_of_exists_of_unique h _,
  rintros B C ⟨hAB, hBA⟩ ⟨hAC, hCA⟩,
  have : B * (A * B) = B * (A * C),
    { rw [hAB, hAC] },
  rwa [matrix.mul_eq_mul, matrix.mul_eq_mul, ←matrix.mul_assoc,
      matrix.mul_eq_mul, matrix.mul_eq_mul, ←matrix.mul_assoc,
      ←matrix.mul_eq_mul, ←matrix.mul_eq_mul, ←matrix.mul_eq_mul, hBA,
      one_mul, one_mul] at this
end

-- GLₙ(ℝ) is not closed under addition
example (n : ℕ) : ¬ is_unit (((1 : GLₙ (n + 1) ℝ) : MnR (n + 1)) + (-1 : GLₙ (n + 1) ℝ)) :=
begin
  rw [units.coe_one, units.coe_neg_one, add_right_neg],
  exact not_is_unit_zero
end

-- GLₙ(ℝ) is not closed under scalar multiplication by 0
example (k : ℝ) {n : ℕ} (A : GLₙ (n + 1) ℝ) : ¬ is_unit (k • (A : MnR (n + 1))) ↔ k = 0 :=
begin
  rw not_iff_comm,
  split,
  { intro h,
    refine ⟨⟨k • (A : MnR (n + 1)), (k • A)⁻¹, _, _⟩, rfl⟩;
    { rw matrix.mul_eq_mul,
      rw matrix.mul_nonsing_inv <|> rw matrix.nonsing_inv_mul,
      rw [matrix.det_smul, is_unit_iff_ne_zero, mul_ne_zero_iff],
      exact ⟨pow_ne_zero _ h, A.det_ne_zero⟩ } },
  { rintro ⟨⟨A', B, hAB, hBA⟩, h⟩ rfl,
    rw [units.coe_mk, zero_smul] at h,
    rw [h, zero_mul] at hAB,
    exact zero_ne_one hAB }
end

-- GLₙ(ℝ) is closed under multiplication, proof 1
example {n : ℕ} (A B : GLₙ n ℝ) : is_unit ((A : MnR n) * B) :=
begin
  refine ⟨⟨(A : MnR n) * B, B⁻¹ * A⁻¹, _, _⟩, rfl⟩;
  simp_rw [matrix.mul_eq_mul],
  { rw [matrix.mul_assoc, ←matrix.mul_assoc (B : MnR n), matrix.mul_nonsing_inv _ B.is_unit_det,
      matrix.one_mul, matrix.mul_nonsing_inv _ A.is_unit_det] },
  { rw [matrix.mul_assoc, ←matrix.mul_assoc _ (A : MnR n), matrix.nonsing_inv_mul _ A.is_unit_det,
      matrix.one_mul, matrix.nonsing_inv_mul _ B.is_unit_det] }
end

-- GLₙ(ℝ) is closed under multiplication, proof 2
example {n : ℕ} (A B : GLₙ n ℝ) : is_unit ((A : MnR n) * B) :=
begin
  rw [matrix.is_unit_iff_is_unit_det, matrix.mul_eq_mul, matrix.det_mul],
  exact A.is_unit_det.mul B.is_unit_det
end

-- GLₙ(ℝ) contains 1
example {n : ℕ} : is_unit (1 : MnR n) := ⟨⟨1, 1, one_mul _, one_mul _⟩, rfl⟩

-- GLₙ(ℝ) contains inverses
example {n : ℕ} (A : GLₙ n ℝ) : is_unit ((A : MnR n)⁻¹) :=
begin
  refine ⟨⟨A⁻¹, A, _, _⟩, rfl⟩,
  rw [matrix.mul_eq_mul, matrix.nonsing_inv_mul _ A.is_unit_det],
  rw [matrix.mul_eq_mul, matrix.mul_nonsing_inv _ A.is_unit_det]
end

-- GLₙ(ℝ) multiplication is associative
example {n : ℕ} (A B C : GLₙ n ℝ) : A * B * C = A * (B * C) :=
begin
  rw mul_assoc -- inherited from group structure on `units`
end

class group (α : Type*) :=
(op : α → α → α)
(infixl `ᵍ*`:70 := op)
(assoc' : ∀ g h k : α, g ᵍ* (h ᵍ* k) = (g ᵍ* h) ᵍ* k)
(e : α)
(notation `ᵍ1`:50 := e)
(op_e' : ∀ g, g ᵍ* ᵍ1 = g)
(e_op' : ∀ g, ᵍ1 ᵍ* g = g)
(inv : α → α)
(postfix `ᵍ⁻¹`:max := inv)
(inv_op' : ∀ g, gᵍ⁻¹ ᵍ* g = e)
(op_inv' : ∀ g, g ᵍ* gᵍ⁻¹ = e)

infixl ` ᵍ* `:70 := group.op
notation `ᵍ1` := group.e
postfix `ᵍ⁻¹`:std.prec.max_plus := group.inv

variables {α : Type*} [group α]

namespace group

lemma mul_assoc (g h k : α) : g ᵍ* (h ᵍ* k) = (g ᵍ* h) ᵍ* k := group.assoc' _ _ _
@[simp] lemma mul_one (g : α) : g ᵍ* ᵍ1 = g := group.op_e' _
@[simp] lemma one_mul (g : α) : ᵍ1 ᵍ* g = g := group.e_op' _
@[simp] lemma inv_mul (g : α) : gᵍ⁻¹ ᵍ* g = ᵍ1 := inv_op' _
@[simp] lemma mul_inv (g : α) : g ᵍ* gᵍ⁻¹ = ᵍ1 := op_inv' _

end group

class abelian_group (α : Type*) extends group α :=
(comm : ∀ (g h : α), g ᵍ* h = h ᵍ* g)

-- The integers are an abelian group
example : abelian_group ℤ :=
{ op := (+),
  assoc' := λ _ _ _, (int.add_assoc _ _ _).symm,
  e := 0,
  op_e' := int.add_zero,
  e_op' := int.zero_add,
  inv := λ x, -x,
  inv_op' := int.add_left_neg,
  op_inv' := int.add_right_neg,
  comm := int.add_comm }

-- Any vector space is an abelian group. Uses the proofs for groups already in mathlib
example (K V : Type*) [field K] [add_comm_group V] [module K V] : abelian_group V :=
{ op := (+),
  assoc' := λ _ _ _, (add_assoc _ _ _).symm,
  e := 0,
  op_e' := add_zero,
  e_op' := zero_add,
  inv := λ x, -x,
  inv_op' := add_left_neg,
  op_inv' := add_right_neg,
  comm := add_comm }

-- The bijections (symmetries) of a type are a group
-- this example has `(f * g)(x) = g(f(x))`
example (T : Type*) : group (T ≃ T) :=
{ op := equiv.trans,
  assoc' := equiv.trans_assoc,
  e := equiv.refl _,
  op_e' := equiv.trans_refl,
  e_op' := equiv.refl_trans,
  inv := equiv.symm,
  inv_op' := equiv.symm_trans_self,
  op_inv' := equiv.self_trans_symm }

end

open matrix set linear_map
variables {R n : Type*} [comm_ring R] [fintype n] [decidable_eq n]

-- The definition of GLₙ(ℝ) is group-equivalent to the mathlib definition
example {n : ℕ} : (GLₙ n ℝ) ≃* linear_map.general_linear_group ℝ (fin n → ℝ) :=
units.map_equiv to_lin_alg_equiv'.to_mul_equiv

-- The symmetric group, as permutations of `fin n`
notation `Sₙ ` n := equiv.perm (fin n)

-- Sₙ is a finite group of order `n!`
example {n : ℕ} : fintype.card (Sₙ n) = nat.factorial n :=
by rw [fintype.card_perm, fintype.card_fin]

-- Sₙ is not abelian for n = 3
example : ∃ g h : Sₙ 3, g * h ≠ h * g :=
begin
  use [equiv.swap 0 1, equiv.swap 0 2],
  intro H,
  -- evaluate the swaps at the first element, which will make 2 = 1
  have := equiv.congr_fun H 0,
  -- norm_num discharges the false goal with the false hypothesis
  norm_num at this
end

end e222


import standard
import data.nat

structure Category : Type :=
  (Obj : Type)
  (Hom : Obj → Obj → Type)

  (Id : Π A : Obj, Hom A A)
  (compose : Π ⦃A B C : Obj⦄, Hom B C → Hom A B → Hom A C)

  (Id_left  : Π ⦃A B : Obj⦄ (f : Hom A B), compose !Id f = f)
  (Id_right : Π ⦃A B : Obj⦄ (f : Hom A B), compose f !Id = f)
  (assoc : Π ⦃A B C D : Obj⦄ (f : Hom C D) (g : Hom B C) (h : Hom A B),
    compose (compose f g) h = compose f (compose g h))

namespace Category
  -- Can we put this before the definition?
  notation f `∘` g := compose _ f g
  infix `⟶` :25 := Hom _

  definition Mor := Hom

  -- Do these do anything?
  attribute mk [constructor]
  attribute Obj [unfold 1]
  attribute Hom [unfold 1]
  attribute Id [unfold 1]
  attribute compose [unfold 1]
end Category

open Category
open nat

definition ℕCategory : Category :=
  ⦃ Category,
    Obj     := unit,
    Hom     := λ a b, ℕ,
    Id      := λ a, 0,
    compose := λ a b c, add,

    Id_left  := by blast,
    Id_right := by blast,
    assoc    := by blast ⦄

--definition ℕCategory' : Category :=
--begin
--  refine (Category.mk unit (λ a b, ℕ) (λ a, 0) (λ a b c, add) _ _ _),
--end

structure Functor (source target : Category) : Type :=
  (onObj : Obj source → Obj target)
  (onMor : Π ⦃a b : Obj source⦄, !Hom a b → !Hom (onObj a) (onObj b))

  (respect_Id   : Π (a : Obj source), onMor (Id _ a) = Id _ (onObj a))
  (respect_comp : Π ⦃a b c : Obj source⦄ (f : !Hom b c) (g : !Hom a b),
                    onMor (f ∘ g) = onMor f ∘ onMor g)

namespace Functor
  infix `<$>`:50  := λ {C D : Category} (F : Functor C D) (a : Obj C), onObj F a
  infix `<$>m`:50 := λ {C D : Category} (F : Functor C D) {a b : Obj C}
                       (f : !Hom a b), onMor F f
end Functor

theorem double_order (n m p q : ℕ) : n + m + (p + q) = n + p + (m + q) :=
  by blast
--calc
--  n + m + (p + q) = n + (m + (p + q)) : add.assoc n m (p + q)
--              ... = n + (m + p + q)   : congr_arg (add n) (add.assoc m p q)
--              ... = n + (p + m + q)   : congr_arg (add n) (congr_arg (swap add q) (add.comm m p))
--              ... = n + (p + (m + q)) : congr_arg (add n) (add.assoc p m q)
--              ... = n + p + (m + q)   : add.assoc n p (m + q)

definition DoublingAsFunctor : Functor ℕCategory ℕCategory :=
  ⦃ Functor,
    onObj := id,
    onMor := λ a b (x : ℕ), x + x,

    respect_Id   := by intros; trivial,
    respect_comp := λ a b c f g, double_order f g f g⦄
    --respect_comp := begin
    --                intros,
    --                unfold [ℕCategory],
    --                exact (double_order f g f g)
    --                end ⦄

open prod

definition ProductCategory (C D : Category) : Category :=
  ⦃ Category,
    Obj := Obj C × Obj D,
    Hom := λ a b, Hom C (pr1 a) (pr1 b) × Hom D (pr2 a) (pr2 b),
    Id  := λ a, (Id C (pr1 a), Id D (pr2 a)),
    compose := λ a b c f g, (pr1 f ∘ pr1 g, pr2 f ∘ pr2 g),

    Id_left  := by intros; exact prod.eq !Id_left !Id_left,
    Id_right := by intros; exact prod.eq !Id_right !Id_right,
    assoc    := by intros; exact prod.eq !assoc !assoc ⦄

namespace ProductCategory
  notation C `×c` D := ProductCategory C D
end ProductCategory

open Functor
open ProductCategory

structure LaxMonoidalCategory extends cat : Category :=
  (tensor : Functor (cat ×c cat) cat)
  (unit : Obj)

  (associator : Π (a b c : Obj)
                  (infix `⊗`:70 := λ (a b : Obj), tensor <$> (a, b)),
                    Hom ((a ⊗ b) ⊗ c) (a ⊗ (b ⊗ c)))
  (pentagon : Π (a b c d : Obj)
                (infix `∘`     := compose)
                (infix `⊗`:70  := λ (x y : Obj), tensor <$> (x, y))
                (infix `⊗m`:70 := λ {x y z w : Obj} (f : Hom x y) (g : Hom z w),
                  tensor <$>m (f, g)),
                let α := associator in
                  (Id a ⊗m α b c d) ∘ (α a (b ⊗ c) d) ∘ (α a b c ⊗m Id d)
                    = α a b (c ⊗ d) ∘ α (a ⊗ b) c d)

  (unitor_left  : Π (a : Obj)
                    (infix `⊗`:70 := λ (a b : Obj), tensor <$> (a, b)),
                      Hom (unit ⊗ a) a)
  (unitor_right : Π (a : Obj)
                    (infix `⊗`:70 := λ (a b : Obj), tensor <$> (a, b)),
                      Hom (a ⊗ unit) a)
  (triangle : Π (a b : Obj)
                (infix `∘`     := compose)
                (infix `⊗`:70  := λ (x y : Obj), tensor <$> (x, y))
                (infix `⊗m`:70 := λ {x y z w : Obj} (f : Hom x y) (g : Hom z w),
                  tensor <$>m (f, g)),
                let L := unitor_left, R := unitor_right, α := associator in
                  R a ⊗m Id b = (Id a ⊗m L b) ∘ α a unit b)

namespace LaxMonoidalCategory
  infix `⊗`:70  := λ {C : LaxMonoidalCategory} (a b : Obj C), tensor C <$> (a,b)
  infix `⊗m`:70 := λ {C : LaxMonoidalCategory} {a b c d : Obj C}
                     (f : Hom a b) (g : Hom c d), tensor C <$> (f,g)
end LaxMonoidalCategory

definition ℕTensorProduct : Functor (ℕCategory ×c ℕCategory) ℕCategory :=
  ⦃ Functor,
    onObj := pr1,
    onMor := λ a b (f : ℕ × ℕ), pr1 f + pr2 f,

    respect_Id   := by intros; trivial,
    respect_comp := λ a b c (f g : ℕ × ℕ), by krewrite double_order ⦄

--definition ℕTensorProduct' : Functor (ℕCategory ×c ℕCategory) ℕCategory :=
--  Functor.mk pr1 (λ a b (f : ℕ × ℕ), pr1 f + pr2 f) _ _ _
--begin
--  refine Functor.mk (pr1) (λ (a b : unit), λ (f : ℕ × ℕ), pr1 f + pr2 f) _ _,
--end

definition ℕLaxMonoidalCategory : LaxMonoidalCategory :=
  ⦃ LaxMonoidalCategory,
    ℕCategory,
    tensor := ℕTensorProduct,
    unit   := unit.star,

    associator := λ a b c, Id _ _,
    pentagon := sorry,

    unitor_left  := Id _,
    unitor_right := Id _,
    triangle := sorry
    ⦄

open LaxMonoidalCategory

--check (2 : Hom ℕLaxMonoidalCategory unit.star unit.star)


def even(n : ℕ) : Prop := ∃ m, n = 2 * m

#check even 10

example : even 10 := ⟨ 5, rfl ⟩

theorem and_commutative (p q : Prop) : p ∧ q → q ∧ p :=
assume hpq : p ∧ q,
have hp : p, from and.left hpq,
have hq : q, from and.right hpq,
show q ∧ p, from and.intro hq hp

#check and_commutative
#print and_commutative

theorem and_commutative' (p q : Prop) : p ∧ q → q ∧ p :=
begin
  intro hp,
  apply and.intro,
  exact and.right hp,
  exact and.left hp,
end

#check and_commutative'
#print and_commutative'

#check prod
#print prod

#check list

universe u
constant α : Type u
#check α

#check fun x : nat, x + 5
#check λ x : nat, x + 5

constants (a : α) (b : β)
#reduce (λ x : α, x) a

#eval (λ x : α, x) a

def foo : (ℕ → ℕ) → ℕ := λ f, f 0

#check foo

#check (ℕ → ℕ) → ℕ

#print foo

def curry (α β γ : Type) (f : α × β → γ) : α → β → γ := λ x y, f (x, y)

#check curry
#print curry

#check let y := 2 + 2, z := y + y in z * z
#reduce let y := 2 + 2, z := y + y in z * z

def foo1 := let a := nat in λ x : a, x + 2
#check foo1
/-
def bar := (λ a, λ x : a, x + 2) nat
#check bar
-/

#check curry
#print curry

#check 0 - 1
#reduce 0 + 1
#reduce 0 - 1


/- Tactic : rw

## Summary

If `h` is a proof of `X = Y`, then `rw h,` will change
all `X`s in the goal to `Y`s.

**Variants:** `rw ← h` changes
`Y` to `X` and
`rw h at h2` changes `X` to `Y` in hypothesis `h2` instead
of the goal.

## Details

The `rw` tactic is a way to do "substituting in". There
are two distinct situations where use this tactics.

1) If `h : A = B` is a hypothesis (i.e., a proof of `A = B`)
in your local context (the box in the top right)
and if your goal contains one or more `A`s, then `rw h`
will change them all to `B`'s.

2) The `rw` tactic will also work with proofs of theorems
which are equalities (look for them in the drop down
menu on the left, within Theorem Statements).

**Important note:** if `h` is not a proof of the form `A = B`
or `A ↔ B` (for example if `h` is a function, an implication,
or perhaps even a proposition itself rather than its proof),
then `rw` is not the tactic you want to use. For example,
`rw (P = Q)` is never correct: `P = Q` is the true-false
statement itself, not the proof.
If `h : P = Q` is its proof, then `rw h` will work.

**Pro tip 1:** If `h : A = B` and you want to change
`B`s to `A`s instead, try `rw ←h` (get the arrow with `\l`,
note that this is a small letter L, not a number 1).

### Example:
If it looks like this in the top right hand box:
```
A B C : Point
h1 : A = B
h2 : B = C
⊢ A = C
```

then

`rw h1,`

will change the goal into `⊢ B = C`.

### Example:
You can use `rw` to change a hypothesis as well.
For example, if your local context looks like this:
```
A B C : Point
h1 : A = C
h2 : A = B
⊢ B = C
```
then `rw h1 at h2` will turn `h2` into `h2 : C = B` (remember operator precedence).

-/

/-
The next tactic we will learn is `rw` (from rewrite). It rewrites equalities. That is,
if we have a proof `h : A = B` and we want to prove `⊢ A = C`, then after `rw h` the goal
will become `⊢ B = C`.

After many tactics (and `rw` is one of them) Lean tries to apply `refl`. This is why
in the following proof you may get away with only two tactic applications.

-/

/- Hint : Click here for a hint, in case you get stuck.
Delete `sorry` and type `rw h,` (don't forget the comma!). Lean tries `refl` afterwards,
so you will see that this suffices.
-/

variables {Ω : Type} -- hide

/- Lemma : no-side-bar
If A, B and C are points with A = B and B = C, then A = C.
-/
lemma example_rw (A B C: Ω) (h1 : A = B) (h2 : B = C) : A = C :=
begin
  rw h1,
  rw h2,

end